[project @ 2002-09-13 16:06:28 by simonpj]

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

diff --git a/ghc/compiler/codeGen/CodeGen.lhs b/ghc/compiler/codeGen/CodeGen.lhs
index 2390765..5198897 100644 (file)
--- a/ghc/compiler/codeGen/CodeGen.lhs
+++ b/ghc/compiler/codeGen/CodeGen.lhs
@@ -24,76 +24,78 @@ module CodeGen ( codeGen ) where
 -- bother to compile it.
 import CgExpr           ( {-NOTHING!-} )       -- DO NOT DELETE THIS IMPORT
 
 -- bother to compile it.
 import CgExpr           ( {-NOTHING!-} )       -- DO NOT DELETE THIS IMPORT
 

+import DriverState     ( v_Build_tag )

 import StgSyn
 import CgMonad
 import AbsCSyn
 import StgSyn
 import CgMonad
 import AbsCSyn

-import CLabel          ( CLabel, mkSRTLabel, mkClosureLabel, mkModuleInitLabel )
-
+import PrelNames       ( gHC_PRIM )
+import CLabel          ( CLabel, mkSRTLabel, mkClosureLabel, 
+                         mkPlainModuleInitLabel, mkModuleInitLabel )

 import PprAbsC         ( dumpRealC )
 import AbsCUtils       ( mkAbstractCs, flattenAbsC )
 import PprAbsC         ( dumpRealC )
 import AbsCUtils       ( mkAbstractCs, flattenAbsC )

-import CgBindery       ( CgIdInfo, addBindC, addBindsC )
+import CgBindery       ( CgIdInfo, addBindC, addBindsC, getCAddrModeAndInfo )

 import CgClosure       ( cgTopRhsClosure )
 import CgCon           ( cgTopRhsCon )
 import CgConTbls       ( genStaticConBits )
 import ClosureInfo     ( mkClosureLFInfo )
 import CmdLineOpts     ( DynFlags, DynFlag(..),
                          opt_SccProfilingOn, opt_EnsureSplittableC )
 import CgClosure       ( cgTopRhsClosure )
 import CgCon           ( cgTopRhsCon )
 import CgConTbls       ( genStaticConBits )
 import ClosureInfo     ( mkClosureLFInfo )
 import CmdLineOpts     ( DynFlags, DynFlag(..),
                          opt_SccProfilingOn, opt_EnsureSplittableC )

-import CostCentre       ( CostCentre, CostCentreStack )
-import Id               ( Id, idName )
-import Module           ( Module )
+import HscTypes                ( ModGuts(..), ModGuts, ForeignStubs(..),
+                         typeEnvTyCons )
+import CostCentre       ( CollectedCCs )
+import Id               ( Id, idName, setIdName )
+import Name            ( nameSrcLoc, nameOccName, nameUnique, isInternalName, mkExternalName )
+import OccName         ( mkLocalOcc )

 import PrimRep         ( PrimRep(..) )
 import PrimRep         ( PrimRep(..) )

-import TyCon            ( TyCon, isDataTyCon )
+import TyCon            ( isDataTyCon )

 import BasicTypes      ( TopLevelFlag(..) )
 import UniqSupply      ( mkSplitUniqSupply )
 import ErrUtils                ( dumpIfSet_dyn, showPass )
 import Panic           ( assertPanic )
 import BasicTypes      ( TopLevelFlag(..) )
 import UniqSupply      ( mkSplitUniqSupply )
 import ErrUtils                ( dumpIfSet_dyn, showPass )
 import Panic           ( assertPanic )

-\end{code}

 
 

-\begin{code}
+#ifdef DEBUG
+import Outputable
+#endif

 
 

+import DATA_IOREF      ( readIORef )
+\end{code}

 
 

+\begin{code}

 codeGen :: DynFlags
 codeGen :: DynFlags

-       -> Module               -- Module name
-       -> [Module]             -- Import names
-       -> ([CostCentre],       -- Local cost-centres needing declaring/registering
-           [CostCentre],       -- "extern" cost-centres needing declaring
-           [CostCentreStack])  -- Pre-defined "singleton" cost centre stacks
-       -> [Id]                 -- foreign-exported binders
-       -> [TyCon]              -- Local tycons, including ones from classes
+       -> ModGuts
+       -> CollectedCCs         -- (Local/global) cost-centres needing declaring/registering.

        -> [(StgBinding,[Id])]  -- Bindings to convert, with SRTs
        -> IO AbstractC         -- Output
 
        -> [(StgBinding,[Id])]  -- Bindings to convert, with SRTs
        -> IO AbstractC         -- Output
 

