[project @ 2002-11-21 17:54:17 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 5d08357..5198897 100644 (file)
--- a/ghc/compiler/codeGen/CodeGen.lhs
+++ b/ghc/compiler/codeGen/CodeGen.lhs
@@ -24,11 +24,13 @@ module CodeGen ( codeGen ) where
 -- bother to compile it.
 import CgExpr           ( {-NOTHING!-} )       -- DO NOT DELETE THIS IMPORT
 
+import DriverState     ( v_Build_tag )
 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 CgBindery       ( CgIdInfo, addBindC, addBindsC, getCAddrModeAndInfo )
@@ -38,13 +40,14 @@ import CgConTbls    ( genStaticConBits )
 import ClosureInfo     ( mkClosureLFInfo )
 import CmdLineOpts     ( DynFlags, DynFlag(..),
                          opt_SccProfilingOn, opt_EnsureSplittableC )
+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 Module           ( Module )
 import PrimRep         ( PrimRep(..) )
-import TyCon            ( TyCon, isDataTyCon )
+import TyCon            ( isDataTyCon )
 import BasicTypes      ( TopLevelFlag(..) )
 import UniqSupply      ( mkSplitUniqSupply )
 import ErrUtils                ( dumpIfSet_dyn, showPass )
@@ -53,43 +56,46 @@ import Panic                ( assertPanic )
 #ifdef DEBUG
 import Outputable
 #endif
+
+import DATA_IOREF      ( readIORef )
 \end{code}
 
 \begin{code}
 codeGen :: DynFlags
-       -> Module               -- Module name
-       -> [Module]             -- Import names
+       -> ModGuts
        -> CollectedCCs         -- (Local/global) cost-centres needing declaring/registering.
-       -> [Id]                 -- foreign-exported binders
-       -> [TyCon]              -- Local tycons, including ones from classes
        -> [(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"
-       ; fl_uniqs <- mkSplitUniqSupply 'f'
-       ; dumpIfSet_dyn dflags Opt_D_dump_absC "Abstract C" (dumpRealC abstractC)
-       ; let flat_abstractC = flattenAbsC fl_uniqs abstractC
-       ; return flat_abstractC
-       }
-  where
-    data_tycons    = filter isDataTyCon tycons
-    cinfo          = MkCompInfo mod_name
-
-    datatype_stuff = genStaticConBits cinfo data_tycons
-    code_stuff     = initC cinfo (mapCs cgTopBinding stg_binds)
-    init_stuff     = mkModuleInit fe_binders mod_name imported_modules 
-                                         cost_centre_info
-
-    abstractC = mkAbstractCs [ maybeSplitCode,
-                              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
-
+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
+
+           datatype_stuff = genStaticConBits cinfo data_tycons
+           code_stuff     = initC cinfo (mapCs cgTopBinding stg_binds)
+           init_stuff     = mkModuleInit way cost_centre_info mod_impl
+
+           abstractC = mkAbstractCs [ maybeSplitCode,
+                                      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
+
+       dumpIfSet_dyn dflags Opt_D_dump_absC "Abstract C" (dumpRealC abstractC)
+
+       return $! flattenAbsC fl_uniqs abstractC
 \end{code}
 
 %************************************************************************
@@ -100,12 +106,14 @@ codeGen dflags mod_name imported_modules cost_centre_info fe_binders
 
 \begin{code}
 mkModuleInit 
-       :: [Id]                 -- foreign exported functions
-       -> Module               -- module name
-       -> [Module]             -- import names
+       :: String               -- the "way"
        -> CollectedCCs         -- cost centre info
+       -> ModGuts
        -> 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
@@ -115,16 +123,19 @@ mkModuleInit fe_binders mod imps 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,
-        CModuleInitBlock (mkModuleInitLabel mod)
+        CModuleInitBlock (mkPlainModuleInitLabel mod)
+                        (mkModuleInitLabel mod way)
                         (mkAbstractCs (register_fes ++
                                        cc_regs :
                                        register_imports))
@@ -156,10 +167,10 @@ mkCostCentreStuff (local_CCs, extern_CCs, singleton_CCSs)
        [ 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
-         = CCallProfCCMacro SLIT("REGISTER_CCS") [mkCCostCentreStack ccs]
+         = CCallProfCCMacro FSLIT("REGISTER_CCS") [mkCCostCentreStack ccs]
 \end{code}
 
 %************************************************************************