X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FcodeGen%2FCgBindery.lhs;h=f21d393b8326e4ad134ccba807c637074bb8f7b3;hb=a651e21e45b7e390ed65770d6181de874769a7eb;hp=8edd5bd9dc78f8f673031926a192d49582ef89e8;hpb=e7498a3ee1d0484d02a9e86633cc179c76ebf36e;p=ghc-hetmet.git

diff --git a/ghc/compiler/codeGen/CgBindery.lhs b/ghc/compiler/codeGen/CgBindery.lhs
index 8edd5bd..f21d393 100644
--- a/ghc/compiler/codeGen/CgBindery.lhs
+++ b/ghc/compiler/codeGen/CgBindery.lhs
@@ -4,10 +4,8 @@
 \section[CgBindery]{Utility functions related to doing @CgBindings@}
 
 \begin{code}
-#include "HsVersions.h"
-
 module CgBindery (
-	CgBindings(..), CgIdInfo(..){-dubiously concrete-},
+	CgBindings, CgIdInfo(..){-dubiously concrete-},
 	StableLoc, VolatileLoc,
 
 	maybeAStkLoc, maybeBStkLoc,
@@ -26,32 +24,32 @@ module CgBindery (
 	rebindToAStack, rebindToBStack
     ) where
 
-IMP_Ubiq(){-uitous-}
-IMPORT_DELOOPER(CgLoop1)		-- here for paranoia-checking
+#include "HsVersions.h"
 
 import AbsCSyn
 import CgMonad
 
 import CgUsages		( getHpRelOffset, getSpARelOffset, getSpBRelOffset )
-import CLabel		( mkClosureLabel )
-import ClosureInfo	( mkLFImported, mkConLFInfo, mkLFArgument )
-import HeapOffs		( VirtualHeapOffset(..),
-			  VirtualSpAOffset(..), VirtualSpBOffset(..)
+import CLabel		( mkStaticClosureLabel, mkClosureLabel )
+import ClosureInfo	( mkLFImported, mkConLFInfo, mkLFArgument, LambdaFormInfo )
+import HeapOffs		( VirtualHeapOffset,
+			  VirtualSpAOffset, VirtualSpBOffset
 			)
-import Id		( idPrimRep, toplevelishId, isDataCon,
-			  mkIdEnv, rngIdEnv, IdEnv(..),
+import Id		( idPrimRep, toplevelishId, 
+			  mkIdEnv, rngIdEnv, IdEnv,
 			  idSetToList,
-			  GenId{-instance NamedThing-}
+			  Id
 			)
+import Literal		( Literal )
 import Maybes		( catMaybes )
-import Name		( isLocallyDefined )
-#ifdef DEBUG
+import Name		( isLocallyDefined, isWiredInName,
+			  Name{-instance NamedThing-}, NamedThing(..) )
 import PprAbsC		( pprAmode )
-#endif
-import PprStyle		( PprStyle(..) )
-import StgSyn		( StgArg(..), StgLiveVars(..), GenStgArg(..) )
-import Unpretty		( uppShow )
+import PrimRep          ( PrimRep )
+import StgSyn		( StgArg, StgLiveVars, GenStgArg(..) )
+import Unique           ( Unique, Uniquable(..) )
 import Util		( zipWithEqual, panic )
+import Outputable
 \end{code}
 
 
@@ -89,7 +87,12 @@ data VolatileLoc
 
   | VirNodeLoc	VirtualHeapOffset	-- Cts of offset indirect from Node
 					-- ie *(Node+offset)
+\end{code}
+
+@StableLoc@ encodes where an Id can be found, used by
+the @CgBindings@ environment in @CgBindery@.
 
+\begin{code}
 data StableLoc
   = NoStableLoc
   | VirAStkLoc		VirtualSpAOffset
@@ -194,21 +197,28 @@ I {\em think} all looking-up is done through @getCAddrMode(s)@.
 \begin{code}
 getCAddrModeAndInfo :: Id -> FCode (CAddrMode, LambdaFormInfo)
 
-getCAddrModeAndInfo name
-  | not (isLocallyDefined name)
-  = returnFC (global_amode, mkLFImported name)
-
-  | isDataCon name
-  = returnFC (global_amode, mkConLFInfo name)
+getCAddrModeAndInfo id
+  | not (isLocallyDefined name) || isWiredInName name
+    {- Why the "isWiredInName"?
+	Imagine you are compiling PrelBase.hs (a module that
+	supplies some of the wired-in values).  What can
+	happen is that the compiler will inject calls to
+	(e.g.) GHCbase.unpackPS, where-ever it likes -- it
+	assumes those values are ubiquitously available.
+	The main point is: it may inject calls to them earlier
+	in GHCbase.hs than the actual definition...
+    -}
+  = returnFC (global_amode, mkLFImported id)
 
   | otherwise = -- *might* be a nested defn: in any case, it's something whose
 		-- definition we will know about...
-    lookupBindC name `thenFC` \ (MkCgIdInfo _ volatile_loc stable_loc lf_info) ->
+    lookupBindC id `thenFC` \ (MkCgIdInfo _ volatile_loc stable_loc lf_info) ->
     idInfoPiecesToAmode kind volatile_loc stable_loc `thenFC` \ amode ->
     returnFC (amode, lf_info)
   where
-    global_amode = CLbl (mkClosureLabel name) kind
-    kind = idPrimRep name
+    name = getName id
+    global_amode = CLbl (mkClosureLabel id) kind
+    kind = idPrimRep id
 
 getCAddrMode :: Id -> FCode CAddrMode
 getCAddrMode name
@@ -284,7 +294,42 @@ getArgAmodes (atom:atoms)
 
 getArgAmode :: StgArg -> FCode CAddrMode
 
-getArgAmode (StgVarArg var) = getCAddrMode var
+getArgAmode (StgConArg var)
+     {- Why does this case differ from StgVarArg?
+	Because the program might look like this:
+		data Foo a = Empty | Baz a
+		f a x = let c = Empty! a
+			in h c
+	Now, when we go Core->Stg, we drop the type applications, 
+	so we can inline c, giving
+		f x = h Empty
+	Now we are referring to Empty as an argument (rather than in an STGCon), 
+	so we'll look it up with getCAddrMode.  We want to return an amode for
+	the static closure that we make for nullary constructors.  But if we blindly
+	go ahead with getCAddrMode we end up looking in the environment, and it ain't there!
+
+	This special case used to be in getCAddrModeAndInfo, but it doesn't work there.
+	Consider:
+		f a x = Baz a x
+	If the constructor Baz isn't inlined we simply want to treat it like any other
+	identifier, with a top level definition.  We don't want to spot that it's a constructor.
+
+	In short 
+		StgApp con args
+	and
+		StgCon con args
+	are treated differently; the former is a call to a bog standard function while the
+	latter uses the specially-labelled, pre-defined info tables etc for the constructor.
+
+	The way to think of this case in getArgAmode is that
+		SApp f Empty
+	is really
+		App f (StgCon Empty [])
+     -}
+  = returnFC (CLbl (mkStaticClosureLabel var) (idPrimRep var))
+
+getArgAmode (StgVarArg var) = getCAddrMode var		-- The common case
+
 getArgAmode (StgLitArg lit) = returnFC (CLit lit)
 \end{code}
 
@@ -368,7 +413,7 @@ bindNewPrimToAmode name (CVal (NodeRel offset) _)
 
 #ifdef DEBUG
 bindNewPrimToAmode name amode
-  = panic ("bindNew...:"++(uppShow 80 (pprAmode PprDebug  amode)))
+  = pprPanic "bindNew...:" (pprAmode amode)
 #endif
 \end{code}