[project @ 2000-12-06 13:19:49 by simonmar]

Re-engineer the transition from Core to STG syntax.  Main changes in
  this commit:

    - a new pass, CoreSat, handles saturation of constructors and PrimOps,
      and puts the syntax into STG-like normal form (applications to atoms
      only, etc), modulo type applications and Notes.

    - CoreToStg is now done at the same time as StgVarInfo.  Most of the
      contents of StgVarInfo.lhs have been copied into CoreToStg.lhs and
      some simplifications made.

  less major changes:

    - globalisation of names for the purposes of object splitting is
      now done by the C code generator (which is the Right Place in
      principle, but it was a bit fiddly).

    - CoreTidy now does cloning of local binders and collection of arity
      info.  The IdInfo from CoreTidy is now *almost* the final IdInfo we
      put in the interface file, except for CafInfo.  I'm going to move
      the CafInfo collection into CoreTidy in due course too.

    - and some other minor tidyups while I was in cluster-bomb commit mode.

diff --git a/ghc/compiler/codeGen/CgBindery.lhs b/ghc/compiler/codeGen/CgBindery.lhs
index efb4c80..7727c99 100644 (file)
--- a/ghc/compiler/codeGen/CgBindery.lhs
+++ b/ghc/compiler/codeGen/CgBindery.lhs
@@ -38,7 +38,7 @@ import CLabel         ( mkClosureLabel,
 import ClosureInfo     ( mkLFImported, mkLFArgument, LambdaFormInfo )
 import BitSet          ( mkBS, emptyBS )
 import PrimRep         ( isFollowableRep, getPrimRepSize )
 import ClosureInfo     ( mkLFImported, mkLFArgument, LambdaFormInfo )
 import BitSet          ( mkBS, emptyBS )
 import PrimRep         ( isFollowableRep, getPrimRepSize )

-import Id              ( Id, idPrimRep, idType, isDataConWrapId )
+import Id              ( Id, idPrimRep, idType )

 import Type            ( typePrimRep )
 import VarEnv
 import VarSet          ( varSetElems )
 import Type            ( typePrimRep )
 import VarEnv
 import VarSet          ( varSetElems )

@@ -248,31 +248,19 @@ nukeVolatileBinds binds
 I {\em think} all looking-up is done through @getCAddrMode(s)@.
 
 \begin{code}
 I {\em think} all looking-up is done through @getCAddrMode(s)@.
 
 \begin{code}

-getCAddrModeAndInfo :: Id -> FCode (CAddrMode, LambdaFormInfo)
+getCAddrModeAndInfo :: Id -> FCode (Id, CAddrMode, LambdaFormInfo)

 
 getCAddrModeAndInfo id
 
 getCAddrModeAndInfo id

-  | not (isLocalName name) || isDataConWrapId id
-       -- Why the isDataConWrapId?  Because CoreToStg changes a call to 
-       -- a nullary constructor worker fn to a call to its wrapper,
-       -- which may not  be defined until later
-
-    {-                 -- OLD: the unpack stuff isn't injected now Jan 2000
-       Why the "isWiredInName"?
-       Imagine you are compiling PrelBase.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)
+  | not (isLocalName name)
+  = returnFC (id, global_amode, mkLFImported id)
+       -- deals with imported or locally defined but externally visible ids
+       -- (CoreTidy makes all these into global names).

 
   | otherwise = -- *might* be a nested defn: in any case, it's something whose
                -- definition we will know about...
 
   | otherwise = -- *might* be a nested defn: in any case, it's something whose
                -- definition we will know about...

-    lookupBindC id `thenFC` \ (MkCgIdInfo _ volatile_loc stable_loc lf_info) ->
+    lookupBindC id `thenFC` \ (MkCgIdInfo id' volatile_loc stable_loc lf_info) ->

     idInfoPiecesToAmode kind volatile_loc stable_loc `thenFC` \ amode ->
     idInfoPiecesToAmode kind volatile_loc stable_loc `thenFC` \ amode ->

-    returnFC (amode, lf_info)
+    returnFC (id', amode, lf_info)

   where
     name = getName id
     global_amode = CLbl (mkClosureLabel name) kind
   where
     name = getName id
     global_amode = CLbl (mkClosureLabel name) kind

@@ -280,7 +268,7 @@ getCAddrModeAndInfo id
 
 getCAddrMode :: Id -> FCode CAddrMode
 getCAddrMode name
 
 getCAddrMode :: Id -> FCode CAddrMode
 getCAddrMode name

-  = getCAddrModeAndInfo name `thenFC` \ (amode, _) ->
+  = getCAddrModeAndInfo name `thenFC` \ (_, amode, _) ->

     returnFC amode
 \end{code}
 
     returnFC amode
 \end{code}
 

diff --git a/ghc/compiler/codeGen/CgCase.lhs b/ghc/compiler/codeGen/CgCase.lhs
index 1d58b62..b6a438e 100644 (file)
--- a/ghc/compiler/codeGen/CgCase.lhs
+++ b/ghc/compiler/codeGen/CgCase.lhs
@@ -1,7 +1,7 @@
 %
 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
 %
 %
 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
 %

-% $Id: CgCase.lhs,v 1.50 2000/11/15 14:37:08 simonpj Exp $
+% $Id: CgCase.lhs,v 1.51 2000/12/06 13:19:49 simonmar Exp $

 %
 %********************************************************
 %*                                                     *
 %
 %********************************************************
 %*                                                     *

@@ -27,9 +27,8 @@ import AbsCUtils      ( mkAbstractCs, mkAbsCStmts, mkAlgAltsCSwitch,
 import CgUpdate                ( reserveSeqFrame )
 import CgBindery       ( getVolatileRegs, getArgAmodes,
                          bindNewToReg, bindNewToTemp,
 import CgUpdate                ( reserveSeqFrame )
 import CgBindery       ( getVolatileRegs, getArgAmodes,
                          bindNewToReg, bindNewToTemp,

-                         bindNewPrimToAmode,
-                         rebindToStack, getCAddrMode,
-                         getCAddrModeAndInfo, getCAddrModeIfVolatile,
+                         bindNewPrimToAmode, getCAddrModeAndInfo,
+                         rebindToStack, getCAddrMode, getCAddrModeIfVolatile,

                          buildContLivenessMask, nukeDeadBindings,
                        )
 import CgCon           ( bindConArgs, bindUnboxedTupleComponents )
                          buildContLivenessMask, nukeDeadBindings,
                        )
 import CgCon           ( bindConArgs, bindUnboxedTupleComponents )

@@ -252,13 +251,11 @@ we can reuse/trim the stack slot holding the variable (if it is in one).
 
 \begin{code}
 cgCase (StgApp fun args)
 
 \begin{code}
 cgCase (StgApp fun args)

-       live_in_whole_case live_in_alts bndr srt alts   -- @(StgAlgAlts _ _ _)
-                                                       -- SLPJ: Surely PrimAlts is ok too?
-  =
-    getCAddrModeAndInfo fun            `thenFC` \ (fun_amode, lf_info) ->
-    getArgAmodes args                  `thenFC` \ arg_amodes ->
+       live_in_whole_case live_in_alts bndr srt alts
+  = getCAddrModeAndInfo fun                    `thenFC` \ (fun', fun_amode, lf_info) ->
+    getArgAmodes args                          `thenFC` \ arg_amodes ->

 
 

-       -- Squish the environment
+       -- Squish the environment

     nukeDeadBindings live_in_alts      `thenC`
     saveVolatileVarsAndRegs live_in_alts
                        `thenFC` \ (save_assts, alts_eob_info, maybe_cc_slot) ->
     nukeDeadBindings live_in_alts      `thenC`
     saveVolatileVarsAndRegs live_in_alts
                        `thenFC` \ (save_assts, alts_eob_info, maybe_cc_slot) ->

@@ -271,7 +268,7 @@ cgCase (StgApp fun args)
                                         `thenFC` \ scrut_eob_info ->
 
     setEndOfBlockInfo (maybeReserveSeqFrame alts scrut_eob_info)       $
                                         `thenFC` \ scrut_eob_info ->
 
     setEndOfBlockInfo (maybeReserveSeqFrame alts scrut_eob_info)       $

-    tailCallFun fun fun_amode lf_info arg_amodes save_assts
+    tailCallFun fun' fun_amode lf_info arg_amodes save_assts

 \end{code}
 
 Note about return addresses: we *always* push a return address, even
 \end{code}
 
 Note about return addresses: we *always* push a return address, even

diff --git a/ghc/compiler/codeGen/CgClosure.lhs b/ghc/compiler/codeGen/CgClosure.lhs
index 5fba8c0..6f139b1 100644 (file)
--- a/ghc/compiler/codeGen/CgClosure.lhs
+++ b/ghc/compiler/codeGen/CgClosure.lhs
@@ -1,7 +1,7 @@
 %
 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
 %
 %
 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
 %

-% $Id: CgClosure.lhs,v 1.43 2000/11/06 08:15:21 simonpj Exp $
+% $Id: CgClosure.lhs,v 1.44 2000/12/06 13:19:49 simonmar Exp $

 %
 \section[CgClosure]{Code generation for closures}
 
 %
 \section[CgClosure]{Code generation for closures}
 

@@ -45,14 +45,14 @@ import CLabel               ( CLabel, mkClosureLabel, mkFastEntryLabel,
 import ClosureInfo     -- lots and lots of stuff
 import CmdLineOpts     ( opt_GranMacros, opt_SccProfilingOn, opt_DoTickyProfiling )
 import CostCentre      
 import ClosureInfo     -- lots and lots of stuff
 import CmdLineOpts     ( opt_GranMacros, opt_SccProfilingOn, opt_DoTickyProfiling )
 import CostCentre      

-import Id              ( Id, idName, idType, idPrimRep )
-import Name            ( Name, isLocalName )
+import Id              ( Id, idName, idType, idPrimRep, setIdName )
+import Name            ( Name, isLocalName, globaliseName )

 import Module          ( Module, pprModule )
 import ListSetOps      ( minusList )
 import PrimRep         ( PrimRep(..) )
 import PprType          ( showTypeCategory )
 import Util            ( isIn )
 import Module          ( Module, pprModule )
 import ListSetOps      ( minusList )
 import PrimRep         ( PrimRep(..) )
 import PprType          ( showTypeCategory )
 import Util            ( isIn )

-import CmdLineOpts     ( opt_SccProfilingOn )
+import CmdLineOpts     ( opt_SccProfilingOn, opt_EnsureSplittableC )

 import Outputable
 
 import Name             ( nameOccName )
 import Outputable
 
 import Name             ( nameOccName )

@@ -79,9 +79,13 @@ cgTopRhsClosure :: Id
                -> FCode (Id, CgIdInfo)
 
 cgTopRhsClosure id ccs binder_info args body lf_info
                -> FCode (Id, CgIdInfo)
 
 cgTopRhsClosure id ccs binder_info args body lf_info

-  =    -- LAY OUT THE OBJECT
+  = 
+    -- LAY OUT THE OBJECT

     let
     let

-       closure_info = layOutStaticNoFVClosure name lf_info
+       name          = idName id
+       closure_info  = layOutStaticNoFVClosure name lf_info
+       closure_label = mkClosureLabel name
+       cg_id_info    = stableAmodeIdInfo id (CLbl closure_label PtrRep) lf_info

     in
 
        -- BUILD THE OBJECT (IF NECESSARY)
     in
 
        -- BUILD THE OBJECT (IF NECESSARY)

@@ -113,10 +117,7 @@ cgTopRhsClosure id ccs binder_info args body lf_info
     ) `thenC`
 
     returnFC (id, cg_id_info)
     ) `thenC`
 
     returnFC (id, cg_id_info)

-  where
-    name         = idName id
-    closure_label = mkClosureLabel name
-    cg_id_info    = stableAmodeIdInfo id (CLbl closure_label PtrRep) lf_info
+

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

@@ -190,21 +191,19 @@ cgRhsClosure binder cc binder_info fvs args body lf_info
                         then fvs `minusList` [binder]
                         else fvs
     in
                         then fvs `minusList` [binder]
                         else fvs
     in

-    mapFCs getCAddrModeAndInfo reduced_fvs     `thenFC` \ amodes_and_info ->
+    mapFCs getCAddrModeAndInfo reduced_fvs     `thenFC` \ fvs_w_amodes_and_info ->

     let
     let

-       fvs_w_amodes_and_info         = reduced_fvs `zip` amodes_and_info
-

        closure_info :: ClosureInfo
        closure_info :: ClosureInfo

-       bind_details :: [((Id, (CAddrMode, LambdaFormInfo)), VirtualHeapOffset)]
+       bind_details :: [((Id, CAddrMode, LambdaFormInfo), VirtualHeapOffset)]

 
        (closure_info, bind_details)
          = layOutDynClosure (idName binder) get_kind fvs_w_amodes_and_info lf_info
 
 
        (closure_info, bind_details)
          = layOutDynClosure (idName binder) get_kind fvs_w_amodes_and_info lf_info
 

-       bind_fv ((id, (_, lf_info)), offset) = bindNewToNode id offset lf_info
+       bind_fv ((id, _, lf_info), offset) = bindNewToNode id offset lf_info

 
 

-       amodes_w_offsets = [(amode,offset) | ((_, (amode,_)), offset) <- bind_details]
+       amodes_w_offsets = [(amode,offset) | ((_,amode,_), offset) <- bind_details]

 
 

-       get_kind (id, amode_and_info) = idPrimRep id
+       get_kind (id, _, _) = idPrimRep id

     in
        -- BUILD ITS INFO TABLE AND CODE
     forkClosureBody (
     in
        -- BUILD ITS INFO TABLE AND CODE
     forkClosureBody (

diff --git a/ghc/compiler/codeGen/CgCon.lhs b/ghc/compiler/codeGen/CgCon.lhs
index 5ad6264..9b22fcc 100644 (file)
--- a/ghc/compiler/codeGen/CgCon.lhs
+++ b/ghc/compiler/codeGen/CgCon.lhs
@@ -68,7 +68,14 @@ cgTopRhsCon :: Id            -- Name of thing bound to this RHS
            -> [StgArg]         -- Args
            -> FCode (Id, CgIdInfo)
 cgTopRhsCon id con args
            -> [StgArg]         -- Args
            -> FCode (Id, CgIdInfo)
 cgTopRhsCon id con args

-  = ASSERT(not dynamic_con_or_args)    -- checks for litlit args too
+  = ASSERT(not (isDllConApp con args)) -- checks for litlit args too
+    let
+       name          = idName id
+       closure_label = mkClosureLabel name
+       lf_info       = mkConLFInfo con
+       cg_id_info    = stableAmodeIdInfo id (CLbl closure_label PtrRep) lf_info
+    in
+

     (
        -- LAY IT OUT
     getArgAmodes args          `thenFC` \ amodes ->
     (
        -- LAY IT OUT
     getArgAmodes args          `thenFC` \ amodes ->

@@ -82,22 +89,13 @@ cgTopRhsCon id con args
     absC (CStaticClosure
            closure_label               -- Labelled with the name on lhs of defn
            closure_info                -- Closure is static
     absC (CStaticClosure
            closure_label               -- Labelled with the name on lhs of defn
            closure_info                -- Closure is static

-           top_ccc
+           (mkCCostCentreStack dontCareCCS) -- because it's static data

            (map fst amodes_w_offsets)) -- Sorted into ptrs first, then nonptrs
 
     ) `thenC`
 
        -- RETURN
     returnFC (id, stableAmodeIdInfo id (CLbl closure_label PtrRep) lf_info)
            (map fst amodes_w_offsets)) -- Sorted into ptrs first, then nonptrs
 
     ) `thenC`
 
        -- RETURN
     returnFC (id, stableAmodeIdInfo id (CLbl closure_label PtrRep) lf_info)

-  where
-    lf_info        = mkConLFInfo    con
-    closure_label   = mkClosureLabel name
-    name            = idName id
-
-    top_ccc = mkCCostCentreStack dontCareCCS -- because it's static data
-
-    -- stuff needed by the assert pred only.
-    dynamic_con_or_args = isDllConApp con args

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

diff --git a/ghc/compiler/codeGen/CgTailCall.lhs b/ghc/compiler/codeGen/CgTailCall.lhs
index 9a96edb..06e7ff5 100644 (file)
--- a/ghc/compiler/codeGen/CgTailCall.lhs
+++ b/ghc/compiler/codeGen/CgTailCall.lhs
@@ -1,7 +1,7 @@
 %
 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
 %
 %
 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
 %

-% $Id: CgTailCall.lhs,v 1.28 2000/11/06 08:15:21 simonpj Exp $
+% $Id: CgTailCall.lhs,v 1.29 2000/12/06 13:19:49 simonmar Exp $

 %
 %********************************************************
 %*                                                     *
 %
 %********************************************************
 %*                                                     *

@@ -42,8 +42,7 @@ import CgUpdate               ( pushSeqFrame )
 import CLabel          ( mkUpdInfoLabel, mkRtsPrimOpLabel, 
                          mkBlackHoleInfoTableLabel )
 import ClosureInfo     ( nodeMustPointToIt,
 import CLabel          ( mkUpdInfoLabel, mkRtsPrimOpLabel, 
                          mkBlackHoleInfoTableLabel )
 import ClosureInfo     ( nodeMustPointToIt,

-                         getEntryConvention, EntryConvention(..),
-                         LambdaFormInfo
+                         getEntryConvention, EntryConvention(..), LambdaFormInfo

                        )
 import CmdLineOpts     ( opt_DoSemiTagging )
 import Id              ( Id, idType, idName )
                        )
 import CmdLineOpts     ( opt_DoSemiTagging )
 import Id              ( Id, idType, idName )

@@ -322,38 +321,33 @@ returnUnboxedTuple amodes before_jump
 \end{code}
 
 \begin{code}
 \end{code}
 
 \begin{code}

-performTailCall :: Id          -- Function
-               -> [StgArg]     -- Args
-               -> Code
-
+performTailCall :: Id -> [StgArg] -> Code

 performTailCall fun args
 performTailCall fun args

-  =    -- Get all the info we have about the function and args and go on to
-       -- the business end
-    getCAddrModeAndInfo fun    `thenFC` \ (fun_amode, lf_info) ->
-    getArgAmodes args          `thenFC` \ arg_amodes ->
-
-    tailCallFun
-               fun fun_amode lf_info arg_amodes
-               AbsCNop {- No pending assignments -}
-
-
--- generating code for a tail call to a function (or closure)
-
-tailCallFun :: Id -> CAddrMode -- Function and its amode
-                -> LambdaFormInfo      -- Info about the function
-                -> [CAddrMode]         -- Arguments
+  = getCAddrModeAndInfo fun                    `thenFC` \ (fun', fun_amode, lf_info) ->
+    getArgAmodes args                          `thenFC` \ arg_amodes ->
+    tailCallFun fun' fun_amode lf_info arg_amodes AbsCNop{- No pending assignments -}
+\end{code}

 
 

-                -> AbstractC           -- Pending simultaneous assignments
-                                       -- *** GUARANTEED to contain only stack 
-                                       -- assignments.
+Generating code for a tail call to a function (or closure)

 
 

+\begin{code}
+tailCallFun
+        :: Id                          -- Function
+        -> CAddrMode
+        -> LambdaFormInfo
+        -> [CAddrMode]                 -- Arguments
+        -> AbstractC                   -- Pending simultaneous assignments
+                                         -- *** GUARANTEED to contain only stack 
+                                         -- assignments.

                                        -- In ptic, we don't need to look in 
                                        -- here to discover all live regs
                                        -- In ptic, we don't need to look in 
                                        -- here to discover all live regs

-
-                -> Code
+        -> Code

 
 tailCallFun fun fun_amode lf_info arg_amodes pending_assts
   = nodeMustPointToIt lf_info                  `thenFC` \ node_points ->
 
 tailCallFun fun fun_amode lf_info arg_amodes pending_assts
   = nodeMustPointToIt lf_info                  `thenFC` \ node_points ->

+       -- we use the name of fun', the Id from the environment, rather than
+       -- fun from the STG tree, in case it is a top-level name that we globalised
+       -- (see cgTopRhsClosure).

     getEntryConvention (idName fun) lf_info
        (map getAmodeRep arg_amodes)            `thenFC` \ entry_conv ->
     let
     getEntryConvention (idName fun) lf_info
        (map getAmodeRep arg_amodes)            `thenFC` \ entry_conv ->
     let

diff --git a/ghc/compiler/codeGen/ClosureInfo.lhs b/ghc/compiler/codeGen/ClosureInfo.lhs
index 6ccd79e..05a05b4 100644 (file)
--- a/ghc/compiler/codeGen/ClosureInfo.lhs
+++ b/ghc/compiler/codeGen/ClosureInfo.lhs
@@ -1,7 +1,7 @@
 %
 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
 %
 %
 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
 %

-% $Id: ClosureInfo.lhs,v 1.43 2000/07/14 08:14:53 simonpj Exp $
+% $Id: ClosureInfo.lhs,v 1.44 2000/12/06 13:19:49 simonmar Exp $

 %
 \section[ClosureInfo]{Data structures which describe closures}
 
 %
 \section[ClosureInfo]{Data structures which describe closures}
 

@@ -686,7 +686,7 @@ getEntryConvention name lf_info arg_kinds
          -> StdEntry (mkReturnPtLabel (nameUnique name))
 
        LFLetNoEscape arity
          -> StdEntry (mkReturnPtLabel (nameUnique name))
 
        LFLetNoEscape arity

-         -> ASSERT(arity == length arg_kinds)
+         -> if (arity /= length arg_kinds) then pprPanic "let-no-escape: " (ppr name <+> ppr arity) else

             DirectEntry (mkReturnPtLabel (nameUnique name)) arity arg_regs
         where
            (arg_regs, _) = assignRegs [] arg_kinds
             DirectEntry (mkReturnPtLabel (nameUnique name)) arity arg_regs
         where
            (arg_regs, _) = assignRegs [] arg_kinds

diff --git a/ghc/compiler/codeGen/CodeGen.lhs b/ghc/compiler/codeGen/CodeGen.lhs
index 2390765..66373b2 100644 (file)
--- a/ghc/compiler/codeGen/CodeGen.lhs
+++ b/ghc/compiler/codeGen/CodeGen.lhs
@@ -31,7 +31,7 @@ import CLabel         ( CLabel, mkSRTLabel, mkClosureLabel, 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 CgClosure       ( cgTopRhsClosure )
 import CgCon           ( cgTopRhsCon )
 import CgConTbls       ( genStaticConBits )

@@ -39,7 +39,8 @@ import ClosureInfo    ( mkClosureLFInfo )
 import CmdLineOpts     ( DynFlags, DynFlag(..),
                          opt_SccProfilingOn, opt_EnsureSplittableC )
 import CostCentre       ( CostCentre, CostCentreStack )
 import CmdLineOpts     ( DynFlags, DynFlag(..),
                          opt_SccProfilingOn, opt_EnsureSplittableC )
 import CostCentre       ( CostCentre, CostCentreStack )

-import Id               ( Id, idName )
+import Id               ( Id, idName, setIdName )
+import Name            ( globaliseName )

 import Module           ( Module )
 import PrimRep         ( PrimRep(..) )
 import TyCon            ( TyCon, isDataTyCon )
 import Module           ( Module )
 import PrimRep         ( PrimRep(..) )
 import TyCon            ( TyCon, isDataTyCon )

@@ -70,11 +71,11 @@ codeGen dflags mod_name imported_modules cost_centre_info fe_binders
        ; fl_uniqs <- mkSplitUniqSupply 'f'
        ; let
            datatype_stuff = genStaticConBits cinfo data_tycons
        ; fl_uniqs <- mkSplitUniqSupply 'f'
        ; let
            datatype_stuff = genStaticConBits cinfo data_tycons

-           code_stuff     = initC cinfo (cgTopBindings maybe_split stg_binds)
+           code_stuff     = initC cinfo (mapCs cgTopBinding stg_binds)

            init_stuff     = mkModuleInit fe_binders mod_name imported_modules 
                                          cost_centre_info
 
            init_stuff     = mkModuleInit fe_binders mod_name imported_modules 
                                          cost_centre_info
 

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

                                       init_stuff, 
                                       code_stuff,
                                       datatype_stuff]
                                       init_stuff, 
                                       code_stuff,
                                       datatype_stuff]

@@ -90,9 +91,6 @@ codeGen dflags mod_name imported_modules cost_centre_info fe_binders
   where
     data_tycons = filter isDataTyCon tycons
 
   where
     data_tycons = filter isDataTyCon tycons
 

-    maybe_split = if opt_EnsureSplittableC 
-                 then CSplitMarker 
-                 else AbsCNop

     cinfo       = MkCompInfo mod_name
 \end{code}
 
     cinfo       = MkCompInfo mod_name
 \end{code}
 

@@ -174,7 +172,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,37 +183,70 @@ 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 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 (
     setSRTLabel srt_label (

-    cgTopRhs name rhs          `thenFC` \ (name, info) ->
-    addBindC name info
+    cgTopRhs id' rhs           `thenFC` \ (id, info) ->
+    addBindC id info

     )
     )

-  where
-    srt_label = mkSRTLabel (idName name)

 
 

-cgTopBinding split ((StgRec pairs@((name,rhs):_)), srt)
-  = absC split                 `thenC`
-    absC (mkSRT srt_label srt)         `thenC`
+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 (
     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 ) 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 globalised (see maybeGlobaliseId below).
+    remap id = case filter (==id) these of
+               [] ->  getCAddrModeAndInfo id 
+                               `thenFC` \ (id, _, _) -> returnFC id
+               (id':_) -> returnFC id'
+
+-- 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
+
+       -- globalise the name for -split-objs, if necessary
+       real_name | opt_EnsureSplittableC = globaliseName name mod
+                 | otherwise             = name
+
+       id' = setIdName id real_name
+    in 
+    returnFC id'
+
+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

@@ -225,7 +256,8 @@ cgTopRhs :: Id -> StgRhs -> FCode (Id, CgIdInfo)
        -- the Id is passed along for setting up a binding...
 
 cgTopRhs bndr (StgRhsCon cc con args)
        -- the Id is passed along for setting up a binding...
 
 cgTopRhs bndr (StgRhsCon cc con args)

-  = forkStatics (cgTopRhsCon bndr con args)
+  = maybeGlobaliseId bndr `thenFC` \ bndr' ->
+    forkStatics (cgTopRhsCon bndr con args)

 
 cgTopRhs bndr (StgRhsClosure cc bi srt fvs upd_flag args body)
   = ASSERT(null fvs) -- There should be no free variables
 
 cgTopRhs bndr (StgRhsClosure cc bi srt fvs upd_flag args body)
   = ASSERT(null fvs) -- There should be no free variables

@@ -233,5 +265,6 @@ cgTopRhs bndr (StgRhsClosure cc bi srt fvs upd_flag args body)
     let lf_info = 
          mkClosureLFInfo bndr TopLevel [{-no fvs-}] upd_flag args srt_label srt
     in
     let lf_info = 
          mkClosureLFInfo bndr TopLevel [{-no fvs-}] upd_flag args srt_label srt
     in

-    forkStatics (cgTopRhsClosure bndr cc bi args body lf_info)
+    maybeGlobaliseId bndr `thenFC` \ bndr' ->
+    forkStatics (cgTopRhsClosure bndr' cc bi args body lf_info)

 \end{code}
 \end{code}