-codeGen dflags mod_name imported_modules cost_centre_info fe_binders
-       tycons stg_binds
-  = do { showPass dflags "CodeGen"
+codeGen dflags 
+       mod_impl@(ModGuts { mg_module = mod_name, mg_types = type_env })
+       cost_centre_info stg_binds
+  = do 
+       showPass dflags "CodeGen"
+       fl_uniqs <- mkSplitUniqSupply 'f'
+       way <- readIORef v_Build_tag
+
+       let
+           tycons         = typeEnvTyCons type_env
+           data_tycons    = filter isDataTyCon tycons
+           cinfo          = MkCompInfo mod_name

 
 

-       ; fl_uniqs <- mkSplitUniqSupply 'f'
-       ; let

            datatype_stuff = genStaticConBits cinfo data_tycons
            datatype_stuff = genStaticConBits cinfo data_tycons

-           code_stuff     = initC cinfo (cgTopBindings maybe_split stg_binds)
-           init_stuff     = mkModuleInit fe_binders mod_name imported_modules 
-                                         cost_centre_info
+           code_stuff     = initC cinfo (mapCs cgTopBinding stg_binds)
+           init_stuff     = mkModuleInit way cost_centre_info mod_impl

 
 

-           abstractC = mkAbstractCs [ maybe_split,
+           abstractC = mkAbstractCs [ maybeSplitCode,

                                       init_stuff, 
                                       code_stuff,
                                       datatype_stuff]
                -- Put datatype_stuff after code_stuff, because the
                                       init_stuff, 
                                       code_stuff,
                                       datatype_stuff]
                -- Put datatype_stuff after code_stuff, because the

-               -- datatype closure table (for enumeration types)
-               -- to (say) PrelBase_True_closure, which is defined in code_stuff
-
-           flat_abstractC = flattenAbsC fl_uniqs abstractC
+               -- datatype closure table (for enumeration types) to
+               -- (say) PrelBase_True_closure, which is defined in
+               -- code_stuff

 
 

-       ; dumpIfSet_dyn dflags Opt_D_dump_absC "Abstract C" (dumpRealC abstractC)
-       ; return flat_abstractC
-       }
-  where
-    data_tycons = filter isDataTyCon tycons
+       dumpIfSet_dyn dflags Opt_D_dump_absC "Abstract C" (dumpRealC abstractC)

 
 

-    maybe_split = if opt_EnsureSplittableC 
-                 then CSplitMarker 
-                 else AbsCNop
-    cinfo       = MkCompInfo mod_name
+       return $! flattenAbsC fl_uniqs abstractC

 \end{code}
 
 %************************************************************************
 \end{code}
 
 %************************************************************************

@@ -104,14 +106,14 @@ codeGen dflags mod_name imported_modules cost_centre_info fe_binders
 
 \begin{code}
 mkModuleInit 
 
 \begin{code}
 mkModuleInit 

-       :: [Id]                 -- foreign exported functions
-       -> Module               -- module name
-       -> [Module]             -- import names
-       -> ([CostCentre],       -- cost centre info
-           [CostCentre],       
-           [CostCentreStack])
+       :: String               -- the "way"
+       -> CollectedCCs         -- cost centre info
+       -> ModGuts

        -> AbstractC
        -> AbstractC

-mkModuleInit fe_binders mod imps cost_centre_info
+mkModuleInit way cost_centre_info
+            (ModGuts { mg_module  = mod,
+                       mg_foreign = ForeignStubs _ _ _ fe_binders,
+                       mg_dir_imps = imported_modules })

   = let
        register_fes = 
           map (\f -> CMacroStmt REGISTER_FOREIGN_EXPORT [f]) fe_labels
   = let
        register_fes = 
           map (\f -> CMacroStmt REGISTER_FOREIGN_EXPORT [f]) fe_labels

@@ -121,16 +123,19 @@ mkModuleInit fe_binders mod imps cost_centre_info
 
        (cc_decls, cc_regs) = mkCostCentreStuff cost_centre_info
 
 
        (cc_decls, cc_regs) = mkCostCentreStuff cost_centre_info
 

