[project @ 2001-01-05 17:57:07 by rrt]

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

diff --git a/ghc/compiler/codeGen/CodeGen.lhs b/ghc/compiler/codeGen/CodeGen.lhs
index 590aa9f..bf6177d 100644 (file)
--- a/ghc/compiler/codeGen/CodeGen.lhs
+++ b/ghc/compiler/codeGen/CodeGen.lhs
@@ -1,5 +1,5 @@
 %
 %

-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998

 %
 \section[CodeGen]{@CodeGen@: main module of the code generator}
 
 %
 \section[CodeGen]{@CodeGen@: main module of the code generator}
 

@@ -15,103 +15,159 @@ functions drive the mangling of top-level bindings.
 %************************************************************************
 
 \begin{code}
 %************************************************************************
 
 \begin{code}

-#include "HsVersions.h"
-

 module CodeGen ( codeGen ) where
 
 module CodeGen ( codeGen ) where
 

-IMP_Ubiq(){-uitous-}
+#include "HsVersions.h"
+
+-- Kludge (??) so that CgExpr is reached via at least one non-SOURCE
+-- import.  Before, that wasn't the case, and CM therefore didn't 
+-- bother to compile it.
+import CgExpr           ( {-NOTHING!-} )       -- DO NOT DELETE THIS IMPORT

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

+import CLabel          ( CLabel, mkSRTLabel, mkClosureLabel, mkModuleInitLabel )

 
 

-import AbsCUtils       ( mkAbstractCs, mkAbsCStmts )
-import Bag             ( foldBag )
+import PprAbsC         ( dumpRealC )
+import AbsCUtils       ( mkAbstractCs, flattenAbsC )
+import CgBindery       ( CgIdInfo, addBindC, addBindsC, getCAddrModeAndInfo )

 import CgClosure       ( cgTopRhsClosure )
 import CgCon           ( cgTopRhsCon )
 import CgConTbls       ( genStaticConBits )
 import ClosureInfo     ( mkClosureLFInfo )
 import CgClosure       ( cgTopRhsClosure )
 import CgCon           ( cgTopRhsCon )
 import CgConTbls       ( genStaticConBits )
 import ClosureInfo     ( mkClosureLFInfo )

-import CmdLineOpts     ( opt_SccProfilingOn, opt_CompilingPrelude,
-                         opt_EnsureSplittableC, opt_SccGroup
-                       )
-import CStrings                ( modnameToC )
-import Maybes          ( maybeToBool )
-import PrimRep         ( getPrimRepSize, PrimRep(..) )
-import Util            ( panic, assertPanic )
+import CmdLineOpts     ( DynFlags, DynFlag(..),
+                         opt_SccProfilingOn, opt_EnsureSplittableC )
+import CostCentre       ( CostCentre, CostCentreStack )
+import Id               ( Id, idName, setIdName )
+import Name            ( globaliseName )
+import Module           ( Module )
+import PrimRep         ( PrimRep(..) )
+import TyCon            ( TyCon, isDataTyCon )
+import BasicTypes      ( TopLevelFlag(..) )
+import UniqSupply      ( mkSplitUniqSupply )
+import ErrUtils                ( dumpIfSet_dyn, showPass )
+import Panic           ( assertPanic )
+
+#ifdef DEBUG
+import Id              ( idCafInfo )
+import IdInfo          ( mayHaveCafRefs )
+import Outputable
+#endif

 \end{code}
 
 \begin{code}
 \end{code}
 
 \begin{code}

