[project @ 2003-05-06 10:36:17 by simonmar]

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

diff --git a/ghc/compiler/codeGen/CodeGen.lhs b/ghc/compiler/codeGen/CodeGen.lhs
index 89d4baa..5bcfc69 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-1995
+% (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,129 +15,174 @@ functions drive the mangling of top-level bindings.
 %************************************************************************
 
 \begin{code}
 %************************************************************************
 
 \begin{code}

-#include "HsVersions.h"
-
-module CodeGen (
-       codeGen,
+module CodeGen ( codeGen ) where

 
 

-       -- and to make the interface self-sufficient...
-       UniqFM, AbstractC, StgBinding, Id, FiniteMap
-    ) where
+#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 DriverState     ( v_Build_tag )

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

-
-import CLabelInfo      ( modnameToC )
+import PrelNames       ( gHC_PRIM )
+import CLabel          ( CLabel, mkSRTLabel, mkClosureLabel, 
+                         mkPlainModuleInitLabel, mkModuleInitLabel )
+import PprAbsC         ( dumpRealC )
+import AbsCUtils       ( mkAbstractCs, flattenAbsC )
+import CgBindery       ( CgIdInfo, addBindC, addBindsC, getCAddrModeAndInfo )

 import CgClosure       ( cgTopRhsClosure )
 import CgCon           ( cgTopRhsCon )
 import CgClosure       ( cgTopRhsClosure )
 import CgCon           ( cgTopRhsCon )

-import CgConTbls       ( genStaticConBits, TCE(..), UniqFM )
-import ClosureInfo     ( LambdaFormInfo, mkClosureLFInfo )
-import CmdLineOpts
-import FiniteMap       ( FiniteMap )
-import Maybes          ( Maybe(..) )
-import Pretty          -- debugging only
-import PrimKind                ( getKindSize )
-import Util
+import CgConTbls       ( genStaticConBits )
+import ClosureInfo     ( mkClosureLFInfo )
+import CmdLineOpts     ( DynFlags, DynFlag(..),
+                         opt_SccProfilingOn, opt_EnsureSplittableC )
+import HscTypes                ( ModGuts(..), ModGuts, ForeignStubs(..), TypeEnv,
+                         typeEnvTyCons )
+import CostCentre       ( CollectedCCs )
+import Id               ( Id, idName, setIdName )
+import Name            ( nameSrcLoc, nameOccName, nameUnique, isInternalName, mkExternalName )
+import OccName         ( mkLocalOcc )
+import PrimRep         ( PrimRep(..) )
+import TyCon            ( isDataTyCon )
+import Module          ( Module )
+import BasicTypes      ( TopLevelFlag(..) )
+import UniqSupply      ( mkSplitUniqSupply )
+import ErrUtils                ( dumpIfSet_dyn, showPass )
+import Panic           ( assertPanic )
+
+#ifdef DEBUG
+import Outputable
+#endif
+
+import DATA_IOREF      ( readIORef )
+\end{code}
+
+\begin{code}
+codeGen :: DynFlags
+       -> Module
+       -> TypeEnv
+       -> ForeignStubs
+       -> [Module]             -- directly-imported modules
+       -> CollectedCCs         -- (Local/global) cost-centres needing declaring/registering.
+       -> [(StgBinding,[Id])]  -- Bindings to convert, with SRTs
+       -> IO AbstractC         -- Output
+
+codeGen dflags this_mod type_env foreign_stubs imported_mods 
+       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
+
+       mapM_ (\x -> seq x (return ())) data_tycons
+
+       let
+
+           cinfo          = MkCompInfo this_mod
+
+           datatype_stuff = genStaticConBits cinfo data_tycons
+           code_stuff     = initC cinfo (mapCs cgTopBinding stg_binds)
+           init_stuff     = mkModuleInit way cost_centre_info this_mod
+                               foreign_stubs imported_mods
+
+           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}
 
 \end{code}
 

+%************************************************************************
+%*                                                                     *
+\subsection[codegen-init]{Module initialisation code}
+%*                                                                     *
+%************************************************************************
+

 \begin{code}
 \begin{code}

-codeGen :: FAST_STRING         -- module name
-       -> ([CostCentre],       -- local cost-centres needing declaring/registering
-           [CostCentre])       -- "extern" cost-centres needing declaring
-       -> [FAST_STRING]        -- import names
-       -> (GlobalSwitch -> SwitchResult)
-                               -- global switch lookup function
-       -> [TyCon]              -- tycons with data constructors to convert
-       -> FiniteMap TyCon [(Bool, [Maybe UniType])]
-                               -- tycon specialisation info
-       -> PlainStgProgram      -- bindings to convert
-       -> AbstractC            -- output
-
-codeGen mod_name (local_CCs, extern_CCs) import_names sw_lookup_fn gen_tycons tycon_specs stg_pgm
+mkModuleInit 
+       :: String               -- the "way"
+       -> CollectedCCs         -- cost centre info
+       -> Module
+       -> ForeignStubs
+       -> [Module]
+       -> AbstractC
+mkModuleInit way cost_centre_info this_mod foreign_stubs imported_mods

   = let
   = let