-       mk_import_register imp =
-           CMacroStmt REGISTER_IMPORT [
-               CLbl (mkModuleInitLabel imp) AddrRep
-           ]
+       -- we don't want/need to init GHC.Prim, so filter it out
+       mk_import_register mod
+           | mod == gHC_PRIM = AbsCNop
+           | otherwise       = CMacroStmt REGISTER_IMPORT [
+                                  CLbl (mkModuleInitLabel mod way) AddrRep
+                               ]

 
 

-       register_imports = map mk_import_register imps
+       register_imports = map mk_import_register imported_modules

     in
     mkAbstractCs [
        cc_decls,
     in
     mkAbstractCs [
        cc_decls,

-        CModuleInitBlock (mkModuleInitLabel mod)
+        CModuleInitBlock (mkPlainModuleInitLabel mod)
+                        (mkModuleInitLabel mod way)

                         (mkAbstractCs (register_fes ++
                                        cc_regs :
                                        register_imports))
                         (mkAbstractCs (register_fes ++
                                        cc_regs :
                                        register_imports))

@@ -162,10 +167,10 @@ mkCostCentreStuff (local_CCs, extern_CCs, singleton_CCSs)
        [ register_ccs, register_cc_stacks ]
       where
        mk_register cc
        [ register_ccs, register_cc_stacks ]
       where
        mk_register cc

-         = CCallProfCCMacro SLIT("REGISTER_CC") [mkCCostCentre cc]
+         = CCallProfCCMacro FSLIT("REGISTER_CC") [mkCCostCentre cc]

 
        mk_register_ccs ccs
 
        mk_register_ccs ccs

-         = CCallProfCCMacro SLIT("REGISTER_CCS") [mkCCostCentreStack ccs]
+         = CCallProfCCMacro FSLIT("REGISTER_CCS") [mkCCostCentreStack ccs]

 \end{code}
 
 %************************************************************************
 \end{code}
 
 %************************************************************************

@@ -174,7 +179,7 @@ mkCostCentreStuff (local_CCs, extern_CCs, singleton_CCSs)
 %*                                                                     *
 %************************************************************************
 
 %*                                                                     *
 %************************************************************************
 

-@cgTopBindings@ is only used for top-level bindings, since they need
+@cgTopBinding@ is only used for top-level bindings, since they need

 to be allocated statically (not in the heap) and need to be labelled.
 No unboxed bindings can happen at top level.
 
 to be allocated statically (not in the heap) and need to be labelled.
 No unboxed bindings can happen at top level.
 

@@ -185,53 +190,100 @@ style, with the increasing static environment being plumbed as a state
 variable.
 
 \begin{code}
 variable.
 
 \begin{code}

-cgTopBindings :: AbstractC -> [(StgBinding,[Id])] -> Code
-
-cgTopBindings split bindings = mapCs (cgTopBinding split) bindings
-
-cgTopBinding :: AbstractC -> (StgBinding,[Id]) -> Code
-
-cgTopBinding split ((StgNonRec name rhs), srt)
-  = absC split                 `thenC`
-    absC (mkSRT srt_label srt)         `thenC`
+cgTopBinding :: (StgBinding,[Id]) -> Code
+cgTopBinding (StgNonRec srt_info id rhs, srt)
+  = absC maybeSplitCode                `thenC`
+    maybeExternaliseId id              `thenFC` \ id' ->
+    let
+       srt_label = mkSRTLabel (idName id')
+    in
+    mkSRT srt_label srt []     `thenC`

     setSRTLabel srt_label (
     setSRTLabel srt_label (

-    cgTopRhs name rhs          `thenFC` \ (name, info) ->
-    addBindC name info
+    cgTopRhs id' rhs srt_info          `thenFC` \ (id, info) ->
+    addBindC id info   -- Add the un-externalised Id to the envt, so we
+                       -- find it when we look up occurrences

     )
     )

-  where
-    srt_label = mkSRTLabel (idName name)

 
 

-cgTopBinding split ((StgRec pairs@((name,rhs):_)), srt)
-  = absC split                 `thenC`
-    absC (mkSRT srt_label srt)         `thenC`
+cgTopBinding (StgRec srt_info pairs, srt)
+  = absC maybeSplitCode                        `thenC`
+    let
+        (bndrs, rhss) = unzip pairs
+    in
+    mapFCs maybeExternaliseId bndrs    `thenFC` \ bndrs'@(id:_) ->
+    let
+       srt_label = mkSRTLabel (idName id)
+       pairs'    = zip bndrs' rhss
+    in
+    mkSRT srt_label srt bndrs'         `thenC`

     setSRTLabel srt_label (
     setSRTLabel srt_label (

-    fixC (\ new_binds -> addBindsC new_binds   `thenC`
-                        mapFCs ( \ (b,e) -> cgTopRhs b e ) pairs
-    )                    `thenFC` \ new_binds ->
-    addBindsC new_binds
+       fixC (\ new_binds -> 
+               addBindsC new_binds             `thenC`
+               mapFCs ( \ (b,e) -> cgTopRhs b e srt_info ) pairs'
+       )  `thenFC` \ new_binds -> nopC

     )
     )

-  where
-    srt_label = mkSRTLabel (idName name)

 
 

-mkSRT :: CLabel -> [Id] -> AbstractC
-mkSRT lbl []  = AbsCNop
-mkSRT lbl ids = CSRT lbl (map (mkClosureLabel . idName) ids)
+mkSRT :: CLabel -> [Id] -> [Id] -> Code
+mkSRT lbl []  these = nopC
+mkSRT lbl ids these
+  = mapFCs remap ids `thenFC` \ ids ->
+    absC (CSRT lbl (map (mkClosureLabel . idName) ids))
+  where
+       -- sigh, better map all the ids against the environment in case they've
+       -- been externalised (see maybeExternaliseId below).
+    remap id = case filter (==id) these of
+               [] ->  getCAddrModeAndInfo id 
+                               `thenFC` \ (id, _, _) -> returnFC id
+               (id':_) -> returnFC id'

 
 -- Urgh!  I tried moving the forkStatics call from the rhss of cgTopRhs
 -- to enclose the listFCs in cgTopBinding, but that tickled the
 -- statics "error" call in initC.  I DON'T UNDERSTAND WHY!
 
 
 -- Urgh!  I tried moving the forkStatics call from the rhss of cgTopRhs
 -- to enclose the listFCs in cgTopBinding, but that tickled the
 -- statics "error" call in initC.  I DON'T UNDERSTAND WHY!
 

-cgTopRhs :: Id -> StgRhs -> FCode (Id, CgIdInfo)
-       -- the Id is passed along for setting up a binding...
+cgTopRhs :: Id -> StgRhs -> SRT -> FCode (Id, CgIdInfo)
+       -- The Id is passed along for setting up a binding...
+       -- It's already been externalised if necessary

 
 

-cgTopRhs bndr (StgRhsCon cc con args)
-  = forkStatics (cgTopRhsCon bndr con args)
+cgTopRhs bndr (StgRhsCon cc con args) srt
+  = forkStatics (cgTopRhsCon bndr con args srt)

 
 

-cgTopRhs bndr (StgRhsClosure cc bi srt fvs upd_flag args body)
-  = ASSERT(null fvs) -- There should be no free variables
-    getSRTLabel `thenFC` \srt_label ->
-    let lf_info = 
-         mkClosureLFInfo bndr TopLevel [{-no fvs-}] upd_flag args srt_label srt
+cgTopRhs bndr (StgRhsClosure cc bi fvs upd_flag args body) srt
+  = ASSERT(null fvs)    -- There should be no free variables
+    let 
+       lf_info = mkClosureLFInfo bndr TopLevel [{-no fvs-}] upd_flag args

     in
     in

-    forkStatics (cgTopRhsClosure bndr cc bi args body lf_info)
+    forkStatics (cgTopRhsClosure bndr cc bi srt args body lf_info)
+\end{code}
+
+
+%************************************************************************
+%*                                                                     *
+\subsection{Stuff to support splitting}
+%*                                                                     *
+%************************************************************************
+
+If we're splitting the object, we need to externalise all the top-level names
+(and then make sure we only use the externalised one in any C label we use
+which refers to this name).
+
+\begin{code}
+maybeExternaliseId :: Id -> FCode Id
+maybeExternaliseId id
+  | opt_EnsureSplittableC,     -- Externalise the name for -split-objs
+    isInternalName name
+  = moduleName                          `thenFC` \ mod ->
+    returnFC (setIdName id (mkExternalName uniq mod new_occ (nameSrcLoc name)))
+  | otherwise          
+  = returnFC id
+  where
+    name       = idName id
+    uniq       = nameUnique name
+    new_occ    = mkLocalOcc uniq (nameOccName name)
+       -- We want to conjure up a name that can't clash with any
+       -- existing name.  So we generate
+       --      Mod_$L243foo
+       -- where 243 is the unique.
+
+maybeSplitCode
+  | opt_EnsureSplittableC = CSplitMarker 
+  | otherwise             = AbsCNop

 \end{code}
 \end{code}