-codeGen :: FAST_STRING         -- module name
-       -> ([CostCentre],       -- local cost-centres needing declaring/registering
-           [CostCentre])       -- "extern" cost-centres needing declaring
-       -> [Module]             -- import names
-       -> [TyCon]              -- tycons with data constructors to convert
-       -> FiniteMap TyCon [(Bool, [Maybe Type])]
-                               -- tycon specialisation info
-       -> [StgBinding] -- bindings to convert
-       -> AbstractC            -- output
+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
+       -> [(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'
+       ; let
+           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
+
+           flat_abstractC = flattenAbsC fl_uniqs abstractC

 
 

-codeGen mod_name (local_CCs, extern_CCs) import_names gen_tycons tycon_specs stg_pgm
+       ; dumpIfSet_dyn dflags Opt_D_dump_absC "Abstract C" (dumpRealC abstractC)
+       ; return flat_abstractC
+       }
+  where
+    data_tycons = filter isDataTyCon tycons
+
+    cinfo       = MkCompInfo mod_name
+\end{code}
+
+%************************************************************************
+%*                                                                     *
+\subsection[codegen-init]{Module initialisation code}
+%*                                                                     *
+%************************************************************************
+
+\begin{code}
+mkModuleInit 
+       :: [Id]                 -- foreign exported functions
+       -> Module               -- module name
+       -> [Module]             -- import names
+       -> ([CostCentre],       -- cost centre info
+           [CostCentre],       
+           [CostCentreStack])
+       -> AbstractC
+mkModuleInit fe_binders mod imps cost_centre_info

   = let
   = let

-       doing_profiling   = opt_SccProfilingOn
-       compiling_prelude = opt_CompilingPrelude
-       maybe_split       = if maybeToBool (opt_EnsureSplittableC)
-                           then CSplitMarker
-                           else AbsCNop
+       register_fes = 
+          map (\f -> CMacroStmt REGISTER_FOREIGN_EXPORT [f]) fe_labels
+
+       fe_labels = 
+          map (\f -> CLbl (mkClosureLabel (idName f)) PtrRep) fe_binders
+
+       (cc_decls, cc_regs) = mkCostCentreStuff cost_centre_info

 
 

-       cinfo = MkCompInfo mod_name
+       mk_import_register imp =
+           CMacroStmt REGISTER_IMPORT [
+               CLbl (mkModuleInitLabel imp) AddrRep
+           ]
+
+       register_imports = map mk_import_register imps

     in
     in

-    if not doing_profiling then
-       mkAbstractCs [
-           genStaticConBits cinfo gen_tycons tycon_specs,
-           initC cinfo (cgTopBindings maybe_split stg_pgm) ]
-
-    else -- yes, cost-centre profiling:
-        -- Besides the usual stuff, we must produce:
-        --
-        -- * Declarations for the cost-centres defined in this module;
-        -- * Code to participate in "registering" all the cost-centres
-        --   in the program (done at startup time when the pgm is run).
-        --
-        -- (The local cost-centres involved in this are passed
-        -- into the code-generator, as are the imported-modules' names.)
-        --
-        -- Note: we don't register/etc if compiling Prelude bits.
-
-       mkAbstractCs [
-               if compiling_prelude
-               then AbsCNop
-               else mkAbstractCs [mkAbstractCs (map (CCostCentreDecl True)  local_CCs),
-                                  mkAbstractCs (map (CCostCentreDecl False) extern_CCs),
-                                  mkCcRegister local_CCs import_names],
-
-               genStaticConBits cinfo gen_tycons tycon_specs,
-               initC cinfo (cgTopBindings maybe_split stg_pgm) ]
-  where
-    -----------------
-    grp_name  = case opt_SccGroup of
-                 Just xx -> _PK_ xx
-                 Nothing -> mod_name   -- default: module name
+    mkAbstractCs [
+       cc_decls,
+        CModuleInitBlock (mkModuleInitLabel mod)
+                        (mkAbstractCs (register_fes ++
+                                       cc_regs :
+                                       register_imports))
+    ]
+\end{code}
+
+Cost-centre profiling: Besides the usual stuff, we must produce
+declarations for the cost-centres defined in this module;
+
+(The local cost-centres involved in this are passed into the
+code-generator.)

 
 

-    -----------------
-    mkCcRegister ccs import_names
+\begin{code}
+mkCostCentreStuff (local_CCs, extern_CCs, singleton_CCSs)
+  | not opt_SccProfilingOn = (AbsCNop, AbsCNop)
+  | otherwise = 
+       ( mkAbstractCs (
+               map (CCostCentreDecl True)   local_CCs ++
+               map (CCostCentreDecl False)  extern_CCs ++
+               map CCostCentreStackDecl     singleton_CCSs),
+         mkAbstractCs (mkCcRegister local_CCs singleton_CCSs)
+       )
+  where
+    mkCcRegister ccs cc_stacks

       = let
       = let

-           register_ccs     = mkAbstractCs (map mk_register ccs)
-           register_imports
-             = foldr (mkAbsCStmts . mk_import_register) AbsCNop import_names
+           register_ccs       = mkAbstractCs (map mk_register ccs)
+           register_cc_stacks = mkAbstractCs (map mk_register_ccs cc_stacks)

        in
        in

-       mkAbstractCs [
-           CCallProfCCMacro SLIT("START_REGISTER_CCS") [CLitLit (modnameToC (SLIT("_reg") _APPEND_ mod_name)) AddrRep],
-           register_ccs,
-           register_imports,
-           CCallProfCCMacro SLIT("END_REGISTER_CCS") []
-       ]
+       [ register_ccs, register_cc_stacks ]

       where
        mk_register cc
          = CCallProfCCMacro SLIT("REGISTER_CC") [mkCCostCentre cc]
 
       where
        mk_register cc
          = CCallProfCCMacro SLIT("REGISTER_CC") [mkCCostCentre cc]
 

-       mk_import_register import_name
-         = CCallProfCCMacro SLIT("REGISTER_IMPORT") [CLitLit (modnameToC (SLIT("_reg") _APPEND_ import_name)) AddrRep]
+       mk_register_ccs ccs
+         = CCallProfCCMacro SLIT("REGISTER_CCS") [mkCCostCentreStack ccs]

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

@@ -120,7 +176,7 @@ codeGen mod_name (local_CCs, extern_CCs) import_names gen_tycons tycon_specs stg
 %*                                                                     *
 %************************************************************************
 
 %*                                                                     *
 %************************************************************************
 

-@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.
 

@@ -131,23 +187,70 @@ style, with the increasing static environment being plumbed as a state
 variable.
 
 \begin{code}
 variable.
 
 \begin{code}

-cgTopBindings :: AbstractC -> [StgBinding] -> Code
+cgTopBinding :: (StgBinding,[Id]) -> Code
+cgTopBinding (StgNonRec id rhs, srt)
+  = absC maybeSplitCode                `thenC`
+    maybeGlobaliseId id                `thenFC` \ id' ->
+    let
+       srt_label = mkSRTLabel (idName id')
+    in
+    mkSRT srt_label srt []     `thenC`
+    setSRTLabel srt_label (
+    cgTopRhs id' rhs           `thenFC` \ (id, info) ->
+    addBindC id info
+    )
+
+cgTopBinding (StgRec pairs, srt)
+  = absC maybeSplitCode                        `thenC`
+    let
+        (bndrs, rhss) = unzip pairs
+    in
+    mapFCs maybeGlobaliseId bndrs      `thenFC` \ bndrs'@(id:_) ->
+    let
+       srt_label = mkSRTLabel (idName id)
+       pairs'    = zip bndrs' rhss
+    in
+    mkSRT srt_label srt bndrs'         `thenC`
+    setSRTLabel srt_label (
+       fixC (\ new_binds -> 
+               addBindsC new_binds             `thenC`
+               mapFCs ( \ (b,e) -> cgTopRhs b e ) pairs'
+       )  `thenFC` \ new_binds -> nopC
+    )
+
+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 globalised (see maybeGlobaliseId below).
+    remap id = case filter (==id) these of
+               [] ->  getCAddrModeAndInfo id 
+                               `thenFC` \ (id, _, _) -> returnFC id
+               (id':_) -> returnFC id'

 
 

-cgTopBindings split bindings = mapCs (cgTopBinding split) bindings
+-- if we're splitting the object, we need to globalise all the top-level names
+-- (and then make sure we only use the globalised one in any C label we use
+-- which refers to this name).
+maybeGlobaliseId :: Id -> FCode Id
+maybeGlobaliseId id
+  = moduleName `thenFC` \ mod ->
+    let
+       name = idName id

 
 

-cgTopBinding :: AbstractC -> StgBinding -> Code
+       -- globalise the name for -split-objs, if necessary
+       real_name | opt_EnsureSplittableC = globaliseName name mod
+                 | otherwise             = name

 
 

-cgTopBinding split (StgNonRec name rhs)
-  = absC split         `thenC`
-    cgTopRhs name rhs  `thenFC` \ (name, info) ->
-    addBindC name info
+       id' = setIdName id real_name
+    in 
+    returnFC id'

 
 

-cgTopBinding split (StgRec pairs)
-  = absC split         `thenC`
-    fixC (\ new_binds -> addBindsC new_binds   `thenC`
-                        mapFCs ( \ (b,e) -> cgTopRhs b e ) pairs
-    )                  `thenFC` \ new_binds ->
-    addBindsC new_binds
+maybeSplitCode
+  | opt_EnsureSplittableC = CSplitMarker 
+  | otherwise             = AbsCNop

 
 -- Urgh!  I tried moving the forkStatics call from the rhss of cgTopRhs
 -- to enclose the listFCs in cgTopBinding, but that tickled the
 
 -- Urgh!  I tried moving the forkStatics call from the rhss of cgTopRhs
 -- to enclose the listFCs in cgTopBinding, but that tickled the

@@ -156,14 +259,20 @@ cgTopBinding split (StgRec pairs)
 cgTopRhs :: Id -> StgRhs -> FCode (Id, CgIdInfo)
        -- the Id is passed along for setting up a binding...
 
 cgTopRhs :: Id -> StgRhs -> FCode (Id, CgIdInfo)
        -- the Id is passed along for setting up a binding...
 

-cgTopRhs name (StgRhsCon cc con args)
-  = forkStatics (cgTopRhsCon name con args (all zero_size args))
-  where
-    zero_size atom = getPrimRepSize (getArgPrimRep atom) == 0
+cgTopRhs bndr (StgRhsCon cc con args)
+  = maybeGlobaliseId bndr `thenFC` \ bndr' ->
+    forkStatics (cgTopRhsCon bndr con args)

 
 

-cgTopRhs name (StgRhsClosure cc bi fvs upd_flag args body)
-  = ASSERT(null fvs) -- There should be no free variables
-    forkStatics (cgTopRhsClosure name cc bi args body lf_info)
-  where
-    lf_info = mkClosureLFInfo True{-top level-} [{-no fvs-}] upd_flag args body
+cgTopRhs bndr (StgRhsClosure cc bi srt fvs upd_flag args body)
+  =     -- There should be no free variables
+    ASSERT(null fvs)
+       -- If the closure is a thunk, then the binder must be recorded as such.
+    ASSERT2(not (isUpdatable upd_flag) || mayHaveCafRefs (idCafInfo bndr), ppr bndr)
+
+    getSRTLabel `thenFC` \srt_label ->
+    let lf_info = 
+         mkClosureLFInfo bndr TopLevel [{-no fvs-}] upd_flag args srt_label srt
+    in
+    maybeGlobaliseId bndr `thenFC` \ bndr' ->
+    forkStatics (cgTopRhsClosure bndr' cc bi args body lf_info)

 \end{code}
 \end{code}