-       switch_is_on      = switchIsOn   sw_lookup_fn
-       int_switch_set    = intSwitchSet sw_lookup_fn
-       doing_profiling   = switch_is_on SccProfilingOn
-       compiling_prelude = switch_is_on CompilingPrelude
-       maybe_split       = if (switch_is_on (EnsureSplittableC (panic "codeGen:esc")))
-                           then CSplitMarker
-                           else AbsCNop
-
-       cinfo = MkCompInfo switch_is_on int_switch_set mod_name
+       (cc_decls, cc_regs) = mkCostCentreStuff cost_centre_info
+
+       register_foreign_exports 
+               = case foreign_stubs of
+                       NoStubs                     -> []
+                       ForeignStubs _ _ _ fe_bndrs -> map mk_export_register fe_bndrs
+
+       mk_export_register bndr
+         = CMacroStmt REGISTER_FOREIGN_EXPORT [lbl]
+         where
+           lbl = CLbl (mkClosureLabel (idName bndr)) PtrRep
+               -- 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_mod_imports = map mk_import_register imported_mods

     in
     in

+    mkAbstractCs [
+       cc_decls,
+        CModuleInitBlock (mkPlainModuleInitLabel this_mod)
+                        (mkModuleInitLabel this_mod way)
+                        (mkAbstractCs (register_foreign_exports ++
+                                       cc_regs :
+                                       register_mod_imports))
+    ]
+\end{code}

 
 

-{- OLD:
-    pprTrace "codeGen:" (ppCat [
-    (case (switch_is_on StgDoLetNoEscapes) of
-       False -> ppStr "False?"
-       True  -> ppStr "True?"
-    ),
-    (case (int_switch_set ReturnInRegsThreshold) of
-       Nothing -> ppStr "Nothing!"
-       Just  n -> ppCat [ppStr "Just", ppInt n]
-    ),
-    (case (int_switch_set UnfoldingUseThreshold) of
-       Nothing -> ppStr "Nothing!"
-       Just  n -> ppCat [ppStr "Just", ppInt n]
-    ),
-    (case (int_switch_set UnfoldingCreationThreshold) of
-       Nothing -> ppStr "Nothing!"
-       Just  n -> ppCat [ppStr "Just", ppInt n]
-    )
-    ]) $
--}
-    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) ]
+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.)
+
+\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
   where

-    -----------------
-    grp_name  = case (stringSwitchSet sw_lookup_fn SccGroup) of
-                 Just xx -> _PK_ xx
-                 Nothing -> mod_name   -- default: module name
-
-    -----------------
-    mkCcRegister ccs import_names
-      = let 
-           register_ccs     = mkAbstractCs (map mk_register ccs)
-           register_imports = mkAbstractCs (map mk_import_register import_names)
+    mkCcRegister ccs cc_stacks
+      = let
+           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)) AddrKind],
-           register_ccs,
-           register_imports,
-           CCallProfCCMacro SLIT("END_REGISTER_CCS") []
-       ]
+       [ register_ccs, register_cc_stacks ]

       where
        mk_register cc
       where
        mk_register cc

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

 
 

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

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

@@ -146,7 +191,7 @@ codeGen mod_name (local_CCs, extern_CCs) import_names sw_lookup_fn gen_tycons ty
 %*                                                                     *
 %************************************************************************
 
 %*                                                                     *
 %************************************************************************
 

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

@@ -157,39 +202,100 @@ style, with the increasing static environment being plumbed as a state
 variable.
 
 \begin{code}
 variable.
 
 \begin{code}

-cgTopBindings :: AbstractC -> PlainStgProgram -> Code
-
-cgTopBindings split bindings = mapCs (cgTopBinding split) bindings
-  
-cgTopBinding :: AbstractC -> PlainStgBinding -> Code
+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 (
+    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
+    )

 
 

-cgTopBinding split (StgNonRec name rhs) 
-  = absC split         `thenC`
-    cgTopRhs name rhs  `thenFC` \ (name, info) ->
-    addBindC name info
+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 (
+       fixC (\ new_binds -> 
+               addBindsC new_binds             `thenC`
+               mapFCs ( \ (b,e) -> cgTopRhs b e srt_info ) pairs'
+       )  `thenFC` \ new_binds -> nopC
+    )

 
 

-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
+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 -> PlainStgRhs -> 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 name (StgRhsCon cc con args)
-  = forkStatics (cgTopRhsCon name con args (all zero_size args))
-  where
-    zero_size atom = getKindSize (getAtomKind atom) == 0
+cgTopRhs bndr (StgRhsCon cc con args) srt
+  = forkStatics (cgTopRhsCon bndr con args 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
+    forkStatics (cgTopRhsClosure bndr cc bi srt args body lf_info)
+\end{code}

 
 

-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)
+
+%************************************************************************
+%*                                                                     *
+\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
   where

-    lf_info = mkClosureLFInfo True{-top level-} [{-no fvs-}] upd_flag args body
+    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}