[project @ 1997-05-18 03:58:52 by sof]

[ghc-hetmet.git] / ghc / compiler / codeGen / CgBindery.lhs

diff --git a/ghc/compiler/codeGen/CgBindery.lhs b/ghc/compiler/codeGen/CgBindery.lhs
index 4d17fc1..452466b 100644 (file)
--- a/ghc/compiler/codeGen/CgBindery.lhs
+++ b/ghc/compiler/codeGen/CgBindery.lhs
@@ -7,7 +7,7 @@
 #include "HsVersions.h"
 
 module CgBindery (
-       CgBindings(..), CgIdInfo(..){-dubiously concrete-},
+       SYN_IE(CgBindings), CgIdInfo(..){-dubiously concrete-},
        StableLoc, VolatileLoc,
 
        maybeAStkLoc, maybeBStkLoc,
@@ -26,27 +26,30 @@ module CgBindery (
        rebindToAStack, rebindToBStack
     ) where
 
-import Ubiq{-uitous-}
-import CgLoop1         -- here for paranoia-checking
+IMP_Ubiq(){-uitous-}
+IMPORT_DELOOPER(CgLoop1)               -- here for paranoia-checking
 
 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                ( SYN_IE(VirtualHeapOffset),
+                         SYN_IE(VirtualSpAOffset), SYN_IE(VirtualSpBOffset)
                        )
 import Id              ( idPrimRep, toplevelishId, isDataCon,
-                         mkIdEnv, rngIdEnv, IdEnv(..),
+                         mkIdEnv, rngIdEnv, SYN_IE(IdEnv),
                          idSetToList,
                          GenId{-instance NamedThing-}
                        )
 import Maybes          ( catMaybes )
+import Name            ( isLocallyDefined, isWiredInName, Name{-instance NamedThing-} )
+#ifdef DEBUG
 import PprAbsC         ( pprAmode )
+#endif
 import PprStyle                ( PprStyle(..) )
-import StgSyn          ( StgArg(..), StgLiveVars(..), GenStgArg(..) )
+import StgSyn          ( SYN_IE(StgArg), SYN_IE(StgLiveVars), GenStgArg(..) )
 import Unpretty                ( uppShow )
 import Util            ( zipWithEqual, panic )
 \end{code}
@@ -122,7 +125,7 @@ newTempAmodeAndIdInfo :: Id -> LambdaFormInfo -> (CAddrMode, CgIdInfo)
 newTempAmodeAndIdInfo name lf_info
   = (temp_amode, temp_idinfo)
   where
-    uniq               = getItsUnique name
+    uniq               = uniqueOf name
     temp_amode = CTemp uniq (idPrimRep name)
     temp_idinfo = tempIdInfo name uniq lf_info
 
@@ -191,21 +194,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 GHCbase.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
@@ -281,7 +291,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}
 
@@ -337,7 +382,7 @@ bindNewToLit name lit
 
 bindArgsToRegs :: [Id] -> [MagicId] -> Code
 bindArgsToRegs args regs
-  = listCs (zipWithEqual bind args regs)
+  = listCs (zipWithEqual "bindArgsToRegs" bind args regs)
   where
     arg `bind` reg = bindNewToReg arg reg mkLFArgument
 \end{code}