Big collection of patches for the new codegen branch.
authordias@eecs.harvard.edu <unknown>
Mon, 13 Oct 2008 13:25:56 +0000 (13:25 +0000)
committerdias@eecs.harvard.edu <unknown>
Mon, 13 Oct 2008 13:25:56 +0000 (13:25 +0000)
o Fixed bug that emitted the copy-in code for closure entry
  in the wrong place -- at the initialization of the closure.
o Refactored some of the closure entry code.
o Added code to check that no LocalRegs are live-in to a procedure
   -- trip up some buggy programs earlier
o Fixed environment bindings for thunks
   -- we weren't (re)binding the free variables in a thunk
o Fixed a bug in proc-point splitting that dropped some updates
  to the entry block in a procedure.
o Fixed improper calls to code that generates CmmLit's for strings
o New invariant on cg_loc in CgIdInfo: the expression is always tagged
o Code to load free vars on entry to a thunk was (wrongly) placed before
  the heap check.
o Some of the StgCmm code was redundantly passing around Id's
  along with CgIdInfo's; no more.
o Initialize the LocalReg's that point to a closure before allocating and
  initializing the closure itself -- otherwise, we have problems with
  recursive closure bindings
o BlockEnv and BlockSet types are now abstract.
o Update frames:
  - push arguments in Old call area
  - keep track of the return sp in the FCode monad
  - keep the return sp in every call, tail call, and return
      (because it might be different at different call sites,
       e.g. tail calls to the gc after a heap check are performed
            before pushing the update frame)
  - set the sp appropriately on returns and tail calls
o Reduce call, tail call, and return to a single LastCall node
o Added slow entry code, using different calling conventions on entry and tail call
o More fixes to the calling convention code.
  The tricky stuff is all about the closure environment: it must be passed in R1,
  but in non-closures, there is no such argument, so we can't treat all arguments
  the same way: the closure environment is special. Maybe the right step forward
  would be to define a different calling convention for closure arguments.
o Let-no-escapes need to be emitted out-of-line -- otherwise, we drop code.
o Respect RTS requirement of word alignment for pointers
  My stack allocation can pack sub-word values into a single word on the stack,
  but it wasn't requiring word-alignment for pointers. It does now,
  by word-aligning both pointer registers and call areas.
o CmmLint was over-aggresively ruling out non-word-aligned memory references,
  which may be kosher now that we can spill small values into a single word.
o Wrong label order on a conditional branch when compiling switches.
o void args weren't dropped in many cases.
  To help prevent this kind of mistake, I defined a NonVoid wrapper,
  which I'm applying only to Id's for now, although there are probably
  other good candidates.
o A little code refactoring: separate modules for procpoint analysis splitting,
  stack layout, and building infotables.
o Stack limit check: insert along with the heap limit check, using a symbolic
  constant (a special CmmLit), then replace it when the stack layout is known.
o Removed last node: MidAddToContext
o Adding block id as a literal: means that the lowering of the calling conventions
  no longer has to produce labels early, which was inhibiting common-block elimination.
  Will also make it easier for the non-procpoint-splitting path.
o Info tables: don't try to describe the update frame!
o Over aggressive use of NonVoid!!!!
  Don't drop the non-void args before setting the type of the closure!!!
o Sanity checking:
  Added a pass to stub dead dead slots on the stack
  (only ~10 lines with the dataflow framework)
o More sanity checking:
  Check that incoming pointer arguments are non-stubbed.
  Note: these checks are still subject to dead-code removal, but they should
  still be quite helpful.
o Better sanity checking: why stop at function arguments?
  Instead, in mkAssign, check that _any_ assignment to a pointer type is non-null
  -- the sooner the crash, the easier it is to debug.
  Still need to add the debugging flag to turn these checks on explicitly.
o Fixed yet another calling convention bug.
  This time, the calls to the GC were wrong. I've added a new convention
  for GC calls and invoked it where appropriate.
  We should really straighten out the calling convention stuff:
    some of the code (and documentation) is spread across the compiler,
    and there's some magical use of the node register that should really
    be handled (not avoided) by calling conventions.
o Switch bug: the arms in mkCmmLitSwitch weren't returning to a single join point.
o Environment shadowing problem in Stg->Cmm:
  When a closure f is bound at the top-level, we should not bind f to the
  node register on entry to the closure.
  Why? Because if the body of f contains a let-bound closure g that refers
  to f, we want to make sure that it refers to the static closure for f.
  Normally, this would all be fine, because when we compile a closure,
  we rebind free variables in the environment. But f doesn't look like
  a free variable because it's a static value. So, the binding for f
  remains in the environment when we compile g, inconveniently referring
  to the wrong thing.
  Now, I bind the variable in the local environment only if the closure is not
  bound at the top level. It's still okay to make assumptions about the
  node holding the closure environment; we just won't find the binding
  in the environment, so code that names the closure will now directly
  get the label of the static closure, not the node register holding a
  pointer to the static closure.
o Don't generate bogus Cmm code containing SRTs during the STG -> Cmm pass!
  The tables made reference to some labels that don't exist when we compute and
  generate the tables in the back end.
o Safe foreign calls need some special treatment (at least until we have the integrated
  codegen). In particular:
  o they need info tables
  o they are not procpoints -- the successor had better be in the same procedure
  o we cannot (yet) implement the calling conventions early, which means we have
    to carry the calling-conv info all the way to the end
o We weren't following the old convention when registering a module.
  Now, we use update frames to push any new modules that have to be registered
  and enter the youngest one on the stack.
  We also use the update frame machinery to specify that the return should pop
  the return address off the stack.
o At each safe foreign call, an infotable must be at the bottom of the stack,
  and the TSO->sp must point to it.
o More problems with void args in a direct call to a function:
  We were checking the args (minus voids) to check whether the call was saturated,
  which caused problems when the function really wasn't saturated because it
  took an extra void argument.
o Forgot to distinguish integer != from floating != during Stg->Cmm
o Updating slotEnv and areaMap to include safe foreign calls
  The dataflow analyses that produce the slotEnv and areaMap give
  results for each basic block, but we also need the results for
  a safe foreign call, which is a middle node.
  After running the dataflow analysis, we have another pass that
  updates the results to includ any safe foreign calls.
o Added a static flag for the debugging technique that inserts
  instructions to stub dead slots on the stack and crashes when
  a stubbed value is loaded into a pointer-typed LocalReg.
o C back end expects to see return continuations before their call sites.
  Sorted the flowgraphs appropriately after splitting.
o PrimOp calling conventions are special -- unlimited registers, no stack
  Yet another calling convention...
o More void value problems: if the RHS of a case arm is a void-typed variable,
  don't try to return it.
o When calling some primOp, they may allocate memory; if so, we need to
  do a heap check when we return from the call.

56 files changed:
compiler/cmm/BlockId.hs
compiler/cmm/CLabel.hs
compiler/cmm/Cmm.hs
compiler/cmm/CmmBrokenBlock.hs
compiler/cmm/CmmCPS.hs
compiler/cmm/CmmCPSZ.hs
compiler/cmm/CmmCallConv.hs
compiler/cmm/CmmCommonBlockElimZ.hs
compiler/cmm/CmmContFlowOpt.hs
compiler/cmm/CmmCvt.hs
compiler/cmm/CmmExpr.hs
compiler/cmm/CmmInfo.hs
compiler/cmm/CmmLint.hs
compiler/cmm/CmmLive.hs
compiler/cmm/CmmLiveZ.hs
compiler/cmm/CmmOpt.hs
compiler/cmm/CmmParse.y
compiler/cmm/CmmProcPoint.hs
compiler/cmm/CmmProcPointZ.hs
compiler/cmm/CmmSpillReload.hs
compiler/cmm/CmmZipUtil.hs
compiler/cmm/DFMonad.hs
compiler/cmm/MkZipCfg.hs
compiler/cmm/MkZipCfgCmm.hs
compiler/cmm/OptimizationFuel.hs
compiler/cmm/PprC.hs
compiler/cmm/PprCmm.hs
compiler/cmm/PprCmmZ.hs
compiler/cmm/StackColor.hs
compiler/cmm/ZipCfg.hs
compiler/cmm/ZipCfgCmmRep.hs
compiler/cmm/ZipCfgExtras.hs
compiler/cmm/ZipDataflow.hs
compiler/codeGen/CgInfoTbls.hs
compiler/codeGen/StgCmm.hs
compiler/codeGen/StgCmmBind.hs
compiler/codeGen/StgCmmClosure.hs
compiler/codeGen/StgCmmCon.hs
compiler/codeGen/StgCmmEnv.hs
compiler/codeGen/StgCmmExpr.hs
compiler/codeGen/StgCmmForeign.hs
compiler/codeGen/StgCmmHeap.hs
compiler/codeGen/StgCmmLayout.hs
compiler/codeGen/StgCmmMonad.hs
compiler/codeGen/StgCmmPrim.hs
compiler/codeGen/StgCmmProf.hs
compiler/codeGen/StgCmmUtils.hs
compiler/ghc.cabal.in
compiler/main/HscMain.lhs
compiler/main/StaticFlagParser.hs
compiler/main/StaticFlags.hs
compiler/nativeGen/MachRegs.lhs
compiler/nativeGen/PprMach.hs
compiler/nativeGen/RegAllocLinear.hs
compiler/nativeGen/RegLiveness.hs
compiler/nativeGen/RegSpillCost.hs

index 2e4d452..01ddcd2 100644 (file)
@@ -1,12 +1,18 @@
 module BlockId
   ( BlockId(..), mkBlockId     -- ToDo: BlockId should be abstract, but it isn't yet
-  , BlockEnv, emptyBlockEnv, lookupBlockEnv, extendBlockEnv, mkBlockEnv, mapBlockEnv
-  , BlockSet, emptyBlockSet, elemBlockSet, extendBlockSet, sizeBlockSet, mkBlockSet
-  , foldBlockEnv, blockLbl, infoTblLbl
+  , BlockEnv, emptyBlockEnv, elemBlockEnv, lookupBlockEnv, extendBlockEnv
+  , mkBlockEnv, mapBlockEnv
+  , eltsBlockEnv, plusBlockEnv, delFromBlockEnv, blockEnvToList, lookupWithDefaultBEnv
+  , isNullBEnv, sizeBEnv, foldBlockEnv, foldBlockEnv', addToBEnv_Acc
+  , BlockSet, emptyBlockSet, unitBlockSet, isEmptyBlockSet
+  , elemBlockSet, extendBlockSet, sizeBlockSet, unionBlockSets
+  , removeBlockSet, mkBlockSet, blockSetToList, foldBlockSet
+  , blockLbl, infoTblLbl, retPtLbl
   ) where
 
 import CLabel
 import IdInfo
+import Maybes
 import Name
 import Outputable
 import UniqFM
@@ -21,15 +27,15 @@ import UniqSet
 Although a 'BlockId' is a local label, for reasons of implementation,
 'BlockId's must be unique within an entire compilation unit.  The reason
 is that each local label is mapped to an assembly-language label, and in
-most assembly languages allow, a label is visible throughout the enitre
+most assembly languages allow, a label is visible throughout the entire
 compilation unit in which it appears.
 -}
 
-newtype BlockId = BlockId Unique
+data BlockId = BlockId Unique
   deriving (Eq,Ord)
 
 instance Uniquable BlockId where
-  getUnique (BlockId u) = u
+  getUnique (BlockId id) = id
 
 mkBlockId :: Unique -> BlockId
 mkBlockId uniq = BlockId uniq
@@ -38,36 +44,116 @@ instance Show BlockId where
   show (BlockId u) = show u
 
 instance Outputable BlockId where
-  ppr = ppr . getUnique
+  ppr (BlockId id) = ppr id
+
+retPtLbl :: BlockId -> CLabel
+retPtLbl (BlockId id) = mkReturnPtLabel id
 
 blockLbl :: BlockId -> CLabel
-blockLbl id = mkEntryLabel (mkFCallName (getUnique id) "block") NoCafRefs
+blockLbl (BlockId id) = mkEntryLabel (mkFCallName id "block") NoCafRefs
 
 infoTblLbl :: BlockId -> CLabel
-infoTblLbl id = mkInfoTableLabel (mkFCallName (getUnique id) "block") NoCafRefs
+infoTblLbl (BlockId id) = mkInfoTableLabel (mkFCallName id "block") NoCafRefs
+
+-- Block environments: Id blocks
+newtype BlockEnv a = BlockEnv (UniqFM {- id -} a)
 
-type BlockEnv a = UniqFM {- BlockId -} a
+instance Outputable a => Outputable (BlockEnv a) where
+  ppr (BlockEnv env) = ppr env
+
+-- This is pretty horrid. There must be common patterns here that can be
+-- abstracted into wrappers.
 emptyBlockEnv :: BlockEnv a
-emptyBlockEnv = emptyUFM
+emptyBlockEnv = BlockEnv emptyUFM
+
+isNullBEnv :: BlockEnv a -> Bool
+isNullBEnv (BlockEnv env) = isNullUFM env
+
+sizeBEnv :: BlockEnv a -> Int
+sizeBEnv (BlockEnv env)  = sizeUFM env
+
 mkBlockEnv :: [(BlockId,a)] -> BlockEnv a
-mkBlockEnv = listToUFM
+mkBlockEnv = foldl (uncurry . extendBlockEnv) emptyBlockEnv
+
+eltsBlockEnv :: BlockEnv elt -> [elt]
+eltsBlockEnv (BlockEnv env) = eltsUFM env
+
+delFromBlockEnv        :: BlockEnv elt -> BlockId -> BlockEnv elt
+delFromBlockEnv          (BlockEnv env) (BlockId id) = BlockEnv (delFromUFM env id)
+
 lookupBlockEnv :: BlockEnv a -> BlockId -> Maybe a
-lookupBlockEnv = lookupUFM
+lookupBlockEnv (BlockEnv env) (BlockId id) = lookupUFM env id
+
+elemBlockEnv :: BlockEnv a -> BlockId -> Bool
+elemBlockEnv (BlockEnv env) (BlockId id) = isJust $ lookupUFM env id
+
+lookupWithDefaultBEnv :: BlockEnv a -> a -> BlockId -> a
+lookupWithDefaultBEnv env x id = lookupBlockEnv env id `orElse` x
+
 extendBlockEnv :: BlockEnv a -> BlockId -> a -> BlockEnv a
-extendBlockEnv = addToUFM
+extendBlockEnv (BlockEnv env) (BlockId id) x = BlockEnv (addToUFM env id x)
+
 mapBlockEnv :: (a -> b) -> BlockEnv a -> BlockEnv b
-mapBlockEnv = mapUFM
+mapBlockEnv f (BlockEnv env) = BlockEnv (mapUFM f env)
+
 foldBlockEnv :: (BlockId -> a -> b -> b) -> b -> BlockEnv a -> b
-foldBlockEnv f = foldUFM_Directly (\u x y -> f (mkBlockId u) x y)
+foldBlockEnv f b (BlockEnv env) = 
+  foldUFM_Directly (\u x y -> f (mkBlockId u) x y) b env
+
+foldBlockEnv' :: (a -> b -> b) -> b -> BlockEnv a -> b
+foldBlockEnv' f b (BlockEnv env) = foldUFM f b env
+
+plusBlockEnv :: BlockEnv elt -> BlockEnv elt -> BlockEnv elt
+plusBlockEnv (BlockEnv x) (BlockEnv y) = BlockEnv (plusUFM x y)
+
+blockEnvToList :: BlockEnv elt -> [(BlockId, elt)]
+blockEnvToList (BlockEnv env) =
+  map (\ (id, elt) -> (BlockId id, elt)) $ ufmToList env
+
+addToBEnv_Acc  :: (elt -> elts -> elts)        -- Add to existing
+                          -> (elt -> elts)             -- New element
+                          -> BlockEnv elts             -- old
+                          -> BlockId -> elt            -- new
+                          -> BlockEnv elts             -- result
+addToBEnv_Acc add new (BlockEnv old) (BlockId k) v =
+  BlockEnv (addToUFM_Acc add new old k v)
+  -- I believe this is only used by obsolete code.
+
+
+newtype BlockSet = BlockSet (UniqSet Unique)
+instance Outputable BlockSet where
+  ppr (BlockSet set) = ppr set
+
 
-type BlockSet = UniqSet BlockId
 emptyBlockSet :: BlockSet
-emptyBlockSet = emptyUniqSet
+emptyBlockSet = BlockSet emptyUniqSet
+
+isEmptyBlockSet :: BlockSet -> Bool
+isEmptyBlockSet (BlockSet s) = isEmptyUniqSet s
+
+unitBlockSet :: BlockId -> BlockSet
+unitBlockSet = extendBlockSet emptyBlockSet
+
 elemBlockSet :: BlockId -> BlockSet -> Bool
-elemBlockSet = elementOfUniqSet
+elemBlockSet (BlockId id) (BlockSet set) = elementOfUniqSet id set
+
 extendBlockSet :: BlockSet -> BlockId -> BlockSet
-extendBlockSet = addOneToUniqSet
+extendBlockSet (BlockSet set) (BlockId id) = BlockSet (addOneToUniqSet set id)
+
+removeBlockSet :: BlockSet -> BlockId -> BlockSet
+removeBlockSet (BlockSet set) (BlockId id) = BlockSet (delOneFromUniqSet set id)
+
 mkBlockSet :: [BlockId] -> BlockSet
-mkBlockSet = mkUniqSet
+mkBlockSet = foldl extendBlockSet emptyBlockSet
+
+unionBlockSets :: BlockSet -> BlockSet -> BlockSet
+unionBlockSets (BlockSet s) (BlockSet s') = BlockSet (unionUniqSets s s')
+
 sizeBlockSet :: BlockSet -> Int
-sizeBlockSet = sizeUniqSet
+sizeBlockSet (BlockSet set) = sizeUniqSet set
+
+blockSetToList :: BlockSet -> [BlockId]
+blockSetToList (BlockSet set) = map BlockId $ uniqSetToList set
+
+foldBlockSet :: (BlockId -> b -> b) -> b -> BlockSet -> b
+foldBlockSet f z (BlockSet set) = foldUniqSet (f . BlockId) z set
index ffa93fb..aa72b65 100644 (file)
@@ -107,7 +107,7 @@ module CLabel (
         mkHpcModuleNameLabel,
 
         hasCAF,
-       infoLblToEntryLbl, entryLblToInfoLbl,
+       infoLblToEntryLbl, entryLblToInfoLbl, cvtToClosureLbl, cvtToSRTLbl,
        needsCDecl, isAsmTemp, maybeAsmTemp, externallyVisibleCLabel,
         isMathFun,
        isCFunctionLabel, isGcPtrLabel, labelDynamic,
@@ -458,11 +458,23 @@ entryLblToInfoLbl (RtsLabel (RtsEntryFS s)) = RtsLabel (RtsInfoFS s)
 entryLblToInfoLbl (RtsLabel (RtsRetFS s)) = RtsLabel (RtsRetInfoFS s)
 entryLblToInfoLbl l = pprPanic "CLabel.entryLblToInfoLbl" (pprCLabel l)
 
+cvtToClosureLbl   (IdLabel n c InfoTable) = IdLabel n c Closure
+cvtToClosureLbl   (IdLabel n c Entry)     = IdLabel n c Closure
+cvtToClosureLbl   (IdLabel n c ConEntry)  = IdLabel n c Closure
+cvtToClosureLbl l@(IdLabel n c Closure)   = l
+cvtToClosureLbl l = pprPanic "cvtToClosureLbl" (pprCLabel l)
+
+cvtToSRTLbl   (IdLabel n c InfoTable) = mkSRTLabel n c
+cvtToSRTLbl   (IdLabel n c Entry)     = mkSRTLabel n c
+cvtToSRTLbl   (IdLabel n c ConEntry)  = mkSRTLabel n c
+cvtToSRTLbl l@(IdLabel n c Closure)   = mkSRTLabel n c
+cvtToSRTLbl l = pprPanic "cvtToSRTLbl" (pprCLabel l)
+
 -- -----------------------------------------------------------------------------
 -- Does a CLabel refer to a CAF?
 hasCAF :: CLabel -> Bool
-hasCAF (IdLabel _ MayHaveCafRefs Closure) = True
-hasCAF _                                  = False
+hasCAF (IdLabel _ MayHaveCafRefs _) = True
+hasCAF _                            = False
 
 -- -----------------------------------------------------------------------------
 -- Does a CLabel need declaring before use or not?
@@ -823,7 +835,7 @@ pprCLbl ModuleRegdLabel
 pprCLbl (ForeignLabel str _ _)
   = ftext str
 
-pprCLbl (IdLabel name _ flavor) = ppr name <> ppIdFlavor flavor
+pprCLbl (IdLabel name cafs flavor) = ppr name <> ppIdFlavor flavor
 
 pprCLbl (CC_Label cc)          = ppr cc
 pprCLbl (CCS_Label ccs)        = ppr ccs
index 5e52a57..2ee259c 100644 (file)
@@ -13,7 +13,8 @@ module Cmm (
         cmmMapGraph, cmmTopMapGraph,
         cmmMapGraphM, cmmTopMapGraphM,
         CmmInfo(..), UpdateFrame(..),
-        CmmInfoTable(..), ClosureTypeInfo(..), ProfilingInfo(..), ClosureTypeTag,
+        CmmInfoTable(..), HasStaticClosure, ClosureTypeInfo(..), ConstrDescription,
+        ProfilingInfo(..), ClosureTypeTag,
         GenBasicBlock(..), CmmBasicBlock, blockId, blockStmts, mapBlockStmts,
         CmmReturnInfo(..),
         CmmStmt(..), CmmActual, CmmActuals, CmmFormal, CmmFormals, 
@@ -137,7 +138,8 @@ cmmTopMapGraph f (CmmProc h l args g) = CmmProc h l args (f g)
 cmmTopMapGraph _ (CmmData s ds)       = CmmData s ds
 
 cmmMapGraphM f (Cmm tops) = mapM (cmmTopMapGraphM f) tops >>= return . Cmm
-cmmTopMapGraphM f (CmmProc h l args g) = f (showSDoc $ ppr l) g >>= return . CmmProc h l args
+cmmTopMapGraphM f (CmmProc h l args g) =
+  f (showSDoc $ ppr l) g >>= return . CmmProc h l args
 cmmTopMapGraphM _ (CmmData s ds)       = return $ CmmData s ds
 
 -----------------------------------------------------------------------------
@@ -147,17 +149,21 @@ cmmTopMapGraphM _ (CmmData s ds)       = return $ CmmData s ds
 data CmmInfo
   = CmmInfo
       (Maybe BlockId)     -- GC target. Nothing <=> CPS won't do stack check
+                          -- JD: NOT USED BY NEW CODE GEN
       (Maybe UpdateFrame) -- Update frame
       CmmInfoTable        -- Info table
 
 -- Info table as a haskell data type
 data CmmInfoTable
   = CmmInfoTable
+      HasStaticClosure
       ProfilingInfo
       ClosureTypeTag -- Int
       ClosureTypeInfo
   | CmmNonInfoTable   -- Procedure doesn't need an info table
 
+type HasStaticClosure = Bool
+
 -- TODO: The GC target shouldn't really be part of CmmInfo
 -- as it doesn't appear in the resulting info table.
 -- It should be factored out.
index ffb7f02..851f008 100644 (file)
@@ -420,4 +420,4 @@ cmmBlockFromBrokenBlock (BrokenBlock ident _ stmts _ exit) =
 -----------------------------------------------------------------------------
 -- | Build a mapping so we can lookup a 'BrokenBlock' by its 'BlockId'
 blocksToBlockEnv :: [BrokenBlock] -> BlockEnv BrokenBlock
-blocksToBlockEnv blocks = listToUFM $ map (\b -> (brokenBlockId b, b)) blocks
+blocksToBlockEnv blocks = mkBlockEnv $ map (\b -> (brokenBlockId b, b)) blocks
index f00a93c..acdd2a6 100644 (file)
@@ -219,7 +219,7 @@ collectNonProcPointTargets proc_points blocks current_targets new_blocks =
                 new_targets
                 (map (:[]) targets)
     where
-      blocks' = map (lookupWithDefaultUFM blocks (panic "TODO")) new_blocks
+      blocks' = map (lookupWithDefaultBEnv blocks (panic "TODO")) new_blocks
       targets =
         -- Note the subtlety that since the extra branch after a call
         -- will always be to a block that is a proc-point,
@@ -241,8 +241,8 @@ gatherBlocksIntoContinuation live proc_points blocks start =
   Continuation info_table clabel params is_gc_cont body
     where
       children = (collectNonProcPointTargets proc_points blocks (unitUniqSet start) [start]) `minusUniqSet` (unitUniqSet start)
-      start_block = lookupWithDefaultUFM blocks unknown_block start
-      children_blocks = map (lookupWithDefaultUFM blocks unknown_block) (uniqSetToList children)
+      start_block = lookupWithDefaultBEnv blocks unknown_block start
+      children_blocks = map (lookupWithDefaultBEnv blocks unknown_block) (uniqSetToList children)
       unknown_block = panic "unknown block in gatherBlocksIntoContinuation"
       body = start_block : children_blocks
 
@@ -268,7 +268,7 @@ gatherBlocksIntoContinuation live proc_points blocks start =
                  ContinuationEntry args _ _ -> args
                  ControlEntry ->
                      uniqSetToList $
-                     lookupWithDefaultUFM live unknown_block start
+                     lookupWithDefaultBEnv live unknown_block start
                      -- it's a proc-point, pass lives in parameter registers
 
 --------------------------------------------------------------------------------
@@ -282,7 +282,7 @@ selectContinuationFormat live continuations =
     where
       -- User written continuations
       selectContinuationFormat' (Continuation
-                          (Right (CmmInfo _ _ (CmmInfoTable _ _ (ContInfo format srt))))
+                          (Right (CmmInfo _ _ (CmmInfoTable _ _ (ContInfo format srt))))
                           label formals _ _) =
           (formals, Just label, format)
       -- Either user written non-continuation code
@@ -296,7 +296,7 @@ selectContinuationFormat live continuations =
           in (formals,
               Just label,
               map Just $ uniqSetToList $
-              lookupWithDefaultUFM live unknown_block ident)
+              lookupWithDefaultBEnv live unknown_block ident)
 
       unknown_block = panic "unknown BlockId in selectContinuationFormat"
 
@@ -388,10 +388,11 @@ applyContinuationFormat :: [(CLabel, ContinuationFormat)]
                  -> Continuation CmmInfo
 
 -- User written continuations
-applyContinuationFormat formats (Continuation
-                          (Right (CmmInfo gc update_frame (CmmInfoTable prof tag (ContInfo _ srt))))
-                          label formals is_gc blocks) =
-    Continuation (CmmInfo gc update_frame (CmmInfoTable prof tag (ContInfo format srt)))
+applyContinuationFormat formats
+   (Continuation (Right (CmmInfo gc update_frame
+                             (CmmInfoTable clos prof tag (ContInfo _ srt))))
+                 label formals is_gc blocks) =
+    Continuation (CmmInfo gc update_frame (CmmInfoTable clos prof tag (ContInfo format srt)))
                  label formals is_gc blocks
     where
       format = continuation_stack $ maybe unknown_block id $ lookup label formats
@@ -405,7 +406,7 @@ applyContinuationFormat formats (Continuation
 -- CPS generated continuations
 applyContinuationFormat formats (Continuation
                           (Left srt) label formals is_gc blocks) =
-    Continuation (CmmInfo gc Nothing (CmmInfoTable prof tag (ContInfo (continuation_stack $ format) srt)))
+    Continuation (CmmInfo gc Nothing (CmmInfoTable undefined prof tag (ContInfo (continuation_stack $ format) srt)))
                  label formals is_gc blocks
     where
       gc = Nothing -- Generated continuations never need a stack check
index d8c9560..6dcc5c5 100644 (file)
@@ -5,36 +5,59 @@ module CmmCPSZ (
   protoCmmCPSZ
 ) where
 
+import CLabel
 import Cmm
+import CmmBuildInfoTables
 import CmmCommonBlockElimZ
 import CmmProcPointZ
 import CmmSpillReload
+import CmmStackLayout
 import DFMonad
 import PprCmmZ()
 import ZipCfgCmmRep
 
 import DynFlags
 import ErrUtils
+import FiniteMap
 import HscTypes
+import Maybe
 import Monad
 import Outputable
+import StaticFlags
 
 -----------------------------------------------------------------------------
 -- |Top level driver for the CPS pass
 -----------------------------------------------------------------------------
+-- There are two complications here:
+-- 1. We need to compile the procedures in two stages because we need
+--    an analysis of the procedures to tell us what CAFs they use.
+--    The first stage returns a map from procedure labels to CAFs,
+--    along with a closure that will compute SRTs and attach them to
+--    the compiled procedures.
+--    The second stage is to combine the CAF information into a top-level
+--    CAF environment mapping non-static closures to the CAFs they keep live,
+--    then pass that environment to the closures returned in the first
+--    stage of compilation.
+-- 2. We need to thread the module's SRT around when the SRT tables
+--    are computed for each procedure.
+--    The SRT needs to be threaded because it is grown lazily.
 protoCmmCPSZ :: HscEnv -- Compilation env including
                        -- dynamic flags: -dcmm-lint -ddump-cps-cmm
-             -> CmmZ     -- Input C-- with Proceedures
-             -> IO CmmZ  -- Output CPS transformed C--
-protoCmmCPSZ hsc_env (Cmm tops)
+             -> (TopSRT, [CmmZ])  -- SRT table and 
+             -> CmmZ              -- Input C-- with Procedures
+             -> IO (TopSRT, [CmmZ]) -- Output CPS transformed C--
+protoCmmCPSZ hsc_env (topSRT, rst) (Cmm tops)
   | not (dopt Opt_RunCPSZ (hsc_dflags hsc_env))
-  = return (Cmm tops)                -- Only if -frun-cps
+  = return (topSRT, Cmm tops : rst)                -- Only if -frun-cps
   | otherwise
   = do let dflags = hsc_dflags hsc_env
         showPass dflags "CPSZ"
-        tops <- liftM concat $ mapM (cpsTop hsc_env) tops
-        dumpIfSet_dyn dflags Opt_D_dump_cps_cmm "Post CPS Cmm" (ppr (Cmm tops))
-        return $ Cmm tops
+        (cafEnvs, toTops) <- liftM unzip $ mapM (cpsTop hsc_env) tops
+        let topCAFEnv = mkTopCAFInfo (concat cafEnvs)
+        (topSRT, tops) <- foldM (\ z f -> f topCAFEnv z) (topSRT, []) toTops 
+        let cmms = Cmm (reverse (concat tops))
+        dumpIfSet_dyn dflags Opt_D_dump_cps_cmm "Post CPS Cmm" (ppr cmms)
+        return (topSRT, cmms : rst)
 
 {- [Note global fuel]
 ~~~~~~~~~~~~~~~~~~~~~
@@ -43,44 +66,75 @@ mutable reference cells in an 'HscEnv' and are
 global to one compiler session.
 -}
 
-cpsTop :: HscEnv -> CmmTopZ -> IO [CmmTopZ]
-cpsTop _ p@(CmmData {}) = return [p]
+cpsTop :: HscEnv -> CmmTopZ ->
+          IO ([(CLabel, CAFSet)],
+              (FiniteMap CLabel CAFSet -> (TopSRT, [[CmmTopZ]]) -> IO (TopSRT, [[CmmTopZ]])))
+cpsTop _ p@(CmmData {}) =
+  return ([], (\ _ (topSRT, tops) -> return (topSRT, [p] : tops)))
 cpsTop hsc_env (CmmProc h l args g) =
-    do dump Opt_D_dump_cmmz "Pre Proc Points Added"  g
+    do 
+       dump Opt_D_dump_cmmz "Pre Proc Points Added"  g
        let callPPs = callProcPoints g
        g <- dual_rewrite Opt_D_dump_cmmz "spills and reloads"
                              (dualLivenessWithInsertion callPPs) g
+       g <- dual_rewrite Opt_D_dump_cmmz "Dead Assignment Elimination"
+                         (removeDeadAssignmentsAndReloads callPPs) g
        dump Opt_D_dump_cmmz "Pre common block elimination" g
        g <- return $ elimCommonBlocks g
        dump Opt_D_dump_cmmz "Post common block elimination" g
        procPoints <- run $ minimalProcPointSet callPPs g
-       print $ "call procPoints: " ++ (showSDoc $ ppr procPoints)
+       -- print $ "call procPoints: " ++ (showSDoc $ ppr procPoints)
        g <- run $ addProcPointProtocols callPPs procPoints g
        dump Opt_D_dump_cmmz "Post Proc Points Added" g
        g     <- dual_rewrite Opt_D_dump_cmmz "spills and reloads"
                              (dualLivenessWithInsertion procPoints) g
                     -- Insert spills at defns; reloads at return points
-       g     <- run $ insertLateReloads' g -- Duplicate reloads just before uses
+       g     <- run $ insertLateReloads g -- Duplicate reloads just before uses
        dump Opt_D_dump_cmmz "Post late reloads" g
        g     <- dual_rewrite Opt_D_dump_cmmz "Dead Assignment Elimination"
                                         (removeDeadAssignmentsAndReloads procPoints) g
                     -- Remove redundant reloads (and any other redundant asst)
+       -- Debugging: stubbing slots on death can cause crashes early
+       g <-  if opt_StubDeadValues then run $ stubSlotsOnDeath g else return g
+       mbpprTrace "graph before procPointMap: " (ppr g) $ return ()
+       procPointMap <- run $ procPointAnalysis procPoints g
        slotEnv <- run $ liveSlotAnal g
-       print $ "live slot analysis results: " ++ (showSDoc $ ppr slotEnv)
+       mbpprTrace "live slot analysis results: " (ppr slotEnv) $ return ()
        cafEnv <- run $ cafAnal g
-       print $ "live CAF analysis results: " ++ (showSDoc $ ppr cafEnv)
-       slotIGraph <- return $ igraph areaBuilder slotEnv g
-       print $ "slot IGraph: " ++ (showSDoc $ ppr slotIGraph)
-       print $ "graph before procPointMap: " ++ (showSDoc $ ppr g)
-       procPointMap <- run $ procPointAnalysis procPoints g
+       (cafEnv, slotEnv) <- return $ extendEnvsForSafeForeignCalls cafEnv slotEnv g
+       mbpprTrace "slotEnv extended for safe foreign calls: " (ppr slotEnv) $ return ()
        let areaMap = layout procPoints slotEnv g
+       mbpprTrace "areaMap" (ppr areaMap) $ return ()
        g  <- run $ manifestSP procPoints procPointMap areaMap g
-       procPointMap <- run $ procPointAnalysis procPoints g
-       gs <- run $ splitAtProcPoints l callPPs procPoints procPointMap slotEnv areaMap
-                                     (CmmProc h l args g)
-       return gs
-       --return $ [CmmProc h l args (runTx cmmCfgOptsZ g)]
+       dump Opt_D_dump_cmmz "after manifestSP" g
+       -- UGH... manifestSP can require updates to the procPointMap.
+       -- We can probably do something quicker here for the update...
+       procPointMap  <- run $ procPointAnalysis procPoints g
+       gs <- pprTrace "procPointMap" (ppr procPointMap) $
+               run $ splitAtProcPoints l callPPs procPoints procPointMap areaMap
+                                       (CmmProc h l args g)
+       mapM (dump Opt_D_dump_cmmz "after splitting") gs
+       let localCAFs = catMaybes $ map (localCAFInfo cafEnv) gs
+       mbpprTrace "localCAFs" (ppr localCAFs) $ return ()
+       gs <- liftM concat $ run $ foldM (lowerSafeForeignCalls procPoints) [] gs
+       mapM (dump Opt_D_dump_cmmz "after lowerSafeForeignCalls") gs
+
+       -- NO MORE GRAPH TRANSFORMATION AFTER HERE -- JUST MAKING INFOTABLES
+       let gs' = map (setInfoTableStackMap slotEnv areaMap) gs
+       mapM (dump Opt_D_dump_cmmz "after setInfoTableStackMap") gs'
+       -- Return: (a) CAFs used by this proc (b) a closure that will compute
+       --  a new SRT for the procedure.
+       let toTops topCAFEnv (topSRT, tops) =
+             do let setSRT (topSRT, rst) g =
+                      do (topSRT, gs) <- setInfoTableSRT cafEnv topCAFEnv topSRT g
+                         return (topSRT, gs : rst)
+                (topSRT, gs') <- run $ foldM setSRT (topSRT, []) gs'
+                gs' <- mapM finishInfoTables (concat gs')
+                pprTrace "localCAFs" (ppr localCAFs <+> ppr topSRT) $
+                  return (topSRT, concat gs' : tops)
+       return (localCAFs, toTops)
   where dflags = hsc_dflags hsc_env
+        mbpprTrace x y z = if dopt Opt_D_dump_cmmz dflags then pprTrace x y z else z
         dump f txt g = dumpIfSet_dyn dflags f txt (ppr g)
         run = runFuelIO (hsc_OptFuel hsc_env)
         dual_rewrite flag txt pass g =
index 5476eb8..fa619af 100644 (file)
@@ -17,6 +17,7 @@ module CmmCallConv (
 
 import Cmm
 import SMRep
+import ZipCfgCmmRep (Convention(..))
 
 import Constants
 import StaticFlags (opt_Unregisterised)
@@ -30,36 +31,48 @@ data ParamLocation a
   = RegisterParam GlobalReg
   | StackParam a
 
+instance (Outputable a) => Outputable (ParamLocation a) where
+  ppr (RegisterParam g) = ppr g
+  ppr (StackParam p)    = ppr p
+
 type ArgumentFormat a b = [(a, ParamLocation b)]
 
 -- Stack parameters are returned as word offsets.
 assignArguments :: (a -> CmmType) -> [a] -> ArgumentFormat a WordOff
 assignArguments f reps = assignments
     where
+      availRegs = getRegs False
       (sizes, assignments) = unzip $ assignArguments' reps (negate (sum sizes)) availRegs
       assignArguments' [] offset availRegs = []
       assignArguments' (r:rs) offset availRegs =
           (size,(r,assignment)):assignArguments' rs new_offset remaining
           where 
             (assignment, new_offset, size, remaining) =
-                assign_reg False assign_slot_up (f r) offset availRegs
+                assign_reg assign_slot_neg (f r) offset availRegs
 
 -- | JD: For the new stack story, I want arguments passed on the stack to manifest as
 -- positive offsets in a CallArea, not negative offsets from the stack pointer.
 -- Also, I want byte offsets, not word offsets.
 -- The first argument tells us whether we are assigning positions for call arguments
--- or return results. The distinction matters because we reserve different
--- global registers in each case.
-assignArgumentsPos :: Bool -> (a -> CmmType) -> [a] -> ArgumentFormat a ByteOff
-assignArgumentsPos isCall arg_ty reps = map cvt assignments
+-- or return results. The distinction matters because some conventions use different
+-- global registers in each case. In particular, the native calling convention
+-- uses the `node' register to pass the closure environment.
+assignArgumentsPos :: (Outputable a) => Convention -> Bool -> (a -> CmmType) -> [a] ->
+                      ArgumentFormat a ByteOff
+assignArgumentsPos conv isCall arg_ty reps = map cvt assignments
     where
-      (sizes, assignments) = unzip $ assignArguments' reps 0 availRegs
+      regs = case conv of Native -> getRegs isCall
+                          GC     -> getRegs False
+                          PrimOp -> noStack
+                          Slow   -> noRegs
+                          _      -> panic "unrecognized calling convention"
+      (sizes, assignments) = unzip $ assignArguments' reps (sum sizes) regs
       assignArguments' [] _ _ = []
       assignArguments' (r:rs) offset avails =
-          (size,(r,assignment)):assignArguments' rs new_offset remaining
+          (size, (r,assignment)):assignArguments' rs new_offset remaining
           where 
             (assignment, new_offset, size, remaining) =
-                assign_reg isCall assign_slot_down (arg_ty r) offset avails
+                assign_reg assign_slot_pos (arg_ty r) offset avails
       cvt (l, RegisterParam r) = (l, RegisterParam r)
       cvt (l, StackParam off)  = (l, StackParam $ off * wORD_SIZE)
 
@@ -94,12 +107,18 @@ useDoubleRegs  | opt_Unregisterised = 0
 useLongRegs    | opt_Unregisterised = 0
               | otherwise          = mAX_Real_Long_REG
 
-availRegs = (regList VanillaReg useVanillaRegs,
-             regList FloatReg useFloatRegs,
-             regList DoubleReg useDoubleRegs,
-             regList LongReg useLongRegs)
+getRegs reserveNode =
+  (if reserveNode then filter (\r -> r VGcPtr /= node) intRegs else intRegs,
+   regList FloatReg  useFloatRegs,
+   regList DoubleReg useDoubleRegs,
+   regList LongReg   useLongRegs)
     where
       regList f max = map f [1 .. max]
+      intRegs = regList VanillaReg useVanillaRegs
+
+noStack = (map VanillaReg any, map FloatReg any, map DoubleReg any, map LongReg any)
+  where any = [1 .. ]
+noRegs    = ([], [], [], [])
 
 -- Round the size of a local register up to the nearest word.
 slot_size :: LocalReg -> Int
@@ -111,37 +130,37 @@ slot_size' reg = ((widthInBytes reg - 1) `div` wORD_SIZE) + 1
 type Assignment = (ParamLocation WordOff, WordOff, WordOff, AvailRegs)
 type SlotAssigner = Width -> Int -> AvailRegs -> Assignment
 
-assign_reg :: Bool -> SlotAssigner -> CmmType -> WordOff -> AvailRegs -> Assignment
-assign_reg isCall slot ty off avails
-  | isFloatType ty = assign_float_reg        slot width off avails
-  | otherwise      = assign_bits_reg  isCall slot width off gcp avails
+assign_reg :: SlotAssigner -> CmmType -> WordOff -> AvailRegs -> Assignment
+assign_reg slot ty off avails
+  | isFloatType ty = assign_float_reg slot width off avails
+  | otherwise      = assign_bits_reg  slot width off gcp avails
   where
     width = typeWidth ty
     gcp | isGcPtrType ty = VGcPtr
        | otherwise      = VNonGcPtr
 
--- Assigning a slot on a stack that grows up:
+-- Assigning a slot using negative offsets from the stack pointer.
 -- JD: I don't know why this convention stops using all the registers
 --     after running out of one class of registers.
-assign_slot_up :: SlotAssigner
-assign_slot_up width off regs =
+assign_slot_neg :: SlotAssigner
+assign_slot_neg width off regs =
   (StackParam $ off, off + size, size, ([], [], [], [])) where size = slot_size' width
 
--- Assigning a slot on a stack that grows down:
-assign_slot_down :: SlotAssigner
-assign_slot_down width off regs =
-  (StackParam $ off + size, off + size, size, ([], [], [], []))
+-- Assigning a slot using positive offsets into a CallArea.
+assign_slot_pos :: SlotAssigner
+assign_slot_pos width off regs =
+  (StackParam $ off, off - size, size, ([], [], [], []))
   where size = slot_size' width
 
--- On calls, `node` is used to hold the closure that is entered, so we can't
--- pass arguments in that register.
-assign_bits_reg _ _ W128 _ _ _ = panic "I128 is not a supported register type"
-assign_bits_reg isCall assign_slot w off gcp regs@(v:vs, fs, ds, ls) =
-  if isCall && v gcp == node then
-    assign_bits_reg isCall assign_slot w off gcp (vs, fs, ds, ls)
-  else if widthInBits w <= widthInBits wordWidth then
+-- On calls in the native convention, `node` is used to hold the environment
+-- for the closure, so we can't pass arguments in that register.
+assign_bits_reg _ W128 _ _ _ = panic "W128 is not a supported register type"
+assign_bits_reg assign_slot w off gcp regs@(v:vs, fs, ds, ls) =
+  if widthInBits w <= widthInBits wordWidth then
     (RegisterParam (v gcp), off, 0, (vs, fs, ds, ls))
   else assign_slot w off regs
+assign_bits_reg assign_slot w off gcp regs@([], _, _, _) =
+  assign_slot w off regs
 
 assign_float_reg _ W32 off (vs, f:fs, ds, ls) = (RegisterParam $ f, off, 0, (vs, fs, ds, ls))
 assign_float_reg _ W64 off (vs, fs, d:ds, ls) = (RegisterParam $ d, off, 0, (vs, fs, ds, ls))
index 2cef222..df15845 100644 (file)
@@ -10,8 +10,9 @@ import Prelude hiding (iterate, zip, unzip)
 import ZipCfg
 import ZipCfgCmmRep
 
+import Data.Bits
+import Data.Word
 import FastString
-import FiniteMap
 import List hiding (iterate)
 import Monad
 import Outputable
@@ -19,7 +20,7 @@ import UniqFM
 import Unique
 
 my_trace :: String -> SDoc -> a -> a
-my_trace = if True then pprTrace else \_ _ a -> a
+my_trace = if False then pprTrace else \_ _ a -> a
 
 -- Eliminate common blocks:
 -- If two blocks are identical except for the label on the first node,
@@ -36,7 +37,8 @@ my_trace = if True then pprTrace else \_ _ a -> a
 -- TODO: Use optimization fuel
 elimCommonBlocks :: CmmGraph -> CmmGraph
 elimCommonBlocks g =
-    upd_graph g . snd $ iterate common_block reset hashed_blocks (emptyUFM, emptyFM)
+    upd_graph g . snd $ iterate common_block reset hashed_blocks
+                                (emptyUFM, emptyBlockEnv)
       where hashed_blocks    = map (\b -> (hash_block b, b)) (reverse (postorder_dfs g))
             reset (_, subst) = (emptyUFM, subst)
 
@@ -49,83 +51,93 @@ iterate upd reset blocks state =
   where upd' (b, s) a = let (b', s') = upd s a in (b || b', s') -- lift to track changes
 
 -- Try to find a block that is equal (or ``common'') to b.
-type BidMap = FiniteMap BlockId BlockId
+type BidMap = BlockEnv BlockId
 type State  = (UniqFM [CmmBlock], BidMap)
 common_block :: (Outputable h, Uniquable h) =>  State -> (h, CmmBlock) -> (Bool, State)
 common_block (bmap, subst) (hash, b) =
-  case lookupUFM bmap $ my_trace "common_block" (ppr bid <+> ppr subst <+> ppr hash) $ hash of
-    Just bs -> case (find (eqBlockBodyWith (eqBid subst) b) bs, lookupFM subst bid) of
+  case lookupUFM bmap hash of
+    Just bs -> case (find (eqBlockBodyWith (eqBid subst) b) bs,
+                     lookupBlockEnv subst bid) of
                  (Just b', Nothing)                      -> addSubst b'
                  (Just b', Just b'') | blockId b' /= b'' -> addSubst b'
                  _ -> (False, (addToUFM bmap hash (b : bs), subst))
     Nothing -> (False, (addToUFM bmap hash [b], subst))
   where bid = blockId b
         addSubst b' = my_trace "found new common block" (ppr (blockId b')) $
-                      (True, (bmap, addToFM subst bid (blockId b')))
+                      (True, (bmap, extendBlockEnv subst bid (blockId b')))
 
 -- Given the map ``subst'' from BlockId -> BlockId, we rewrite the graph.
 upd_graph :: CmmGraph -> BidMap -> CmmGraph
 upd_graph g subst = map_nodes id middle last g
-  where middle m = m
-        last (LastBranch bid)       = LastBranch $ sub bid
-        last (LastCondBranch p t f) = cond p (sub t) (sub f)
-        last (LastCall t bid s)     = LastCall   t (liftM sub bid) s
-        last (LastSwitch e bs)      = LastSwitch e $ map (liftM sub) bs
-        last l = l
+  where middle = mapExpDeepMiddle exp
+        last l = last' (mapExpDeepLast exp l)
+        last' (LastBranch bid)            = LastBranch $ sub bid
+        last' (LastCondBranch p t f)      = cond p (sub t) (sub f)
+        last' (LastCall t (Just bid) s u) = LastCall t (Just $ sub bid) s u
+        last' l@(LastCall _ Nothing _ _)  = l
+        last' (LastSwitch e bs)           = LastSwitch e $ map (liftM sub) bs
         cond p t f = if t == f then LastBranch t else LastCondBranch p t f
+        exp (CmmStackSlot (CallArea (Young id))       off) =
+             CmmStackSlot (CallArea (Young (sub id))) off
+        exp (CmmLit (CmmBlock id)) = CmmLit (CmmBlock (sub id))
+        exp e = e
         sub = lookupBid subst
 
 -- To speed up comparisons, we hash each basic block modulo labels.
 -- The hashing is a bit arbitrary (the numbers are completely arbitrary),
 -- but it should be fast and good enough.
 hash_block :: CmmBlock -> Int
-hash_block (Block _ _ t) = hash_tail t 0
-  where hash_mid   (MidComment (FastString u _ _ _ _)) = u
+hash_block (Block _ _ t) =
+  fromIntegral (hash_tail t (0 :: Word32) .&. (0x7fffffff :: Word32))
+  -- UniqFM doesn't like negative Ints
+  where hash_mid   (MidComment (FastString u _ _ _ _)) = cvt u
         hash_mid   (MidAssign r e) = hash_reg r + hash_e e
         hash_mid   (MidStore e e') = hash_e e + hash_e e'
-        hash_mid   (MidUnsafeCall t _ as) = hash_tgt t + hash_lst hash_e as
-        hash_mid   (MidAddToContext e es) = hash_e e + hash_lst hash_e es
+        hash_mid   (MidForeignCall _ t _ as) = hash_tgt t + hash_lst hash_e as
+        hash_reg :: CmmReg -> Word32
         hash_reg   (CmmLocal l) = hash_local l
         hash_reg   (CmmGlobal _)    = 19
         hash_local (LocalReg _ _) = 117
+        hash_e :: CmmExpr -> Word32
         hash_e (CmmLit l) = hash_lit l
         hash_e (CmmLoad e _) = 67 + hash_e e
         hash_e (CmmReg r) = hash_reg r
         hash_e (CmmMachOp _ es) = hash_lst hash_e es -- pessimal - no operator check
-        hash_e (CmmRegOff r i) = hash_reg r + i
+        hash_e (CmmRegOff r i) = hash_reg r + cvt i
         hash_e (CmmStackSlot _ _) = 13
+        hash_lit :: CmmLit -> Word32
         hash_lit (CmmInt i _) = fromInteger i
         hash_lit (CmmFloat r _) = truncate r
         hash_lit (CmmLabel _) = 119 -- ugh
-        hash_lit (CmmLabelOff _ i) = 199 + i
-        hash_lit (CmmLabelDiffOff _ _ i) = 299 + i
+        hash_lit (CmmLabelOff _ i) = cvt $ 199 + i
+        hash_lit (CmmLabelDiffOff _ _ i) = cvt $ 299 + i
+        hash_lit (CmmBlock id) = 191 -- ugh
+        hash_lit (CmmHighStackMark) = cvt 313
         hash_tgt (ForeignTarget e _) = hash_e e
         hash_tgt (PrimTarget _) = 31 -- lots of these
-        hash_lst f = foldl (\z x -> f x + z) (0::Int)
+        hash_lst f = foldl (\z x -> f x + z) (0::Word32)
         hash_last (LastBranch _) = 23 -- would be great to hash these properly
         hash_last (LastCondBranch p _ _) = hash_e p 
-        hash_last (LastReturn _) = 17 -- better ideas?
-        hash_last (LastJump e _) = hash_e e
-        hash_last (LastCall e _ _) = hash_e e
+        hash_last (LastCall e _ _ _) = hash_e e
         hash_last (LastSwitch e _) = hash_e e
-        hash_tail (ZLast LastExit) v = 29 + v * 2
-        hash_tail (ZLast (LastOther l)) v = hash_last l + (v * 2)
-        hash_tail (ZTail m t) v = hash_tail t (hash_mid m + (v * 2))
-
+        hash_tail (ZLast LastExit) v = 29 + v `shiftL` 1
+        hash_tail (ZLast (LastOther l)) v = hash_last l + (v `shiftL` 1)
+        hash_tail (ZTail m t) v = hash_tail t (hash_mid m + (v `shiftL` 1))
+        cvt = fromInteger . toInteger
 -- Utilities: equality and substitution on the graph.
 
 -- Given a map ``subst'' from BlockID -> BlockID, we define equality.
 eqBid :: BidMap -> BlockId -> BlockId -> Bool
 eqBid subst bid bid' = lookupBid subst bid == lookupBid subst bid'
 lookupBid :: BidMap -> BlockId -> BlockId
-lookupBid subst bid = case lookupFM subst bid of
+lookupBid subst bid = case lookupBlockEnv subst bid of
                         Just bid  -> lookupBid subst bid
                         Nothing -> bid
 
 -- Equality on the body of a block, modulo a function mapping block IDs to block IDs.
 eqBlockBodyWith :: (BlockId -> BlockId -> Bool) -> CmmBlock -> CmmBlock -> Bool
-eqBlockBodyWith eqBid (Block _ Nothing t) (Block _ Nothing t') = eqTailWith eqBid t t'
-eqBlockBodyWith _ _ _ = False
+eqBlockBodyWith eqBid (Block _ sinfo t) (Block _ sinfo' t') =
+  sinfo == sinfo' && eqTailWith eqBid t t'
 
 type CmmTail = ZTail Middle Last
 eqTailWith :: (BlockId -> BlockId -> Bool) -> CmmTail -> CmmTail -> Bool
@@ -135,16 +147,13 @@ eqTailWith eqBid (ZLast (LastOther l)) (ZLast (LastOther l')) = eqLastWith eqBid
 eqTailWith _ _ _ = False
 
 eqLastWith :: (BlockId -> BlockId -> Bool) -> Last -> Last -> Bool
-eqLastWith eqBid (LastBranch bid) (LastBranch bid') = eqBid bid bid'
-eqLastWith eqBid c@(LastCondBranch _ _ _) c'@(LastCondBranch _ _ _) =
-  eqBid (cml_true c) (cml_true c')  && eqBid (cml_false c) (cml_false c') 
-eqLastWith _ (LastReturn s) (LastReturn s') = s == s'
-eqLastWith _ (LastJump e s) (LastJump e' s') = e == e' && s == s'
-eqLastWith eqBid c@(LastCall _ _ s) c'@(LastCall _ _ s') =
-  cml_target c == cml_target c' && eqMaybeWith eqBid (cml_cont c) (cml_cont c') &&
-  s == s'
-eqLastWith eqBid (LastSwitch e bs) (LastSwitch e' bs') =
-  e == e' && eqLstWith (eqMaybeWith eqBid) bs bs'
+eqLastWith eqBid (LastBranch bid1) (LastBranch bid2) = eqBid bid1 bid2
+eqLastWith eqBid (LastCondBranch c1 t1 f1) (LastCondBranch c2 t2 f2) =
+  c1 == c2 && eqBid t1 t2 && eqBid f1 f2
+eqLastWith eqBid (LastCall t1 c1 s1 u1) (LastCall t2 c2 s2 u2) =
+  t1 == t2 && eqMaybeWith eqBid c1 c2 && s1 == s2 && u1 == u2
+eqLastWith eqBid (LastSwitch e1 bs1) (LastSwitch e2 bs2) =
+  e1 == e2 && eqLstWith (eqMaybeWith eqBid) bs1 bs2
 eqLastWith _ _ _ = False
 
 eqLstWith :: (a -> b -> Bool) -> [a] -> [b] -> Bool
index 320b1e7..a3239b9 100644 (file)
@@ -2,7 +2,7 @@
 module CmmContFlowOpt
     ( runCmmOpts, cmmCfgOpts, cmmCfgOptsZ
     , branchChainElimZ, removeUnreachableBlocksZ, predMap
-    , replaceLabelsZ, runCmmContFlowOptsZs
+    , replaceLabelsZ, replaceBranches, runCmmContFlowOptsZs
     )
 where
 
@@ -19,7 +19,6 @@ import Outputable
 import Panic
 import Prelude hiding (unzip, zip)
 import Util
-import UniqFM
 
 ------------------------------------
 runCmmContFlowOptsZs :: [CmmZ] -> [CmmZ]
@@ -31,7 +30,8 @@ cmmCfgOpts  :: Tx (ListGraph CmmStmt)
 cmmCfgOptsZ :: Tx CmmGraph
 
 cmmCfgOpts  = branchChainElim  -- boring, but will get more exciting later
-cmmCfgOptsZ = branchChainElimZ `seqTx` blockConcatZ `seqTx` removeUnreachableBlocksZ
+cmmCfgOptsZ g =
+    (branchChainElimZ `seqTx` blockConcatZ `seqTx` removeUnreachableBlocksZ) g
         -- Here branchChainElim can ultimately be replaced
         -- with a more exciting combination of optimisations
 
@@ -89,16 +89,19 @@ branchChainElimZ g@(G.LGraph eid args _)
     (lone_branch_blocks, others) = partitionWith isLoneBranchZ (G.to_block_list g)
     env = mkClosureBlockEnvZ lone_branch_blocks
     self_branches =
-        let loop_to (id, _) =
-                if lookup id == id then
-                    Just (G.Block id Nothing (G.ZLast (G.mkBranchNode id)))
-                else
-                    Nothing
-        in  mapMaybe loop_to lone_branch_blocks
+      let loop_to (id, _) =
+            if lookup id == id then
+              Just (G.Block id emptyStackInfo (G.ZLast (G.mkBranchNode id)))
+            else
+              Nothing
+      in  mapMaybe loop_to lone_branch_blocks
     lookup id = lookupBlockEnv env id `orElse` id 
 
+-- Be careful not to mark a block as a lone branch if it carries
+-- important information about incoming arguments or the update frame.
 isLoneBranchZ :: CmmBlock -> Either (BlockId, BlockId) CmmBlock
-isLoneBranchZ (G.Block id Nothing (G.ZLast (G.LastOther (LastBranch target))))
+isLoneBranchZ (G.Block id (StackInfo {argBytes = Nothing, returnOff = Nothing})
+              (G.ZLast (G.LastOther (LastBranch target))))
     | id /= target  = Left (id,target)
 isLoneBranchZ other = Right other
    -- An infinite loop is not a link in a branch chain!
@@ -107,27 +110,25 @@ replaceLabelsZ :: BlockEnv BlockId -> CmmGraph -> CmmGraph
 replaceLabelsZ env = replace_eid . G.map_nodes id middle last
   where
     replace_eid (G.LGraph eid off blocks) = G.LGraph (lookup eid) off blocks
-    middle m@(MidComment _)            = m
-    middle   (MidAssign r e)           = MidAssign r (exp e)
-    middle   (MidStore addr e)         = MidStore (exp addr) (exp e)
-    middle   (MidUnsafeCall tgt fs as) = MidUnsafeCall (midcall tgt) fs (map exp as)
-    middle   (MidAddToContext e es)    = MidAddToContext (exp e) (map exp es)
-    last (LastBranch id)             = LastBranch (lookup id)
-    last (LastCondBranch e ti fi)    = LastCondBranch (exp e) (lookup ti) (lookup fi)
-    last (LastSwitch e tbl)          = LastSwitch (exp e) (map (fmap lookup) tbl)
-    last (LastCall tgt mb_id s)      = LastCall (exp tgt) (fmap lookup mb_id) s
-    last (LastJump e s)              = LastJump (exp e) s
-    last (LastReturn s)              = LastReturn s
-    midcall   (ForeignTarget e c)    = ForeignTarget (exp e) c
-    midcall m@(PrimTarget _)         = m
-    exp e@(CmmLit _)         = e
-    exp   (CmmLoad addr ty)  = CmmLoad (exp addr) ty
-    exp e@(CmmReg _)         = e
-    exp   (CmmMachOp op es)  = CmmMachOp op $ map exp es
-    exp e@(CmmRegOff _ _)    = e
+    middle = mapExpDeepMiddle exp
+    last l = mapExpDeepLast   exp (last' l)
+    last' (LastBranch bid) = LastBranch (lookup bid)
+    last' (LastCondBranch p t f) = LastCondBranch p (lookup t) (lookup f)
+    last' (LastSwitch e arms) = LastSwitch e (map (liftM lookup) arms)
+    last' (LastCall t k a r) = LastCall t (liftM lookup k) a r
+    exp (CmmLit (CmmBlock bid)) = CmmLit (CmmBlock (lookup bid))
     exp   (CmmStackSlot (CallArea (Young id)) i) =
       CmmStackSlot (CallArea (Young (lookup id))) i
-    exp e@(CmmStackSlot _ _) = e
+    exp e = e
+    lookup id = fmap lookup (lookupBlockEnv env id) `orElse` id 
+
+replaceBranches :: BlockEnv BlockId -> CmmGraph -> CmmGraph
+replaceBranches env g = map_nodes id id last g
+  where
+    last (LastBranch id)          = LastBranch (lookup id)
+    last (LastCondBranch e ti fi) = LastCondBranch e (lookup ti) (lookup fi)
+    last (LastSwitch e tbl)       = LastSwitch e (map (fmap lookup) tbl)
+    last l@(LastCall {})          = l
     lookup id = fmap lookup (lookupBlockEnv env id) `orElse` id 
 
 ----------------------------------------------------------------
@@ -146,35 +147,38 @@ predMap g = G.fold_blocks add_preds emptyBlockEnv g -- find the back edges
 -- Order matters, so we work bottom up (reverse postorder DFS).
 --
 -- To ensure correctness, we have to make sure that the BlockId of the block
--- we are about to eliminate is not named in another instruction
--- (except an adjacent stack pointer adjustment, which we expect and also eliminate).
--- For 
+-- we are about to eliminate is not named in another instruction.
 --
 -- Note: This optimization does _not_ subsume branch chain elimination.
 blockConcatZ  :: Tx CmmGraph
 blockConcatZ = removeUnreachableBlocksZ `seqTx` blockConcatZ'
 blockConcatZ' :: Tx CmmGraph
 blockConcatZ' g@(G.LGraph eid off blocks) =
-  tx $ pprTrace "concatMap" (ppr concatMap) $ replaceLabelsZ concatMap $ G.LGraph eid off blocks'
+  tx $ replaceLabelsZ concatMap $ G.LGraph eid off blocks'
   where (changed, blocks', concatMap) =
            foldr maybe_concat (False, blocks, emptyBlockEnv) $ G.postorder_dfs g
         maybe_concat b@(G.Block bid _ _) (changed, blocks', concatMap) =
           let unchanged = (changed, extendBlockEnv blocks' bid b, concatMap)
           in case G.goto_end $ G.unzip b of
                (h, G.LastOther (LastBranch b')) ->
-                  if num_preds b' == 1 then
+                  if canConcatWith b' then
                     (True, extendBlockEnv blocks' bid $ splice blocks' h b',
                      extendBlockEnv concatMap b' bid)
                   else unchanged
                _ -> unchanged
         num_preds bid = liftM sizeBlockSet (lookupBlockEnv backEdges bid) `orElse` 0
+        canConcatWith b' =
+          case lookupBlockEnv blocks b' of
+            Just (G.Block _ (StackInfo {returnOff = Nothing}) _) -> num_preds b' == 1
+            _ -> False
         backEdges = predMap g
         splice blocks' h bid' =
           case lookupBlockEnv blocks' bid' of
-            Just (G.Block _ Nothing t) -> G.zip $ G.ZBlock h t
-            Just (G.Block _ (Just _) _) ->
+            Just (G.Block _ (StackInfo {returnOff = Nothing}) t) ->
+              G.zip $ G.ZBlock h t
+            Just (G.Block _ _ _) ->
               panic "trying to concatenate but successor block has incoming args"
-            Nothing -> panic "unknown successor block"
+            Nothing -> pprPanic "unknown successor block" (ppr bid' <+> ppr blocks' <+> ppr blocks)
         tx = if changed then aTx else noTx
 ----------------------------------------------------------------
 mkClosureBlockEnv :: [(BlockId, BlockId)] -> BlockEnv BlockId
@@ -194,6 +198,6 @@ mkClosureBlockEnvZ blocks = mkBlockEnv $ map follow blocks
 ----------------------------------------------------------------
 removeUnreachableBlocksZ :: Tx CmmGraph
 removeUnreachableBlocksZ g@(G.LGraph id off blocks) =
-      if length blocks' < sizeUFM blocks then aTx $ G.of_block_list id off blocks'
-      else noTx g
+  if length blocks' < sizeBEnv blocks then aTx $ G.of_block_list id off blocks'
+  else noTx g
     where blocks' = G.postorder_dfs g
index 0f0ccd2..3484ed6 100644 (file)
@@ -5,13 +5,12 @@ module CmmCvt
 where
 
 import BlockId
-import ClosureInfo (C_SRT(..))
 import Cmm
 import CmmExpr
 import MkZipCfgCmm hiding (CmmGraph)
+import ZipCfg       -- imported for reverse conversion
 import ZipCfgCmmRep -- imported for reverse conversion
 import CmmZipUtil
-import ForeignCall
 import PprCmm()
 import qualified ZipCfg as G
 
@@ -19,7 +18,6 @@ import FastString
 import Monad
 import Outputable
 import Panic
-import UniqSet
 import UniqSupply
 
 import Maybe
@@ -39,18 +37,23 @@ toZgraph fun_name args g@(ListGraph (BasicBlock id ss : other_blocks)) =
            let (offset, entry) = mkEntry id Native args in
            labelAGraph id offset $
               entry <*> mkStmts ss <*> foldr addBlock emptyAGraph other_blocks
-  where addBlock (BasicBlock id ss) g = mkLabel id Nothing  <*> mkStmts ss <*> g
+  where addBlock (BasicBlock id ss) g =
+          mkLabel id emptyStackInfo <*> mkStmts ss <*> g
+        updfr_sz = panic "upd frame size lost in cmm conversion"
         mkStmts (CmmNop        : ss)  = mkNop        <*> mkStmts ss 
         mkStmts (CmmComment s  : ss)  = mkComment s  <*> mkStmts ss
         mkStmts (CmmAssign l r : ss)  = mkAssign l r <*> mkStmts ss
         mkStmts (CmmStore  l r : ss)  = mkStore  l r <*> mkStmts ss
         mkStmts (CmmCall (CmmCallee f conv) res args (CmmSafe srt) CmmMayReturn : ss) =
-            mkCall f conv (map hintlessCmm res) (map hintlessCmm args) srt <*> mkStmts ss 
+            mkCall f conv' (map hintlessCmm res) (map hintlessCmm args) updfr_sz
+            <*> mkStmts ss 
+              where conv' = Foreign (ForeignConvention conv [] []) -- JD: DUBIOUS
         mkStmts (CmmCall (CmmPrim {}) _ _ (CmmSafe _) _ : _) =
             panic "safe call to a primitive CmmPrim CallishMachOp"
         mkStmts (CmmCall f res args CmmUnsafe CmmMayReturn : ss) =
                       mkUnsafeCall (convert_target f res args)
-                       (strip_hints res) (strip_hints args) <*> mkStmts ss
+                       (strip_hints res) (strip_hints args)
+                      <*> mkStmts ss
         mkStmts (CmmCondBranch e l : fbranch) =
             mkCmmIfThenElse e (mkBranch l) (mkStmts fbranch)
         mkStmts (last : []) = mkLast last
@@ -58,14 +61,15 @@ toZgraph fun_name args g@(ListGraph (BasicBlock id ss : other_blocks)) =
         mkStmts (_ : _ : _) = bad "last node not at end"
         bad msg = pprPanic (msg ++ " in function " ++ fun_name) (ppr g)
         mkLast (CmmCall (CmmCallee f conv) []     args _ CmmNeverReturns) =
-            mkFinalCall f conv $ map hintlessCmm args
+            mkFinalCall f conv (map hintlessCmm args) updfr_sz
         mkLast (CmmCall (CmmPrim {}) _ _ _ CmmNeverReturns) =
             panic "Call to CmmPrim never returns?!"
         mkLast (CmmSwitch scrutinee table) = mkSwitch scrutinee table
         -- SURELY, THESE HINTLESS ARGS ARE WRONG AND WILL BE FIXED WHEN CALLING
         -- CONVENTIONS ARE HONORED?
-        mkLast (CmmJump tgt args)          = mkJump   tgt $ map hintlessCmm args
-        mkLast (CmmReturn ress)            = mkReturn $ map hintlessCmm ress
+        mkLast (CmmJump tgt args)          = mkJump   tgt (map hintlessCmm args) updfr_sz
+        mkLast (CmmReturn ress)            =
+          mkReturnSimple (map hintlessCmm ress) updfr_sz
         mkLast (CmmBranch tgt)             = mkBranch tgt
         mkLast (CmmCall _f (_:_) _args _ CmmNeverReturns) =
                    panic "Call never returns but has results?!"
@@ -104,7 +108,7 @@ ofZgraph g = ListGraph $ swallow blocks
           showblocks = "LGraph has " ++ show (length blocks) ++ " blocks:" ++
                        concat (map (\(G.Block id _ _) -> " " ++ show id) blocks)
           cscomm = "Call successors are" ++
-                   (concat $ map (\id -> " " ++ show id) $ uniqSetToList call_succs)
+                   (concat $ map (\id -> " " ++ show id) $ blockSetToList call_succs)
           swallow [] = []
           swallow (G.Block id _ t : rest) = tail id [] t rest
           tail id prev' (G.ZTail m t)             rest = tail id (mid m : prev') t rest
@@ -113,15 +117,13 @@ ofZgraph g = ListGraph $ swallow blocks
           mid (MidComment s)  = CmmComment s
           mid (MidAssign l r) = CmmAssign l r
           mid (MidStore  l r) = CmmStore  l r
-          mid (MidUnsafeCall target ress args)
+          mid (MidForeignCall _ target ress args)
                = CmmCall (cmm_target target)
                          (add_hints conv Results   ress) 
                          (add_hints conv Arguments args) 
                          CmmUnsafe CmmMayReturn
                where
                  conv = get_conv target
-          mid m@(MidAddToContext {}) = pcomment (ppr m)
-          pcomment p = scomment $ showSDoc p
           block' id prev'
               | id == G.lg_entry g = BasicBlock id $ extend_entry    (reverse prev')
               | otherwise          = BasicBlock id $ extend_block id (reverse prev')
@@ -130,7 +132,7 @@ ofZgraph g = ListGraph $ swallow blocks
             case l of
               LastBranch tgt ->
                   case n of
-                    -- THIS IS NOW WRONG -- LABELS CAN SHOW UP ELSEWHERE IN THE GRAPH
+                    -- THIS OPT IS WRONG -- LABELS CAN SHOW UP ELSEWHERE IN THE GRAPH
                     --G.Block id' _ t : bs
                     --    | tgt == id', unique_pred id' 
                     --    -> tail id prev' t bs -- optimize out redundant labels
@@ -138,6 +140,10 @@ ofZgraph g = ListGraph $ swallow blocks
               LastCondBranch expr tid fid ->
                   case n of
                     G.Block id' _ t : bs
+                      -- It would be better to handle earlier, but we still must
+                      -- generate correct code here.
+                      | id' == fid, tid == fid, unique_pred id' ->
+                                 tail id prev' t bs
                       | id' == fid, unique_pred id' ->
                                  tail id (CmmCondBranch expr tid : prev') t bs
                       | id' == tid, unique_pred id',
@@ -145,16 +151,8 @@ ofZgraph g = ListGraph $ swallow blocks
                                  tail id (CmmCondBranch e'   fid : prev') t bs
                     _ -> let instrs' = CmmBranch fid : CmmCondBranch expr tid : prev'
                          in block' id instrs' : swallow n
-              LastJump expr _      -> endblock $ CmmJump expr []
-              LastReturn _         -> endblock $ CmmReturn []
               LastSwitch arg ids   -> endblock $ CmmSwitch arg $ ids
-              LastCall e cont _ ->
-                let tgt = CmmCallee e CCallConv in
-                case cont of
-                  Nothing ->
-                      endblock $ CmmCall tgt [] [] CmmUnsafe CmmNeverReturns
-                  Just _ ->
-                       endblock $ CmmCall tgt [] [] (CmmSafe NoC_SRT) CmmMayReturn
+              LastCall e _ _ _ -> endblock $ CmmJump e []
           exit id prev' n = -- highly irregular (assertion violation?)
               let endblock stmt = block' id (stmt : prev') : swallow n in
               case n of [] -> endblock (scomment "procedure falls off end")
@@ -169,7 +167,7 @@ ofZgraph g = ListGraph $ swallow blocks
                     let id = G.blockId b
                     in  case lookupBlockEnv preds id of
                           Nothing -> single
-                          Just s -> if sizeUniqSet s == 1 then
+                          Just s -> if sizeBlockSet s == 1 then
                                         extendBlockSet single id
                                     else single
               in  G.fold_blocks add emptyBlockSet g
@@ -177,7 +175,8 @@ ofZgraph g = ListGraph $ swallow blocks
           call_succs = 
               let add b succs =
                       case G.last (G.unzip b) of
-                        G.LastOther (LastCall _ (Just id) _) -> extendBlockSet succs id
+                        G.LastOther (LastCall _ (Just id) _ _) ->
+                          extendBlockSet succs id
                         _ -> succs
               in  G.fold_blocks add emptyBlockSet g
           _is_call_succ id = elemBlockSet id call_succs
index 5893843..6e09a6f 100644 (file)
@@ -1,15 +1,15 @@
 
 module CmmExpr
     ( CmmType  -- Abstract 
-         , b8, b16, b32, b64, f32, f64, bWord, bHalfWord, gcWord
-         , cInt, cLong
-         , cmmBits, cmmFloat
-         , typeWidth, cmmEqType, cmmEqType_ignoring_ptrhood
-         , isFloatType, isGcPtrType, isWord32, isWord64, isFloat64, isFloat32
+    , b8, b16, b32, b64, f32, f64, bWord, bHalfWord, gcWord
+    , cInt, cLong
+    , cmmBits, cmmFloat
+    , typeWidth, cmmEqType, cmmEqType_ignoring_ptrhood
+    , isFloatType, isGcPtrType, isWord32, isWord64, isFloat64, isFloat32
  
     , Width(..)
-         , widthInBits, widthInBytes, widthInLog
-         , wordWidth, halfWordWidth, cIntWidth, cLongWidth
+    , widthInBits, widthInBytes, widthInLog, widthFromBytes
+    , wordWidth, halfWordWidth, cIntWidth, cLongWidth
  
     , CmmExpr(..), cmmExprType, cmmExprWidth, maybeInvertCmmExpr
     , CmmReg(..), cmmRegType
@@ -21,7 +21,7 @@ module CmmExpr
     , DefinerOfSlots, UserOfSlots, foldSlotsDefd, foldSlotsUsed
     , RegSet, emptyRegSet, elemRegSet, extendRegSet, deleteFromRegSet, mkRegSet
             , plusRegSet, minusRegSet, timesRegSet
-    , Area(..), AreaId(..), SubArea, StackSlotMap, getSlot
+    , Area(..), AreaId(..), SubArea, SubAreaSet, AreaMap, StackSlotMap, getSlot
  
    -- MachOp
     , MachOp(..) 
@@ -98,7 +98,9 @@ data AreaId
   | Young BlockId
   deriving (Eq, Ord)
 
-type SubArea = (Area, Int, Int) -- area, offset, width
+type SubArea    = (Area, Int, Int) -- area, offset, width
+type SubAreaSet = FiniteMap Area [SubArea]
+type AreaMap    = FiniteMap Area Int
 
 data CmmLit
   = CmmInt Integer  Width
@@ -119,6 +121,8 @@ data CmmLit
         -- It is also used inside the NCG during when generating
         -- position-independent code. 
   | CmmLabelDiffOff CLabel CLabel Int   -- label1 - label2 + offset
+  | CmmBlock BlockId                   -- Code label
+  | CmmHighStackMark -- stands for the max stack space used during a procedure
   deriving Eq
 
 cmmExprType :: CmmExpr -> CmmType
@@ -135,6 +139,8 @@ cmmLitType (CmmFloat _ width)   = cmmFloat width
 cmmLitType (CmmLabel lbl)      = cmmLabelType lbl
 cmmLitType (CmmLabelOff lbl _)  = cmmLabelType lbl
 cmmLitType (CmmLabelDiffOff {}) = bWord
+cmmLitType (CmmBlock _)        = bWord
+cmmLitType (CmmHighStackMark)   = bWord
 
 cmmLabelType :: CLabel -> CmmType
 cmmLabelType lbl | isGcPtrLabel lbl = gcWord
@@ -244,6 +250,10 @@ instance DefinerOfLocalRegs a => DefinerOfLocalRegs [a] where
   foldRegsDefd _ set [] = set
   foldRegsDefd f set (x:xs) = foldRegsDefd f (foldRegsDefd f set x) xs
 
+instance DefinerOfLocalRegs a => DefinerOfLocalRegs (Maybe a) where
+  foldRegsDefd _ set Nothing  = set
+  foldRegsDefd f set (Just x) = foldRegsDefd f set x
+
 
 -----------------------------------------------------------------------------
 --    Stack slots
@@ -605,6 +615,15 @@ widthInBytes W64  = 8
 widthInBytes W128 = 16
 widthInBytes W80  = 10
 
+widthFromBytes :: Int -> Width
+widthFromBytes 1  = W8
+widthFromBytes 2  = W16
+widthFromBytes 4  = W32
+widthFromBytes 8  = W64
+widthFromBytes 16 = W128
+widthFromBytes 10 = W80
+widthFromBytes n  = pprPanic "no width for given number of bytes" (ppr n)
+
 -- log_2 of the width in bytes, useful for generating shifts.
 widthInLog :: Width -> Int
 widthInLog W8   = 0
index eb226da..438f122 100644 (file)
@@ -6,8 +6,10 @@
 -- for details
 
 module CmmInfo (
+  emptyContInfoTable,
   cmmToRawCmm,
-  mkInfoTable
+  mkInfoTable,
+  mkBareInfoTable
 ) where
 
 #include "HsVersions.h"
@@ -23,6 +25,7 @@ import CgInfoTbls
 import CgCallConv
 import CgUtils
 import SMRep
+import ZipCfgCmmRep
 
 import Constants
 import Outputable
@@ -33,6 +36,13 @@ import Panic
 
 import Data.Bits
 
+-- When we split at proc points, we need an empty info table.
+emptyContInfoTable :: CmmInfo
+emptyContInfoTable =
+  CmmInfo Nothing Nothing (CmmInfoTable False (ProfilingInfo zero zero) rET_SMALL
+                                              (ContInfo [] NoC_SRT))
+    where zero = CmmInt 0 wordWidth
+
 cmmToRawCmm :: [Cmm] -> IO [RawCmm]
 cmmToRawCmm cmm = do
   info_tbl_uniques <- mkSplitUniqSupply 'i'
@@ -81,7 +91,7 @@ mkInfoTable uniq (CmmProc (CmmInfo _ _ info) entry_label arguments blocks) =
       -- Code without an info table.  Easy.
       CmmNonInfoTable -> [CmmProc [] entry_label arguments blocks]
 
-      CmmInfoTable (ProfilingInfo ty_prof cl_prof) type_tag type_info ->
+      CmmInfoTable (ProfilingInfo ty_prof cl_prof) type_tag type_info ->
           let info_label = entryLblToInfoLbl entry_label
               ty_prof'   = makeRelativeRefTo info_label ty_prof
               cl_prof'   = makeRelativeRefTo info_label cl_prof
@@ -144,6 +154,17 @@ mkInfoTable uniq (CmmProc (CmmInfo _ _ info) entry_label arguments blocks) =
                                      else type_tag
                 (srt_label, srt_bitmap) = mkSRTLit info_label srt
 
+-- Generate a bare info table, not attached to any procedure.
+mkBareInfoTable :: CLabel -> Unique -> CmmInfoTable -> [CmmTopZ]
+mkBareInfoTable lbl uniq info =
+  case mkInfoTable uniq (CmmProc (CmmInfo Nothing Nothing info) lbl [] (ListGraph [])) of
+    [CmmProc d _ _ _] ->
+      ASSERT (tablesNextToCode)
+      [CmmData Data (d ++ [CmmDataLabel (entryLblToInfoLbl lbl)])]
+    [CmmData d s]     -> [CmmData d s]
+    _ -> panic "mkBareInfoTable expected to produce only data"
+
+
 -- Handle the differences between tables-next-to-code
 -- and not tables-next-to-code
 mkInfoTableAndCode :: CLabel
index 7c8f2b3..1b60ed7 100644 (file)
@@ -22,7 +22,6 @@ import CLabel
 import Maybe
 import Outputable
 import PprCmm
-import Unique
 import Constants
 import FastString
 
@@ -59,7 +58,7 @@ lintCmmTop (CmmData {})
 
 lintCmmBlock :: BlockSet -> GenBasicBlock CmmStmt -> CmmLint ()
 lintCmmBlock labels (BasicBlock id stmts)
-  = addLintInfo (text "in basic block " <> ppr (getUnique id)) $
+  = addLintInfo (text "in basic block " <> ppr id) $
        mapM_ (lintCmmStmt labels) stmts
 
 -- -----------------------------------------------------------------------------
@@ -88,20 +87,11 @@ lintCmmExpr expr =
 
 -- Check for some common byte/word mismatches (eg. Sp + 1)
 cmmCheckMachOp   :: MachOp -> [CmmExpr] -> [CmmType] -> CmmLint CmmType
-cmmCheckMachOp  op args@[CmmReg reg, CmmLit (CmmInt i _)] _
-  | isWordOffsetReg reg && isOffsetOp op && i `rem` fromIntegral wORD_SIZE /= 0
-  = cmmLintDubiousWordOffset (CmmMachOp op args)
 cmmCheckMachOp op [lit@(CmmLit (CmmInt { })), reg@(CmmReg _)] tys
   = cmmCheckMachOp op [reg, lit] tys
 cmmCheckMachOp op _ tys
   = return (machOpResultType op tys)
 
-isWordOffsetReg  :: CmmReg -> Bool
-isWordOffsetReg (CmmGlobal Sp) = True
--- No warnings for unaligned arithmetic, which is used to tag dynamic constructor closures.
---isWordOffsetReg (CmmGlobal Hp) = True
-isWordOffsetReg _ = False
-
 isOffsetOp :: MachOp -> Bool
 isOffsetOp (MO_Add _) = True
 isOffsetOp (MO_Sub _) = True
index 93372fc..e53a606 100644 (file)
@@ -47,13 +47,13 @@ cmmLiveness blocks =
     fixedpoint (cmmBlockDependants sources)
                (cmmBlockUpdate blocks')
                (map blockId blocks)
-               (listToUFM [(blockId b, emptyUniqSet) | b <- blocks])
+               (mkBlockEnv [(blockId b, emptyUniqSet) | b <- blocks])
     where
       sources :: BlockSources
       sources = cmmBlockSources blocks
 
       blocks' :: BlockStmts
-      blocks' = listToUFM $ map block_name blocks
+      blocks' = mkBlockEnv $ map block_name blocks
 
       block_name :: CmmBasicBlock -> (BlockId, [CmmStmt])
       block_name b = (blockId b, blockStmts b)
@@ -75,7 +75,7 @@ cmmLivenessComment live (BasicBlock ident stmts) =
 -- need updating after a given block is updated in the liveness analysis
 -----------------------------------------------------------------------------
 cmmBlockSources :: [CmmBasicBlock] -> BlockSources
-cmmBlockSources blocks = foldr aux emptyUFM blocks
+cmmBlockSources blocks = foldr aux emptyBlockEnv blocks
     where
       aux :: CmmBasicBlock
           -> BlockSources
@@ -89,7 +89,7 @@ cmmBlockSources blocks = foldr aux emptyUFM blocks
                        -> BlockSources
                        -> BlockSources
       add_source_edges source target ufm =
-          addToUFM_Acc (flip addOneToUniqSet) unitUniqSet ufm target source
+          addToBEnv_Acc (flip addOneToUniqSet) unitUniqSet ufm target source
 
       branch_targets :: [CmmStmt] -> UniqSet BlockId
       branch_targets stmts =
@@ -107,7 +107,7 @@ cmmBlockSources blocks = foldr aux emptyUFM blocks
 -----------------------------------------------------------------------------
 cmmBlockDependants :: BlockSources -> BlockId -> [BlockId]
 cmmBlockDependants sources ident =
-    uniqSetToList $ lookupWithDefaultUFM sources emptyUniqSet ident
+    uniqSetToList $ lookupWithDefaultBEnv sources emptyUniqSet ident
 
 -----------------------------------------------------------------------------
 -- | Given the table of type 'BlockStmts' and a block that was updated,
@@ -122,14 +122,14 @@ cmmBlockUpdate ::
 cmmBlockUpdate blocks node _ state =
     if (sizeUniqSet old_live) == (sizeUniqSet new_live)
       then Nothing
-      else Just $ addToUFM state node new_live
+      else Just $ extendBlockEnv state node new_live
     where
       new_live, old_live :: CmmLive
       new_live = cmmStmtListLive state block_stmts
-      old_live = lookupWithDefaultUFM state missing_live node
+      old_live = lookupWithDefaultBEnv state missing_live node
 
       block_stmts :: [CmmStmt]
-      block_stmts = lookupWithDefaultUFM blocks missing_block node
+      block_stmts = lookupWithDefaultBEnv blocks missing_block node
 
       missing_live = panic "unknown block id during liveness analysis"
       missing_block = panic "unknown block id during liveness analysis"
@@ -187,14 +187,14 @@ cmmStmtLive _ (CmmCall target results arguments _ _) =
               (CmmCallee target _) -> cmmExprLive target
               (CmmPrim _) -> id
 cmmStmtLive other_live (CmmBranch target) =
-    addLive (lookupWithDefaultUFM other_live emptyUniqSet target)
+    addLive (lookupWithDefaultBEnv other_live emptyUniqSet target)
 cmmStmtLive other_live (CmmCondBranch expr target) =
     cmmExprLive expr .
-    addLive (lookupWithDefaultUFM other_live emptyUniqSet target)
+    addLive (lookupWithDefaultBEnv other_live emptyUniqSet target)
 cmmStmtLive other_live (CmmSwitch expr targets) =
     cmmExprLive expr .
     (foldr ((.) . (addLive .
-                   lookupWithDefaultUFM other_live emptyUniqSet))
+                   lookupWithDefaultBEnv other_live emptyUniqSet))
            id
            (mapCatMaybes id targets))
 cmmStmtLive _ (CmmJump expr params) =
index b239ae3..7bafc91 100644 (file)
@@ -3,7 +3,7 @@ module CmmLiveZ
     ( CmmLive
     , cmmLivenessZ
     , liveLattice
-    , middleLiveness, lastLiveness
+    , middleLiveness, lastLiveness, noLiveOnEntry
     ) 
 where
 
@@ -19,6 +19,7 @@ import ZipDataflow
 import ZipCfgCmmRep
 
 import Maybes
+import Outputable
 import UniqSet
 
 -----------------------------------------------------------------------------
@@ -30,7 +31,7 @@ type CmmLive = RegSet
 
 -- | The dataflow lattice
 liveLattice :: DataflowLattice CmmLive
-liveLattice = DataflowLattice "live LocalReg's" emptyUniqSet add False
+liveLattice = DataflowLattice "live LocalReg's" emptyUniqSet add True
     where add new old =
             let join = unionUniqSets new old in
             (if sizeUniqSet join > sizeUniqSet old then aTx else noTx) join
@@ -42,13 +43,22 @@ type BlockEntryLiveness = BlockEnv CmmLive
 -- | Calculated liveness info for a CmmGraph
 -----------------------------------------------------------------------------
 cmmLivenessZ :: CmmGraph -> FuelMonad BlockEntryLiveness
-cmmLivenessZ g = liftM zdfFpFacts $ (res :: FuelMonad (CmmBackwardFixedPoint CmmLive))
+cmmLivenessZ g@(LGraph entry _ _) =
+  liftM (check . zdfFpFacts) (res :: FuelMonad (CmmBackwardFixedPoint CmmLive))
   where res = zdfSolveFrom emptyBlockEnv "liveness analysis" liveLattice transfers
                            emptyUniqSet (graphOfLGraph g)
         transfers = BackwardTransfers first middle last
         first live _ = live
         middle       = flip middleLiveness
         last         = flip lastLiveness
+        check facts  =
+          noLiveOnEntry entry (expectJust "check" $ lookupBlockEnv facts entry) facts
+
+-- | On entry to the procedure, there had better not be any LocalReg's live-in.
+noLiveOnEntry :: BlockId -> CmmLive -> a -> a
+noLiveOnEntry bid in_fact x =
+  if isEmptyUniqSet in_fact then x
+  else pprPanic "LocalReg's live-in to graph" (ppr bid <+> ppr in_fact)
 
 -- | The transfer equations use the traditional 'gen' and 'kill'
 -- notations, which should be familiar from the dragon book.
@@ -56,20 +66,18 @@ gen, kill :: UserOfLocalRegs a => a -> RegSet -> RegSet
 gen  a live = foldRegsUsed extendRegSet      live a
 kill a live = foldRegsUsed delOneFromUniqSet live a
 
+-- Why aren't these function using the typeclasses on Middle and Last?
 middleLiveness :: Middle -> CmmLive -> CmmLive
-middleLiveness m = middle m
-  where middle (MidComment {})               = id
-        middle (MidAssign lhs expr)          = gen expr . kill lhs
-        middle (MidStore addr rval)          = gen addr . gen rval
-        middle (MidUnsafeCall tgt ress args) = gen tgt . gen args . kill ress
-        middle (MidAddToContext ra args)     = gen ra . gen args
+middleLiveness (MidComment {})            live = live
+middleLiveness (MidAssign lhs expr)       live = gen expr $ kill lhs live
+middleLiveness (MidStore addr rval)       live = gen addr $ gen rval live
+middleLiveness (MidForeignCall _ tgt _ args) _ = gen tgt $ gen args emptyUniqSet
 
 lastLiveness :: Last -> (BlockId -> CmmLive) -> CmmLive
 lastLiveness l env = last l
-  where last (LastReturn _)            = emptyUniqSet
-        last (LastJump e _)            = gen e $ emptyUniqSet
-        last (LastBranch id)           = env id
-        last (LastCall tgt (Just k) _) = gen tgt $ env k
-        last (LastCall tgt Nothing _)  = gen tgt $ emptyUniqSet
-        last (LastCondBranch e t f)    = gen e $ unionUniqSets (env t) (env f)
-        last (LastSwitch e tbl) = gen e $ unionManyUniqSets $ map env (catMaybes tbl)
+  where last (LastBranch id)             = env id
+        last (LastCall tgt Nothing  _ _) = gen tgt $ emptyUniqSet
+        last (LastCall tgt (Just k) _ _) = gen tgt $ env k
+        last (LastCondBranch e t f)      = gen e $ unionUniqSets (env t) (env f)
+        last (LastSwitch e tbl)          =
+          gen e $ unionManyUniqSets $ map env (catMaybes tbl)
index e459a75..148e3da 100644 (file)
@@ -543,7 +543,8 @@ narrowS _ _ = panic "narrowTo"
 -}
 
 cmmLoopifyForC :: RawCmmTop -> RawCmmTop
-cmmLoopifyForC p@(CmmProc info entry_lbl [] (ListGraph blocks@(BasicBlock top_id _ : _)))
+cmmLoopifyForC p@(CmmProc info entry_lbl []
+                 (ListGraph blocks@(BasicBlock top_id _ : _)))
   | null info = p  -- only if there's an info table, ignore case alts
   | otherwise =  
 --  pprTrace "jump_lbl" (ppr jump_lbl <+> ppr entry_lbl) $
index 9382994..180aad6 100644 (file)
@@ -247,7 +247,7 @@ info        :: { ExtFCode (CLabel, CmmInfoTable, [Maybe LocalReg]) }
                -- ptrs, nptrs, closure type, description, type
                { do prof <- profilingInfo $11 $13
                     return (mkRtsEntryLabelFS $3,
-                       CmmInfoTable prof (fromIntegral $9)
+                       CmmInfoTable False prof (fromIntegral $9)
                                     (ThunkInfo (fromIntegral $5, fromIntegral $7) NoC_SRT),
                        []) }
        
@@ -255,7 +255,7 @@ info        :: { ExtFCode (CLabel, CmmInfoTable, [Maybe LocalReg]) }
                -- ptrs, nptrs, closure type, description, type, fun type
                { do prof <- profilingInfo $11 $13
                     return (mkRtsEntryLabelFS $3,
-                       CmmInfoTable prof (fromIntegral $9)
+                       CmmInfoTable False prof (fromIntegral $9)
                                     (FunInfo (fromIntegral $5, fromIntegral $7) NoC_SRT
                                      0  -- Arity zero
                                      (ArgSpec (fromIntegral $15))
@@ -269,7 +269,7 @@ info        :: { ExtFCode (CLabel, CmmInfoTable, [Maybe LocalReg]) }
                -- ptrs, nptrs, closure type, description, type, fun type, arity
                { do prof <- profilingInfo $11 $13
                     return (mkRtsEntryLabelFS $3,
-                       CmmInfoTable prof (fromIntegral $9)
+                       CmmInfoTable False prof (fromIntegral $9)
                                     (FunInfo (fromIntegral $5, fromIntegral $7) NoC_SRT (fromIntegral $17)
                                      (ArgSpec (fromIntegral $15))
                                      zeroCLit),
@@ -284,7 +284,7 @@ info        :: { ExtFCode (CLabel, CmmInfoTable, [Maybe LocalReg]) }
                     -- but that's the way the old code did it we can fix it some other time.
                     desc_lit <- code $ mkStringCLit $13
                     return (mkRtsEntryLabelFS $3,
-                       CmmInfoTable prof (fromIntegral $11)
+                       CmmInfoTable False prof (fromIntegral $11)
                                     (ConstrInfo (fromIntegral $5, fromIntegral $7) (fromIntegral $9) desc_lit),
                        []) }
        
@@ -292,7 +292,7 @@ info        :: { ExtFCode (CLabel, CmmInfoTable, [Maybe LocalReg]) }
                -- selector, closure type, description, type
                { do prof <- profilingInfo $9 $11
                     return (mkRtsEntryLabelFS $3,
-                       CmmInfoTable prof (fromIntegral $7)
+                       CmmInfoTable False prof (fromIntegral $7)
                                     (ThunkSelectorInfo (fromIntegral $5) NoC_SRT),
                        []) }
 
@@ -300,7 +300,7 @@ info        :: { ExtFCode (CLabel, CmmInfoTable, [Maybe LocalReg]) }
                -- closure type (no live regs)
                { do let infoLabel = mkRtsInfoLabelFS $3
                     return (mkRtsRetLabelFS $3,
-                       CmmInfoTable (ProfilingInfo zeroCLit zeroCLit) (fromIntegral $5)
+                       CmmInfoTable False (ProfilingInfo zeroCLit zeroCLit) (fromIntegral $5)
                                     (ContInfo [] NoC_SRT),
                        []) }
 
@@ -308,7 +308,7 @@ info        :: { ExtFCode (CLabel, CmmInfoTable, [Maybe LocalReg]) }
                -- closure type, live regs
                { do live <- sequence (map (liftM Just) $7)
                     return (mkRtsRetLabelFS $3,
-                       CmmInfoTable (ProfilingInfo zeroCLit zeroCLit) (fromIntegral $5)
+                       CmmInfoTable False (ProfilingInfo zeroCLit zeroCLit) (fromIntegral $5)
                                     (ContInfo live NoC_SRT),
                        live) }
 
index aa0ef01..a90af71 100644 (file)
@@ -85,8 +85,8 @@ calculateNewProcPoints  owners block =
             then unitUniqSet child_id
             else emptyUniqSet
           where
-            parent_owners = lookupWithDefaultUFM owners emptyUniqSet parent_id
-            child_owners = lookupWithDefaultUFM owners emptyUniqSet child_id
+            parent_owners = lookupWithDefaultBEnv owners emptyUniqSet parent_id
+            child_owners = lookupWithDefaultBEnv owners emptyUniqSet child_id
             needs_proc_point =
                 -- only if parent isn't dead
                 (not $ isEmptyUniqSet parent_owners) &&
@@ -99,11 +99,11 @@ calculateOwnership :: BlockEnv BrokenBlock
                    -> [BrokenBlock]
                    -> BlockEnv (UniqSet BlockId)
 calculateOwnership blocks_ufm proc_points blocks =
-    fixedpoint dependants update (map brokenBlockId blocks) emptyUFM
+    fixedpoint dependants update (map brokenBlockId blocks) emptyBlockEnv
     where
       dependants :: BlockId -> [BlockId]
       dependants ident =
-          brokenBlockTargets $ lookupWithDefaultUFM
+          brokenBlockTargets $ lookupWithDefaultBEnv
                                  blocks_ufm unknown_block ident
 
       update :: BlockId
@@ -113,16 +113,16 @@ calculateOwnership blocks_ufm proc_points blocks =
       update ident cause owners =
           case (cause, ident `elementOfUniqSet` proc_points) of
             (Nothing, True) ->
-                Just $ addToUFM owners ident (unitUniqSet ident)
+                Just $ extendBlockEnv owners ident (unitUniqSet ident)
             (Nothing, False) -> Nothing
             (Just cause', True) -> Nothing
             (Just cause', False) ->
                 if (sizeUniqSet old) == (sizeUniqSet new)
                    then Nothing
-                   else Just $ addToUFM owners ident new
+                   else Just $ extendBlockEnv owners ident new
                 where
-                  old = lookupWithDefaultUFM owners emptyUniqSet ident
+                  old = lookupWithDefaultBEnv owners emptyUniqSet ident
                   new = old `unionUniqSets`
-                        lookupWithDefaultUFM owners emptyUniqSet cause'
+                        lookupWithDefaultBEnv owners emptyUniqSet cause'
 
       unknown_block = panic "unknown BlockId in calculateOwnership"
index cedb9ef..7cf477a 100644 (file)
@@ -1,38 +1,30 @@
-
 module CmmProcPointZ
-    ( callProcPoints, minimalProcPointSet
+    ( ProcPointSet, Status(..)
+    , callProcPoints, minimalProcPointSet
     , addProcPointProtocols, splitAtProcPoints, procPointAnalysis
-    , liveSlotAnal, cafAnal, layout, manifestSP, igraph, areaBuilder
     )
 where
 
-import Constants
 import qualified Prelude as P
 import Prelude hiding (zip, unzip, last)
-import Util (sortLe)
 
 import BlockId
-import Bitmap
 import CLabel
 import Cmm hiding (blockId)
-import CmmExpr
 import CmmContFlowOpt
+import CmmExpr
+import CmmInfo
 import CmmLiveZ
 import CmmTx
 import DFMonad
 import FiniteMap
-import IdInfo
 import List (sortBy)
 import Maybes
+import MkZipCfg
 import MkZipCfgCmm hiding (CmmBlock, CmmGraph, CmmTopZ)
 import Monad
-import Name
 import Outputable
 import Panic
-import SMRep (rET_SMALL)
-import StgCmmClosure
-import StgCmmUtils
-import UniqFM
 import UniqSet
 import UniqSupply
 import ZipCfg
@@ -105,9 +97,9 @@ data Status
 
 instance Outputable Status where
   ppr (ReachedBy ps)
-      | isEmptyUniqSet ps = text "<not-reached>"
+      | isEmptyBlockSet ps = text "<not-reached>"
       | otherwise = text "reached by" <+>
-                    (hsep $ punctuate comma $ map ppr $ uniqSetToList ps)
+                    (hsep $ punctuate comma $ map ppr $ blockSetToList ps)
   ppr ProcPoint = text "<procpt>"
 
 
@@ -117,8 +109,8 @@ lattice = DataflowLattice "direct proc-point reachability" unreached add_to Fals
           add_to _ ProcPoint = noTx ProcPoint
           add_to ProcPoint _ = aTx ProcPoint -- aTx because of previous case again
           add_to (ReachedBy p) (ReachedBy p') =
-              let union = unionUniqSets p p'
-              in  if sizeUniqSet union > sizeUniqSet p' then
+              let union = unionBlockSets p p'
+              in  if sizeBlockSet union > sizeBlockSet p' then
                       aTx (ReachedBy union)
                   else
                       noTx (ReachedBy p')
@@ -127,10 +119,10 @@ lattice = DataflowLattice "direct proc-point reachability" unreached add_to Fals
 
 forward :: ForwardTransfers Middle Last Status
 forward = ForwardTransfers first middle last exit
-    where first ProcPoint id = ReachedBy $ unitUniqSet id
+    where first ProcPoint id = ReachedBy $ unitBlockSet id
           first  x _ = x
           middle x _ = x
-          last _ (LastCall _ (Just id) _) = LastOutFacts [(id, ProcPoint)]
+          last _ (LastCall _ (Just id) _ _) = LastOutFacts [(id, ProcPoint)]
           last x l = LastOutFacts $ map (\id -> (id, x)) (succs l)
           exit x   = x
                 
@@ -140,10 +132,9 @@ forward = ForwardTransfers first middle last exit
 callProcPoints      :: CmmGraph -> ProcPointSet
 minimalProcPointSet :: ProcPointSet -> CmmGraph -> FuelMonad ProcPointSet
 
-callProcPoints g = fold_blocks add entryPoint g
-  where entryPoint = unitUniqSet (lg_entry g)
-        add b set = case last $ unzip b of
-                      LastOther (LastCall _ (Just k) _) -> extendBlockSet set k
+callProcPoints g = fold_blocks add (unitBlockSet (lg_entry g)) g
+  where add b set = case last $ unzip b of
+                      LastOther (LastCall _ (Just k) _ _) -> extendBlockSet set k
                       _ -> set
 
 minimalProcPointSet callProcPoints g = extendPPSet g (postorder_dfs g) callProcPoints
@@ -153,7 +144,7 @@ type PPFix = FuelMonad (ForwardFixedPoint Middle Last Status ())
 procPointAnalysis :: ProcPointSet -> CmmGraph -> FuelMonad (BlockEnv Status)
 procPointAnalysis procPoints g =
   let addPP env id = extendBlockEnv env id ProcPoint
-      initProcPoints = foldl addPP emptyBlockEnv (uniqSetToList procPoints)
+      initProcPoints = foldl addPP emptyBlockEnv (blockSetToList procPoints)
   in liftM zdfFpFacts $
         (zdfSolveFrom initProcPoints "proc-point reachability" lattice
                               forward (fact_bot lattice) $ graphOfLGraph g :: PPFix)
@@ -166,18 +157,26 @@ extendPPSet g blocks procPoints =
                                  Just ProcPoint -> extendBlockSet pps id
                                  _ -> pps
            procPoints' = fold_blocks add emptyBlockSet g
-           newPoint = listToMaybe (mapMaybe ppSuccessor blocks)
-           ppSuccessor b@(Block id _ _) =
-               let nreached id = case lookupBlockEnv env id `orElse` panic "no ppt" of
+           newPoints = mapMaybe ppSuccessor blocks
+           newPoint  = listToMaybe newPoints 
+           ppSuccessor b@(Block bid _ _) =
+               let nreached id = case lookupBlockEnv env id `orElse`
+                                       pprPanic "no ppt" (ppr id <+> ppr b) of
                                    ProcPoint -> 1
-                                   ReachedBy ps -> sizeUniqSet ps
-                   my_nreached = nreached id
+                                   ReachedBy ps -> sizeBlockSet ps
+                   block_procpoints = nreached bid
                    -- | Looking for a successor of b that is reached by
                    -- more proc points than b and is not already a proc
                    -- point.  If found, it can become a proc point.
                    newId succ_id = not (elemBlockSet succ_id procPoints') &&
-                                   nreached succ_id > my_nreached
+                                   nreached succ_id > block_procpoints
                in  listToMaybe $ filter newId $ succs b
+{-
+       case newPoints of
+           []  -> return procPoints'
+           pps -> extendPPSet g blocks
+                    (foldl extendBlockSet procPoints' pps)
+-}
        case newPoint of Just id ->
                           if elemBlockSet id procPoints' then panic "added old proc pt"
                           else extendPPSet g blocks (extendBlockSet procPoints' id)
@@ -245,16 +244,18 @@ instance Outputable Protocol where
 addProcPointProtocols :: ProcPointSet -> ProcPointSet -> CmmGraph -> FuelMonad CmmGraph
 addProcPointProtocols callPPs procPoints g =
   do liveness <- cmmLivenessZ g
-     (protos, g') <- return $ optimize_calls liveness g
+     (protos, g') <- optimize_calls liveness g
      blocks'' <- add_CopyOuts protos procPoints g'
      return $ LGraph (lg_entry g) (lg_argoffset g) blocks''
     where optimize_calls liveness g =  -- see Note [Separate Adams optimization]
-              let (protos, blocks') =
-                      fold_blocks maybe_add_call (init_protocols, emptyBlockEnv) g
-                  protos' = add_unassigned liveness procPoints protos
-                  g'  = LGraph (lg_entry g) (lg_argoffset g) $
-                               add_CopyIns callPPs protos' blocks'
-              in  (protos', runTx removeUnreachableBlocksZ g')
+            do let (protos, blocks') =
+                       fold_blocks maybe_add_call (init_protocols, emptyBlockEnv) g
+                   protos' = add_unassigned liveness procPoints protos
+               blocks <- add_CopyIns callPPs protos' blocks'
+               let g' = LGraph (lg_entry g) (lg_argoffset g)
+                               (mkBlockEnv (map withKey (concat blocks)))
+                   withKey b@(Block bid _ _) = (bid, b)
+               return (protos', runTx removeUnreachableBlocksZ g')
           maybe_add_call :: CmmBlock -> (BlockEnv Protocol, BlockEnv CmmBlock)
                          -> (BlockEnv Protocol, BlockEnv CmmBlock)
           -- ^ If the block is a call whose continuation goes to a proc point
@@ -262,10 +263,10 @@ addProcPointProtocols callPPs procPoints g =
           -- redirect the call (cf 'newblock') and set the protocol if necessary
           maybe_add_call block (protos, blocks) =
               case goto_end $ unzip block of
-                (h, LastOther (LastCall tgt (Just k) s))
+                (h, LastOther (LastCall tgt (Just k) s))
                     | Just proto <- lookupBlockEnv protos k,
                       Just pee   <- branchesToProcPoint k
-                    -> let newblock = zipht h (tailOfLast (LastCall tgt (Just pee) s))
+                    -> let newblock = zipht h (tailOfLast (LastCall tgt (Just pee) s))
                            changed_blocks   = insertBlock newblock blocks
                            unchanged_blocks = insertBlock block    blocks
                        in case lookupBlockEnv protos pee of
@@ -279,7 +280,7 @@ addProcPointProtocols callPPs procPoints g =
           -- ^ Tells whether the named block is just a branch to a proc point
           branchesToProcPoint id =
               let (Block _ _ t) = lookupBlockEnv (lg_blocks g) id `orElse`
-                                  panic "branch out of graph"
+                                    panic "branch out of graph"
               in case t of
                    ZLast (LastOther (LastBranch pee))
                        | elemBlockSet pee procPoints -> Just pee
@@ -301,12 +302,12 @@ add_unassigned = pass_live_vars_as_args
 pass_live_vars_as_args :: BlockEnv CmmLive -> ProcPointSet ->
                           BlockEnv Protocol -> BlockEnv Protocol
 pass_live_vars_as_args _liveness procPoints protos = protos'
-  where protos' = foldUniqSet addLiveVars protos procPoints
+  where protos' = foldBlockSet addLiveVars protos procPoints
         addLiveVars :: BlockId -> BlockEnv Protocol -> BlockEnv Protocol
         addLiveVars id protos =
             case lookupBlockEnv protos id of
               Just _  -> protos
-              Nothing -> let live = emptyBlockEnv
+              Nothing -> let live = emptyRegSet
                                     --lookupBlockEnv _liveness id `orElse`
                                     --panic ("no liveness at block " ++ show id)
                              formals = uniqSetToList live
@@ -317,16 +318,23 @@ pass_live_vars_as_args _liveness procPoints protos = protos'
 -- | Add copy-in instructions to each proc point that did not arise from a call
 -- instruction. (Proc-points that arise from calls already have their copy-in instructions.)
 
-add_CopyIns :: ProcPointSet -> BlockEnv Protocol -> BlockEnv CmmBlock -> BlockEnv CmmBlock
-add_CopyIns callPPs protos blocks = mapUFM maybe_insert_CopyIns blocks
-    where maybe_insert_CopyIns :: CmmBlock -> CmmBlock
-          maybe_insert_CopyIns b@(Block id off t) | not $ elementOfUniqSet id callPPs =
-            case (off, lookupBlockEnv protos id) of
-              (Just _, _) -> panic "shouldn't copy arguments twice into a block"
-              (_, Just (Protocol c fs area)) -> Block id (Just off) $ foldr ZTail t copies
-                where (off, copies) = copyIn c False area fs
-              (_, Nothing) -> b
-          maybe_insert_CopyIns b = b
+add_CopyIns :: ProcPointSet -> BlockEnv Protocol -> BlockEnv CmmBlock ->
+               FuelMonad [[CmmBlock]]
+add_CopyIns callPPs protos blocks =
+  liftUniq $ mapM maybe_insert_CopyIns (blockEnvToList blocks)
+    where maybe_insert_CopyIns (_, b@(Block id stackInfo t))
+           | not $ elemBlockSet id callPPs
+           = case (argBytes stackInfo, lookupBlockEnv protos id) of
+               (Just _, _) -> panic "shouldn't copy arguments twice into a block"
+               (_, Just (Protocol c fs area)) ->
+                 do let (off, copies) = copyIn c False area fs
+                        stackInfo' = stackInfo {argBytes = Just off}
+                    LGraph _ _ blocks <-
+                      lgraphOfAGraph 0 (mkLabel id stackInfo' <*>
+                      copies <*> mkZTail t)
+                    return (map snd $ blockEnvToList blocks)
+               (_, Nothing) -> return [b]
+           | otherwise = return [b]
 
 -- | Add a CopyOut node before each procpoint.
 -- If the predecessor is a call, then the copy outs should already be done by the callee.
@@ -342,7 +350,7 @@ add_CopyOuts protos procPoints g = fold_blocks mb_copy_out (return emptyBlockEnv
           mb_copy_out b@(Block bid _ _) z | bid == lg_entry g = skip b z 
           mb_copy_out b z =
             case last $ unzip b of
-              LastOther (LastCall _ _ _) -> skip b z -- copy out done by callee
+              LastOther (LastCall _ _ _ _) -> skip b z -- copy out done by callee
               _ -> mb_copy_out' b z
           mb_copy_out' b z = fold_succs trySucc b init >>= finish
             where init = z >>= (\bmap -> return (b, bmap))
@@ -351,7 +359,8 @@ add_CopyOuts protos procPoints g = fold_blocks mb_copy_out (return emptyBlockEnv
                       case lookupBlockEnv protos succId of
                         Nothing -> z
                         Just (Protocol c fs area) ->
-                          let (_, copies) = copyOut c Jump area $ map (CmmReg . CmmLocal) fs
+                          let (_, copies) =
+                                copyOut c Jump area (map (CmmReg . CmmLocal) fs) 0
                           in  insert z succId copies
                     else z
                   insert z succId m =
@@ -375,540 +384,86 @@ add_CopyOuts protos procPoints g = fold_blocks mb_copy_out (return emptyBlockEnv
 --    the SRTs in the entry procedure as well.
 -- Input invariant: A block should only be reachable from a single ProcPoint.
 splitAtProcPoints :: CLabel -> ProcPointSet-> ProcPointSet -> BlockEnv Status ->
-                     BlockEnv SubAreaSet -> AreaMap -> CmmTopZ -> FuelMonad [CmmTopZ]
-splitAtProcPoints entry_label callPPs procPoints procMap slotEnv areaMap
-                  (CmmProc top_info top_l top_args g@(LGraph entry e_off blocks)) =
+                     AreaMap -> CmmTopZ -> FuelMonad [CmmTopZ]
+splitAtProcPoints entry_label callPPs procPoints procMap areaMap
+                  (CmmProc (CmmInfo gc upd_fr info_tbl) top_l top_args
+                           g@(LGraph entry e_off blocks)) =
   do -- Build a map from procpoints to the blocks they reach
      let addBlock b@(Block bid _ _) graphEnv =
            case lookupBlockEnv procMap bid of
              Just ProcPoint -> add graphEnv bid bid b
              Just (ReachedBy set) ->
-               case uniqSetToList set of
+               case blockSetToList set of
                  []   -> graphEnv
                  [id] -> add graphEnv id bid b 
-                 _ -> panic "Each block should be reachable from only one ProcPoint"
+                 _    -> panic "Each block should be reachable from only one ProcPoint"
              Nothing -> pprPanic "block not reached by a proc point?" (ppr bid)
          add graphEnv procId bid b = extendBlockEnv graphEnv procId graph'
                where graph  = lookupBlockEnv graphEnv procId `orElse` emptyBlockEnv
                      graph' = extendBlockEnv graph bid b
-     graphEnv <- return $ fold_blocks addBlock emptyBlockEnv g
+     graphEnv_pre <- return $ fold_blocks addBlock emptyBlockEnv g
+     graphEnv <- return $ pprTrace "graphEnv" (ppr graphEnv_pre) graphEnv_pre
      -- Build a map from proc point BlockId to labels for their new procedures
      let add_label map pp = return $ addToFM map pp lbl
            where lbl = if pp == entry then entry_label else blockLbl pp
-     procLabels <- foldM add_label emptyFM (uniqSetToList procPoints)
-     -- Convert call and return instructions to jumps.
-     let last (LastCall e _ n) = LastJump e n
-         last l = l
-     graphEnv <- return $ mapUFM (mapUFM (map_one_block id id last)) graphEnv
+     -- Due to common blockification, we may overestimate the set of procpoints.
+     procLabels <- foldM add_label emptyFM
+                         (filter (elemBlockEnv blocks) (blockSetToList procPoints))
      -- In each new graph, add blocks jumping off to the new procedures,
      -- and replace branches to procpoints with branches to the jump-off blocks
      let add_jump_block (env, bs) (pp, l) =
            do bid <- liftM mkBlockId getUniqueM
-              let b = Block bid Nothing (ZLast (LastOther jump))
-                  argSpace = case lookupBlockEnv blocks pp of
-                               Just (Block _ (Just s) _) -> s
-                               Just (Block _ Nothing  _) -> panic "no args at procpoint"
-                               _ -> panic "can't find procpoint block"
-                  jump = LastJump (CmmLit (CmmLabel l)) argSpace
-              return $ (extendBlockEnv env pp bid, b : bs)
-         add_jumps newGraphEnv (guniq, blockEnv) =
-           do (jumpEnv, jumpBlocks) <- foldM add_jump_block (emptyBlockEnv, [])
-                                           $ fmToList procLabels
-              let ppId = mkBlockId guniq
-                  (b_off, b) =
-                    case lookupBlockEnv blockEnv ppId of
-                      Just (Block id (Just b_off) t) -> (b_off, Block id Nothing t)
-                      Just b@(Block _ Nothing _)     -> (0, b)
+              let b = Block bid emptyStackInfo (ZLast (LastOther jump))
+                  argSpace =
+                    case lookupBlockEnv blocks pp of
+                      Just (Block _ (StackInfo {argBytes = Just s}) _) -> s
+                      Just (Block _ _ _) -> panic "no args at procpoint"
+                      _ -> panic "can't find procpoint block"
+                  jump = LastCall (CmmLit (CmmLabel l')) Nothing argSpace Nothing
+                  l' = if elemBlockSet pp callPPs then entryLblToInfoLbl l else l
+              return (extendBlockEnv env pp bid, b : bs)
+         add_jumps (newGraphEnv) (ppId, blockEnv) =
+           do (jumpEnv, jumpBlocks) <-
+                 foldM add_jump_block (emptyBlockEnv, []) (fmToList procLabels)
+              let (b_off, b) = -- get the stack offset on entry into the block and
+                               -- remove the offset from the block (it goes in new graph)
+                    case lookupBlockEnv blockEnv ppId of -- get the procpoint block
+                      Just (Block id sinfo@(StackInfo {argBytes = Just b_off}) t) ->
+                        (b_off, Block id (sinfo {argBytes = Nothing}) t)
+                      Just b@(Block _ _ _) -> (0, b)
                       Nothing -> panic "couldn't find entry block while splitting"
+                  blockEnv' = extendBlockEnv blockEnv ppId b
                   off = if ppId == entry then e_off else b_off
-                  LGraph _ _ blockEnv' = pprTrace "jumpEnv" (ppr jumpEnv) $
-                                         replaceLabelsZ jumpEnv $ LGraph ppId off blockEnv
-                  blockEnv'' = foldl (flip insertBlock) (extendBlockEnv blockEnv' ppId b)
-                                     jumpBlocks
-              return $ extendBlockEnv newGraphEnv ppId $
-                       runTx cmmCfgOptsZ $ LGraph ppId off blockEnv''
-         upd_info_tbl srt' (CmmInfoTable p t typeinfo) = CmmInfoTable p t typeinfo'
-           where typeinfo' = case typeinfo of
-                   t@(ConstrInfo _ _ _)    -> t
-                   (FunInfo    c _ a d e)  -> FunInfo c srt' a d e
-                   (ThunkInfo  c _)        -> ThunkInfo c srt'
-                   (ThunkSelectorInfo s _) -> ThunkSelectorInfo s srt'
-                   (ContInfo vars _)       -> ContInfo vars srt'
-         upd_info_tbl _ CmmNonInfoTable = CmmNonInfoTable 
-         to_proc cafMap (ppUniq, g) | elementOfUniqSet bid callPPs =
+                  LGraph _ _ blockEnv'' = 
+                    replaceBranches jumpEnv $ LGraph ppId off blockEnv'
+                  blockEnv''' = foldl (flip insertBlock) blockEnv'' jumpBlocks
+              let g' = LGraph ppId off blockEnv'''
+              pprTrace "g' pre jumps" (ppr g') $
+               return (extendBlockEnv newGraphEnv ppId g')
+     graphEnv_pre <- foldM add_jumps emptyBlockEnv $ blockEnvToList graphEnv
+     graphEnv <- return $ pprTrace "graphEnv with jump blocks" (ppr graphEnv_pre)
+                                         graphEnv_pre
+     let to_proc (bid, g@(LGraph g_entry _ blocks)) | elemBlockSet bid callPPs =
            if bid == entry then 
-             CmmProc (CmmInfo gc upd_fr (upd_info_tbl srt' info_tbl)) top_l top_args g
+             CmmProc (CmmInfo gc upd_fr info_tbl) top_l top_args g
            else
-            pprTrace "adding infotable for" (ppr bid) $
-             CmmProc (CmmInfo Nothing Nothing $ infoTbl) lbl [] g
-           where bid = mkBlockId ppUniq
-                 lbl = expectJust "pp label" $ lookupFM procLabels bid
-                 infoTbl = CmmInfoTable (ProfilingInfo zero zero) rET_SMALL
-                                        (ContInfo stack_vars srt')
-                 stack_vars = pprTrace "slotEnv" (ppr slotEnv) $
-                               live_vars slotEnv areaMap bid
-                 zero = CmmInt 0 wordWidth
-                 srt' = expectJust "procpoint.infoTbl" $ lookupBlockEnv cafMap bid
-                 CmmInfo gc upd_fr info_tbl = top_info
-         to_proc _ (ppUniq, g) =
-          pprTrace "not adding infotable for" (ppr bid) $
+             CmmProc emptyContInfoTable lbl [] g
+           where lbl = expectJust "pp label" $ lookupFM procLabels bid
+         to_proc (bid, g) =
            CmmProc (CmmInfo Nothing Nothing CmmNonInfoTable) lbl [] g
-             where bid = mkBlockId ppUniq
-                   lbl = expectJust "pp label" $ lookupFM procLabels bid
-     graphEnv <- foldM add_jumps emptyBlockEnv $ ufmToList graphEnv
-     cafEnv <- cafAnal g
-     (cafTable, blockCafs) <- buildCafs cafEnv
-     procs <- return $ map (to_proc blockCafs) $ ufmToList graphEnv
-     return $ pprTrace "procLabels" (ppr procLabels) $
-              pprTrace "splitting graphs" (ppr graphEnv) $ cafTable ++ procs
-splitAtProcPoints _ _ _ _ _ _ t@(CmmData _ _) = return [t]
-
-------------------------------------------------------------------------
---                    Stack Layout                                    --
-------------------------------------------------------------------------
-
--- | Before we lay out the stack, we need to know something about the
--- liveness of the stack slots. In particular, to decide whether we can
--- reuse a stack location to hold multiple stack slots, we need to know
--- when each of the stack slots is used.
--- Although tempted to use something simpler, we really need a full interference
--- graph. Consider the following case:
---   case <...> of
---     1 -> <spill x>; // y is dead out
---     2 -> <spill y>; // x is dead out
---     3 -> <spill x and y>
--- If we consider the arms in order and we use just the deadness information given by a
--- dataflow analysis, we might decide to allocate the stack slots for x and y
--- to the same stack location, which will lead to incorrect code in the third arm.
--- We won't make this mistake with an interference graph.
-
--- First, the liveness analysis.
--- We represent a slot with an area, an offset into the area, and a width.
--- Tracking the live slots is a bit tricky because there may be loads and stores
--- into only a part of a stack slot (e.g. loading the low word of a 2-word long),
--- e.g. Slot A 0 8 overlaps with Slot A 4 4.
---
--- The definition of a slot set is intended to reduce the number of overlap
--- checks we have to make. There's no reason to check for overlap between
--- slots in different areas, so we segregate the map by Area's.
--- We expect few slots in each Area, so we collect them in an unordered list.
--- To keep these lists short, any contiguous live slots are coalesced into
--- a single slot, on insertion.
-
-type SubAreaSet   = FiniteMap Area [SubArea]
-fold_subareas :: (SubArea -> z -> z) -> SubAreaSet -> z -> z
-fold_subareas f m z = foldFM (\_ s z -> foldr (\a z -> f a z) z s) z m
-
-liveGen :: SubArea -> [SubArea] -> (Bool, [SubArea])
-liveGen s set = liveGen' s set []
-  where liveGen' s [] z = (True, s : z)
-        liveGen' s@(a, hi, w) (s'@(a', hi', w') : rst) z =
-          if a /= a' || hi < lo' || lo > hi' then    -- no overlap
-            liveGen' s rst (s' : z)
-          else if s' `contains` s then               -- old contains new
-            (False, set)
-          else                                       -- overlap: coalesce the slots
-            let new_hi = max hi hi'
-                new_lo = min lo lo'
-            in liveGen' (a, new_hi, new_hi - new_lo) rst z
-          where lo  = hi  - w  -- remember: areas grow down
-                lo' = hi' - w'
-        contains (a, hi, w) (a', hi', w') =
-          a == a' && hi >= hi' && hi - w <= hi' - w'
-
-liveKill :: SubArea -> [SubArea] -> [SubArea]
-liveKill (a, hi, w) set = pprTrace "killing slots in area" (ppr a) $ liveKill' set []
-  where liveKill' [] z = z
-        liveKill' (s'@(a', hi', w') : rst) z =
-          if a /= a' || hi < lo' || lo > hi' then    -- no overlap
-            liveKill' rst (s' : z)
-          else                                       -- overlap: split the old slot
-            let z'  = if hi' > hi  then (a, hi', hi' - hi)  : z else z
-                z'' = if lo  > lo' then (a, lo,  lo  - lo') : z' else z'
-            in liveKill' rst z''
-          where lo  = hi  - w  -- remember: areas grow down
-                lo' = hi' - w'
-
-slotLattice :: DataflowLattice SubAreaSet
-slotLattice = DataflowLattice "live slots" emptyFM add True
-  where add new old = case foldFM addArea (False, old) new of
-                        (True,  x) -> aTx  x
-                        (False, x) -> noTx x
-        addArea a newSlots z = foldr (addSlot a) z newSlots
-        addSlot a slot (changed, map) =
-          let (c, live) = liveGen slot $ lookupWithDefaultFM map [] a
-          in (c || changed, addToFM map a live)
-
-liveInSlots :: (DefinerOfSlots s, UserOfSlots s) => SubAreaSet -> s -> SubAreaSet
-liveInSlots live x = foldSlotsUsed add (foldSlotsDefd remove live x) x
-  where add    live (a, i, w) = liftToArea a (snd . liveGen  (a, i, w)) live
-        remove live (a, i, w) = liftToArea a       (liveKill (a, i, w)) live
-        liftToArea a f map = addToFM map a $ f (lookupWithDefaultFM map [] a)
-
--- Unlike the liveness transfer functions @gen@ and @kill@, this function collects
--- _any_ slot that is named.
---addNamedSlots :: (DefinerOfSlots s, UserOfSlots s) => SubAreaSet -> s -> SubAreaSet
---addNamedSlots live x = foldSlotsUsed add (foldSlotsDefd add live x) x
---  where add    live (a, i, w) = liftToArea a (snd . liveGen  (a, i, w)) live
---        liftToArea a f map = addToFM map a $ f (lookupWithDefaultFM map [] a)
-
--- Note: the stack slots that hold variables returned on the stack are not
--- considered live in to the block -- we treat the first node as a definition site.
--- BEWARE: I'm being a little careless here in failing to check for the
--- entry Id (which would use the CallArea Old).
-liveTransfers :: BackwardTransfers Middle Last SubAreaSet
-liveTransfers = BackwardTransfers first liveInSlots liveLastIn
-    where first live id = delFromFM live (CallArea (Young id))
-
-liveLastIn :: (BlockId -> SubAreaSet) -> Last -> SubAreaSet
-liveLastIn env l = liveInSlots (liveLastOut env l) l
-
--- Don't forget to keep the outgoing parameters in the CallArea live.
-liveLastOut :: (BlockId -> SubAreaSet) -> Last -> SubAreaSet
-liveLastOut env l =
-  case l of
-    LastReturn n          -> add_area (CallArea Old)       n out
-    LastJump _ n          -> add_area (CallArea Old)       n out
-    LastCall _ Nothing  n -> add_area (CallArea Old)       n out
-    LastCall _ (Just k) n -> add_area (CallArea (Young k)) n out
-    _                     -> out
-  where out = joinOuts slotLattice env l
-add_area :: Area -> Int -> SubAreaSet -> SubAreaSet
-add_area a n live =
-  addToFM live a $ snd $ liveGen (a, n, n) $ lookupWithDefaultFM live [] a
-
-type SlotFix a = FuelMonad (BackwardFixedPoint Middle Last SubAreaSet a)
-liveSlotAnal :: LGraph Middle Last -> FuelMonad (BlockEnv SubAreaSet)
-liveSlotAnal g = liftM zdfFpFacts (res :: SlotFix ())
-  where res = zdfSolveFromL emptyBlockEnv "live slot analysis" slotLattice
-                            liveTransfers (fact_bot slotLattice) g
-
--- The liveness analysis must be precise: otherwise, we won't know if a definition
--- should really kill a live-out stack slot.
--- But the interference graph does not have to be precise -- it might decide that
--- any live areas interfere. To maintain both a precise analysis and an imprecise
--- interference graph, we need to convert the live-out stack slots to graph nodes
--- at each and every instruction; rather than reconstruct a new list of nodes
--- every time, I provide a function to fold over the nodes, which should be a
--- reasonably efficient approach for the implementations we envision.
--- Of course, it will probably be much easier to program if we just return a list...
-type Set x = FiniteMap x ()
-type AreaMap = FiniteMap Area Int
-data IGraphBuilder n =
-  Builder { foldNodes     :: forall z. SubArea -> (n -> z -> z) -> z -> z
-          , _wordsOccupied :: AreaMap -> AreaMap -> n -> [Int]
-          }
-
-areaBuilder :: IGraphBuilder Area
-areaBuilder = Builder fold words
-  where fold (a, _, _) f z = f a z
-        words areaSize areaMap a =
-          case lookupFM areaMap a of
-            Just addr -> [addr .. addr + (lookupFM areaSize a `orElse`
-                                          pprPanic "wordsOccupied: unknown area" (ppr a))]
-            Nothing   -> []
-
---slotBuilder :: IGraphBuilder (Area, Int)
---slotBuilder = undefined
-
--- Now, we can build the interference graph.
--- The usual story: a definition interferes with all live outs and all other
--- definitions.
-type IGraph x = FiniteMap x (Set x)
-type IGPair x = (IGraph x, IGraphBuilder x)
-igraph :: (Ord x) => IGraphBuilder x -> BlockEnv SubAreaSet -> LGraph Middle Last -> IGraph x
-igraph builder env g = foldr interfere emptyFM (postorder_dfs g)
-  where foldN = foldNodes builder
-        interfere block igraph =
-          let (h, l) = goto_end (unzip block)
-              --heads :: ZHead Middle -> (IGraph x, SubAreaSet) -> IGraph x
-              heads (ZFirst _ _) (igraph, _)       = igraph
-              heads (ZHead h m)  (igraph, liveOut) =
-                heads h (addEdges igraph m liveOut, liveInSlots liveOut m)
-              -- add edges between a def and the other defs and liveouts
-              addEdges igraph i out = fst $ foldSlotsDefd addDef (igraph, out) i
-              addDef (igraph, out) def@(a, _, _) =
-                (foldN def (addDefN out) igraph,
-                 addToFM out a (snd $ liveGen def (lookupWithDefaultFM out [] a)))
-              addDefN out n igraph =
-                let addEdgeNO o igraph = foldN o addEdgeNN igraph
-                    addEdgeNN n' igraph = addEdgeNN' n n' $ addEdgeNN' n' n igraph
-                    addEdgeNN' n n' igraph = addToFM igraph n (addToFM set n' ())
-                      where set = lookupWithDefaultFM igraph emptyFM n
-                in foldFM (\ _ os igraph -> foldr addEdgeNO igraph os) igraph out
-              env' bid = lookupBlockEnv env bid `orElse` panic "unknown blockId in igraph"
-          in heads h $ case l of LastExit    -> (igraph, emptyFM)
-                                 LastOther l -> (addEdges igraph l $ liveLastOut env' l,
-                                                 liveLastIn env' l)
-
--- Before allocating stack slots, we need to collect one more piece of information:
--- what's the highest offset (in bytes) used in each Area?
--- We'll need to allocate that much space for each Area.
-getAreaSize :: LGraph Middle Last -> AreaMap
-getAreaSize g@(LGraph _ off _) =
-  fold_blocks (fold_fwd_block first add add) (unitFM (CallArea Old) off) g
-  where first _ z = z
-        add   x z = foldSlotsUsed addSlot (foldSlotsDefd addSlot z x) x
-        addSlot z (a, off, _) = addToFM z a $ max off $ lookupWithDefaultFM z 0 a
-
-
--- Find the Stack slots occupied by the subarea's conflicts
-conflictSlots :: Ord x => IGPair x -> AreaMap -> AreaMap -> SubArea -> Set Int
-conflictSlots (ig, Builder foldNodes wordsOccupied) areaSize areaMap subarea =
-  foldNodes subarea foldNode emptyFM
-  where foldNode n set = foldFM conflict set $ lookupWithDefaultFM ig emptyFM n
-        conflict n' () set = liveInSlots areaMap n' set
-        -- Add stack slots occupied by igraph node n
-        liveInSlots areaMap n set = foldr setAdd set (wordsOccupied areaSize areaMap n)
-        setAdd w s = addToFM s w ()
-
--- Find any open space on the stack, starting from the offset.
-freeSlotFrom :: Ord x => IGPair x -> AreaMap -> Int -> AreaMap -> Area -> Int
-freeSlotFrom ig areaSize offset areaMap area =
-  let size = lookupFM areaSize area `orElse` 0
-      conflicts = conflictSlots ig areaSize areaMap (area, size, size)
-      -- Find a space big enough to hold the area
-      findSpace curr 0 = curr
-      findSpace curr cnt = -- target slot, considerand, # left to check
-        if elemFM curr conflicts then
-          findSpace (curr + size) size
-        else findSpace (curr - 1) (cnt - 1)
-  in findSpace (offset + size) size
-
--- Find an open space on the stack, and assign it to the area.
-allocSlotFrom :: Ord x => IGPair x -> AreaMap -> Int -> AreaMap -> Area -> AreaMap
-allocSlotFrom ig areaSize from areaMap area =
-  if elemFM area areaMap then areaMap
-  else addToFM areaMap area $ freeSlotFrom ig areaSize from areaMap area
-
--- | Greedy stack layout.
--- Compute liveness, build the interference graph, and allocate slots for the areas.
--- We visit each basic block in a (generally) forward order.
--- At each instruction that names a register subarea r, we immediately allocate
--- any available slot on the stack by the following procedure:
---  1. Find the nodes N' that conflict with r
---  2. Find the stack slots used for N'
---  3. Choose a contiguous stack space s not in N' (s must be large enough to hold r)
--- For a CallArea, we allocate the stack space only when we reach a function
--- call that returns to the CallArea's blockId.
--- We use a similar procedure, with one exception: the stack space
--- must be allocated below the youngest stack slot that is live out.
-
--- Note: The stack pointer only has to be younger than the youngest live stack slot
--- at proc points. Otherwise, the stack pointer can point anywhere.
-layout :: ProcPointSet -> BlockEnv SubAreaSet -> LGraph Middle Last -> AreaMap
-layout procPoints env g@(LGraph _ entrySp _) =
-  let builder = areaBuilder
-      ig = (igraph builder env g, builder)
-      env' bid = lookupBlockEnv env bid `orElse` panic "unknown blockId in igraph"
-      areaSize = getAreaSize g
-      -- Find the slots that are live-in to the block
-      live_in (ZTail m l) = liveInSlots (live_in l) m
-      live_in (ZLast (LastOther l)) = liveLastIn env' l
-      live_in (ZLast LastExit) = emptyFM 
-      -- Find the youngest live stack slot
-      youngest_live areaMap live = fold_subareas young_slot live 0
-        where young_slot (a, o, _) z = case lookupFM areaMap a of
-                                         Just top -> max z $ top + o
-                                         Nothing  -> z
-      -- Allocate space for spill slots and call areas
-      allocVarSlot = allocSlotFrom ig areaSize 0
-      allocCallSlot areaMap (Block id _ t) | elemBlockSet id procPoints =
-        allocSlotFrom ig areaSize (youngest_live areaMap $ live_in t)
-                      areaMap (CallArea (Young id))
-      allocCallSlot areaMap _ = areaMap
-      alloc i areaMap = foldSlotsDefd alloc' (foldSlotsUsed alloc' areaMap i) i
-        where alloc' areaMap (a@(RegSlot _), _, _) = allocVarSlot areaMap a
-              alloc' areaMap _ = areaMap
-      layoutAreas areaMap b@(Block _ _ t) = layout areaMap t
-        where layout areaMap (ZTail m t) = layout (alloc m areaMap) t
-              layout areaMap (ZLast _) = allocCallSlot areaMap b
-      areaMap = foldl layoutAreas (addToFM emptyFM (CallArea Old) 0) $ postorder_dfs g
-  in pprTrace "ProcPoints" (ppr procPoints) $
-       pprTrace "Area SizeMap" (ppr areaSize) $
-         pprTrace "Entry SP" (ppr entrySp) $
-           pprTrace "Area Map" (ppr areaMap) $ areaMap
-
--- After determining the stack layout, we can:
--- 1. Replace references to stack Areas with addresses relative to the stack
---    pointer.
--- 2. Insert adjustments to the stack pointer to ensure that it is at a
---    conventional location at each proc point.
---    Because we don't take interrupts on the execution stack, we only need the
---    stack pointer to be younger than the live values on the stack at proc points.
--- 3. At some point, we should check for stack overflow, but not just yet.
-manifestSP :: ProcPointSet -> BlockEnv Status -> AreaMap ->
-                LGraph Middle Last -> FuelMonad (LGraph Middle Last)
-manifestSP procPoints procMap areaMap g@(LGraph entry args blocks) =
-  liftM (LGraph entry args) blocks'
-  where blocks' = foldl replB (return emptyBlockEnv) (postorder_dfs g)
-        slot a = pprTrace "slot" (ppr a) $ lookupFM areaMap a `orElse` panic "unallocated Area"
-        slot' id = pprTrace "slot'" (ppr id)$ slot $ CallArea (Young id)
-        sp_on_entry id | id == entry = slot (CallArea Old) + args
-        sp_on_entry id | elemBlockSet id procPoints =
-          case lookupBlockEnv blocks id of
-            Just (Block _ (Just o) _) -> slot' id + o
-            Just (Block _ Nothing  _) -> slot' id
-            Nothing -> panic "procpoint dropped from block env"
-        sp_on_entry id =
-          case lookupBlockEnv procMap id of
-            Just (ReachedBy pp) -> case uniqSetToList pp of
-                                     [id] -> sp_on_entry id
-                                     _    -> panic "block not reached by single proc point"
-            Just ProcPoint -> panic "procpoint not in procpoint set"
-            Nothing -> panic "block not found in procmap"
-        -- On entry to procpoints, the stack pointer is conventional;
-        -- otherwise, we check the SP set by predecessors.
-        replB :: FuelMonad (BlockEnv CmmBlock) -> CmmBlock -> FuelMonad (BlockEnv CmmBlock)
-        replB blocks (Block id o t) =
-          do bs <- replTail (Block id o) spIn t
-             pprTrace "spIn" (ppr id <+> ppr spIn)$ liftM (flip (foldr insertBlock) bs) blocks
-          where spIn = sp_on_entry id
-        replTail :: (ZTail Middle Last -> CmmBlock) -> Int -> (ZTail Middle Last) -> 
-                    FuelMonad ([CmmBlock])
-        replTail h spOff (ZTail m t) = replTail (h . ZTail (middle spOff m)) spOff t
-        replTail h spOff (ZLast (LastOther l)) = fixSp h spOff l
-        replTail h _   l@(ZLast LastExit) = return [h l]
-        middle spOff m = mapExpDeepMiddle (replSlot spOff) m
-        last   spOff l = mapExpDeepLast   (replSlot spOff) l
-        replSlot spOff (CmmStackSlot a i) = CmmRegOff (CmmGlobal Sp) (spOff - (slot a + i))
-        replSlot _ e = e
-        -- The block must establish the SP expected at each successsor.
-        fixSp :: (ZTail Middle Last -> CmmBlock) -> Int -> Last -> FuelMonad ([CmmBlock])
-        fixSp h spOff l@(LastReturn n)          = updSp h spOff (slot (CallArea Old) + n) l
-        fixSp h spOff l@(LastJump _ n)          = updSp h spOff (slot (CallArea Old) + n) l
-        fixSp h spOff l@(LastCall _ (Just k) n) = updSp h spOff (slot' k + n)             l
-        fixSp h spOff l@(LastCall _ Nothing  n) = updSp h spOff (slot (CallArea Old) + n) l
-        fixSp h spOff l@(LastBranch k) | elemBlockSet k procPoints =
-          pprTrace "updSp" (ppr k <> ppr spOff <> ppr (sp_on_entry k)) $ updSp h spOff (sp_on_entry k) l
-        fixSp h spOff l = liftM (uncurry (:)) $ fold_succs succ l $ return (b, [])
-          where b = h (ZLast (LastOther (last spOff l)))
-                succ succId z =
-                  let succSp = sp_on_entry succId in
-                  if elemBlockSet succId procPoints && succSp /= spOff then
-                    do (b,  bs)  <- z
-                       (b', bs') <- insertBetween b [setSpMid spOff succSp] succId
-                       return (b', bs ++ bs')
-                  else z
-        updSp h old new l = return [h $ setSp old new $ ZLast $ LastOther (last new l)]
-        setSpMid sp sp' = MidAssign (CmmGlobal Sp) e
-          where e = CmmMachOp (MO_Add wordWidth) [CmmReg (CmmGlobal Sp), off]
-                off = CmmLit $ CmmInt (toInteger $ sp - sp') wordWidth
-        setSp sp sp' t = if sp == sp' then t else ZTail (setSpMid sp sp') t
-
-----------------------------------------------------------------
--- Building InfoTables
-
-type CAFSet = FiniteMap CLabel ()
-
--- First, an analysis to find live CAFs.
-cafLattice :: DataflowLattice CAFSet
-cafLattice = DataflowLattice "live cafs" emptyFM add True
-  where add new old = if sizeFM new' > sizeFM old then aTx new' else noTx new'
-          where new' = new `plusFM` old
-
-cafTransfers :: BackwardTransfers Middle Last CAFSet
-cafTransfers = BackwardTransfers first middle last
-    where first  live _ = live
-          middle live m = pprTrace "cafmiddle" (ppr m) $ foldExpDeepMiddle addCaf m live
-          last   env  l = foldExpDeepLast addCaf l (joinOuts cafLattice env l)
-          addCaf e set = case e of
-                 CmmLit (CmmLabel c) -> add c set
-                 CmmLit (CmmLabelOff c _) -> add c set
-                 CmmLit (CmmLabelDiffOff c1 c2 _) -> add c1 $ add c2 set
-                 _ -> set
-          add c s = pprTrace "CAF analysis saw label" (ppr c) $
-                     if hasCAF c then (pprTrace "has caf" (ppr c) $ addToFM s c ()) else (pprTrace "no cafs" (ppr c) $ s)
-
-type CafFix a = FuelMonad (BackwardFixedPoint Middle Last CAFSet a)
-cafAnal :: LGraph Middle Last -> FuelMonad (BlockEnv CAFSet)
-cafAnal g = liftM zdfFpFacts (res :: CafFix ())
-  where res = zdfSolveFromL emptyBlockEnv "live CAF analysis" cafLattice
-                            cafTransfers (fact_bot cafLattice) g
-
--- Once we have found the CAFs, we need to do two things:
--- 1. Build a table of all the CAFs used in the procedure.
--- 2. Compute the C_SRT describing the subset of CAFs live at each procpoint.
-buildCafs :: (BlockEnv CAFSet) -> FuelMonad ([CmmTopZ], BlockEnv C_SRT)
-buildCafs blockCafs =
-  -- This is surely the wrong way to get names, as in BlockId
-  do top_lbl <- getUniqueM >>= \ u -> return $ mkSRTLabel (mkFCallName u "srt") MayHaveCafRefs
-     let allCafs = foldBlockEnv (\_ x y -> plusFM x y) emptyFM blockCafs
-         caf_entry (ix, map, tbl') caf = (ix + 1, addToFM map caf ix, entry : tbl')
-           where entry = CmmStaticLit $ CmmLabel caf
-         (_::Int, cafMap, tbl') = foldl caf_entry (0, emptyFM, []) $ keysFM allCafs
-         top_tbl = CmmData RelocatableReadOnlyData $ CmmDataLabel top_lbl : reverse tbl'
-         sub_srt id cafs z =
-           do (tbls, blocks) <- z
-              (top, srt)     <- procpointSRT top_lbl cafMap cafs
-              let blocks' = extendBlockEnv blocks id srt
-              case top of Just t  -> return (t:tbls, blocks')
-                          Nothing -> return (tbls,   blocks')
-     (sub_tbls, blockSRTs) <- foldBlockEnv sub_srt (return ([], emptyBlockEnv)) blockCafs
-     return (top_tbl :  sub_tbls, blockSRTs) 
-
--- Construct an SRT bitmap.
--- Adapted from simpleStg/SRT.lhs, which expects Id's.
-procpointSRT :: CLabel -> FiniteMap CLabel Int -> FiniteMap CLabel () ->
-                FuelMonad (Maybe CmmTopZ, C_SRT)
-procpointSRT top_srt top_table entries
- | isEmptyFM entries = pprTrace "nil SRT" (ppr top_srt) $ return (Nothing, NoC_SRT)
- | otherwise  = pprTrace "non-nil SRT" (ppr top_srt) $ bitmap `seq` to_SRT top_srt offset len bitmap
-  where
-    ints = map (expectJust "constructSRT" . lookupFM top_table) (keysFM entries)
-    sorted_ints = sortLe (<=) ints
-    offset = head sorted_ints
-    bitmap_entries = map (subtract offset) sorted_ints
-    len = P.last bitmap_entries + 1
-    bitmap = intsToBitmap len bitmap_entries
-
--- Adapted from codeGen/StgCmmUtils, which converts from SRT to C_SRT.
-to_SRT :: CLabel -> Int -> Int -> Bitmap -> FuelMonad (Maybe CmmTopZ, C_SRT)
-to_SRT top_srt off len bmp
-  | len > widthInBits wordWidth `div` 2 || bmp == [fromIntegral srt_escape]
-  = do id <- getUniqueM
-       let srt_desc_lbl = mkLargeSRTLabel id
-           tbl = CmmData RelocatableReadOnlyData $
-                   CmmDataLabel srt_desc_lbl : map CmmStaticLit
-                     ( cmmLabelOffW top_srt off
-                     : mkWordCLit (fromIntegral len)
-                     : map mkWordCLit bmp)
-       return (Just tbl, C_SRT srt_desc_lbl 0 srt_escape)
-  | otherwise
-  = return (Nothing, C_SRT top_srt off (fromIntegral (head bmp)))
-       -- The fromIntegral converts to StgHalfWord
-
--- Given a block ID, we return a representation of the layout of the stack.
--- If the element is `Nothing`, then it represents an empty or dead
--- word on the stack.
--- If the element is `Just` a register, then it represents a live spill slot
--- for the register; note that a register may occupy multiple words.
--- The head of the list represents the young end of the stack where the infotable
--- pointer for the block `Bid` is stored.
--- The infotable pointer itself is not included in the list.
-live_vars :: BlockEnv SubAreaSet -> AreaMap -> BlockId -> [Maybe LocalReg]
-live_vars slotEnv areaMap bid = slotsToList youngByte liveSlots
-  where slotsToList 0 [] = []
-        slotsToList 0 ((_, r, _) : _)  = pprPanic "slot left off live_vars" (ppr r)
-        slotsToList n _ | n < 0 = panic "stack slots not allocated on word boundaries?"
-        slotsToList n ((n', r, w) : rst) =
-          if n == n' then Just r : slotsToList (n - w) rst
-          else Nothing : slotsToList (n - wORD_SIZE) rst
-        slotsToList n [] = Nothing : slotsToList (n - wORD_SIZE) []
-        liveSlots = sortBy (\ (_,off,_) (_,off',_) -> compare off' off)
-                      (foldFM (\_ -> flip $ foldr add_slot) [] slots)
-        add_slot (a@(RegSlot r@(LocalReg _ ty)), off, w) rst = 
-          if off == w && widthInBytes (typeWidth ty) == w then
-            (expectJust "add_slot" (lookupFM areaMap a), r, w) : rst
-          else panic "live_vars: only part of a variable live at a proc point"
-        add_slot (CallArea Old, off, w) rst =
-          if off == wORD_SIZE && w == wORD_SIZE then
-             rst -- the return infotable should be live
-          else pprPanic "CallAreas must not be live across function calls" (ppr bid)
-        add_slot (CallArea (Young _), _, _) _ =
-          pprPanic "CallAreas must not be live across function calls" (ppr bid)
-        slots = expectJust "live_vars slots" $ lookupBlockEnv slotEnv bid
-        youngByte = expectJust "live_vars bid_pos" $ lookupFM areaMap (CallArea (Young bid))
+             where lbl = expectJust "pp label" $ lookupFM procLabels bid
+     -- The C back end expects to see return continuations before the call sites.
+     -- Here, we sort them in reverse order -- it gets reversed later.
+     let (_, block_order) = foldl add_block_num (0::Int, emptyBlockEnv) (postorder_dfs g)
+         add_block_num (i, map) (Block bid _ _) = (i+1, extendBlockEnv map bid i)
+         sort_fn (bid, _) (bid', _) =
+           compare (expectJust "block_order" $ lookupBlockEnv block_order bid)
+                   (expectJust "block_order" $ lookupBlockEnv block_order bid')
+     procs <- return $ map to_proc $ sortBy sort_fn $ blockEnvToList graphEnv
+     return $ pprTrace "procLabels" (ppr procLabels)
+            $ pprTrace "splitting graphs" (ppr procs)
+            $ procs
+splitAtProcPoints _ _ _ _ _ t@(CmmData _ _) = return [t]
 
 ----------------------------------------------------------------
 
index 67cf8d3..be043fe 100644 (file)
@@ -8,7 +8,6 @@ module CmmSpillReload
   , availRegsLattice
   , cmmAvailableReloads
   , insertLateReloads
-  , insertLateReloads'
   , removeDeadAssignmentsAndReloads
   )
 where
@@ -25,7 +24,6 @@ import ZipCfg
 import ZipCfgCmmRep
 import ZipDataflow
 
-import Maybes
 import Monad
 import Outputable hiding (empty)
 import qualified Outputable as PP
@@ -63,7 +61,7 @@ dualUnionList ls = DualLive ss rs
 
 changeStack, changeRegs :: (RegSet -> RegSet) -> DualLive -> DualLive
 changeStack f live = live { on_stack = f (on_stack live) }
-changeRegs   f live = live { in_regs  = f (in_regs  live) }
+changeRegs  f live = live { in_regs  = f (in_regs  live) }
 
 
 dualLiveLattice :: DataflowLattice DualLive
@@ -79,33 +77,37 @@ dualLiveLattice =
 type LiveReloadFix a = FuelMonad (BackwardFixedPoint Middle Last DualLive a)
 
 dualLivenessWithInsertion :: BlockSet -> (LGraph Middle Last) -> FuelMonad (LGraph Middle Last)
-dualLivenessWithInsertion procPoints g =
+dualLivenessWithInsertion procPoints g@(LGraph entry _ _) =
   liftM zdfFpContents $ (res :: LiveReloadFix (LGraph Middle Last))
     where res = zdfBRewriteFromL RewriteDeep emptyBlockEnv "dual liveness with insertion"
-                                 dualLiveLattice (dualLiveTransfers procPoints)
-                                 (insertSpillAndReloadRewrites procPoints) empty g
+                                 dualLiveLattice (dualLiveTransfers entry procPoints)
+                                 (insertSpillAndReloadRewrites entry procPoints) empty g
           empty = fact_bot dualLiveLattice
 
 dualLiveness :: BlockSet -> LGraph Middle Last -> FuelMonad (BlockEnv DualLive)
-dualLiveness procPoints g = liftM zdfFpFacts $ (res :: LiveReloadFix ())
+dualLiveness procPoints g@(LGraph entry _ _) =
+  liftM zdfFpFacts $ (res :: LiveReloadFix ())
     where res = zdfSolveFromL emptyBlockEnv "dual liveness" dualLiveLattice
-                              (dualLiveTransfers procPoints) empty g
+                              (dualLiveTransfers entry procPoints) empty g
           empty = fact_bot dualLiveLattice
 
-dualLiveTransfers :: BlockSet -> BackwardTransfers Middle Last DualLive
-dualLiveTransfers procPoints = BackwardTransfers first middle last
+dualLiveTransfers :: BlockId -> BlockSet -> BackwardTransfers Middle Last DualLive
+dualLiveTransfers entry procPoints = BackwardTransfers first middle last
     where last   = lastDualLiveness
           middle = middleDualLiveness
-          first live _id =
-            if elemBlockSet _id procPoints then -- live at procPoint => spill
+          first live id = check live id $  -- live at procPoint => spill
+            if id /= entry && elemBlockSet id procPoints then
               DualLive { on_stack = on_stack live `plusRegSet` in_regs live
                        , in_regs  = emptyRegSet }
             else live
+          check live id x = if id == entry then noLiveOnEntry id (in_regs live) x else x
   
 middleDualLiveness :: DualLive -> Middle -> DualLive
 middleDualLiveness live m =
-  changeStack updSlots $ changeRegs (middleLiveness m) live
-    where updSlots live = foldSlotsUsed reload (foldSlotsDefd spill live m) m
+  changeStack updSlots $ changeRegs (middleLiveness m) (changeRegs regs_in live)
+    where regs_in live = case m of MidForeignCall {} -> emptyRegSet
+                                   _ -> live
+          updSlots live = foldSlotsUsed reload (foldSlotsDefd spill live m) m
           spill  live s@(RegSlot r, _, _) = check s $ deleteFromRegSet live r
           spill  live _ = live
           reload live s@(RegSlot r, _, _) = check s $ extendRegSet live r
@@ -116,37 +118,39 @@ middleDualLiveness live m =
 
 lastDualLiveness :: (BlockId -> DualLive) -> Last -> DualLive
 lastDualLiveness env l = last l
-  where last (LastReturn _)            = empty
-        last (LastJump e _)            = changeRegs (gen e) empty
-        last (LastBranch id)           = env id
-        last (LastCall tgt Nothing _)  = changeRegs (gen tgt) empty
-        last (LastCall tgt (Just k) _) = 
-            -- nothing can be live in registers at this point
-            let live = env k in
-            if  isEmptyUniqSet (in_regs live) then
-                DualLive (on_stack live) (gen tgt emptyRegSet)
-            else
-                pprTrace "Offending party:" (ppr k <+> ppr live) $
-                panic "live values in registers at call continuation"
-        last (LastCondBranch e t f)   = changeRegs (gen e) $ dualUnion (env t) (env f)
-        last (LastSwitch e tbl)       = changeRegs (gen e) $ dualUnionList $
+  where last (LastBranch id)          = env id
+        last l@(LastCall tgt Nothing  _ _) = changeRegs (gen l . kill l) empty
+        last l@(LastCall tgt (Just k) _ _) = 
+            -- nothing can be live in registers at this point, unless safe foreign call
+            let live = env k
+                live_in = DualLive (on_stack live) (gen l emptyRegSet)
+            in if isEmptyUniqSet (in_regs live) then live_in
+               else pprTrace "Offending party:" (ppr k <+> ppr live) $
+                    panic "live values in registers at call continuation"
+        last l@(LastCondBranch e t f)   =
+            changeRegs (gen l . kill l) $ dualUnion (env t) (env f)
+        last l@(LastSwitch e tbl)       = changeRegs (gen l . kill l) $ dualUnionList $
                                                              map env (catMaybes tbl)
         empty = fact_bot dualLiveLattice
                       
-gen :: UserOfLocalRegs a => a -> RegSet -> RegSet
-gen a live = foldRegsUsed extendRegSet      live a
-
-insertSpillAndReloadRewrites :: BlockSet -> BackwardRewrites Middle Last DualLive
-insertSpillAndReloadRewrites procPoints = BackwardRewrites first middle last exit
+gen  :: UserOfLocalRegs    a => a -> RegSet -> RegSet
+gen  a live = foldRegsUsed extendRegSet     live a
+kill :: DefinerOfLocalRegs a => a -> RegSet -> RegSet
+kill a live = foldRegsDefd deleteFromRegSet live a
+
+insertSpillAndReloadRewrites ::
+  BlockId -> BlockSet -> BackwardRewrites Middle Last DualLive
+insertSpillAndReloadRewrites entry procPoints =
+  BackwardRewrites first middle last exit
     where middle = middleInsertSpillsAndReloads
-          last   = \_ _ -> Nothing
-          exit = Nothing
+          last _ _ = Nothing
+          exit     = Nothing
           first live id =
-            if elemBlockSet id procPoints && not (isEmptyUniqSet reloads) then
-              Just $ mkMiddles $ map reload $ uniqSetToList reloads
+            if id /= entry && elemBlockSet id procPoints then
+              case map reload (uniqSetToList (in_regs live)) of
+                [] -> Nothing
+                is -> Just (mkMiddles is)
             else Nothing
-            where reloads = in_regs live
-
 
 middleInsertSpillsAndReloads :: DualLive -> Middle -> Maybe (AGraph Middle Last)
 middleInsertSpillsAndReloads live m = middle m
@@ -158,6 +162,11 @@ middleInsertSpillsAndReloads live m = middle m
                                              text "after", ppr m]) $
                  Just $ mkMiddles $ [m, spill reg]
             else Nothing
+        middle (MidForeignCall _ _ fs _) =
+          case map spill  (filter (flip elemRegSet (on_stack live)) fs) ++
+               map reload (uniqSetToList (kill fs (in_regs live))) of
+            []      -> Nothing
+            reloads -> Just (mkMiddles (m : reloads))
         middle _ = Nothing
                       
 -- Generating spill and reload code
@@ -168,10 +177,7 @@ spill, reload :: LocalReg -> Middle
 spill  r = MidStore  (regSlot r) (CmmReg $ CmmLocal r)
 reload r = MidAssign (CmmLocal r) (CmmLoad (regSlot r) $ localRegType r)
 
-spillHead  :: ZHead Middle -> RegSet            -> ZHead Middle
 reloadTail :: RegSet       -> ZTail Middle Last -> ZTail Middle Last
-spillHead h regset = foldl spl h $ uniqSetToList regset
-  where spl h r = ZHead h $ spill r
 reloadTail regset t = foldl rel t $ uniqSetToList regset
   where rel t r = ZTail (reload r) t
 
@@ -189,7 +195,7 @@ data AvailRegs = UniverseMinus RegSet
 
 
 availRegsLattice :: DataflowLattice AvailRegs
-availRegsLattice = DataflowLattice "register gotten from reloads" empty add False
+availRegsLattice = DataflowLattice "register gotten from reloads" empty add True
                             -- last True <==> debugging on
     where empty = UniverseMinus emptyRegSet
           -- | compute in the Tx monad to track whether anything has changed
@@ -229,7 +235,7 @@ cmmAvailableReloads :: LGraph Middle Last -> FuelMonad CmmAvail
 cmmAvailableReloads g = liftM zdfFpFacts $ (res :: AvailFix)
     where res = zdfSolveFromL emptyBlockEnv "available reloads" availRegsLattice
                               avail_reloads_transfer empty g
-          empty = (fact_bot availRegsLattice)
+          empty = fact_bot availRegsLattice
 
 avail_reloads_transfer :: ForwardTransfers Middle Last AvailRegs
 avail_reloads_transfer = ForwardTransfers first middle last id
@@ -248,40 +254,19 @@ akill a live = foldRegsUsed deleteFromAvail live a
 middleAvail :: Middle -> AvailRegs -> AvailRegs
 middleAvail m = middle m
   where middle m live = middle' m $ foldRegsUsed deleteFromAvail live m
-        middle' (MidComment {})                 = id
-        middle' (MidAssign lhs _expr)           = akill lhs
-        middle' (MidStore {})                   = id
-        middle' (MidUnsafeCall _tgt ress _args) = akill ress
-        middle' (MidAddToContext {})            = id
+        middle' (MidComment {})                 live = live
+        middle' (MidAssign lhs _expr)           live = akill lhs live
+        middle' (MidStore {})                   live = live
+        middle' (MidForeignCall _ _tgt ress _args) _ = AvailRegs emptyRegSet
 
 lastAvail :: AvailRegs -> Last -> LastOutFacts AvailRegs
-lastAvail _ (LastCall _ (Just k) _) = LastOutFacts [(k, AvailRegs emptyRegSet)]
+lastAvail _ (LastCall _ (Just k) _ _) = LastOutFacts [(k, AvailRegs emptyRegSet)]
 lastAvail avail l = LastOutFacts $ map (\id -> (id, avail)) $ succs l
 
-insertLateReloads :: LGraph Middle Last -> FuelMonad (LGraph Middle Last)
-insertLateReloads g =
-  do env <- cmmAvailableReloads g
-     mapM_blocks (insertM env) g
-    where insertM env b = fuelConsumingPass "late reloads" (insert b)
-            where avail id = lookupBlockEnv env id `orElse` AvailRegs emptyRegSet
-                  insert (Block id off tail) fuel =
-                    propagate (ZFirst id off) (avail id) tail fuel
-                  propagate h avail (ZTail m t) fuel =
-                      let (h', fuel') = maybe_add_reload h avail m fuel in
-                      propagate (ZHead h' m) (middleAvail m avail) t fuel'
-                  propagate h avail (ZLast l) fuel =
-                      let (h', fuel') = maybe_add_reload h avail l fuel in
-                      (zipht h' (ZLast l), fuel')
-                  maybe_add_reload h avail node fuel =
-                      let used = filterRegsUsed (elemAvail avail) node
-                      in  if not (canRewriteWithFuel fuel) || isEmptyUniqSet used
-                          then (h,fuel)
-                          else (spillHead h used, oneLessFuel fuel)
-
-type LateReloadFix = FuelMonad (ForwardFixedPoint Middle Last AvailRegs (LGraph Middle Last))
-
-insertLateReloads' :: (LGraph Middle Last) -> FuelMonad (LGraph Middle Last)
-insertLateReloads' g = liftM zdfFpContents $ (res :: LateReloadFix)
+type LateReloadFix = FuelMonad (ForwardFixedPoint Middle Last AvailRegs CmmGraph)
+
+insertLateReloads :: (LGraph Middle Last) -> FuelMonad (LGraph Middle Last)
+insertLateReloads g = liftM zdfFpContents $ (res :: LateReloadFix)
     where res = zdfFRewriteFromL RewriteShallow emptyBlockEnv "insert late reloads"
                                  availRegsLattice avail_reloads_transfer rewrites bot g
           bot = fact_bot availRegsLattice
@@ -290,7 +275,7 @@ insertLateReloads' g = liftM zdfFpContents $ (res :: LateReloadFix)
           middle :: AvailRegs -> Middle -> Maybe (AGraph Middle Last)
           last   :: AvailRegs -> Last -> Maybe (AGraph Middle Last)
           middle avail m = maybe_reload_before avail m (ZTail m (ZLast LastExit))
-          last avail l   = maybe_reload_before avail l (ZLast (LastOther l))
+          last   avail l = maybe_reload_before avail l (ZLast (LastOther l))
           exit _ = Nothing
           maybe_reload_before avail node tail =
               let used = filterRegsUsed (elemAvail avail) node
@@ -298,10 +283,10 @@ insertLateReloads' g = liftM zdfFpContents $ (res :: LateReloadFix)
                   else Just $ mkZTail $ reloadTail used tail
           
 removeDeadAssignmentsAndReloads :: BlockSet -> (LGraph Middle Last) -> FuelMonad (LGraph Middle Last)
-removeDeadAssignmentsAndReloads procPoints g =
+removeDeadAssignmentsAndReloads procPoints g@(LGraph entry _ _) =
    liftM zdfFpContents $ (res :: LiveReloadFix (LGraph Middle Last))
      where res = zdfBRewriteFromL RewriteDeep emptyBlockEnv "dead-assignment & -reload elim"
-                   dualLiveLattice (dualLiveTransfers procPoints)
+                   dualLiveLattice (dualLiveTransfers entry procPoints)
                    rewrites (fact_bot dualLiveLattice) g
            rewrites = BackwardRewrites first middle last exit
            exit   = Nothing
index 9f0993d..5171218 100644 (file)
@@ -9,7 +9,6 @@ import Prelude hiding (last, unzip)
 import ZipCfg
 
 import Maybes
-import UniqSet
 
 -- | Compute the predecessors of each /reachable/ block
 zipPreds :: LastNode l => LGraph m l -> BlockEnv BlockSet
@@ -32,7 +31,7 @@ givesUniquePredecessorTo g = \id -> elemBlockSet id singlePreds
           add_pred pair@(single, multi) id =
               if elemBlockSet id multi then pair
               else if elemBlockSet id single then
-                       (delOneFromUniqSet single id, extendBlockSet multi id)
+                       (removeBlockSet single id, extendBlockSet multi id)
                    else
                        (extendBlockSet single id, multi)
               
index cce112b..0bce264 100644 (file)
@@ -19,7 +19,6 @@ import OptimizationFuel
 import Control.Monad
 import Maybes
 import Outputable
-import UniqFM
 import UniqSupply
 
 {-
@@ -74,7 +73,7 @@ type DFM fact a = DFM' FuelMonad fact a
 
 runDFM :: Monad m => DataflowLattice f -> DFM' m f a -> m a
 runDFM lattice (DFM' f) =
-  (f lattice $ DFState NoChange emptyBlockEnv (fact_bot lattice)[] NoChange)
+  (f lattice $ DFState NoChange emptyBlockEnv (fact_bot lattice) [] NoChange)
   >>= return . fst
 
 class DataflowAnalysis m where
@@ -153,7 +152,7 @@ instance Monad m => DataflowAnalysis (DFM' m) where
   botFact = DFM' f
     where f lattice s = return (fact_bot lattice, s)
   forgetFact id = DFM' f 
-    where f _ s = return ((), s { df_facts = delFromUFM (df_facts s) id })
+    where f _ s = return ((), s { df_facts = delFromBlockEnv (df_facts s) id })
   addLastOutFact pair = DFM' f
     where f _ s = return ((), s { df_last_outs = pair : df_last_outs s })
   bareLastOutFacts = DFM' f
@@ -175,7 +174,7 @@ instance Monad m => DataflowAnalysis (DFM' m) where
                                     text "env is", pprFacts facts]) 
                   ; setFact id a }
          }
-    where pprFacts env = vcat (map pprFact (ufmToList env))
+    where pprFacts env = vcat (map pprFact (blockEnvToList env))
           pprFact (id, a) = hang (ppr id <> colon) 4 (ppr a)
 
   lattice = DFM' f
index 0b549fa..332b464 100644 (file)
@@ -6,16 +6,15 @@ module MkZipCfg
     , mkMiddle, mkMiddles, mkLast, mkZTail, mkBranch, mkLabel, mkIfThenElse, mkWhileDo
     , outOfLine
     , emptyGraph, graphOfMiddles, graphOfZTail
-    , lgraphOfAGraph, graphOfAGraph, labelAGraph
+    , lgraphOfAGraph, graphOfAGraph, labelAGraph, pprAGraph
     )
 where
 
-import BlockId (BlockId(..), emptyBlockEnv)
+import BlockId (BlockId(..), emptyBlockEnv, plusBlockEnv)
 import ZipCfg
 
 import Outputable
 import Unique
-import UniqFM
 import UniqSupply
 import Util
 
@@ -167,7 +166,7 @@ catAGraphs :: [AGraph m l] -> AGraph m l
 
 emptyAGraph :: AGraph m l
 mkLabel     :: (LastNode l) =>
-               BlockId -> Maybe Int -> AGraph m l -- graph contains the label
+               BlockId -> StackInfo -> AGraph m l -- graph contains the label
 mkMiddle    :: m -> AGraph m l   -- graph contains the node
 mkLast      :: (Outputable m, Outputable l, LastNode l) =>
                l       -> AGraph m l              -- graph contains the node
@@ -264,7 +263,8 @@ emptyGraph = Graph (ZLast LastExit) emptyBlockEnv
 
 labelAGraph id args g =
     do Graph tail blocks <- graphOfAGraph g
-       return $ LGraph id args $ insertBlock (Block id Nothing tail) blocks
+       return $ LGraph id args $ insertBlock (Block id stackInfo tail) blocks
+    where stackInfo = StackInfo Nothing Nothing
 
 lgraphOfAGraph args g = do id <- freshBlockId "graph entry"
                            labelAGraph id args g
@@ -291,12 +291,12 @@ graphOfZTail   t  = Graph t emptyBlockEnv
 
 mkLast l = AGraph f
     where f (Graph tail blocks) =
-            do note_this_code_becomes_unreachable tail
+            do note_this_code_becomes_unreachable "mkLast" (ppr l <+> ppr blocks) tail
                return $ Graph (ZLast (LastOther l)) blocks
 
 mkZTail tail = AGraph f
     where f (Graph utail blocks) =
-            do note_this_code_becomes_unreachable utail
+            do note_this_code_becomes_unreachable "mkZTail" (ppr tail) utail
                return $ Graph tail blocks
 
 withFreshLabel name ofId = AGraph f
@@ -310,36 +310,54 @@ withUnique ofU = AGraph f
                  f' g
 
 outOfLine (AGraph f) = AGraph f'
-    where f' (Graph tail' blocks') =
+    where f' g@(Graph tail' blocks') =
             do Graph emptyEntrance blocks <- f emptyGraph
-               note_this_code_becomes_unreachable emptyEntrance
-               return $ Graph tail' (blocks `plusUFM` blocks')
-                                                       
+               note_this_code_becomes_unreachable "outOfLine" (ppr tail') emptyEntrance
+               return $ Graph tail' (blocks `plusBlockEnv` blocks')
+
 mkIfThenElse cbranch tbranch fbranch = 
     withFreshLabel "end of if"     $ \endif ->
     withFreshLabel "start of then" $ \tid ->
     withFreshLabel "start of else" $ \fid ->
         cbranch tid fid <*>
-        mkLabel tid Nothing <*> tbranch <*> mkBranch endif <*>
-        mkLabel fid Nothing <*> fbranch <*> mkLabel endif Nothing
+        mkLabel tid emptyStackInfo <*> tbranch <*> mkBranch endif <*>
+        mkLabel fid emptyStackInfo <*> fbranch <*>
+        mkLabel endif emptyStackInfo 
 
 mkWhileDo cbranch body = 
   withFreshLabel "loop test" $ \test ->
   withFreshLabel "loop head" $ \head ->
   withFreshLabel "end while" $ \endwhile ->
      -- Forrest Baskett's while-loop layout
-     mkBranch test <*> mkLabel head Nothing <*> body <*> mkLabel test Nothing
-                   <*> cbranch head endwhile <*> mkLabel endwhile Nothing
+     mkBranch test <*> mkLabel head emptyStackInfo <*> body
+                   <*> mkLabel test emptyStackInfo <*> cbranch head endwhile
+                   <*> mkLabel endwhile emptyStackInfo 
 
 -- | Bleat if the insertion of a last node will create unreachable code
 note_this_code_becomes_unreachable ::
-    (Monad m, LastNode l, Outputable middle, Outputable l) => ZTail middle l -> m ()
+    (Monad m, LastNode l, Outputable middle, Outputable l) =>
+       String -> SDoc -> ZTail middle l -> m ()
 
-note_this_code_becomes_unreachable = if debugIsOn then u else \_ -> return ()
+note_this_code_becomes_unreachable str old = if debugIsOn then u else \_ -> return ()
     where u (ZLast LastExit)                       = return ()
           u (ZLast (LastOther l)) | isBranchNode l = return ()
                                     -- Note [Branch follows branch]
-          u tail = fail ("unreachable code: " ++ showSDoc (ppr tail))
+          u tail = fail ("unreachable code in " ++ str ++ ": " ++
+                         (showSDoc ((ppr tail) <+> old)))
+
+-- | The string argument to 'freshBlockId' was originally helpful in debugging
+-- the Quick C-- compiler, so I have kept it here even though at present it is
+-- thrown away at this spot---there's no reason a BlockId couldn't one day carry
+-- a string.  
+
+freshBlockId :: MonadUnique m => String -> m BlockId
+freshBlockId _s = getUniqueM >>= return . BlockId
+
+-------------------------------------
+-- Debugging
+
+pprAGraph :: (Outputable m, LastNode l, Outputable l) => AGraph m l -> UniqSM SDoc
+pprAGraph g = graphOfAGraph g >>= return . ppr
 
 {-
 Note [Branch follows branch]
@@ -353,11 +371,3 @@ Emitting a Branch at this point is fine:
 -}
 
 
--- | The string argument to 'freshBlockId' was originally helpful in debugging
--- the Quick C-- compiler, so I have kept it here even though at present it is
--- thrown away at this spot---there's no reason a BlockId couldn't one day carry
--- a string.  
-
-freshBlockId :: MonadUnique m => String -> m BlockId
-freshBlockId _s = getUniqueM >>= return . BlockId
-
index 1d80650..4b073e2 100644 (file)
@@ -6,15 +6,16 @@
 -- complain to Norman Ramsey.
 
 module MkZipCfgCmm
-  ( mkNop, mkAssign, mkStore, mkCall, mkCmmCall, mkUnsafeCall, mkFinalCall
-         , mkJump, mkCbranch, mkSwitch, mkReturn, mkComment, copyIn, copyOut, mkEntry 
-        , mkCmmIfThenElse, mkCmmIfThen, mkCmmWhileDo
-        , mkAddToContext
+  ( mkNop, mkAssign, mkStore, mkCall, mkCmmCall, mkSafeCall, mkUnsafeCall, mkFinalCall
+         , mkJump, mkForeignJump, mkJumpGC, mkCbranch, mkSwitch, mkReturn
+         , mkReturnSimple, mkComment, copyIn, copyOut
+         , mkEntry, mkCmmIfThenElse, mkCmmIfThen, mkCmmWhileDo
   , (<*>), catAGraphs, mkLabel, mkBranch
   , emptyAGraph, withFreshLabel, withUnique, outOfLine
   , lgraphOfAGraph, graphOfAGraph, labelAGraph
   , CmmZ, CmmTopZ, CmmGraph, CmmBlock, CmmAGraph
   , Middle, Last, Convention(..), ForeignConvention(..), MidCallTarget(..), Transfer(..)
+  , emptyStackInfo, stackStubExpr, pprAGraph
   )
 where
 
@@ -31,11 +32,11 @@ import ZipCfgCmmRep hiding (CmmGraph, CmmAGraph, CmmBlock, CmmZ, CmmTopZ)
   -- duplicated below
 import PprCmm()
 
-import ClosureInfo
 import FastString
 import ForeignCall
 import MkZipCfg
 import Panic 
+import StaticFlags 
 import ZipCfg 
 
 type CmmGraph  = LGraph Middle Last
@@ -55,21 +56,24 @@ mkAssign     :: CmmReg  -> CmmExpr -> CmmAGraph
 mkStore      :: CmmExpr -> CmmExpr -> CmmAGraph
 
 ---------- Calls
-mkCall       :: CmmExpr -> CCallConv -> CmmFormals -> CmmActuals -> C_SRT -> CmmAGraph
-mkCmmCall    :: CmmExpr -> CmmFormals -> CmmActuals -> C_SRT -> CmmAGraph
+mkCall       :: CmmExpr -> Convention -> CmmFormals -> CmmActuals ->
+                  UpdFrameOffset -> CmmAGraph
+mkCmmCall    :: CmmExpr ->              CmmFormals -> CmmActuals ->
+                  UpdFrameOffset -> CmmAGraph
                        -- Native C-- calling convention
-mkUnsafeCall :: MidCallTarget -> CmmFormals -> CmmActuals -> CmmAGraph
-mkFinalCall  :: CmmExpr -> CCallConv -> CmmActuals -> CmmAGraph
+mkSafeCall    :: MidCallTarget -> CmmFormals -> CmmActuals -> UpdFrameOffset -> CmmAGraph
+mkUnsafeCall  :: MidCallTarget -> CmmFormals -> CmmActuals -> CmmAGraph
+mkFinalCall   :: CmmExpr -> CCallConv -> CmmActuals -> UpdFrameOffset -> CmmAGraph
                 -- Never returns; like exit() or barf()
 
----------- Context manipulation ("return via")
-mkAddToContext :: CmmExpr -> [CmmExpr] -> CmmAGraph
-
 ---------- Control transfer
-mkJump         :: CmmExpr -> CmmActuals -> CmmAGraph
+mkJump         ::               CmmExpr -> CmmActuals -> UpdFrameOffset -> CmmAGraph
+mkJumpGC               ::               CmmExpr -> CmmActuals -> UpdFrameOffset -> CmmAGraph
+mkForeignJump   :: Convention -> CmmExpr -> CmmActuals -> UpdFrameOffset -> CmmAGraph
 mkCbranch      :: CmmExpr -> BlockId -> BlockId          -> CmmAGraph
 mkSwitch       :: CmmExpr -> [Maybe BlockId]             -> CmmAGraph
-mkReturn       :: CmmActuals -> CmmAGraph
+mkReturn       :: CmmExpr -> CmmActuals -> UpdFrameOffset -> CmmAGraph
+mkReturnSimple  :: CmmActuals -> UpdFrameOffset -> CmmAGraph
 
 mkCmmIfThenElse :: CmmExpr -> CmmAGraph -> CmmAGraph -> CmmAGraph
 mkCmmIfThen     :: CmmExpr -> CmmAGraph -> CmmAGraph
@@ -91,8 +95,8 @@ mkCmmIfThen e tbranch
   = withFreshLabel "end of if"     $ \endif ->
     withFreshLabel "start of then" $ \tid ->
     mkCbranch e tid endif <*>
-    mkLabel tid Nothing <*> tbranch <*> mkBranch endif <*>
-    mkLabel endif Nothing
+    mkLabel tid   emptyStackInfo <*> tbranch <*> mkBranch endif <*>
+    mkLabel endif emptyStackInfo
 
 
 
@@ -100,52 +104,68 @@ mkCmmIfThen e tbranch
 
 mkNop                     = emptyAGraph
 mkComment fs              = mkMiddle $ MidComment fs
-mkAssign l r              = mkMiddle $ MidAssign l r
 mkStore  l r              = mkMiddle $ MidStore  l r
 
+-- NEED A COMPILER-DEBUGGING FLAG HERE
+-- Sanity check: any value assigned to a pointer must be non-zero.
+-- If it's 0, cause a crash immediately.
+mkAssign l r = if opt_StubDeadValues then assign l r <*> check l else assign l r
+  where assign l r = mkMiddle (MidAssign l r)
+        check (CmmGlobal _) = mkNop
+        check l@(CmmLocal reg) = -- if a ptr arg is NULL, cause a crash!
+          if isGcPtrType ty then
+            mkCmmIfThen (CmmMachOp (MO_Eq w) [r, stackStubExpr w])
+                        (assign l (CmmLoad (CmmLit (CmmInt 0 w)) ty))
+          else mkNop
+            where ty = localRegType reg
+                  w  = typeWidth ty
+                  r  = CmmReg l
+
 
 -- Why are we inserting extra blocks that simply branch to the successors?
 -- Because in addition to the branch instruction, @mkBranch@ will insert
 -- a necessary adjustment to the stack pointer.
 mkCbranch pred ifso ifnot = mkLast (LastCondBranch pred ifso ifnot)
-mkSwitch e tbl            = mkLast   $ LastSwitch e tbl
+mkSwitch e tbl            = mkLast $ LastSwitch e tbl
 
-mkUnsafeCall tgt results actuals = mkMiddle $ MidUnsafeCall tgt results actuals
-mkAddToContext ra actuals        = mkMiddle $ MidAddToContext ra actuals
+mkSafeCall   t fs as upd =
+  withFreshLabel "safe call" $ \k ->
+    mkMiddle $ MidForeignCall (Safe k upd) t fs as
+mkUnsafeCall t fs as = mkMiddle $ MidForeignCall Unsafe t fs as
 
-cmmResConv :: Convention
-cmmResConv = Native
+-- For debugging purposes, we can stub out dead stack slots:
+stackStubExpr :: Width -> CmmExpr
+stackStubExpr w = CmmLit (CmmInt 0 w)
 
 -- Return the number of bytes used for copying arguments, as well as the
 -- instructions to copy the arguments.
-copyIn :: Convention -> Bool -> Area -> CmmFormals -> (Int, [Middle])
-copyIn _ isCall area formals =
-  foldr ci (init_offset, []) $ assignArgumentsPos isCall localRegType formals
+copyIn :: Convention -> Bool -> Area -> CmmFormals -> (Int, AGraph Middle Last)
+copyIn conv isCall area formals =
+  foldr ci (init_offset, mkNop) $ assignArgumentsPos conv isCall localRegType formals
   where ci (reg, RegisterParam r) (n, ms) =
-          (n, MidAssign (CmmLocal reg) (CmmReg $ CmmGlobal r) : ms)
+          (n, mkAssign (CmmLocal reg) (CmmReg $ CmmGlobal r) <*> ms)
         ci (reg, StackParam off) (n, ms) =
           let ty = localRegType reg
               off' = off + init_offset
           in (max n off',
-              MidAssign (CmmLocal reg) (CmmLoad (CmmStackSlot area off') ty) : ms)
+              mkAssign (CmmLocal reg) (CmmLoad (CmmStackSlot area off') ty) <*> ms)
         init_offset = widthInBytes wordWidth
 
 -- The argument layout function ignores the pointer to the info table, so we slot that
 -- in here. When copying-out to a young area, we set the info table for return
 -- and adjust the offsets of the other parameters.
 -- If this is a call instruction, we adjust the offsets of the other parameters.
-copyOut :: Convention -> Transfer -> Area -> CmmActuals -> (Int, [Middle])
-copyOut _ transfer area@(CallArea a) actuals =
+copyOut :: Convention -> Transfer -> Area -> CmmActuals -> UpdFrameOffset -> (Int, [Middle])
+copyOut conv transfer area@(CallArea a) actuals updfr_off =
   foldr co (init_offset, []) args'
-  where args = assignArgumentsPos skip_node cmmExprType actuals
+  where args = assignArgumentsPos conv skip_node cmmExprType actuals
         skip_node = transfer /= Ret
         (setRA, init_offset) =
-          case a of Young id -> -- set RA if making a call
+          case a of Young id@(BlockId _) -> -- set RA if making a call
                       if transfer == Call then
-                        ([(CmmLit (CmmLabel (infoTblLbl id)),
-                           StackParam init_offset)], ra_width)
+                        ([(CmmLit (CmmBlock id), StackParam init_offset)], ra_width)
                       else ([], 0)
-                    Old -> ([], ra_width)
+                    Old -> ([], updfr_off)
         ra_width = widthInBytes wordWidth
         args' = foldl adjust setRA args
           where adjust rst (v, StackParam off) = (v, StackParam (off + init_offset)) : rst
@@ -153,39 +173,47 @@ copyOut _ transfer area@(CallArea a) actuals =
         co (v, RegisterParam r) (n, ms) = (n, MidAssign (CmmGlobal r) v : ms)
         co (v, StackParam off)  (n, ms) =
           (max n off, MidStore (CmmStackSlot area off) v : ms)
-copyOut _ _ (RegSlot _) _ = panic "cannot copy arguments into a register slot"
+copyOut _ _ (RegSlot _) _ = panic "cannot copy arguments into a register slot"
 
 mkEntry :: BlockId -> Convention -> CmmFormals -> (Int, CmmAGraph)
-mkEntry _ conv formals =
-  let (off, copies) = copyIn conv False (CallArea Old) formals in
-  (off, mkMiddles copies)
-
--- I'm not sure how to get the calling conventions right yet,
--- and I suspect this should not be resolved until sometime after
--- Simon's patch is applied.
--- For now, I apply a bogus calling convention: all arguments go on the
--- stack, using the same amount of stack space.
-
-lastWithArgs :: Transfer -> Area -> Convention -> CmmActuals -> (Int -> Last) -> CmmAGraph
-lastWithArgs transfer area conv actuals last =
-  let (outArgs, copies) = copyOut conv transfer area actuals in
+mkEntry _ conv formals = copyIn conv False (CallArea Old) formals
+
+lastWithArgs :: Transfer -> Area -> Convention -> CmmActuals -> UpdFrameOffset ->
+                (Int -> Last) -> CmmAGraph
+lastWithArgs transfer area conv actuals updfr_off last =
+  let (outArgs, copies) = copyOut conv transfer area actuals updfr_off in
   mkMiddles copies <*> mkLast (last outArgs)
 
 -- The area created for the jump and return arguments is the same area as the
 -- procedure entry.
-mkJump e actuals = lastWithArgs Jump (CallArea Old) cmmResConv actuals $ LastJump e
-mkReturn actuals = lastWithArgs Ret  (CallArea Old) cmmResConv actuals $ LastJump e
-  where e = CmmStackSlot (CallArea Old) (widthInBytes wordWidth)
-
-mkFinalCall f _ actuals =
-  lastWithArgs Call (CallArea Old) Native actuals $ LastCall f Nothing
-
-mkCmmCall f results actuals srt = mkCall f CmmCallConv results actuals srt
+old :: Area
+old = CallArea Old
+toCall :: CmmExpr -> Maybe BlockId -> UpdFrameOffset -> Int -> Last
+toCall e cont updfr_off arg_space = LastCall e cont arg_space (Just updfr_off)
+mkJump e actuals updfr_off =
+  lastWithArgs Jump old Native actuals updfr_off $ toCall e Nothing updfr_off
+mkJumpGC e actuals updfr_off =
+  lastWithArgs Jump old GC actuals updfr_off $ toCall e Nothing updfr_off
+mkForeignJump conv e actuals updfr_off =
+  lastWithArgs Jump old conv actuals updfr_off $ toCall e Nothing updfr_off
+mkReturn e actuals updfr_off =
+  lastWithArgs Ret  old Native actuals updfr_off $ toCall e Nothing updfr_off
+    -- where e = CmmLoad (CmmStackSlot (CallArea Old) updfr_off) gcWord
+mkReturnSimple actuals updfr_off =
+  lastWithArgs Ret  old Native actuals updfr_off $ toCall e Nothing updfr_off
+    where e = CmmLoad (CmmStackSlot (CallArea Old) updfr_off) gcWord
+
+mkFinalCall f _ actuals updfr_off =
+  lastWithArgs Call old Native actuals updfr_off $ toCall f Nothing updfr_off
+
+mkCmmCall f results actuals = mkCall f Native results actuals
 
 -- I'm dropping the SRT, but that should be okay: we plan to reconstruct it later.
-mkCall f _ results actuals _ =
+mkCall f conv results actuals updfr_off =
   withFreshLabel "call successor" $ \k ->
-  let area = CallArea $ Young k
-      (off, copyin) = copyIn Native False area results
-      copyout = lastWithArgs Call area Native actuals $ LastCall f (Just k)
-  in copyout <*> mkLabel k (Just off) <*> (mkMiddles copyin)
+    let area = CallArea $ Young k
+        (off, copyin) = copyIn conv False area results
+        copyout = lastWithArgs Call area conv actuals updfr_off 
+                               (toCall f (Just k) updfr_off)
+    in (copyout <*> mkLabel k (StackInfo (Just off) (Just updfr_off))
+                <*> copyin)
index d9e8365..7de398a 100644 (file)
@@ -59,7 +59,7 @@ diffFuel (OptimizationFuel f) (OptimizationFuel f') = f - f'
 -- type OptimizationFuel = State# () -- would like this, but it won't work
 data OptimizationFuel = OptimizationFuel
   deriving Show
-tankFilledTo _ = undefined -- should be impossible to evaluate
+tankFilledTo _ = panic "tankFilledTo" -- should be impossible to evaluate
   -- realWorld# might come in handy, too...
 canRewriteWithFuel OptimizationFuel = True
 maybeRewriteWithFuel _ ma = ma
@@ -131,4 +131,5 @@ fuelDecrementState new_optimizer old new s =
 lGraphOfGraph :: Graph m l -> Int -> FuelMonad (LGraph m l)
 lGraphOfGraph (Graph tail blocks) args =
   do entry <- liftM BlockId $ getUniqueM
-     return $ LGraph entry args (insertBlock (Block entry Nothing tail) blocks)
+     return $ LGraph entry args
+                     (insertBlock (Block entry emptyStackInfo tail) blocks)
index fea2374..374058f 100644 (file)
@@ -140,6 +140,12 @@ pprTop top@(CmmData _section (CmmDataLabel lbl : lits)) =
   pprDataExterns lits $$
   pprWordArray lbl lits  
 
+-- Floating info table for safe a foreign call.
+pprTop top@(CmmData _section d@(_ : _))
+  | CmmDataLabel lbl : lits <- reverse d = 
+  pprDataExterns lits $$
+  pprWordArray lbl lits  
+
 -- these shouldn't appear?
 pprTop (CmmData _ _) = panic "PprC.pprTop: can't handle this data"
 
@@ -432,6 +438,8 @@ pprLit lit = case lit of
                 -- these constants come from <math.h>
                 -- see #1861
 
+    CmmBlock bid       -> mkW_ <> pprCLabelAddr (infoTblLbl bid)
+    CmmHighStackMark   -> panic "PprC printing high stack mark"
     CmmLabel clbl      -> mkW_ <> pprCLabelAddr clbl
     CmmLabelOff clbl i -> mkW_ <> pprCLabelAddr clbl <> char '+' <> int i
     CmmLabelDiffOff clbl1 clbl2 i
index 4478dfd..a9e00fc 100644 (file)
@@ -45,7 +45,6 @@ import CLabel
 
 
 import ForeignCall
-import Unique
 import Outputable
 import FastString
 
@@ -125,7 +124,7 @@ pprTop      :: (Outputable d, Outputable info, Outputable i)
 
 pprTop (CmmProc info lbl params graph )
 
-  = vcat [ pprCLabel lbl <> parens (commafy $ map ppr params) <+> lbrace
+  = vcat [ pprCLabel lbl <> parens (commafy $ map ppr params)
          , nest 8 $ lbrace <+> ppr info $$ rbrace
          , nest 4 $ ppr graph
          , rbrace ]
@@ -154,13 +153,14 @@ instance Outputable CmmSafety where
 pprInfo :: CmmInfo -> SDoc
 pprInfo (CmmInfo _gc_target update_frame CmmNonInfoTable) =
     vcat [{-ptext (sLit "gc_target: ") <>
-                maybe (ptext (sLit "<none>")) pprBlockId gc_target,-}
+                maybe (ptext (sLit "<none>")) ppr gc_target,-}
           ptext (sLit "update_frame: ") <>
                 maybe (ptext (sLit "<none>")) pprUpdateFrame update_frame]
 pprInfo (CmmInfo _gc_target update_frame
-         (CmmInfoTable (ProfilingInfo closure_type closure_desc) tag info)) =
+         (CmmInfoTable stat_clos (ProfilingInfo closure_type closure_desc) tag info)) =
     vcat [{-ptext (sLit "gc_target: ") <>
-                maybe (ptext (sLit "<none>")) pprBlockId gc_target,-}
+                maybe (ptext (sLit "<none>")) ppr gc_target,-}
+          ptext (sLit "has static closure: ") <> ppr stat_clos <+>
           ptext (sLit "update_frame: ") <>
                 maybe (ptext (sLit "<none>")) pprUpdateFrame update_frame,
           ptext (sLit "type: ") <> pprLit closure_type,
@@ -228,7 +228,7 @@ pprUpdateFrame (UpdateFrame expr args) =
 --      lbl: stmt ; stmt ; .. 
 pprBBlock :: Outputable stmt => GenBasicBlock stmt -> SDoc
 pprBBlock (BasicBlock ident stmts) =
-    hang (pprBlockId ident <> colon) 4 (vcat (map ppr stmts))
+    hang (ppr ident <> colon) 4 (vcat (map ppr stmts))
 
 -- --------------------------------------------------------------------------
 -- Statements. C-- usually, exceptions to this should be obvious.
@@ -302,7 +302,7 @@ instance (Outputable a) => Outputable (CmmHinted a) where
 --
 genBranch :: BlockId -> SDoc
 genBranch ident = 
-    ptext (sLit "goto") <+> pprBlockId ident <> semi
+    ptext (sLit "goto") <+> ppr ident <> semi
 
 -- --------------------------------------------------------------------------
 -- Conditional. [1], section 6.4
@@ -314,7 +314,7 @@ genCondBranch expr ident =
     hsep [ ptext (sLit "if")
          , parens(ppr expr)
          , ptext (sLit "goto")
-         , pprBlockId ident <> semi ]
+         , ppr ident <> semi ]
 
 -- --------------------------------------------------------------------------
 -- A tail call. [1], Section 6.9
@@ -381,7 +381,7 @@ genSwitch expr maybe_ids
           in hsep [ ptext (sLit "case")
                   , hcat (punctuate comma (map int is))
                   , ptext (sLit ": goto")
-                  , pprBlockId (head [ id | Just id <- ids]) <> semi ]
+                  , ppr (head [ id | Just id <- ids]) <> semi ]
 
 -- --------------------------------------------------------------------------
 -- Expressions
@@ -514,6 +514,8 @@ pprLit lit = case lit of
     CmmLabelOff clbl i -> pprCLabel clbl <> ppr_offset i
     CmmLabelDiffOff clbl1 clbl2 i -> pprCLabel clbl1 <> char '-'  
                                   <> pprCLabel clbl2 <> ppr_offset i
+    CmmBlock id        -> ppr id
+    CmmHighStackMark -> text "<highSp>"
 
 pprLit1 :: CmmLit -> SDoc
 pprLit1 lit@(CmmLabelOff {}) = parens (pprLit lit)
@@ -614,12 +616,6 @@ pprSection s = case s of
  where
     section = ptext (sLit "section")
 
--- --------------------------------------------------------------------------
--- Basic block ids
---
-pprBlockId :: BlockId -> SDoc
-pprBlockId b = ppr $ getUnique b
-
 -----------------------------------------------------------------------------
 
 commafy :: [SDoc] -> SDoc
index c588466..30eb492 100644 (file)
@@ -14,7 +14,6 @@ import qualified ZipCfg as Z
 import CmmZipUtil
 
 import Maybe
-import UniqSet
 import FastString
 
 ----------------------------------------------------------------
@@ -54,23 +53,21 @@ pprCmmGraphLikeCmm g = vcat (swallow blocks)
                       | id' == tid, Just e' <- maybeInvertCmmExpr expr, isNothing out->
                           tail id (ft tid : ppr (CmmCondBranch e'   fid) : prev') Nothing t bs
                     _ -> endblock $ with_out out l
-                l@(G.LastJump   {}) -> endblock $ with_out out l
-                l@(G.LastReturn {}) -> endblock $ with_out out l
-                l@(G.LastSwitch {}) -> endblock $ with_out out l
-                l@(G.LastCall _ _ _)-> endblock $ with_out out l
+                l@(G.LastSwitch {})   -> endblock $ with_out out l
+                l@(G.LastCall _ _ _ _)-> endblock $ with_out out l
           exit id prev' n = -- highly irregular (assertion violation?)
               let endblock stmt = block' id (stmt : prev') : swallow n in
               endblock (text "// <exit>")
           preds = zipPreds g
           entry_has_no_pred = case lookupBlockEnv preds (Z.lg_entry g) of
                                 Nothing -> True
-                                Just s -> isEmptyUniqSet s
+                                Just s -> isEmptyBlockSet s
           single_preds =
               let add b single =
                     let id = Z.blockId b
                     in  case lookupBlockEnv preds id of
                           Nothing -> single
-                          Just s -> if sizeUniqSet s == 1 then
+                          Just s -> if sizeBlockSet s == 1 then
                                         extendBlockSet single id
                                     else single
               in  Z.fold_blocks add emptyBlockSet g
@@ -79,21 +76,14 @@ pprCmmGraphLikeCmm g = vcat (swallow blocks)
 with_out :: Maybe (G.Convention, CmmActuals) -> G.Last -> SDoc
 with_out Nothing l = ptext (sLit "??no-arguments??") <+> ppr l
 with_out (Just (conv, args)) l = last l
-    where last (G.LastCall e k _) =
+    where last (G.LastCall e k _ _) =
               hcat [ptext (sLit "... = foreign "),
                     doubleQuotes(ppr conv), space,
                     ppr_target e, parens ( commafy $ map ppr args ),
                     ptext (sLit " \"safe\""),
-                    case k of Nothing -> ptext (sLit " never returns")
-                              Just _ -> empty,
+                    text " returns to " <+> ppr k,
                     semi ]
-          last (G.LastReturn _) = ppr (CmmReturn $ noHints args)
-          last (G.LastJump e _) = ppr (CmmJump e $ noHints args)
           last l = ppr l
           ppr_target (CmmLit lit) = pprLit lit
           ppr_target fn'          = parens (ppr fn')
           commafy xs = hsep $ punctuate comma xs
-
--- Anything that uses this is bogus!
-noHints :: [a] -> [CmmHinted a]
-noHints = map (\v -> CmmHinted v NoHint)
index f3c1c32..03af181 100644 (file)
@@ -33,11 +33,11 @@ fold_edge_facts_b f comp graph env z =
     head_fold (ZFirst id _) out z = f (bt_first_in comp out id) (f out z)
 
 foldConflicts :: (RegSet -> a -> a) -> a -> LGraph Middle Last -> FuelMonad a
-foldConflicts f z g =
+foldConflicts f z g@(LGraph entry _ _) =
   do env <- dualLiveness emptyBlockSet g
      let lookup id = lookupBlockEnv env id `orElse` fact_bot dualLiveLattice
          f' dual z = f (on_stack dual) z
-     return $ fold_edge_facts_b f' (dualLiveTransfers emptyBlockSet) g lookup z
+     return $ fold_edge_facts_b f' (dualLiveTransfers entry emptyBlockSet) g lookup z
   --let env = runDFA dualLiveLattice (run_b_anal dualLiveness g >> getAllFacts)
   --    lookup id = lookupBlockEnv env id `orElse` fact_bot dualLiveLattice
   --    f' dual z = f (on_stack dual) z
index 634bc8c..c1bd956 100644 (file)
@@ -2,6 +2,7 @@ module ZipCfg
     (  -- These data types and names are carefully thought out
       Graph(..), LGraph(..), FGraph(..)
     , Block(..), ZBlock(..), ZHead(..), ZTail(..), ZLast(..)
+    , StackInfo(..), emptyStackInfo
     , insertBlock
     , HavingSuccessors, succs, fold_succs
     , LastNode, mkBranchNode, isBranchNode, branchNodeTarget
@@ -37,14 +38,14 @@ where
 #include "HsVersions.h"
 
 import BlockId ( BlockId, BlockEnv, emptyBlockEnv, lookupBlockEnv, extendBlockEnv
-               , BlockSet, emptyBlockSet, elemBlockSet, extendBlockSet)
+               , BlockSet, emptyBlockSet, unitBlockSet, elemBlockSet, extendBlockSet
+               , delFromBlockEnv, foldBlockEnv', mapBlockEnv
+               , eltsBlockEnv, isNullBEnv, plusBlockEnv)
 import CmmExpr ( UserOfLocalRegs(..) )
 import PprCmm()
 
 import Outputable hiding (empty)
 import Panic
-import UniqFM
-import UniqSet
 
 import Maybe
 import Prelude hiding (zip, unzip, last)
@@ -78,7 +79,7 @@ the data constructor 'LastExit'.  A graph may contain at most one
 'LastExit' node, and a graph representing a full procedure should not
 contain any 'LastExit' nodes.  'LastExit' nodes are used only to splice
 graphs together, either during graph construction (see module 'MkZipCfg')
-or during optimization (see module 'ZipDataflow0').
+or during optimization (see module 'ZipDataflow').
 
 A graph is parameterized over the types of middle and last nodes.  Each of
 these types will typically be instantiated with a subset of C-- statements
@@ -151,16 +152,29 @@ instance UserOfLocalRegs a => UserOfLocalRegs (ZLast a) where
     foldRegsUsed _f z LastExit      = z
 
 
-data ZHead m   = ZFirst BlockId  (Maybe Int)
+data ZHead m   = ZFirst BlockId StackInfo
                | ZHead (ZHead m) m
     -- ZHead is a (reversed) sequence of middle nodes labeled by a BlockId
 data ZTail m l = ZLast (ZLast l) | ZTail m (ZTail m l)
     -- ZTail is a sequence of middle nodes followed by a last node
 
 -- | Blocks and flow graphs; see Note [Kinds of graphs]
--- In addition to its id, the block carries the number of bytes of stack space
--- used for incoming parameters on entry to the block.
-data Block m l = Block BlockId (Maybe Int) (ZTail m l)
+
+-- For each block, we may need two pieces of information about the stack:
+-- 1. If the block is a procpoint, how many bytes are used to pass
+--    arguments on the stack?
+-- 2. If the block succeeds a call, we need to generate an infotable
+--    that describes the stack layout... but only up to the update frame!
+-- Note that a block can be a proc point without requiring an infotable.
+data StackInfo = StackInfo { argBytes  :: Maybe Int
+                           , returnOff :: Maybe Int }
+  deriving ( Eq )
+emptyStackInfo :: StackInfo
+emptyStackInfo = StackInfo Nothing Nothing
+
+data Block m l = Block { bid       :: BlockId
+                       , stackInfo :: StackInfo
+                       , tail      :: ZTail m l }
 
 data Graph m l = Graph { g_entry :: (ZTail m l), g_blocks :: (BlockEnv (Block m l)) }
 
@@ -284,8 +298,8 @@ fold_layout ::
 fold_blocks :: (Block m l -> a -> a) -> a -> LGraph m l -> a
 
 -- | Fold from first to last
-fold_fwd_block ::
-  (BlockId -> a -> a) -> (m -> a -> a) -> (ZLast l -> a -> a) -> Block m l -> a -> a
+fold_fwd_block :: (BlockId -> StackInfo -> a -> a) -> (m -> a -> a) ->
+                  (ZLast l -> a -> a) -> Block m l -> a -> a
 
 map_one_block :: (BlockId -> BlockId) -> (m -> m') -> (l -> l') -> Block m l -> Block m' l'
 
@@ -378,7 +392,7 @@ unzip (Block id off t) = ZBlock (ZFirst id off) t
 
 head_id :: ZHead m -> BlockId
 head_id (ZFirst id _) = id
-head_id (ZHead  h  _) = head_id h
+head_id (ZHead  h  _)   = head_id h
 
 last (ZBlock _ t) = lastTail t
 
@@ -394,7 +408,7 @@ tailOfLast l = ZLast (LastOther l) -- tedious to write in every client
 focus :: BlockId -> LGraph m l -> FGraph m l -- focus on edge out of node with id 
 focus id (LGraph entry _ blocks) =
     case lookupBlockEnv blocks id of
-      Just b -> FGraph entry (unzip b) (delFromUFM blocks id)
+      Just b -> FGraph entry (unzip b) (delFromBlockEnv blocks id)
       Nothing -> panic "asked for nonexistent block in flow graph"
 
 entry   :: LGraph m l -> FGraph m l         -- focus on edge out of entry node 
@@ -403,7 +417,7 @@ entry g@(LGraph eid _ _) = focus eid g
 -- | pull out a block satisfying the predicate, if any
 splitp_blocks :: (Block m l -> Bool) -> BlockEnv (Block m l) ->
                  Maybe (Block m l, BlockEnv (Block m l))
-splitp_blocks p blocks = lift $ foldUFM scan (Nothing, emptyBlockEnv) blocks 
+splitp_blocks p blocks = lift $ foldBlockEnv' scan (Nothing, emptyBlockEnv) blocks 
     where scan b (yes, no) =
               case yes of
                 Nothing | p b -> (Just b, no)
@@ -422,14 +436,14 @@ insertBlock b bs =
 
 -- | Used in assertions; tells if a graph has exactly one exit
 single_exit :: LGraph l m -> Bool
-single_exit g = foldUFM check 0 (lg_blocks g) == 1
+single_exit g = foldBlockEnv' check 0 (lg_blocks g) == 1
     where check block count = case last (unzip block) of
                                 LastExit -> count + (1 :: Int)
                                 _ -> count
 
 -- | Used in assertions; tells if a graph has exactly one exit
 single_exitg :: Graph l m -> Bool
-single_exitg (Graph tail blocks) = foldUFM add (exit_count (lastTail tail)) blocks == 1
+single_exitg (Graph tail blocks) = foldBlockEnv' add (exit_count (lastTail tail)) blocks == 1
     where add block count = count + exit_count (last (unzip block))
           exit_count LastExit = 1 :: Int
           exit_count _        = 0
@@ -456,12 +470,12 @@ single_exitg (Graph tail blocks) = foldUFM add (exit_count (lastTail tail)) bloc
 --     C -> D
 -- @
 -- Then ordinary dfs would give [A,B,D,C] which has a back ref from C to D.
--- Better to geot [A,B,C,D]
+-- Better to get [A,B,C,D]
 
 
 postorder_dfs g@(LGraph _ _ blockenv) =
     let FGraph id eblock _ = entry g in
-     zip eblock : postorder_dfs_from_except blockenv eblock (unitUniqSet id)
+     zip eblock : postorder_dfs_from_except blockenv eblock (unitBlockSet id)
 
 postorder_dfs_from_except :: (HavingSuccessors b, LastNode l)
                           => BlockEnv (Block m l) -> b -> BlockSet -> [Block m l]
@@ -507,10 +521,10 @@ fold_layout f z g@(LGraph eid _ _) = fold (postorder_dfs g) z
 
 -- | The rest of the traversals are straightforward
 
-map_blocks f (LGraph eid off blocks) = LGraph eid off (mapUFM f blocks)
+map_blocks f (LGraph eid off blocks) = LGraph eid off (mapBlockEnv f blocks)
 
 map_nodes idm middle last (LGraph eid off blocks) =
-  LGraph (idm eid) off (mapUFM (map_one_block idm middle last) blocks)
+  LGraph (idm eid) off (mapBlockEnv (map_one_block idm middle last) blocks)
 
 map_one_block idm middle last (Block id off t) = Block (idm id) off (tail t)
     where tail (ZTail m t) = ZTail (middle m) (tail t)
@@ -520,18 +534,18 @@ map_one_block idm middle last (Block id off t) = Block (idm id) off (tail t)
 
 mapM_blocks f (LGraph eid off blocks) = blocks' >>= return . LGraph eid off
     where blocks' =
-            foldUFM (\b mblocks -> do { blocks <- mblocks
+            foldBlockEnv' (\b mblocks -> do { blocks <- mblocks
                                       ; b <- f b
                                       ; return $ insertBlock b blocks })
                     (return emptyBlockEnv) blocks
 
-fold_blocks f z (LGraph _ _ blocks) = foldUFM f z blocks
-fold_fwd_block first middle last (Block id _ t) z = tail t (first id z)
+fold_blocks f z (LGraph _ _ blocks) = foldBlockEnv' f z blocks
+fold_fwd_block first middle last (Block id off t) z = tail t (first id off z)
     where tail (ZTail m t) z = tail t (middle m z)
           tail (ZLast l)   z = last l z
 
 of_block_list e off blocks = LGraph e off $ foldr insertBlock emptyBlockEnv blocks 
-to_block_list (LGraph _ _ blocks) = eltsUFM blocks
+to_block_list (LGraph _ _ blocks) = eltsBlockEnv blocks
 
 
 -- We want to be able to scrutinize a single-entry, single-exit 'LGraph' for
@@ -544,7 +558,7 @@ prepare_for_splicing ::
 prepare_for_splicing g single multi =
   let FGraph _ gentry gblocks = entry g 
       ZBlock _ etail = gentry
-  in if isNullUFM gblocks then
+  in if isNullBEnv gblocks then
          case last gentry of
            LastExit -> single etail
            _ -> panic "bad single block"
@@ -560,7 +574,7 @@ prepare_for_splicing' ::
   Graph m l -> (ZTail m l -> a) -> (ZTail m l -> ZHead m -> BlockEnv (Block m l) -> a)
   -> a
 prepare_for_splicing' (Graph etail gblocks) single multi =
-   if isNullUFM gblocks then
+   if isNullBEnv gblocks then
        case lastTail etail of
          LastExit -> single etail
          _ -> panic "bad single block"
@@ -634,7 +648,7 @@ splice_head_only' head (Graph tail gblocks) =
 --- Translation
 
 translate txm txl (LGraph eid off blocks) =
-    do blocks' <- foldUFM txblock (return emptyBlockEnv) blocks
+    do blocks' <- foldBlockEnv' txblock (return emptyBlockEnv) blocks
        return $ LGraph eid off blocks'
     where
       -- txblock ::
@@ -647,10 +661,10 @@ translate txm txl (LGraph eid off blocks) =
       txtail h (ZTail m t) blocks' =
         do m' <- txm m 
            let (g, h') = splice_head h m' 
-           txtail h' t (plusUFM (lg_blocks g) blocks')
+           txtail h' t (plusBlockEnv (lg_blocks g) blocks')
       txtail h (ZLast (LastOther l)) blocks' =
         do l' <- txl l
-           return $ plusUFM (lg_blocks (splice_head_only h l')) blocks'
+           return $ plusBlockEnv (lg_blocks (splice_head_only h l')) blocks'
       txtail h (ZLast LastExit) blocks' =
         return $ insertBlock (zipht h (ZLast LastExit)) blocks'
 
@@ -672,6 +686,9 @@ instance (Outputable m, Outputable l, LastNode l) => Outputable (LGraph m l) whe
 instance (Outputable m, Outputable l, LastNode l) => Outputable (Block m l) where
     ppr = pprBlock
 
+instance Outputable StackInfo where
+    ppr = pprStackInfo
+
 instance (Outputable l) => Outputable (ZLast l) where
     ppr = pprLast
 
@@ -683,8 +700,15 @@ pprLast :: (Outputable l) => ZLast l -> SDoc
 pprLast LastExit = text "<exit>"
 pprLast (LastOther l) = ppr l
 
+pprStackInfo :: StackInfo -> SDoc
+pprStackInfo cs =
+  text "<arg bytes:" <+> ppr (argBytes  cs) <+>
+  text "ret offset:" <+> ppr (returnOff cs) <> text ">"
+
 pprBlock :: (Outputable m, Outputable l, LastNode l) => Block m l -> SDoc
-pprBlock (Block id args tail) = ppr id <> parens (ppr args) <> colon $$ ppr tail
+pprBlock (Block id stackInfo tail) =
+  ppr id <>  parens (ppr stackInfo) <> colon
+         $$  (nest 3 (ppr tail))
 
 pprLgraph :: (Outputable m, Outputable l, LastNode l) => LGraph m l -> SDoc
 pprLgraph g = text "{" <> text "offset" <> parens (ppr $ lg_argoffset g) $$
index e030f4b..05203e5 100644 (file)
@@ -1,5 +1,3 @@
-
 -- This module is pure representation and should be imported only by
 -- clients that need to manipulate representation and know what
 -- they're doing.  Clients that need to create flow graphs should
@@ -7,13 +5,12 @@
 
 module ZipCfgCmmRep
   ( CmmZ, CmmTopZ, CmmGraph, CmmBlock, CmmAGraph
-  , Middle(..), Last(..), MidCallTarget(..)
-  , Convention(..), ForeignConvention(..)
+  , Middle(..), Last(..), MidCallTarget(..), UpdFrameOffset
+  , Convention(..), ForeignConvention(..), ForeignSafety(..)
   , ValueDirection(..), ForeignHint(..)
   , CmmBackwardFixedPoint, CmmForwardFixedPoint, pprHinted
   , insertBetween, mapExpMiddle, mapExpLast, mapExpDeepMiddle, mapExpDeepLast
-  , foldExpMiddle, foldExpLast, foldExpDeepMiddle, foldExpDeepLast
-  , joinOuts
+  , foldExpMiddle, foldExpLast, foldExpDeepMiddle, foldExpDeepLast, joinOuts
   )
 where
 
@@ -43,6 +40,7 @@ import Monad
 import Outputable
 import Prelude hiding (zip, unzip, last)
 import qualified Data.List as L
+import SMRep (ByteOff)
 import UniqSupply
 
 ----------------------------------------------------------------------
@@ -56,6 +54,8 @@ type CmmTopZ                 = GenCmmTop CmmStatic CmmInfo CmmGraph
 type CmmBackwardFixedPoint a = DF.BackwardFixedPoint Middle Last a ()
 type CmmForwardFixedPoint  a = DF.ForwardFixedPoint  Middle Last a ()
 
+type UpdFrameOffset = ByteOff
+
 data Middle
   = MidComment FastString
 
@@ -64,18 +64,11 @@ data Middle
   | MidStore  CmmExpr CmmExpr    -- Assign to memory location.  Size is
                                  -- given by cmmExprType of the rhs.
 
-  | MidUnsafeCall                -- An "unsafe" foreign call;
-     MidCallTarget               -- just a fat machine instructoin
+  | MidForeignCall               -- A foreign call;
+     ForeignSafety               -- Is it a safe or unsafe call?
+     MidCallTarget               -- call target and convention
      CmmFormals                  -- zero or more results
      CmmActuals                  -- zero or more arguments
-
-  | MidAddToContext              -- Push a frame on the stack;
-                                 --    I will return to this frame
-     CmmExpr                     -- The frame's return address; it must be
-                                 -- preceded by an info table that describes the
-                                 -- live variables.
-     [CmmExpr]                   -- The frame's live variables, to go on the 
-                                 -- stack with the first one at the young end
   deriving Eq
 
 data Last
@@ -90,13 +83,17 @@ data Last
         --      zero -> first block
         --      one  -> second block etc
         -- Undefined outside range, and when there's a Nothing
-  | LastReturn Int       -- Return from a function; values in previous copy middles
-  | LastJump CmmExpr Int -- Tail call to another procedure; args in a copy middles
-  | LastCall {                      -- A call (native or safe foreign); args in copy middles
-        cml_target :: CmmExpr,      -- never a CmmPrim to a CallishMachOp!
-        cml_cont   :: Maybe BlockId,-- BlockId of continuation, if call returns
-        cml_args   :: Int }     -- liveness info for outgoing args
-  -- All the last nodes that pass arguments carry the size of the outgoing CallArea
+  | LastCall {                   -- A call (native or safe foreign)
+        cml_target  :: CmmExpr,  -- never a CmmPrim to a CallishMachOp!
+        cml_cont    :: Maybe BlockId,
+            -- BlockId of continuation (Nothing for return or tail call)
+        cml_args    :: ByteOff,  -- bytes offset for youngest outgoing arg
+        cml_ret_off :: Maybe UpdFrameOffset}
+          -- stack offset for return (update frames);
+          -- The return offset should be Nothing only if we have to create
+          -- a new call, e.g. for a procpoint, in which case it's an invariant
+          -- that the call does not stand for a return or a tail call,
+          -- and the successor does not need an info table.
 
 data MidCallTarget     -- The target of a MidUnsafeCall
   = ForeignTarget      -- A foreign procedure
@@ -110,6 +107,12 @@ data MidCallTarget -- The target of a MidUnsafeCall
 data Convention
   = Native             -- Native C-- call/return
 
+  | Slow               -- Slow entry points: all args pushed on the stack
+
+  | GC                         -- Entry to the garbage collector: uses the node reg!
+
+  | PrimOp             -- Calling prim ops
+
   | Foreign            -- Foreign call/return
        ForeignConvention
 
@@ -128,6 +131,12 @@ data ForeignConvention
        [ForeignHint]           -- Extra info about the result
   deriving Eq 
 
+data ForeignSafety
+  = Unsafe              -- unsafe call
+  | Safe BlockId        -- making infotable requires: 1. label 
+         UpdFrameOffset --                            2. where the upd frame is
+  deriving Eq
+
 data ValueDirection = Arguments | Results
   -- Arguments go with procedure definitions, jumps, and arguments to calls
   -- Results go with returns and with results of calls.
@@ -161,13 +170,11 @@ insertBetween b ms succId = insert $ goto_end $ unzip b
         insert (h, LastOther (LastSwitch e ks)) =
           do (ids, bs) <- mapAndUnzipM mbNewBlocks ks
              return (zipht h $ ZLast $ LastOther (LastSwitch e ids), join bs)
-        insert (_, LastOther (LastCall _ _ _)) =
+        insert (_, LastOther (LastCall {})) =
           panic "unimp: insertBetween after a call -- probably not a good idea"
-        insert (_, LastOther (LastReturn _)) = panic "cannot insert after return"
-        insert (_, LastOther (LastJump _ _)) = panic "cannot insert after jump"
         insert (_, LastExit) = panic "cannot insert after exit"
         newBlocks = do id <- liftM BlockId $ getUniqueM
-                       return $ (id, [Block id Nothing $
+                       return $ (id, [Block id emptyStackInfo $
                                    foldr ZTail (ZLast (LastOther (LastBranch succId))) ms])
         mbNewBlocks (Just k) = if k == succId then liftM lift newBlocks
                                else return (Just k, [])
@@ -189,33 +196,28 @@ instance LastNode Last where
     branchNodeTarget _ = panic "asked for target of non-branch"
 
 cmmSuccs :: Last -> [BlockId]
-cmmSuccs (LastReturn _)           = []
-cmmSuccs (LastJump {})            = [] 
-cmmSuccs (LastBranch id)          = [id]
-cmmSuccs (LastCall _ (Just id) _) = [id]
-cmmSuccs (LastCall _ Nothing _)   = []
-cmmSuccs (LastCondBranch _ t f)   = [f, t]  -- meets layout constraint
-cmmSuccs (LastSwitch _ edges)     = catMaybes edges
+cmmSuccs (LastBranch id)            = [id]
+cmmSuccs (LastCall _ Nothing _ _)   = []
+cmmSuccs (LastCall _ (Just id) _ _) = [id]
+cmmSuccs (LastCondBranch _ t f)     = [f, t]  -- meets layout constraint
+cmmSuccs (LastSwitch _ edges)       = catMaybes edges
 
 fold_cmm_succs :: (BlockId -> a -> a) -> Last -> a -> a
-fold_cmm_succs _f (LastReturn _)           z = z
-fold_cmm_succs _f (LastJump {})            z = z
-fold_cmm_succs  f (LastBranch id)          z = f id z
-fold_cmm_succs  f (LastCall _ (Just id) _) z = f id z
-fold_cmm_succs _f (LastCall _ Nothing _)   z = z
-fold_cmm_succs  f (LastCondBranch _ te fe) z = f te (f fe z)
-fold_cmm_succs  f (LastSwitch _ edges)     z = foldl (flip f) z $ catMaybes edges
+fold_cmm_succs  f (LastBranch id)            z = f id z
+fold_cmm_succs  _ (LastCall _ Nothing _ _)   z = z
+fold_cmm_succs  f (LastCall _ (Just id) _ _) z = f id z
+fold_cmm_succs  f (LastCondBranch _ te fe)   z = f te (f fe z)
+fold_cmm_succs  f (LastSwitch _ edges)       z = foldl (flip f) z $ catMaybes edges
 
 ----------------------------------------------------------------------
 ----- Instance declarations for register use
 
 instance UserOfLocalRegs Middle where
     foldRegsUsed f z m = middle m
-      where middle (MidComment {})            = z
-            middle (MidAssign _lhs expr)      = fold f z expr
-            middle (MidStore addr rval)       = fold f (fold f z addr) rval
-            middle (MidUnsafeCall tgt _ args) = fold f (fold f z tgt) args
-            middle (MidAddToContext ra args)  = fold f (fold f z ra) args
+      where middle (MidComment {})               = z
+            middle (MidAssign _lhs expr)         = fold f z expr
+            middle (MidStore addr rval)          = fold f (fold f z addr) rval
+            middle (MidForeignCall _ tgt _ args) = fold f (fold f z tgt) args
             fold f z m = foldRegsUsed f z m  -- avoid monomorphism restriction
 
 instance UserOfLocalRegs MidCallTarget where
@@ -226,22 +228,27 @@ instance UserOfSlots MidCallTarget where
   foldSlotsUsed _f z (PrimTarget _)      = z
   foldSlotsUsed f  z (ForeignTarget e _) = foldSlotsUsed f z e
 
+instance (UserOfLocalRegs a) => UserOfLocalRegs (Maybe a) where
+  foldRegsUsed f z (Just x) = foldRegsUsed f z x
+  foldRegsUsed _ z Nothing  = z
+
+instance (UserOfSlots a) => UserOfSlots (Maybe a) where
+  foldSlotsUsed f z (Just x) = foldSlotsUsed f z x
+  foldSlotsUsed _ z Nothing  = z
+
 instance UserOfLocalRegs Last where
     foldRegsUsed f z l = last l
-      where last (LastReturn _)         = z
-            last (LastJump e _)         = foldRegsUsed f z e
-            last (LastBranch _id)       = z
-            last (LastCall tgt _ _)     = foldRegsUsed f z tgt
+      where last (LastBranch _id)       = z
+            last (LastCall tgt _ _ _)   = foldRegsUsed f z tgt
             last (LastCondBranch e _ _) = foldRegsUsed f z e
             last (LastSwitch e _tbl)    = foldRegsUsed f z e
 
 instance DefinerOfLocalRegs Middle where
     foldRegsDefd f z m = middle m
-      where middle (MidComment {})         = z
-            middle (MidAssign _lhs _)      = fold f z _lhs
-            middle (MidStore _ _)          = z
-            middle (MidUnsafeCall _ _ _)   = z
-            middle (MidAddToContext _ _)   = z
+      where middle (MidComment {})            = z
+            middle (MidAssign _lhs _)         = fold f z _lhs
+            middle (MidStore _ _)             = z
+            middle (MidForeignCall _ _ fs _)  = fold f z fs
             fold f z m = foldRegsDefd f z m  -- avoid monomorphism restriction
 
 instance DefinerOfLocalRegs Last where
@@ -253,19 +260,16 @@ instance DefinerOfLocalRegs Last where
 
 instance UserOfSlots Middle where
     foldSlotsUsed f z m = middle m
-      where middle (MidComment {})                = z
-            middle (MidAssign _lhs expr)          = fold f z expr
-            middle (MidStore addr rval)           = fold f (fold f z addr) rval
-            middle (MidUnsafeCall tgt _ress args) = fold f (fold f z tgt) args
-            middle (MidAddToContext ra args)      = fold f (fold f z ra) args
+      where middle (MidComment {})                   = z
+            middle (MidAssign _lhs expr)             = fold f z expr
+            middle (MidStore addr rval)              = fold f (fold f z addr) rval
+            middle (MidForeignCall _ tgt _ress args) = fold f (fold f z tgt) args
             fold f z e = foldSlotsUsed f z e  -- avoid monomorphism restriction
 
 instance UserOfSlots Last where
     foldSlotsUsed f z l = last l
-      where last (LastReturn _)         = z
-            last (LastJump e _)         = foldSlotsUsed f z e
-            last (LastBranch _id)       = z
-            last (LastCall tgt _ _)     = foldSlotsUsed f z tgt
+      where last (LastBranch _id)       = z
+            last (LastCall tgt _ _ _)   = foldSlotsUsed f z tgt
             last (LastCondBranch e _ _) = foldSlotsUsed f z e
             last (LastSwitch e _tbl)    = foldSlotsUsed f z e
 
@@ -275,13 +279,12 @@ instance UserOfSlots l => UserOfSlots (ZLast l) where
 
 instance DefinerOfSlots Middle where
     foldSlotsDefd f z m = middle m
-      where middle (MidComment {})       = z
-            middle (MidAssign _ _)       = z
+      where middle (MidComment {})    = z
+            middle (MidAssign _ _)    = z
+            middle (MidForeignCall {}) = z
             middle (MidStore (CmmStackSlot a i) e) =
               f z (a, i, widthInBytes $ typeWidth $ cmmExprType e)
-            middle (MidStore _ _)        = z
-            middle (MidUnsafeCall _ _ _) = z
-            middle (MidAddToContext _ _) = z
+            middle (MidStore _ _)     = z
 
 instance DefinerOfSlots Last where
     foldSlotsDefd _ z _ = z
@@ -297,32 +300,26 @@ mapExpMiddle :: (CmmExpr -> CmmExpr) -> Middle -> Middle
 mapExpMiddle _   m@(MidComment _)            = m
 mapExpMiddle exp   (MidAssign r e)           = MidAssign r (exp e)
 mapExpMiddle exp   (MidStore addr e)         = MidStore (exp addr) (exp e)
-mapExpMiddle exp   (MidUnsafeCall tgt fs as) =
-  MidUnsafeCall (mapExpMidcall exp tgt) fs (map exp as)
-mapExpMiddle exp   (MidAddToContext e es)    = MidAddToContext (exp e) (map exp es)
+mapExpMiddle exp   (MidForeignCall s tgt fs as) =
+  MidForeignCall s (mapExpMidcall exp tgt) fs (map exp as)
 
 foldExpMiddle :: (CmmExpr -> z -> z) -> Middle -> z -> z
-foldExpMiddle _   (MidComment _)           z = z
-foldExpMiddle exp (MidAssign _ e)          z = exp e z
-foldExpMiddle exp (MidStore addr e)        z = exp addr $ exp e z
-foldExpMiddle exp (MidUnsafeCall tgt _ as) z = foldExpMidcall exp tgt $ foldr exp z as
-foldExpMiddle exp (MidAddToContext e es)   z = exp e $ foldr exp z es
+foldExpMiddle _   (MidComment _)              z = z
+foldExpMiddle exp (MidAssign _ e)             z = exp e z
+foldExpMiddle exp (MidStore addr e)           z = exp addr $ exp e z
+foldExpMiddle exp (MidForeignCall _ tgt _ as) z = foldExpMidcall exp tgt $ foldr exp z as
 
 mapExpLast :: (CmmExpr -> CmmExpr) -> Last -> Last
-mapExpLast _   l@(LastBranch _)         = l
-mapExpLast exp (LastCondBranch e ti fi) = LastCondBranch (exp e) ti fi
-mapExpLast exp (LastSwitch e tbl)       = LastSwitch (exp e) tbl
-mapExpLast exp (LastCall tgt mb_id s)   = LastCall (exp tgt) mb_id s
-mapExpLast exp (LastJump e s)           = LastJump (exp e) s
-mapExpLast _   (LastReturn s)           = LastReturn s
+mapExpLast _   l@(LastBranch _)           = l
+mapExpLast exp (LastCondBranch e ti fi)   = LastCondBranch (exp e) ti fi
+mapExpLast exp (LastSwitch e tbl)         = LastSwitch (exp e) tbl
+mapExpLast exp (LastCall tgt mb_id u s) = LastCall (exp tgt) mb_id u s
 
 foldExpLast :: (CmmExpr -> z -> z) -> Last -> z -> z
 foldExpLast _   (LastBranch _)         z = z
 foldExpLast exp (LastCondBranch e _ _) z = exp e z
 foldExpLast exp (LastSwitch e _)       z = exp e z
-foldExpLast exp (LastCall tgt _ _)     z = exp tgt z
-foldExpLast exp (LastJump e _)         z = exp e z
-foldExpLast _   (LastReturn _)         z = z
+foldExpLast exp (LastCall tgt _ _ _)   z = exp tgt z
 
 mapExpMidcall :: (CmmExpr -> CmmExpr) -> MidCallTarget -> MidCallTarget 
 mapExpMidcall exp   (ForeignTarget e c) = ForeignTarget (exp e) c
@@ -334,8 +331,8 @@ foldExpMidcall _   (PrimTarget _)      z = z
 
 -- Take a transformer on expressions and apply it recursively.
 wrapRecExp :: (CmmExpr -> CmmExpr) -> CmmExpr -> CmmExpr
-wrapRecExp f (CmmMachOp op es)    = f (CmmMachOp op $ map f es)
-wrapRecExp f (CmmLoad addr ty)    = f (CmmLoad (f addr) ty)
+wrapRecExp f (CmmMachOp op es)    = f (CmmMachOp op $ map (wrapRecExp f) es)
+wrapRecExp f (CmmLoad addr ty)    = f (CmmLoad (wrapRecExp f addr) ty)
 wrapRecExp f e                    = f e
 
 mapExpDeepMiddle :: (CmmExpr -> CmmExpr) -> Middle -> Middle
@@ -345,8 +342,8 @@ mapExpDeepLast   f = mapExpLast   $ wrapRecExp f
 
 -- Take a folder on expressions and apply it recursively.
 wrapRecExpf :: (CmmExpr -> z -> z) -> CmmExpr -> z -> z
-wrapRecExpf f e@(CmmMachOp _ es) z = foldr f (f e z) es
-wrapRecExpf f e@(CmmLoad addr _) z = f addr  (f e z)
+wrapRecExpf f e@(CmmMachOp _ es) z = foldr (wrapRecExpf f) (f e z) es
+wrapRecExpf f e@(CmmLoad addr _) z = wrapRecExpf f addr (f e z)
 wrapRecExpf f e                  z = f e z
 
 foldExpDeepMiddle :: (CmmExpr -> z -> z) -> Middle -> z -> z
@@ -362,13 +359,11 @@ joinOuts lattice env l =
   let bot  = fact_bot lattice
       join x y = txVal $ fact_add_to lattice x y
   in case l of
-       (LastReturn _)          -> bot
-       (LastJump _ _)          -> bot
-       (LastBranch id)         -> env id
-       (LastCall _ Nothing _)  -> bot
-       (LastCall _ (Just k) _) -> env k
-       (LastCondBranch _ t f)  -> join (env t) (env f)
-       (LastSwitch _ tbl)      -> foldr join bot (map env $ catMaybes tbl)
+       (LastBranch id)           -> env id
+       (LastCall _ Nothing _ _)  -> bot
+       (LastCall _ (Just k) _ _) -> env k
+       (LastCondBranch _ t f)    -> join (env t) (env f)
+       (LastSwitch _ tbl)        -> foldr join bot (map env $ catMaybes tbl)
 
 ----------------------------------------------------------------------
 ----- Instance declarations for prettyprinting (avoids recursive imports)
@@ -411,30 +406,30 @@ pprMiddle stmt = pp_stmt <+> pp_debug
 
        -- call "ccall" foo(x, y)[r1, r2];
        -- ToDo ppr volatile
-       MidUnsafeCall target results args ->
+       MidForeignCall safety target results args ->
            hsep [ if null results
                      then empty
                      else parens (commafy $ map ppr results) <+> equals,
+                      ppr_safety safety,
                   ptext $ sLit "call", 
                   ppr_call_target target <> parens (commafy $ map ppr args) <> semi]
 
-       MidAddToContext ra args ->
-           hcat [ ptext $ sLit "return via "
-                , ppr_target ra, parens (commafy $ map ppr args), semi ]
-  
     pp_debug =
       if not debugPpr then empty
       else text " //" <+>
            case stmt of
-             MidComment {} -> text "MidComment"
-             MidAssign {}  -> text "MidAssign"
-             MidStore {}   -> text "MidStore"
-             MidUnsafeCall  {} -> text "MidUnsafeCall"
-             MidAddToContext {} -> text "MidAddToContext"
+             MidComment     {} -> text "MidComment"
+             MidAssign      {} -> text "MidAssign"
+             MidStore       {} -> text "MidStore"
+             MidForeignCall {} -> text "MidForeignCall"
 
 ppr_fc :: ForeignConvention -> SDoc
 ppr_fc (ForeignConvention c _ _) = doubleQuotes (ppr c)
 
+ppr_safety :: ForeignSafety -> SDoc
+ppr_safety (Safe bid upd) = text "safe<" <> ppr bid <> text ", " <> ppr upd <> text ">"
+ppr_safety Unsafe         = text "unsafe"
+
 ppr_call_target :: MidCallTarget -> SDoc
 ppr_call_target (ForeignTarget fn c) = ppr_fc c <+> ppr_target fn
 ppr_call_target (PrimTarget op)      = ppr (CmmLabel (mkForeignLabel (mkFastString (show op)) Nothing False))
@@ -452,31 +447,24 @@ pprLast :: Last -> SDoc
 pprLast stmt = pp_stmt <+> pp_debug
   where
     pp_stmt = case stmt of
-       LastBranch ident          -> ptext (sLit "goto") <+> ppr ident <> semi
-       LastCondBranch expr t f   -> genFullCondBranch expr t f
-       LastJump expr _           -> hcat [ ptext (sLit "jump"), space, pprFun expr
-                                         , ptext (sLit "(...)"), semi]
-       LastReturn _              -> hcat [ ptext (sLit "return"), space 
-                                         , ptext (sLit "(...)"), semi]
-       LastSwitch arg ids        -> ppr $ CmmSwitch arg ids
-       LastCall tgt k _          -> genBareCall tgt k
+       LastBranch ident             -> ptext (sLit "goto") <+> ppr ident <> semi
+       LastCondBranch expr t f      -> genFullCondBranch expr t f
+       LastSwitch arg ids           -> ppr $ CmmSwitch arg ids
+       LastCall tgt k off updfr_off -> genBareCall tgt k off updfr_off
 
     pp_debug = text " //" <+> case stmt of
            LastBranch {} -> text "LastBranch"
            LastCondBranch {} -> text "LastCondBranch"
-           LastJump {} -> text "LastJump"
-           LastReturn {} -> text "LastReturn"
            LastSwitch {} -> text "LastSwitch"
            LastCall {} -> text "LastCall"
 
-genBareCall :: CmmExpr -> Maybe BlockId -> SDoc
-genBareCall fn k =
+genBareCall :: CmmExpr -> Maybe BlockId -> Int -> Maybe UpdFrameOffset -> SDoc
+genBareCall fn k off updfr_off =
         hcat [ ptext (sLit "call"), space
              , pprFun fn, ptext (sLit "(...)"), space
-             , case k of Nothing -> ptext (sLit "never returns")
-                         Just k -> ptext (sLit "returns to") <+> ppr k
+             , ptext (sLit "returns to") <+> ppr k <+> parens (ppr off)
+             , ptext (sLit " with update frame") <+> ppr updfr_off
              , semi ]
-        where
 
 pprFun :: CmmExpr -> SDoc
 pprFun f@(CmmLit _) = ppr f
@@ -493,7 +481,10 @@ genFullCondBranch expr t f =
          ]
 
 pprConvention :: Convention -> SDoc
-pprConvention (Native {})  = empty
+pprConvention (Native {})  = text "<native-convention>"
+pprConvention  Slow        = text "<slow-convention>"
+pprConvention  GC          = text "<gc-convention>"
+pprConvention  PrimOp      = text "<primop-convention>"
 pprConvention (Foreign c)  = ppr c
 pprConvention (Private {}) = text "<private-convention>"
 
index acddbae..660f8e5 100644 (file)
@@ -71,6 +71,6 @@ foldM_fwd_block first middle last (Block id _ t) z = do { z <- first id z; tail
 
 splitp_blocks :: (Block m l -> Bool) -> BlockEnv (Block m l) ->
                  Maybe (Block m l, BlockEnv (Block m l))
-splitp_blocks = undefined -- implemented in ZipCfg but not exported
+splitp_blocks = panic "splitp_blocks" -- implemented in ZipCfg but not exported
 is_exit :: Block m l -> Bool
-is_exit = undefined -- implemented in ZipCfg but not exported
+is_exit = panic "is_exit" -- implemented in ZipCfg but not exported
index de2f53d..2d50165 100644 (file)
@@ -30,7 +30,6 @@ import qualified ZipCfg as G
 import Maybes
 import Outputable
 import Panic
-import UniqFM
 
 import Control.Monad
 import Maybe
@@ -148,10 +147,6 @@ newtype LastOutFacts a = LastOutFacts [(BlockId, a)]
 
 -- | A backward rewrite takes the same inputs as a backward transfer,
 -- but instead of producing a fact, it produces a replacement graph or Nothing.
--- The type of the replacement graph is given as a type parameter 'g'
--- of kind * -> * -> *.  This design offers great flexibility to clients, 
--- but it might be worth simplifying this module by replacing this type
--- parameter with AGraph everywhere (SLPJ 19 May 2008).
 
 data BackwardRewrites middle last a = BackwardRewrites
     { br_first  :: a              -> BlockId -> Maybe (AGraph middle last)
@@ -433,11 +428,11 @@ areturn g = liftToDFM $ liftUniq $ graphOfAGraph g
 -- want to stress out the finite map more than necessary
 lgraphToGraph :: LastNode l => LGraph m l -> Graph m l
 lgraphToGraph (LGraph eid _ blocks) =
-    if flip any (eltsUFM blocks) $ \block -> any (== eid) (succs block) then
+    if flip any (eltsBlockEnv blocks) $ \block -> any (== eid) (succs block) then
         Graph (ZLast (mkBranchNode eid)) blocks
     else -- common case: entry is not a branch target
         let Block _ _ entry = lookupBlockEnv blocks eid `orElse` panic "missing entry!"
-        in  Graph entry (delFromUFM blocks eid)
+        in  Graph entry (delFromBlockEnv blocks eid)
     
 
 class (Outputable m, Outputable l, LastNode l, Outputable (LGraph m l)) => DebugNodes m l
@@ -453,7 +448,7 @@ fwd_pure_anal :: (DebugNodes m l, LastNode l, Outputable a)
 fwd_pure_anal name env transfers in_fact g =
     do (fp, _) <- anal_f name env transfers panic_rewrites in_fact g panic_fuel
        return fp
-  where -- definitiely a case of "I love lazy evaluation"
+  where -- definitely a case of "I love lazy evaluation"
     anal_f = forward_sol (\_ _ -> Nothing) panic_depth
     panic_rewrites = panic "pure analysis asked for a rewrite function"
     panic_fuel     = panic "pure analysis asked for fuel"
@@ -643,7 +638,8 @@ forward_rew check_maybe = forw
             in do { solve depth name start transfers rewrites in_fact g fuel
                   ; eid <- freshBlockId "temporary entry id"
                   ; (rewritten, fuel) <-
-                      rew_tail (ZFirst eid Nothing) in_fact entry emptyBlockEnv fuel
+                      rew_tail (ZFirst eid emptyStackInfo)
+                               in_fact entry emptyBlockEnv fuel
                   ; (rewritten, fuel) <- rewrite_blocks blocks rewritten fuel
                   ; a <- finish
                   ; return (a, lgraphToGraph (LGraph eid 0 rewritten), fuel)
@@ -682,7 +678,7 @@ forward_rew check_maybe = forw
                                ; (outfact, g, fuel) <- inner_rew getExitFact a g fuel
                                ; let (blocks, h) = splice_head' h g
                                ; (rewritten, fuel) <-
-                                 rew_tail h outfact t (blocks `plusUFM` rewritten) fuel
+                                 rew_tail h outfact t (blocks `plusBlockEnv` rewritten) fuel
                                ; rewrite_blocks bs rewritten fuel }
 
           rew_tail head in' (G.ZTail m t) rewritten fuel =
@@ -694,7 +690,7 @@ forward_rew check_maybe = forw
                            ; g <- areturn g
                            ; (a, g, fuel) <- inner_rew getExitFact in' g fuel
                            ; let (blocks, h) = G.splice_head' head g
-                           ; rew_tail h a t (blocks `plusUFM` rewritten) fuel
+                           ; rew_tail h a t (blocks `plusBlockEnv` rewritten) fuel
                            }
           rew_tail h in' (G.ZLast l) rewritten fuel = 
             my_trace "Rewriting last node" (ppr l) $
@@ -705,7 +701,7 @@ forward_rew check_maybe = forw
                            ; g <- areturn g
                            ; ((), g, fuel) <- inner_rew (return ()) in' g fuel
                            ; let g' = G.splice_head_only' h g
-                           ; return (G.lg_blocks g' `plusUFM` rewritten, fuel)
+                           ; return (G.lg_blocks g' `plusBlockEnv` rewritten, fuel)
                            }
           either_last rewrites in' (LastExit) = fr_exit rewrites in'
           either_last rewrites in' (LastOther l) = fr_last rewrites in' l
@@ -805,13 +801,16 @@ backward_sol check_maybe = back
                     ; (a, fuel) <-
                       case check_maybe fuel $ last_rew env l of
                         Nothing -> return (last_in env l, fuel)
-                        Just g -> subsolve g exit_fact fuel
+                        Just g -> do g' <- areturn g
+                                     my_trace "analysis rewrites last node"
+                                      (ppr l <+> pprGraph g') $
+                                      subsolve g exit_fact fuel
                     ; set_head_fact h a fuel
                     ; return fuel }
 
          in do { fuel <- run "backward" name set_block_fact blocks fuel
                ; eid <- freshBlockId "temporary entry id"
-               ; fuel <- set_block_fact (Block eid Nothing entry) fuel
+               ; fuel <- set_block_fact (Block eid emptyStackInfo entry) fuel
                ; a <- getFact eid
                ; forgetFact eid
                ; return (a, fuel)
@@ -823,14 +822,20 @@ backward_sol check_maybe = back
                                                      ppr (bt_first_in transfers a id)) $
                            setFact id $ bt_first_in transfers a id
                          ; return fuel }
-           Just g  -> do { (a, fuel) <- subsolve g a fuel
-                         ; setFact id a
+           Just g  -> do { g' <- areturn g
+                         ; (a, fuel) <- my_trace "analysis rewrites first node"
+                                      (ppr id <+> pprGraph g') $
+                                      subsolve g a fuel
+                         ; setFact id $ bt_first_in transfers a id
                          ; return fuel
                          }
        set_head_fact (G.ZHead h m) a fuel =
          case check_maybe fuel $ br_middle rewrites a m of
            Nothing -> set_head_fact h (bt_middle_in transfers a m) fuel
-           Just g -> do { (a, fuel) <- subsolve g a fuel
+           Just g -> do { g' <- areturn g
+                        ; (a, fuel) <- my_trace "analysis rewrites middle node"
+                                      (ppr m <+> pprGraph g') $
+                                      subsolve g a fuel
                         ; set_head_fact h a fuel }
 
        fixed_point g exit_fact fuel =
@@ -898,11 +903,13 @@ backward_rew check_maybe = back
            in do { (FP env in_fact _ _ _, _) <-    -- don't drop the entry fact!
                      solve depth name start transfers rewrites g exit_fact fuel
                  --; env <- getAllFacts
-                 ; my_trace "facts after solving" (ppr env) $ return ()
+                 -- ; my_trace "facts after solving" (ppr env) $ return ()
                  ; eid <- freshBlockId "temporary entry id"
                  ; (rewritten, fuel) <- rewrite_blocks True blocks emptyBlockEnv fuel
                  -- We can't have the fact check fail on the bogus entry, which _may_ change
-                 ; (rewritten, fuel) <- rewrite_blocks False [Block eid Nothing entry] rewritten fuel
+                 ; (rewritten, fuel) <-
+                     rewrite_blocks False [Block eid emptyStackInfo entry]
+                                    rewritten fuel
                  ; my_trace "eid" (ppr eid) $ return ()
                  ; my_trace "exit_fact" (ppr exit_fact) $ return ()
                  ; my_trace "in_fact" (ppr in_fact) $ return ()
@@ -940,7 +947,7 @@ backward_rew check_maybe = back
                    ; g <- areturn g
                    ; (a, g, fuel) <- inner_rew g exit_fact fuel
                    ; let G.Graph t new_blocks = g
-                   ; let rewritten' = new_blocks `plusUFM` rewritten
+                   ; let rewritten' = new_blocks `plusBlockEnv` rewritten
                    ; propagate check fuel h a t rewritten' -- continue at entry of g
                    } 
           either_last _env (LastExit)    = br_exit rewrites 
@@ -961,10 +968,11 @@ backward_rew check_maybe = back
                    ; (a, g, fuel) <- inner_rew g a fuel
                    ; let Graph t newblocks = G.splice_tail g tail
                    ; my_trace "propagating facts" (ppr a) $
-                     propagate check fuel h a t (newblocks `plusUFM` rewritten) }
+                     propagate check fuel h a t (newblocks `plusBlockEnv` rewritten) }
           propagate check fuel (ZFirst id off) a tail rewritten =
             case maybeRewriteWithFuel fuel $ br_first rewrites a id of
-              Nothing -> do { if check then checkFactMatch id $ bt_first_in transfers a id
+              Nothing -> do { if check then
+                                checkFactMatch id $ bt_first_in transfers a id
                               else return ()
                             ; return (insertBlock (Block id off tail) rewritten, fuel) }
               Just g ->
@@ -973,9 +981,10 @@ backward_rew check_maybe = back
                    ; my_trace "Rewrote first node"
                      (f4sep [ppr id <> colon, text "to", pprGraph g]) $ return ()
                    ; (a, g, fuel) <- inner_rew g a fuel
-                   ; if check then checkFactMatch id a else return ()
+                   ; if check then checkFactMatch id (bt_first_in transfers a id)
+                     else return ()
                    ; let Graph t newblocks = G.splice_tail g tail
-                   ; let r = insertBlock (Block id off t) (newblocks `plusUFM` rewritten)
+                   ; let r = insertBlock (Block id off t) (newblocks `plusBlockEnv` rewritten)
                    ; return (r, fuel) }
       in  fixed_pt_and_fuel
 
@@ -1013,12 +1022,16 @@ run dir name do_block blocks b =
    where
      -- N.B. Each iteration starts with the same transaction limit;
      -- only the rewrites in the final iteration actually count
-     trace_block b block =
-         my_trace "about to do" (text name <+> text "on" <+> ppr (blockId block)) $
-         do_block block b
+     trace_block (b, cnt) block =
+         do b' <- my_trace "about to do" (text name <+> text "on" <+>
+                     ppr (blockId block) <+> ppr cnt) $
+                    do_block block b
+            return (b', cnt + 1)
      iterate n = 
          do { markFactsUnchanged
-            ; b <- foldM trace_block b blocks
+            ; (b, _) <-
+                 my_trace "block count:" (ppr (length blocks)) $
+                   foldM trace_block (b, 0 :: Int) blocks
             ; changed <- factsStatus
             ; facts <- getAllFacts
             ; let depth = 0 -- was nesting depth
@@ -1043,7 +1056,7 @@ run dir name do_block blocks b =
      pprBlock (Block id off t) = nest 2 (pprFact' (id, off, t))
      pprFacts depth n env =
          my_nest depth (text "facts for iteration" <+> pp_i n <+> text "are:" $$
-                        (nest 2 $ vcat $ map pprFact $ ufmToList env))
+                        (nest 2 $ vcat $ map pprFact $ blockEnvToList env))
      pprFact  (id, a) = hang (ppr id <> colon) 4 (ppr a)
      pprFact' (id, off, a) = hang (ppr id <> parens (ppr off) <> colon) 4 (ppr a)
 
@@ -1058,10 +1071,10 @@ subAnalysis' :: (Monad (m f), DataflowAnalysis m, Outputable f) =>
 subAnalysis' m =
     do { a <- subAnalysis $
                do { a <- m; facts <- getAllFacts
-                  ; my_trace "after sub-analysis facts are" (pprFacts facts) $
+                  ; -- my_trace "after sub-analysis facts are" (pprFacts facts) $
                     return a }
        ; facts <- getAllFacts
-       ; my_trace "in parent analysis facts are" (pprFacts facts) $
+       ; -- my_trace "in parent analysis facts are" (pprFacts facts) $
          return a }
-  where pprFacts env = nest 2 $ vcat $ map pprFact $ ufmToList env
+  where pprFacts env = nest 2 $ vcat $ map pprFact $ blockEnvToList env
         pprFact (id, a) = hang (ppr id <> colon) 4 (ppr a)
index 9fbe4fb..9719d71 100644 (file)
@@ -94,12 +94,12 @@ mkCmmInfo cl_info = do
            info = ConstrInfo (ptrs, nptrs)
                              (fromIntegral (dataConTagZ con))
                              conName
-       return $ CmmInfo gc_target Nothing (CmmInfoTable prof cl_type info)
+       return $ CmmInfo gc_target Nothing (CmmInfoTable False prof cl_type info)
 
     ClosureInfo { closureName   = name,
                   closureLFInfo = lf_info,
                   closureSRT    = srt } ->
-       return $ CmmInfo gc_target Nothing (CmmInfoTable prof cl_type info)
+       return $ CmmInfo gc_target Nothing (CmmInfoTable False prof cl_type info)
        where
          info =
              case lf_info of
@@ -152,7 +152,7 @@ emitReturnTarget name stmts
         ; let info = CmmInfo
                        gc_target
                        Nothing
-                       (CmmInfoTable
+                       (CmmInfoTable False
                         (ProfilingInfo zeroCLit zeroCLit)
                         rET_SMALL -- cmmToRawCmm may convert it to rET_BIG
                         (ContInfo frame srt_info))
index 56cd1d5..0fc6c4c 100644 (file)
@@ -104,43 +104,25 @@ variable. -}
 cgTopBinding :: DynFlags -> (StgBinding,[(Id,[Id])]) -> FCode ()
 cgTopBinding dflags (StgNonRec id rhs, _srts)
   = do { id' <- maybeExternaliseId dflags id
-       --; mapM_ (mkSRT [id']) srts
-       ; (id,info) <- cgTopRhs id' rhs
-       ; addBindC id info      -- Add the *un-externalised* Id to the envt,
-                               -- so we find it when we look up occurrences
+       ; info <- cgTopRhs id' rhs
+       ; addBindC (cg_id info) info -- Add the *un-externalised* Id to the envt,
+                                    -- so we find it when we look up occurrences
        }
 
 cgTopBinding dflags (StgRec pairs, _srts)
   = do { let (bndrs, rhss) = unzip pairs
        ; bndrs' <- mapFCs (maybeExternaliseId dflags) bndrs
        ; let pairs' = zip bndrs' rhss
-       --; mapM_ (mkSRT bndrs')  srts
        ; fixC (\ new_binds -> do 
                { addBindsC new_binds
                ; mapFCs ( \ (b,e) -> cgTopRhs b e ) pairs' })
        ; return () }
 
---mkSRT :: [Id] -> (Id,[Id]) -> FCode ()
---mkSRT these (id,ids)
---  | null ids = nopC
---  | otherwise
---  = do       { ids <- mapFCs remap ids
---     ; id  <- remap id
---     ; emitRODataLits (mkSRTLabel (idName id) (idCafInfo id))
---                      (map (\id -> CmmLabel $ mkClosureLabel (idName id) (idCafInfo id)) 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
---             (id':_) -> returnFC id'
---             [] -> do { info <- getCgIdInfo id; return (cgIdInfoId info) }
-
 -- 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)
+cgTopRhs :: Id -> StgRhs -> FCode CgIdInfo
        -- The Id is passed along for setting up a binding...
        -- It's already been externalised if necessary
 
@@ -153,7 +135,6 @@ cgTopRhs bndr (StgRhsClosure cc bi fvs upd_flag srt args body)
     forkStatics (cgTopRhsClosure bndr cc bi upd_flag srt args body)
 
 
-
 ---------------------------------------------------------------
 --     Module initialisation code
 ---------------------------------------------------------------
@@ -213,14 +194,17 @@ mkModuleInit way cost_centre_info this_mod main_mod imported_mods hpc_info
           -- In this way, Hpc enabled modules can interact seamlessly with
          -- not Hpc enabled moduled, provided Main is compiled with Hpc.
 
-        ; emitSimpleProc real_init_lbl $ withFreshLabel "ret_block" $ \retId -> catAGraphs
-               [ check_already_done retId
+        ; updfr_sz <- getUpdFrameOff
+        ; tail <- getCode (pushUpdateFrame imports
+                       (do updfr_sz' <- getUpdFrameOff
+                           emit $ mkReturn (ret_e updfr_sz') [] (pop_ret_loc updfr_sz')))
+        ; emitSimpleProc real_init_lbl $ (withFreshLabel "ret_block" $ \retId -> catAGraphs
+               [ check_already_done retId updfr_sz
                , init_prof
                , init_hpc
-               , catAGraphs $ map (registerImport way) all_imported_mods
-                , mkBranch retId ]
+                , tail])
            -- Make the "plain" procedure jump to the "real" init procedure
-       ; emitSimpleProc plain_init_lbl jump_to_init
+       ; emitSimpleProc plain_init_lbl (jump_to_init updfr_sz)
 
        -- When compiling the module in which the 'main' function lives,
        -- (that is, this_mod == main_mod)
@@ -233,14 +217,14 @@ mkModuleInit way cost_centre_info this_mod main_mod imported_mods hpc_info
 
 
        ; whenC (this_mod == main_mod)
-               (emitSimpleProc plain_main_init_lbl rec_descent_init)
+               (emitSimpleProc plain_main_init_lbl (rec_descent_init updfr_sz))
     }
   where
     plain_init_lbl = mkPlainModuleInitLabel this_mod
     real_init_lbl  = mkModuleInitLabel this_mod way
     plain_main_init_lbl = mkPlainModuleInitLabel rOOT_MAIN
 
-    jump_to_init = mkJump (mkLblExpr real_init_lbl) []
+    jump_to_init updfr_sz = mkJump (mkLblExpr real_init_lbl) [] updfr_sz
 
 
     -- Main refers to GHC.TopHandler.runIO, so make sure we call the
@@ -249,34 +233,30 @@ mkModuleInit way cost_centre_info this_mod main_mod imported_mods hpc_info
        | this_mod == main_mod = [gHC_TOP_HANDLER]
        | otherwise            = []
     all_imported_mods = imported_mods ++ extra_imported_mods
+    imports = map (\mod -> mkLblExpr (mkModuleInitLabel mod way))
+                  (filter (gHC_PRIM /=) all_imported_mods)
 
     mod_reg_val = CmmLoad (mkLblExpr moduleRegdLabel) bWord
-    check_already_done retId
+    check_already_done retId updfr_sz
      = mkCmmIfThenElse (cmmNeWord (CmmLit zeroCLit) mod_reg_val)
-                      (mkLabel retId Nothing <*> mkReturn []) mkNop
+                      (mkLabel retId emptyStackInfo
+                    <*> mkReturn (ret_e updfr_sz) [] (pop_ret_loc updfr_sz)) mkNop
        <*>     -- Set mod_reg to 1 to record that we've been here
            mkStore (mkLblExpr moduleRegdLabel) (CmmLit (mkIntCLit 1))
 
                     -- The return-code pops the work stack by 
-                    -- incrementing Sp, and then jumpd to the popped item
-    ret_code = mkAssign spReg (cmmRegOffW spReg 1)
-               <*> mkJump (CmmLoad (cmmRegOffW spReg (-1)) bWord) []
-
-    rec_descent_init = if opt_SccProfilingOn || isHpcUsed hpc_info
-                      then jump_to_init
-                      else ret_code
-
------------------------
-registerImport :: String -> Module -> CmmAGraph
-registerImport way mod
-  | mod == gHC_PRIM
-  = mkNop
-  | otherwise  -- Push the init procedure onto the work stack
-  = mkCmmCall init_lbl [] [] NoC_SRT
-  where
-    init_lbl = mkLblExpr $ mkModuleInitLabel mod way
+                    -- incrementing Sp, and then jumps to the popped item
+    ret_e updfr_sz = CmmLoad (CmmStackSlot (CallArea Old) updfr_sz) gcWord
+    ret_code updfr_sz = mkJump (ret_e updfr_sz) [] (pop_ret_loc updfr_sz)
+      -- mkAssign spReg (cmmRegOffW spReg 1) <*>
+      -- mkJump (CmmLoad (cmmRegOffW spReg (-1)) bWord) [] updfr_sz
 
+    pop_ret_loc updfr_sz = updfr_sz - widthInBytes (typeWidth bWord)
 
+    rec_descent_init updfr_sz =
+      if opt_SccProfilingOn || isHpcUsed hpc_info
+      then jump_to_init updfr_sz
+      else ret_code updfr_sz
 
 ---------------------------------------------------------------
 --     Generating static stuff for algebraic data types
@@ -351,8 +331,7 @@ cgDataCon data_con
            (dyn_cl_info, arg_things) = layOutDynConstr data_con arg_reps
 
            emit_info cl_info ticky_code
-               = do { code_blks <- getCode (mk_code ticky_code)
-                    ; emitClosureCodeAndInfoTable cl_info [] code_blks }
+               = emitClosureAndInfoTable cl_info [] $ mk_code ticky_code
 
            mk_code ticky_code
              =         -- NB: We don't set CC when entering data (WDP 94/06)
index 0e8d853..0467678 100644 (file)
@@ -9,11 +9,13 @@
 module StgCmmBind ( 
        cgTopRhsClosure, 
        cgBind,
-       emitBlackHoleCode
+       emitBlackHoleCode,
+        pushUpdateFrame
   ) where
 
 #include "HsVersions.h"
 
+import StgCmmExpr
 import StgCmmMonad
 import StgCmmExpr
 import StgCmmEnv
@@ -35,6 +37,7 @@ import CLabel
 import StgSyn
 import CostCentre      
 import Id
+import Monad (foldM, liftM)
 import Name
 import Module
 import ListSetOps
@@ -59,11 +62,11 @@ cgTopRhsClosure :: Id
                -> StgBinderInfo
                -> UpdateFlag
                -> SRT
-               -> [Id]         -- Args
+               -> [Id]                 -- Args
                -> StgExpr
-               -> FCode (Id, CgIdInfo)
+               -> FCode CgIdInfo
 
-cgTopRhsClosure id ccs binder_info upd_flag srt args body = do
+cgTopRhsClosure id ccs _ upd_flag srt args body = do
   {    -- LAY OUT THE OBJECT
     let name = idName id
   ; lf_info  <- mkClosureLFInfo id TopLevel [] upd_flag args
@@ -77,12 +80,15 @@ cgTopRhsClosure id ccs binder_info upd_flag srt args body = do
 
         -- BUILD THE OBJECT, AND GENERATE INFO TABLE (IF NECESSARY)
   ; emitDataLits closure_label closure_rep
-  ; forkClosureBody $ do
-       { node <- bindToReg id lf_info
-       ; closureCodeBody binder_info closure_info
-                         ccs srt_info node args body }
+  ; let fv_details :: [(NonVoid Id, VirtualHpOffset)]
+       (_, _, fv_details) = mkVirtHeapOffsets (isLFThunk lf_info) 
+                                              (addIdReps [])
+  -- Don't drop the non-void args until the closure info has been made
+  ; forkClosureBody (closureCodeBody True id closure_info ccs srt_info
+                                     (nonVoidIds args) (length args) body fv_details)
 
-  ; returnFC (id, cg_id_info) }
+  ; pprTrace "arity for" (ppr id <+> ppr (length args) <+> ppr args) $
+    returnFC cg_id_info }
 
 ------------------------------------------------------------------------
 --             Non-top-level bindings
@@ -90,36 +96,77 @@ cgTopRhsClosure id ccs binder_info upd_flag srt args body = do
 
 cgBind :: StgBinding -> FCode ()
 cgBind (StgNonRec name rhs)
-  = do { (name, info) <- cgRhs name rhs
-       ; addBindC name info }
+  = do { ((info, init), body) <- getCodeR $ cgRhs name rhs
+        ; addBindC (cg_id info) info
+        ; emit (init <*> body) }
 
 cgBind (StgRec pairs)
-  = do { new_binds <- fixC (\ new_binds -> 
-               do { addBindsC new_binds
-                  ; listFCs [ cgRhs b e | (b,e) <- pairs ] })
-       ; addBindsC new_binds }
+  = do { ((new_binds, inits), body) <- getCodeR $ fixC (\ new_binds_inits -> 
+               do { addBindsC $ fst new_binds_inits -- avoid premature deconstruction
+                  ; liftM unzip $ listFCs [ cgRhs b e | (b,e) <- pairs ] })
+       ; addBindsC new_binds
+       ; emit (catAGraphs inits <*> body) }
+
+{- Recursive let-bindings are tricky.
+   Consider the following pseudocode:
+     let x = \_ ->  ... y ...
+         y = \_ ->  ... z ...
+         z = \_ ->  ... x ...
+     in ...
+   For each binding, we need to allocate a closure, and each closure must
+   capture the address of the other closures.
+   We want to generate the following C-- code:
+     // Initialization Code
+     x = hp - 24; // heap address of x's closure
+     y = hp - 40; // heap address of x's closure
+     z = hp - 64; // heap address of x's closure
+     // allocate and initialize x
+     m[hp-8]   = ...
+     m[hp-16]  = y       // the closure for x captures y
+     m[hp-24] = x_info;
+     // allocate and initialize y
+     m[hp-32] = z;       // the closure for y captures z
+     m[hp-40] = y_info;
+     // allocate and initialize z
+     ...
+     
+   For each closure, we must generate not only the code to allocate and
+   initialize the closure itself, but also some Initialization Code that
+   sets a variable holding the closure pointer.
+   The complication here is that we don't know the heap offsets a priori,
+   which has two consequences:
+     1. we need a fixpoint
+     2. we can't trivially separate the Initialization Code from the
+        code that compiles the right-hand-sides
+
+   Note: We don't need this complication with let-no-escapes, because
+   in that case, the names are bound to labels in the environment,
+   and we don't need to emit any code to witness that binding.
+-}
 
 --------------------
-cgRhs :: Id -> StgRhs -> FCode (Id, CgIdInfo)
+cgRhs :: Id -> StgRhs -> FCode (CgIdInfo, CmmAGraph)
    -- The Id is passed along so a binding can be set up
+   -- The returned values are the binding for the environment
+   -- and the Initialization Code that witnesses the binding
 
 cgRhs name (StgRhsCon maybe_cc con args)
-  = do { idinfo <- buildDynCon name maybe_cc con args
-       ; return (name, idinfo) }
+  = buildDynCon name maybe_cc con args
 
 cgRhs name (StgRhsClosure cc bi fvs upd_flag srt args body)
-  = mkRhsClosure name cc bi fvs upd_flag srt args body
+  = pprTrace "cgRhs closure" (ppr name <+> ppr args) $
+    mkRhsClosure name cc bi (nonVoidIds fvs) upd_flag srt args body
 
 ------------------------------------------------------------------------
 --             Non-constructor right hand sides
 ------------------------------------------------------------------------
 
 mkRhsClosure :: Id -> CostCentreStack -> StgBinderInfo
-            -> [Id]                    -- Free vars
+            -> [NonVoid Id]                    -- Free vars
             -> UpdateFlag -> SRT
-            -> [Id]                    -- Args
+            -> [Id]                            -- Args
             -> StgExpr
-            -> FCode (Id, CgIdInfo) 
+            -> FCode (CgIdInfo, CmmAGraph)
 
 {- mkRhsClosure looks for two special forms of the right-hand side:
        a) selector thunks
@@ -158,7 +205,7 @@ for semi-obvious reasons.
 
 ---------- Note [Selectors] ------------------
 mkRhsClosure   bndr cc bi
-               [the_fv]                -- Just one free var
+               [NonVoid the_fv]                -- Just one free var
                upd_flag                -- Updatable thunk
                _srt
                []                      -- A thunk
@@ -184,7 +231,7 @@ mkRhsClosure        bndr cc bi
                                 (isUpdatable upd_flag)
     (_, params_w_offsets) = layOutDynConstr con (addIdReps params)
                        -- Just want the layout
-    maybe_offset         = assocMaybe params_w_offsets selectee
+    maybe_offset         = assocMaybe params_w_offsets (NonVoid selectee)
     Just the_offset      = maybe_offset
     offset_into_int       = the_offset - fixedHdrSize
 
@@ -197,7 +244,7 @@ mkRhsClosure    bndr cc bi
                body@(StgApp fun_id args)
 
   | args `lengthIs` (arity-1)
-       && all isFollowableArg (map idCgRep fvs) 
+       && all isFollowableArg (map (idCgRep . stripNV) fvs) 
        && isUpdatable upd_flag
        && arity <= mAX_SPEC_AP_SIZE 
 
@@ -211,19 +258,19 @@ mkRhsClosure    bndr cc bi
        arity   = length fvs
 
 ---------- Default case ------------------
-mkRhsClosure bndr cc bi fvs upd_flag srt args body
+mkRhsClosure bndr cc _ fvs upd_flag srt args body
   = do {       -- LAY OUT THE OBJECT
        -- If the binder is itself a free variable, then don't store
        -- it in the closure.  Instead, just bind it to Node on entry.
        -- NB we can be sure that Node will point to it, because we
-       -- havn't told mkClosureLFInfo about this; so if the binder
+       -- haven't told mkClosureLFInfo about this; so if the binder
        -- _was_ a free var of its RHS, mkClosureLFInfo thinks it *is*
        -- stored in the closure itself, so it will make sure that
        -- Node points to it...
        ; let
                is_elem      = isIn "cgRhsClosure"
-               bndr_is_a_fv = bndr `is_elem` fvs
-               reduced_fvs | bndr_is_a_fv = fvs `minusList` [bndr]
+               bndr_is_a_fv = (NonVoid bndr) `is_elem` fvs
+               reduced_fvs | bndr_is_a_fv = fvs `minusList` [NonVoid bndr]
                            | otherwise    = fvs
 
                
@@ -233,43 +280,35 @@ mkRhsClosure bndr cc bi fvs upd_flag srt args body
        ; c_srt <- getSRTInfo srt
        ; let   name  = idName bndr
                descr = closureDescription mod_name name
-               fv_details :: [(Id, VirtualHpOffset)]
+               fv_details :: [(NonVoid Id, VirtualHpOffset)]
                (tot_wds, ptr_wds, fv_details) 
                   = mkVirtHeapOffsets (isLFThunk lf_info) 
-                                      (addIdReps reduced_fvs)
+                                      (addIdReps (map stripNV reduced_fvs))
                closure_info = mkClosureInfo False      -- Not static
                                             bndr lf_info tot_wds ptr_wds
                                             c_srt descr
 
        -- BUILD ITS INFO TABLE AND CODE
-       ; forkClosureBody $ do
-               {   -- Bind the binder itself
-                   -- It does no harm to have it in the envt even if
-                   -- it's not a free variable; and we need a reg for it
-                 node <- bindToReg bndr lf_info
-
-                   -- Bind the free variables
-               ; mapCs (bind_fv node) fv_details
-       
-                   -- And compile the body
-               ; closureCodeBody bi closure_info cc c_srt node args body }
+       ; forkClosureBody $
+               -- forkClosureBody: (a) ensure that bindings in here are not seen elsewhere
+               --                  (b) ignore Sequel from context; use empty Sequel
+               -- And compile the body
+               closureCodeBody False bndr closure_info cc c_srt (nonVoidIds args)
+                                (length args) body fv_details
 
        -- BUILD THE OBJECT
        ; (use_cc, blame_cc) <- chooseDynCostCentres cc args body
         ; emit (mkComment $ mkFastString "calling allocDynClosure")
-       ; tmp <- allocDynClosure closure_info use_cc blame_cc 
-                                (mapFst StgVarArg fv_details)
+        ; let toVarArg (NonVoid a, off) = (NonVoid (StgVarArg a), off)
+       ; (tmp, init) <- allocDynClosure closure_info use_cc blame_cc 
+                                        (map toVarArg fv_details)
        
        -- RETURN
-       ; return (bndr, regIdInfo bndr lf_info tmp) }
-  where
-      -- A function closure pointer may be tagged, so we
-      -- must take it into account when accessing the free variables.
-     tag = tagForArity (length args)
+       ; return $ (regIdInfo bndr lf_info tmp, init) }
 
-     bind_fv node (id, off) 
-       = do { reg <- rebindToReg id
-            ; emit $ mkTaggedObjectLoad reg node off tag }
+-- Use with care; if used inappropriately, it could break invariants.
+stripNV :: NonVoid a -> a
+stripNV (NonVoid a) = a
 
 -------------------------
 cgStdThunk
@@ -279,7 +318,7 @@ cgStdThunk
        -> StgExpr
        -> LambdaFormInfo
        -> [StgArg]                     -- payload
-       -> FCode (Id, CgIdInfo)
+       -> FCode (CgIdInfo, CmmAGraph)
 
 cgStdThunk bndr cc _bndr_info body lf_info payload
   = do -- AHA!  A STANDARD-FORM THUNK
@@ -297,35 +336,36 @@ cgStdThunk bndr cc _bndr_info body lf_info payload
   ; (use_cc, blame_cc) <- chooseDynCostCentres cc [{- no args-}] body
 
        -- BUILD THE OBJECT
-  ; tmp <- allocDynClosure closure_info use_cc blame_cc payload_w_offsets
+  ; (tmp, init) <- allocDynClosure closure_info use_cc blame_cc payload_w_offsets
 
        -- RETURN
-  ; returnFC (bndr, regIdInfo bndr lf_info tmp) }
+  ; returnFC $ (regIdInfo bndr lf_info tmp, init) }
 
 mkClosureLFInfo :: Id          -- The binder
                -> TopLevelFlag -- True of top level
-               -> [Id]         -- Free vars
+               -> [NonVoid Id] -- Free vars
                -> UpdateFlag   -- Update flag
-               -> [Id]         -- Args
+               -> [Id]         -- Args
                -> FCode LambdaFormInfo
 mkClosureLFInfo bndr top fvs upd_flag args
-  | null args = return (mkLFThunk (idType bndr) top fvs upd_flag)
+  | null args = return (mkLFThunk (idType bndr) top (map stripNV fvs) upd_flag)
   | otherwise = do { arg_descr <- mkArgDescr (idName bndr) args
-                  ; return (mkLFReEntrant top fvs args arg_descr) }
+                  ; return (mkLFReEntrant top (map stripNV fvs) args arg_descr) }
 
 
 ------------------------------------------------------------------------
 --             The code for closures}
 ------------------------------------------------------------------------
 
-closureCodeBody :: StgBinderInfo   -- XXX: unused?
+closureCodeBody :: Bool            -- whether this is a top-level binding
+                -> Id              -- the closure's name
                -> ClosureInfo     -- Lots of information about this closure
                -> CostCentreStack -- Optional cost centre attached to closure
                -> C_SRT
-               -> LocalReg        -- The closure itself; first argument
-                                  -- The Id is in scope already, bound to this reg
-               -> [Id]
+               -> [NonVoid Id]    -- incoming args to the closure
+               -> Int             -- arity, including void args
                -> StgExpr
+               -> [(NonVoid Id, VirtualHpOffset)] -- the closure's free variables
                -> FCode ()
 
 {- There are two main cases for the code for closures.  
@@ -341,41 +381,50 @@ closureCodeBody :: StgBinderInfo   -- XXX: unused?
   argSatisfactionCheck (by calling fetchAndReschedule).  
   There info if Node points to closure is available. -- HWL -}
 
-closureCodeBody _binder_info cl_info cc srt node args body 
-  | null args  -- No args i.e. thunk
-  = do  { code <- getCode $ thunkCode cl_info cc srt node body
-       ; emitClosureCodeAndInfoTable cl_info [node] code }
+closureCodeBody top_lvl bndr cl_info cc srt args arity body fv_details
+  | length args == 0 -- No args i.e. thunk
+  = emitClosureProcAndInfoTable top_lvl bndr cl_info [] $
+      (\ (node, _) -> thunkCode cl_info fv_details cc srt node arity body)
 
-closureCodeBody _binder_info cl_info cc srt node args body 
+closureCodeBody top_lvl bndr cl_info cc srt args arity body fv_details
   = ASSERT( length args > 0 )
     do {       -- Allocate the global ticky counter,
                -- and establish the ticky-counter 
                -- label for this block
          let ticky_ctr_lbl = mkRednCountsLabel (closureName cl_info) $ clHasCafRefs cl_info
-       ; emitTickyCounter cl_info args
+       ; emitTickyCounter cl_info (map stripNV args)
        ; setTickyCtrLabel ticky_ctr_lbl $ do
 
---     -- XXX: no slow-entry code for now
---     -- Emit the slow-entry code
---     { reg_save_code <- mkSlowEntryCode cl_info reg_args
-
        -- Emit the main entry code
-       ; let node_points = nodeMustPointToIt (closureLFInfo cl_info)
-       ; arg_regs <- bindArgsToRegs args
-       ; blks <- forkProc $ getCode $ do
-               { enterCostCentre cl_info cc body
+        ; emitClosureProcAndInfoTable top_lvl bndr cl_info args $ \(node, arg_regs) -> do
+               -- Emit the slow-entry code (for entering a closure through a PAP)
+               { mkSlowEntryCode cl_info arg_regs
+
+               ; let lf_info = closureLFInfo cl_info
+                     node_points = nodeMustPointToIt lf_info
                ; tickyEnterFun cl_info
                ; whenC node_points (ldvEnterClosure cl_info)
                ; granYield arg_regs node_points
 
                        -- Main payload
-               ; entryHeapCheck node arg_regs srt $
-                 cgExpr body }
+               ; entryHeapCheck node arity arg_regs srt $ do
+               { enterCostCentre cl_info cc body
+                ; fv_bindings <- mapM bind_fv fv_details
+               ; load_fvs node lf_info fv_bindings -- Load free vars out of closure *after*
+               ; cgExpr body }}            -- heap check, to reduce live vars over check
 
-       ; emitClosureCodeAndInfoTable cl_info (node:arg_regs) blks
   }
 
-{-
+-- A function closure pointer may be tagged, so we
+-- must take it into account when accessing the free variables.
+bind_fv :: (NonVoid Id, VirtualHpOffset) -> FCode (LocalReg, WordOff)
+bind_fv (id, off) = do { reg <- rebindToReg id; return (reg, off) }
+
+load_fvs :: LocalReg -> LambdaFormInfo -> [(LocalReg, WordOff)] -> FCode ()
+load_fvs node lf_info = mapCs (\ (reg, off) ->
+      pprTrace "get tag for" (ppr reg <+> ppr tag) $ emit $ mkTaggedObjectLoad reg node off tag)
+  where tag = lfDynTag lf_info
+
 -----------------------------------------
 -- The "slow entry" code for a function.  This entry point takes its
 -- arguments on the stack.  It loads the arguments into registers
@@ -383,76 +432,53 @@ closureCodeBody _binder_info cl_info cc srt node args body
 -- normal entry point.  The function's closure is assumed to be in
 -- R1/node.
 -- 
--- The slow entry point is used in two places:
--- 
--- (a) unknown calls: eg. stg_PAP_entry 
---  (b) returning from a heap-check failure
+-- The slow entry point is used for unknown calls: eg. stg_PAP_entry 
 
-mkSlowEntryCode :: ClosureInfo -> [(Id,GlobalReg)] -> FCode CmmStmts
+mkSlowEntryCode :: ClosureInfo -> [LocalReg] -> FCode ()
 -- If this function doesn't have a specialised ArgDescr, we need
--- to generate the function's arg bitmap, slow-entry code, and
--- register-save code for the heap-check failure
--- Here, we emit the slow-entry code, and 
--- return the register-save assignments
-mkSlowEntryCode cl_info reg_args
+-- to generate the function's arg bitmap and slow-entry code.
+-- Here, we emit the slow-entry code.
+mkSlowEntryCode cl_info (_ : arg_regs) -- first arg should already be in `Node'
   | Just (_, ArgGen _) <- closureFunInfo cl_info
-  = do         { emitSimpleProc slow_lbl (emitStmts load_stmts)
-       ; return save_stmts }
-  | otherwise = return noStmts
+  = emitProcWithConvention Slow (CmmInfo Nothing Nothing CmmNonInfoTable) slow_lbl
+                           arg_regs jump
+  | otherwise = return ()
   where
-     name = closureName cl_info
-     slow_lbl = mkSlowEntryLabel name
-
-     load_stmts = mkStmts load_assts `plusStmts` mkStmts [stk_adj_pop, jump_to_entry]
-     save_stmts = oneStmt stk_adj_push `plusStmts`  mkStmts save_assts
-
-     reps_w_regs :: [(CgRep,GlobalReg)]
-     reps_w_regs = [(idCgRep id, reg) | (id,reg) <- reverse reg_args]
-     (final_stk_offset, stk_offsets)
-       = mapAccumL (\off (rep,_) -> (off + cgRepSizeW rep, off))
-                   0 reps_w_regs
-
-     load_assts = zipWithEqual "mk_load" mk_load reps_w_regs stk_offsets
-     mk_load (rep,reg) offset = CmmAssign (CmmGlobal reg) 
-                                         (CmmLoad (cmmRegOffW spReg offset)
-                                                  (argMachRep rep))
-
-     save_assts = zipWithEqual "mk_save" mk_save reps_w_regs stk_offsets
-     mk_save (rep,reg) offset = ASSERT( argMachRep rep == globalRegType reg )
-                               CmmStore (cmmRegOffW spReg offset) 
-                                        (CmmReg (CmmGlobal reg))
-
-     stk_adj_pop   = CmmAssign spReg (cmmRegOffW spReg final_stk_offset)
-     stk_adj_push  = CmmAssign spReg (cmmRegOffW spReg (- final_stk_offset))
-     jump_to_entry = CmmJump (mkLblExpr (enterLocalIdLabel name)) []
--}
+     caf_refs = clHasCafRefs cl_info
+     name     = closureName cl_info
+     slow_lbl = mkSlowEntryLabel  name caf_refs
+     fast_lbl = enterLocalIdLabel name caf_refs
+     jump = mkJump (mkLblExpr fast_lbl) (map (CmmReg . CmmLocal) arg_regs)
+                   initUpdFrameOff
+mkSlowEntryCode _ [] = panic "entering a closure with no arguments?"
 
 -----------------------------------------
-thunkCode :: ClosureInfo -> CostCentreStack -> C_SRT -> LocalReg -> StgExpr -> FCode ()
-thunkCode cl_info cc srt node body 
+thunkCode :: ClosureInfo -> [(NonVoid Id, VirtualHpOffset)] -> CostCentreStack ->
+             C_SRT -> LocalReg -> Int -> StgExpr -> FCode ()
+thunkCode cl_info fv_details cc srt node arity body 
   = do { let node_points = nodeMustPointToIt (closureLFInfo cl_info)
-
        ; tickyEnterThunk cl_info
        ; ldvEnterClosure cl_info  -- NB: Node always points when profiling
        ; granThunk node_points
 
         -- Heap overflow check
-       ; entryHeapCheck node [] srt $ do
+       ; entryHeapCheck node arity [] srt $ do
        {       -- Overwrite with black hole if necessary
                -- but *after* the heap-overflow check
          whenC (blackHoleOnEntry cl_info && node_points)
                (blackHoleIt cl_info)
 
                -- Push update frame
-       ; setupUpdate cl_info node
-
+       ; setupUpdate cl_info node $
                -- We only enter cc after setting up update so
                -- that cc of enclosing scope will be recorded
                -- in update frame CAF/DICT functions will be
                -- subsumed by this enclosing cc
-       ; enterCostCentre cl_info cc body
-
-       ; cgExpr body } }
+            do { enterCostCentre cl_info cc body
+               ; let lf_info = closureLFInfo cl_info
+               ; fv_bindings <- mapM bind_fv fv_details
+               ; load_fvs node lf_info fv_bindings
+              ; cgExpr body }}}
 
 
 ------------------------------------------------------------------------
@@ -491,18 +517,20 @@ emitBlackHoleCode is_single_entry
 
     eager_blackholing = False 
 
-setupUpdate :: ClosureInfo -> LocalReg -> FCode ()
+setupUpdate :: ClosureInfo -> LocalReg -> FCode () -> FCode ()
        -- Nota Bene: this function does not change Node (even if it's a CAF),
        -- so that the cost centre in the original closure can still be
        -- extracted by a subsequent enterCostCentre
-setupUpdate closure_info node
+setupUpdate closure_info node body
   | closureReEntrant closure_info
-  = return ()
+  = body
 
   | not (isStaticClosure closure_info)
   = if closureUpdReqd closure_info
-    then do { tickyPushUpdateFrame; pushUpdateFrame node }
-    else tickyUpdateFrameOmitted
+    then do { tickyPushUpdateFrame;
+           ; pushUpdateFrame [CmmReg (CmmLocal node),
+                               mkLblExpr mkUpdInfoLabel] body }
+    else do { tickyUpdateFrameOmitted; body}
  
   | otherwise  -- A static closure
   = do         { tickyUpdateBhCaf closure_info
@@ -510,14 +538,23 @@ setupUpdate closure_info node
        ; if closureUpdReqd closure_info
          then do       -- Blackhole the (updatable) CAF:
                { upd_closure <- link_caf closure_info True
-               ; pushUpdateFrame upd_closure }
-         else tickyUpdateFrameOmitted
+               ; pushUpdateFrame [CmmReg (CmmLocal upd_closure),
+                                   mkLblExpr mkUpdInfoLabel] body }
+         else do {tickyUpdateFrameOmitted; body}
     }
 
-pushUpdateFrame :: LocalReg -> FCode ()
-pushUpdateFrame cl_reg
-  = emit (mkAddToContext (mkLblExpr mkUpdInfoLabel) 
-                        [CmmReg (CmmLocal cl_reg)])
+-- Push the update frame on the stack in the Entry area,
+-- leaving room for the return address that is already
+-- at the old end of the area.
+pushUpdateFrame :: [CmmExpr] -> FCode () -> FCode ()
+pushUpdateFrame es body
+  = do updfr  <- getUpdFrameOff
+       offset <- foldM push updfr es
+       withUpdFrameOff offset body
+     where push off e =
+             do emit (mkStore (CmmStackSlot (CallArea Old) base) e)
+                return base
+             where base = off + widthInBytes (cmmExprWidth e)
 
 -----------------------------------------------------------------------------
 -- Entering a CAF
@@ -565,7 +602,8 @@ link_caf cl_info is_upd = do
   {    -- Alloc black hole specifying CC_HDR(Node) as the cost centre
   ; let        use_cc   = costCentreFrom (CmmReg nodeReg)
         blame_cc = use_cc
-  ; hp_rel <- allocDynClosure bh_cl_info use_cc blame_cc []
+  ; (hp_rel, init) <- allocDynClosure bh_cl_info use_cc blame_cc []
+  ; emit init
 
        -- Call the RTS function newCAF to add the CAF to the CafList
        -- so that the garbage collector can find them
index c32d7cd..b425163 100644 (file)
@@ -73,7 +73,7 @@ import ClosureInfo (ArgDescr(..), C_SRT(..), Liveness(..))
 
 import StgSyn
 import SMRep
-import Cmm     ( ClosureTypeInfo(..) )
+import Cmm     ( ClosureTypeInfo(..), ConstrDescription )
 import CmmExpr
 
 import CLabel
@@ -236,7 +236,7 @@ mkLFLetNoEscape = LFLetNoEscape
 
 -------------
 mkLFReEntrant :: TopLevelFlag  -- True of top level
-             -> [Id]           -- Free vars
+             -> [Id]           -- Free vars
              -> [Id]           -- Args
              -> ArgDescr       -- Argument descriptor
              -> LambdaFormInfo
@@ -335,8 +335,10 @@ tagForArity arity | isSmallFamily arity = arity
                   | otherwise           = 0
 
 lfDynTag :: LambdaFormInfo -> DynTag
-lfDynTag (LFCon con)               = tagForCon con
-lfDynTag (LFReEntrant _ arity _ _) = tagForArity arity
+-- Return the tag in the low order bits of a variable bound
+-- to this LambdaForm
+lfDynTag (LFCon con)               = pprTrace "tagForCon" (ppr con <+> ppr (tagForCon con)) $ tagForCon con
+lfDynTag (LFReEntrant _ arity _ _) = pprTrace "reentrant" (ppr arity) $ tagForArity arity
 lfDynTag _other                    = 0
 
 
@@ -506,7 +508,8 @@ getCallMethod name caf (LFReEntrant _ arity _ _) n_args
   | n_args == 0    = ASSERT( arity /= 0 )
                     ReturnIt   -- No args at all
   | n_args < arity = SlowCall  -- Not enough args
-  | otherwise      = DirectEntry (enterIdLabel name caf) arity
+  | otherwise      = pprTrace "getCallMethod" (ppr name <+> ppr arity) $
+                     DirectEntry (enterIdLabel name caf) arity
 
 getCallMethod _name _ LFUnLifted n_args
   = ASSERT( n_args == 0 ) ReturnIt
@@ -675,7 +678,8 @@ data ClosureInfo
        closureSMRep  :: !SMRep,          -- representation used by storage mgr
        closureSRT    :: !C_SRT,          -- What SRT applies to this closure
        closureType   :: !Type,           -- Type of closure (ToDo: remove)
-       closureDescr  :: !String          -- closure description (for profiling)
+       closureDescr  :: !String,         -- closure description (for profiling)
+        closureCafs   :: !CafInfo         -- whether the closure may have CAFs
     }
 
   -- Constructor closures don't have a unique info table label (they use
@@ -720,7 +724,8 @@ mkClosureInfo is_static id lf_info tot_wds ptr_wds srt_info descr
                  closureSMRep = sm_rep, 
                  closureSRT = srt_info,
                  closureType = idType id,
-                 closureDescr = descr }
+                 closureDescr = descr,
+                  closureCafs = idCafInfo id }
   where
     name   = idName id
     sm_rep = chooseSMRep is_static lf_info tot_wds ptr_wds
@@ -743,39 +748,49 @@ mkConInfo is_static data_con tot_wds ptr_wds
 
 cafBlackHoleClosureInfo :: ClosureInfo -> ClosureInfo
 cafBlackHoleClosureInfo (ClosureInfo { closureName = nm,
-                                      closureType = ty })
+                                      closureType = ty,
+                                      closureCafs = cafs })
   = ClosureInfo { closureName   = nm,
                  closureLFInfo = LFBlackHole mkCAFBlackHoleInfoTableLabel,
                  closureSMRep  = BlackHoleRep,
                  closureSRT    = NoC_SRT,
                  closureType   = ty,
-                 closureDescr  = "" }
+                 closureDescr  = "", 
+                 closureCafs   = cafs }
 cafBlackHoleClosureInfo _ = panic "cafBlackHoleClosureInfo"
 
 seCafBlackHoleClosureInfo :: ClosureInfo -> ClosureInfo
 seCafBlackHoleClosureInfo (ClosureInfo { closureName = nm,
-                                        closureType = ty })
+                                        closureType = ty,
+                                        closureCafs = cafs })
   = ClosureInfo { closureName   = nm,
                  closureLFInfo = LFBlackHole mkSECAFBlackHoleInfoTableLabel,
                  closureSMRep  = BlackHoleRep,
                  closureSRT    = NoC_SRT,
                  closureType   = ty,
-                 closureDescr  = ""  }
+                 closureDescr  = "",
+                 closureCafs   = cafs }
 seCafBlackHoleClosureInfo _ = panic "seCafBlackHoleClosureInfo"
 
 --------------------------------------
 --   Extracting ClosureTypeInfo
 --------------------------------------
 
-closureTypeInfo :: ClosureInfo -> ClosureTypeInfo
-closureTypeInfo cl_info
+-- JD: I've added the continuation arguments not for fun but because
+-- I don't want to pipe the monad in here (circular module dependencies),
+-- and I don't want to pull this code out of this module, which would
+-- require us to expose a bunch of abstract types.
+
+closureTypeInfo ::
+  ClosureInfo -> ((ConstrDescription -> ClosureTypeInfo) -> DataCon -> CLabel -> a) ->
+  (ClosureTypeInfo -> a) -> a
+closureTypeInfo cl_info k_with_con_name k_simple
    = case cl_info of
        ConInfo { closureCon = con } 
-               -> ConstrInfo (ptrs, nptrs)
-                             (fromIntegral (dataConTagZ con))
-                             con_name
+               -> k_with_con_name (ConstrInfo (ptrs, nptrs)
+                                     (fromIntegral (dataConTagZ con))) con info_lbl
                where
-                 con_name = panic "closureTypeInfo"
+                 --con_name = panic "closureTypeInfo"
                        -- Was: 
                        -- cstr <- mkByteStringCLit $ dataConIdentity con
                        -- con_name = makeRelativeRefTo info_lbl cstr
@@ -783,23 +798,23 @@ closureTypeInfo cl_info
        ClosureInfo { closureName   = name,
                       closureLFInfo = LFReEntrant _ arity _ arg_descr,
                       closureSRT    = srt }
-               -> FunInfo (ptrs, nptrs)
-                          srt 
-                          (fromIntegral arity)
-                          arg_descr 
-                          (CmmLabel (mkSlowEntryLabel name (clHasCafRefs cl_info)))
+               -> k_simple $ FunInfo (ptrs, nptrs)
+                               srt 
+                               (fromIntegral arity)
+                               arg_descr 
+                               (CmmLabel (mkSlowEntryLabel name (clHasCafRefs cl_info)))
   
        ClosureInfo { closureLFInfo = LFThunk _ _ _ (SelectorThunk offset) _, 
                       closureSRT    = srt }
-               -> ThunkSelectorInfo (fromIntegral offset) srt
+               -> k_simple $ ThunkSelectorInfo (fromIntegral offset) srt
 
        ClosureInfo { closureLFInfo = LFThunk {}, 
                       closureSRT    = srt }
-               -> ThunkInfo (ptrs, nptrs) srt
+               -> k_simple $ ThunkInfo (ptrs, nptrs) srt
 
         _ -> panic "unexpected lambda form in mkCmmInfo"
   where
---    info_lbl = infoTableLabelFromCI cl_info
+    info_lbl = infoTableLabelFromCI cl_info
     ptrs     = fromIntegral $ closurePtrsSize cl_info
     size     = fromIntegral $ closureNonHdrSize cl_info
     nptrs    = size - ptrs
@@ -1092,9 +1107,7 @@ getPredTyDescription (EqPred ty1 _ty2) = getTyDescription ty1     -- Urk?
 --   SRTs/CAFs
 --------------------------------------
 
--- This is horrible, but we need to know whether a closure may have CAFs.
+-- We need to know whether a closure may have CAFs.
 clHasCafRefs :: ClosureInfo -> CafInfo
-clHasCafRefs (ClosureInfo {closureSRT = srt}) = 
-  case srt of NoC_SRT -> NoCafRefs
-              _       -> MayHaveCafRefs
+clHasCafRefs (ClosureInfo {closureCafs = cafs}) = cafs
 clHasCafRefs (ConInfo {}) = NoCafRefs
index de1d77a..e818bd7 100644 (file)
@@ -27,6 +27,7 @@ import StgCmmProf
 
 import Cmm
 import CLabel
+import MkZipCfgCmm (CmmAGraph, mkNop)
 import SMRep
 import CostCentre
 import Constants
@@ -47,7 +48,7 @@ import Char           ( ord )
 cgTopRhsCon :: Id              -- Name of thing bound to this RHS
            -> DataCon          -- Id
            -> [StgArg]         -- Args
-           -> FCode (Id, CgIdInfo)
+           -> FCode CgIdInfo
 cgTopRhsCon id con args
   = do { 
 #if mingw32_TARGET_OS
@@ -67,7 +68,7 @@ cgTopRhsCon id con args
                        = layOutStaticConstr con (addArgReps args)
 
            get_lit (arg, _offset) = do { CmmLit lit <- getArgAmode arg
-                                       ; return lit }
+                                       ; return lit }
 
        ; payload <- mapM get_lit nv_args_w_offsets
                -- NB1: nv_args_w_offsets is sorted into ptrs then non-ptrs
@@ -83,7 +84,7 @@ cgTopRhsCon id con args
        ; emitDataLits closure_label closure_rep
 
                -- RETURN
-       ; return (id, litIdInfo id lf_info (CmmLabel closure_label)) }
+       ; return $ litIdInfo id lf_info (CmmLabel closure_label) }
 
 
 ---------------------------------------------------------------
@@ -96,7 +97,8 @@ buildDynCon :: Id               -- Name of the thing to which this constr will
                                  -- current CCS if currentOrSubsumedCCS
            -> DataCon            -- The data constructor
            -> [StgArg]           -- Its args
-           -> FCode CgIdInfo     -- Return details about how to find it
+           -> FCode (CgIdInfo, CmmAGraph)
+               -- Return details about how to find it and initialization code
 
 {- We used to pass a boolean indicating whether all the
 args were of size zero, so we could use a static
@@ -121,7 +123,8 @@ premature looking at the args will cause the compiler to black-hole!
 
 buildDynCon binder _cc con []
   = return (litIdInfo binder (mkConLFInfo con)
-               (CmmLabel (mkClosureLabel (dataConName con) (idCafInfo binder))))
+               (CmmLabel (mkClosureLabel (dataConName con) (idCafInfo binder))),
+            mkNop)
 
 -------- buildDynCon: Charlike and Intlike constructors -----------
 {- The following three paragraphs about @Char@-like and @Int@-like
@@ -155,7 +158,7 @@ buildDynCon binder _cc con [arg]
              offsetW = (val_int - mIN_INTLIKE) * (fixedHdrSize + 1)
                -- INTLIKE closures consist of a header and one word payload
              intlike_amode = cmmLabelOffW intlike_lbl offsetW
-       ; return (litIdInfo binder (mkConLFInfo con) intlike_amode) }
+       ; return (litIdInfo binder (mkConLFInfo con) intlike_amode, mkNop) }
 
 buildDynCon binder _cc con [arg]
   | maybeCharLikeCon con 
@@ -167,14 +170,14 @@ buildDynCon binder _cc con [arg]
              offsetW = (val_int - mIN_CHARLIKE) * (fixedHdrSize + 1)
                -- CHARLIKE closures consist of a header and one word payload
              charlike_amode = cmmLabelOffW charlike_lbl offsetW
-       ; return (litIdInfo binder (mkConLFInfo con) charlike_amode) }
+       ; return (litIdInfo binder (mkConLFInfo con) charlike_amode, mkNop) }
 
 -------- buildDynCon: the general case -----------
 buildDynCon binder ccs con args
   = do { let (cl_info, args_w_offsets) = layOutDynConstr con (addArgReps args)
                -- No void args in args_w_offsets
-       ; tmp <- allocDynClosure cl_info use_cc blame_cc args_w_offsets
-       ; return (regIdInfo binder lf_info tmp) }
+       ; (tmp, init) <- allocDynClosure cl_info use_cc blame_cc args_w_offsets
+       ; return (regIdInfo binder lf_info tmp, init) }
   where
     lf_info = mkConLFInfo con
 
@@ -204,10 +207,11 @@ bindConArgs (DataAlt con) base args
 
           -- The binding below forces the masking out of the tag bits
           -- when accessing the constructor field.
-    bind_arg :: (Id, VirtualHpOffset) -> FCode LocalReg
+    bind_arg :: (NonVoid Id, VirtualHpOffset) -> FCode LocalReg
     bind_arg (arg, offset) 
        = do { emit $ mkTaggedObjectLoad (idToReg arg) base offset tag
-            ; bindArgToReg arg }
+            ; pprTrace "bind_arg gets tag" (ppr arg <+> ppr tag) $
+               bindArgToReg arg }
 
 bindConArgs _other_con _base args
   = ASSERT( null args ) return []
index c43bf80..67d82f0 100644 (file)
@@ -14,6 +14,8 @@ module StgCmmEnv (
        litIdInfo, lneIdInfo, regIdInfo,
        idInfoToAmode,
 
+        NonVoid(..), isVoidId, nonVoidIds,
+
        addBindC, addBindsC,
 
        bindArgsToRegs, bindToReg, rebindToReg,
@@ -25,6 +27,7 @@ module StgCmmEnv (
 
 #include "HsVersions.h"
 
+import TyCon
 import StgCmmMonad
 import StgCmmUtils
 import StgCmmClosure
@@ -39,11 +42,28 @@ import PprCmm               ( {- instance Outputable -} )
 import Id
 import VarEnv
 import Maybes
+import Monad
 import Name
 import StgSyn
 import Outputable
 
+-------------------------------------
+--     Non-void types
+-------------------------------------
+-- We frequently need the invariant that an Id or a an argument
+-- is of a non-void type. This type is a witness to the invariant.
+
+newtype NonVoid a = NonVoid a
+  deriving (Eq, Show)
+
+instance (Outputable a) => Outputable (NonVoid a) where
+  ppr (NonVoid a) = ppr a
+
+isVoidId :: Id -> Bool
+isVoidId = isVoidRep . idPrimRep
 
+nonVoidIds :: [Id] -> [NonVoid Id]
+nonVoidIds ids = [NonVoid id | id <- ids, not (isVoidRep (idPrimRep id))]
 
 -------------------------------------
 --     Manipulating CgIdInfo
@@ -65,15 +85,16 @@ lneIdInfo id regs
     blk_id = mkBlockId (idUnique id)
 
 litIdInfo :: Id -> LambdaFormInfo -> CmmLit -> CgIdInfo
-litIdInfo id lf_info lit = mkCgIdInfo id lf_info (CmmLit lit)
+litIdInfo id lf_info lit = --mkCgIdInfo id lf_info (CmmLit lit)
+  mkCgIdInfo id lf_info (addDynTag (CmmLit lit) (lfDynTag lf_info))
 
 regIdInfo :: Id -> LambdaFormInfo -> LocalReg -> CgIdInfo
-regIdInfo id lf_info reg = mkCgIdInfo id lf_info (CmmReg (CmmLocal reg))
+regIdInfo id lf_info reg =
+  mkCgIdInfo id lf_info (addDynTag (CmmReg (CmmLocal reg)) (lfDynTag lf_info))
 
 idInfoToAmode :: CgIdInfo -> CmmExpr
 -- Returns a CmmExpr for the *tagged* pointer
-idInfoToAmode (CgIdInfo { cg_loc = CmmLoc e, cg_tag = tag })
-  = addDynTag e tag
+idInfoToAmode (CgIdInfo { cg_loc = CmmLoc e }) = e
 idInfoToAmode cg_info
   = pprPanic "idInfoToAmode" (ppr (cg_id cg_info))     -- LneLoc
 
@@ -105,10 +126,10 @@ addBindC name stuff_to_bind = do
        binds <- getBinds
        setBinds $ extendVarEnv binds name stuff_to_bind
 
-addBindsC :: [(Id, CgIdInfo)] -> FCode ()
+addBindsC :: [CgIdInfo] -> FCode ()
 addBindsC new_bindings = do
        binds <- getBinds
-       let new_binds = foldl (\ binds (name,info) -> extendVarEnv binds name info)
+       let new_binds = foldl (\ binds info -> extendVarEnv binds (cg_id info) info)
                              binds
                              new_bindings
        setBinds new_binds
@@ -155,10 +176,11 @@ cgLookupPanic id
 
 
 --------------------
-getArgAmode :: StgArg -> FCode CmmExpr
-getArgAmode (StgVarArg var)  = do { info  <- getCgIdInfo var; return (idInfoToAmode info) }
-getArgAmode (StgLitArg lit)  = return (CmmLit (mkSimpleLit lit))
-getArgAmode (StgTypeArg _)   = panic "getArgAmode: type arg"
+getArgAmode :: NonVoid StgArg -> FCode CmmExpr
+getArgAmode (NonVoid (StgVarArg var))  =
+  do { info  <- getCgIdInfo var; return (idInfoToAmode info) }
+getArgAmode (NonVoid (StgLitArg lit))  = liftM CmmLit $ cgLit lit
+getArgAmode (NonVoid (StgTypeArg _))   = panic "getArgAmode: type arg"
 
 getNonVoidArgAmodes :: [StgArg] -> FCode [CmmExpr]
 -- NB: Filters out void args, 
@@ -166,7 +188,7 @@ getNonVoidArgAmodes :: [StgArg] -> FCode [CmmExpr]
 getNonVoidArgAmodes [] = return []
 getNonVoidArgAmodes (arg:args)
   | isVoidRep (argPrimRep arg) = getNonVoidArgAmodes args
-  | otherwise = do { amode  <- getArgAmode  arg 
+  | otherwise = do { amode  <- getArgAmode (NonVoid arg)
                   ; amodes <- getNonVoidArgAmodes args
                   ; return ( amode : amodes ) }
 
@@ -175,27 +197,27 @@ getNonVoidArgAmodes (arg:args)
 --     Interface functions for binding and re-binding names
 ------------------------------------------------------------------------
 
-bindToReg :: Id -> LambdaFormInfo -> FCode LocalReg
+bindToReg :: NonVoid Id -> LambdaFormInfo -> FCode LocalReg
 -- Bind an Id to a fresh LocalReg
-bindToReg id lf_info
-  = do { let reg = idToReg id
-       ; addBindC id (regIdInfo id lf_info reg)
+bindToReg nvid@(NonVoid id) lf_info
+  = do { let reg = idToReg nvid
+       ; addBindC id (mkCgIdInfo id lf_info (CmmReg (CmmLocal reg)))
        ; return reg }
 
-rebindToReg :: Id -> FCode LocalReg
+rebindToReg :: NonVoid Id -> FCode LocalReg
 -- Like bindToReg, but the Id is already in scope, so 
 -- get its LF info from the envt
-rebindToReg id 
+rebindToReg nvid@(NonVoid id)
   = do { info <- getCgIdInfo id
-       ; bindToReg id (cgIdInfoLF info) }
+       ; bindToReg nvid (cgIdInfoLF info) }
 
-bindArgToReg :: Id -> FCode LocalReg
-bindArgToReg id = bindToReg id (mkLFArgument id)
+bindArgToReg :: NonVoid Id -> FCode LocalReg
+bindArgToReg nvid@(NonVoid id) = bindToReg nvid (mkLFArgument id)
 
-bindArgsToRegs :: [Id] -> FCode [LocalReg]
+bindArgsToRegs :: [NonVoid Id] -> FCode [LocalReg]
 bindArgsToRegs args = mapM bindArgToReg args
 
-idToReg :: Id -> LocalReg
+idToReg :: NonVoid Id -> LocalReg
 -- Make a register from an Id, typically a function argument,
 -- free variable, or case binder
 --
@@ -203,7 +225,8 @@ idToReg :: Id -> LocalReg
 --
 -- By now the Ids should be uniquely named; else one would worry
 -- about accidental collision 
-idToReg id = LocalReg (idUnique id) 
-                     (primRepCmmType (idPrimRep id))
+idToReg (NonVoid id) = LocalReg (idUnique id) 
+                        (case idPrimRep id of VoidRep -> pprPanic "idToReg" (ppr id)
+                                              _ -> primRepCmmType (idPrimRep id))
 
 
index 74c69b7..379f1cd 100644 (file)
@@ -33,7 +33,9 @@ import Cmm()
 import CmmExpr
 import CoreSyn
 import DataCon
+import ForeignCall
 import Id
+import PrimOp
 import TyCon
 import CostCentre      ( CostCentreStack, currentCCS )
 import Maybes
@@ -50,16 +52,16 @@ cgExpr      :: StgExpr -> FCode ()
 cgExpr (StgApp fun args)     = cgIdApp fun args
 cgExpr (StgOpApp op args ty) = cgOpApp op args ty
 cgExpr (StgConApp con args)  = cgConApp con args
-
 cgExpr (StgSCC cc expr)   = do { emitSetCCC cc; cgExpr expr }
 cgExpr (StgTick m n expr) = do { emit (mkTickBox m n); cgExpr expr }
-cgExpr (StgLit lit)       = emitReturn [CmmLit (mkSimpleLit lit)]
+cgExpr (StgLit lit)       = do cmm_lit <- cgLit lit
+                               emitReturn [CmmLit cmm_lit]
 
-cgExpr (StgLet binds expr)            = do { emit (mkComment $ mkFastString "calling cgBind"); cgBind binds; emit (mkComment $ mkFastString "calling cgExpr"); cgExpr expr }
+cgExpr (StgLet binds expr)            = do { cgBind binds; cgExpr expr }
 cgExpr (StgLetNoEscape _ _ binds expr) = do { cgLneBinds binds; cgExpr expr }
 
-cgExpr (StgCase expr _live_vars _save_vars bndr srt alt_type alts)
-  cgCase expr bndr srt alt_type alts
+cgExpr (StgCase expr _live_vars _save_vars bndr srt alt_type alts) =
+  cgCase expr bndr srt alt_type alts
 
 cgExpr (StgLam {}) = panic "cgExpr: StgLam"
 
@@ -68,7 +70,7 @@ cgExpr (StgLam {}) = panic "cgExpr: StgLam"
 ------------------------------------------------------------------------
 
 {- Generating code for a let-no-escape binding, aka join point is very
-very similar to whatwe do for a case expression.  The duality is
+very similar to what we do for a case expression.  The duality is
 between
        let-no-escape x = b
        in e
@@ -86,8 +88,8 @@ cgLneBinds :: StgBinding -> FCode ()
 cgLneBinds (StgNonRec bndr rhs)
   = do { local_cc <- saveCurrentCostCentre
                -- See Note [Saving the current cost centre]
-       ; (bndr,info) <- cgLetNoEscapeRhs local_cc bndr rhs 
-       ; addBindC bndr info }
+       ; info <- cgLetNoEscapeRhs local_cc bndr rhs 
+       ; addBindC (cg_id info) info }
 
 cgLneBinds (StgRec pairs)
   = do { local_cc <- saveCurrentCostCentre
@@ -98,16 +100,24 @@ cgLneBinds (StgRec pairs)
 
        ; addBindsC new_bindings }
 
+
 -------------------------
-cgLetNoEscapeRhs
+cgLetNoEscapeRhs, cgLetNoEscapeRhsBody
     :: Maybe LocalReg  -- Saved cost centre
     -> Id
     -> StgRhs
-    -> FCode (Id, CgIdInfo)
-
-cgLetNoEscapeRhs local_cc bndr (StgRhsClosure cc _bi _ _upd srt args body)
-  = cgLetNoEscapeClosure bndr local_cc cc srt args body
-cgLetNoEscapeRhs local_cc bndr (StgRhsCon cc con args)
+    -> FCode CgIdInfo
+
+cgLetNoEscapeRhs local_cc bndr rhs =
+  do { (info, rhs_body) <- getCodeR $ cgLetNoEscapeRhsBody local_cc bndr rhs 
+     ; let (bid, _) = expectJust "cgLetNoEscapeRhs" $ maybeLetNoEscape info
+     ; emit (outOfLine $ mkLabel bid emptyStackInfo <*> rhs_body)
+     ; return info
+     }
+
+cgLetNoEscapeRhsBody local_cc bndr (StgRhsClosure cc _bi _ _upd srt args body)
+  = cgLetNoEscapeClosure bndr local_cc cc srt (nonVoidIds args) body
+cgLetNoEscapeRhsBody local_cc bndr (StgRhsCon cc con args)
   = cgLetNoEscapeClosure bndr local_cc cc NoSRT [] (StgConApp con args)
        -- For a constructor RHS we want to generate a single chunk of 
        -- code which can be jumped to from many places, which will 
@@ -120,9 +130,9 @@ cgLetNoEscapeClosure
        -> Maybe LocalReg       -- Slot for saved current cost centre
        -> CostCentreStack      -- XXX: *** NOT USED *** why not?
        -> SRT
-       -> [Id]                 -- Args (as in \ args -> body)
+       -> [NonVoid Id]         -- Args (as in \ args -> body)
        -> StgExpr              -- Body (as in above)
-       -> FCode (Id, CgIdInfo)
+       -> FCode CgIdInfo
 
 cgLetNoEscapeClosure bndr cc_slot _unused_cc srt args body
   = do  { arg_regs <- forkProc $ do    
@@ -133,7 +143,7 @@ cgLetNoEscapeClosure bndr cc_slot _unused_cc srt args body
                        -- Using altHeapCheck just reduces
                        -- instructions to save on stack
                ; return arg_regs }
-       ; return (bndr, lneIdInfo bndr arg_regs) }
+       ; return $ lneIdInfo bndr arg_regs}
 
 
 ------------------------------------------------------------------------
@@ -253,6 +263,11 @@ data GcPlan
 
 -------------------------------------
 cgCase :: StgExpr -> Id -> SRT -> AltType -> [StgAlt] -> FCode ()
+-- cgCase (OpApp ) bndr srt AlgAlt [(DataAlt flase, a2]
+  -- | isBoolTy (idType bndr)
+  -- , isDeadBndr bndr
+  -- = 
+
 cgCase scrut bndr srt alt_type alts 
   = do { up_hp_usg <- getVirtHp        -- Upstream heap usage
        ; let ret_bndrs = chooseReturnBndrs bndr alt_type alts
@@ -270,7 +285,7 @@ cgCase scrut bndr srt alt_type alts
        ; restoreCurrentCostCentre mb_cc
 
        ; bindArgsToRegs ret_bndrs
-       ; cgAlts gc_plan bndr alt_type alts }
+       ; cgAlts gc_plan (NonVoid bndr) alt_type alts }
 
 -----------------
 maybeSaveCostCentre :: Bool -> FCode (Maybe LocalReg)
@@ -279,17 +294,25 @@ maybeSaveCostCentre simple_scrut
   | otherwise    = return Nothing
 
 
-
 -----------------
 isSimpleScrut :: StgExpr -> AltType -> Bool
--- Simple scrutinee, does not allocate
-isSimpleScrut (StgOpApp _ _ _) _           = True
-isSimpleScrut (StgLit _)       _           = True
-isSimpleScrut (StgApp _ [])    (PrimAlt _) = True
+-- Simple scrutinee, does not block or allocate; hence safe to amalgamate
+-- heap usage from alternatives into the stuff before the case
+-- NB: if you get this wrong, and claim that the expression doesn't allocate
+--     when it does, you'll deeply mess up allocation
+isSimpleScrut (StgOpApp op _ _) _          = isSimpleOp op
+isSimpleScrut (StgLit _)       _           = True      -- case 1# of { 0# -> ..; ... }
+isSimpleScrut (StgApp _ [])    (PrimAlt _) = True      -- case x# of { 0# -> ..; ... }
 isSimpleScrut _                       _           = False
 
+isSimpleOp :: StgOp -> Bool
+-- True iff the op cannot block or allocate
+isSimpleOp (StgFCallOp (CCall (CCallSpec _ _ safe)) _) = not (playSafe safe)
+isSimpleOp (StgFCallOp (DNCall _) _)                   = False         -- Safe!
+isSimpleOp (StgPrimOp op)                                     = not (primOpOutOfLine op)
+
 -----------------
-chooseReturnBndrs :: Id -> AltType -> [StgAlt] -> [Id]
+chooseReturnBndrs :: Id -> AltType -> [StgAlt] -> [NonVoid Id]
 -- These are the binders of a case that are assigned
 -- by the evaluation of the scrutinee
 -- Only non-void ones come back
@@ -300,19 +323,16 @@ chooseReturnBndrs _bndr (UbxTupAlt _) [(_, ids, _, _)]
   = nonVoidIds ids     -- 'bndr' is not assigned!
 
 chooseReturnBndrs bndr (AlgAlt _) _alts
-  = [bndr]             -- Only 'bndr' is assigned
+  = nonVoidIds [bndr]  -- Only 'bndr' is assigned
 
 chooseReturnBndrs bndr PolyAlt _alts
-  = [bndr]             -- Only 'bndr' is assigned
+  = nonVoidIds [bndr]  -- Only 'bndr' is assigned
 
 chooseReturnBndrs _ _ _ = panic "chooseReturnBndrs"
        -- UbxTupALt has only one alternative
 
-nonVoidIds :: [Id] -> [Id]
-nonVoidIds ids = [id | id <- ids, not (isVoidRep (idPrimRep id))]
-
 -------------------------------------
-cgAlts :: GcPlan -> Id -> AltType -> [StgAlt] -> FCode ()
+cgAlts :: GcPlan -> NonVoid Id -> AltType -> [StgAlt] -> FCode ()
 -- At this point the result of the case are in the binders
 cgAlts gc_plan _bndr PolyAlt [(_, _, _, rhs)]
   = maybeAltHeapCheck gc_plan (cgExpr rhs)
@@ -347,7 +367,7 @@ cgAlts gc_plan bndr (AlgAlt tycon) alts
                         | (DataAlt con, cmm) <- tagged_cmms ]
 
                     -- Is the constructor tag in the node reg?
-       ; if isSmallFamily fam_sz
+        ; if isSmallFamily fam_sz
          then let      -- Yes, bndr_reg has constr. tag in ls bits
                    tag_expr = cmmConstrTag1 (CmmReg bndr_reg)
                    branches' = [(tag+1,branch) | (tag,branch) <- branches]
@@ -366,7 +386,7 @@ cgAlts _ _ _ _ = panic "cgAlts"
        -- UbxTupAlt and PolyAlt have only one alternative
 
 -------------------
-cgAltRhss :: GcPlan -> Id -> [StgAlt] -> FCode [(AltCon, CmmAGraph)]
+cgAltRhss :: GcPlan -> NonVoid Id -> [StgAlt] -> FCode [(AltCon, CmmAGraph)]
 cgAltRhss gc_plan bndr alts
   = forkAlts (map cg_alt alts)
   where
@@ -375,7 +395,7 @@ cgAltRhss gc_plan bndr alts
     cg_alt (con, bndrs, _uses, rhs)
       = getCodeR                 $
        maybeAltHeapCheck gc_plan $
-       do { bindConArgs con base_reg bndrs
+       do { pprTrace "binding args for" (ppr bndr <+> ppr con) $ bindConArgs con base_reg bndrs
           ; cgExpr rhs
           ; return con }
 
@@ -392,19 +412,28 @@ maybeAltHeapCheck (GcInAlts regs srt) code
 
 cgConApp :: DataCon -> [StgArg] -> FCode ()
 cgConApp con stg_args
+  | isUnboxedTupleCon con      -- Unboxed tuple: assign and return
+  = do { arg_exprs <- getNonVoidArgAmodes stg_args
+       ; tickyUnboxedTupleReturn (length arg_exprs)
+       ; emitReturn arg_exprs }
+
+  | otherwise  --  Boxed constructors; allocate and return
   = ASSERT( stg_args `lengthIs` dataConRepArity con )
-    do { idinfo <- buildDynCon (dataConWorkId con) currentCCS con stg_args
+    do { (idinfo, init) <- buildDynCon (dataConWorkId con) currentCCS con stg_args
                -- The first "con" says that the name bound to this closure is
                -- is "con", which is a bit of a fudge, but it only affects profiling
 
+        ; emit init
        ; emitReturn [idInfoToAmode idinfo] }
 
+
 cgIdApp :: Id -> [StgArg] -> FCode ()
+cgIdApp fun_id [] | isVoidId fun_id = emitReturn []
 cgIdApp fun_id args
   = do         { fun_info <- getCgIdInfo fun_id
-       ; case maybeLetNoEscape fun_info of
-               Just (blk_id, lne_regs) -> cgLneJump blk_id lne_regs args
-               Nothing -> cgTailCall fun_id fun_info args }
+        ; case maybeLetNoEscape fun_info of
+            Just (blk_id, lne_regs) -> cgLneJump blk_id lne_regs args
+            Nothing -> cgTailCall fun_id fun_info args }
 
 cgLneJump :: BlockId -> [LocalReg] -> [StgArg] -> FCode ()
 cgLneJump blk_id lne_regs args -- Join point; discard sequel
@@ -416,35 +445,40 @@ cgTailCall :: Id -> CgIdInfo -> [StgArg] -> FCode ()
 cgTailCall fun_id fun_info args
   = case (getCallMethod fun_name (idCafInfo fun_id) lf_info (length args)) of
 
-           -- A value in WHNF, so we can just return it.  
+           -- A value in WHNF, so we can just return it.
        ReturnIt -> emitReturn [fun]    -- ToDo: does ReturnIt guarantee tagged?
     
        EnterIt -> ASSERT( null args )  -- Discarding arguments
-               do { [ret,call] <- forkAlts [
+               do { let fun' = CmmLoad fun (cmmExprType fun)
+                   ; [ret,call] <- forkAlts [
                        getCode $ emitReturn [fun],     -- Is tagged; no need to untag
-                       getCode $ emitCall (entryCode fun) [fun]]       -- Not tagged
+                       getCode $ do emit (mkAssign nodeReg fun)
+                                     emitCall Native (entryCode fun') []]  -- Not tagged
                   ; emit (mkCmmIfThenElse (cmmIsTagged fun) ret call) }
 
        SlowCall -> do      -- A slow function call via the RTS apply routines
                { tickySlowCall lf_info args
+                ; emit $ mkComment $ mkFastString "slowCall"
                ; slowCall fun args }
     
        -- A direct function call (possibly with some left-over arguments)
        DirectEntry lbl arity -> do
                { tickyDirectCall arity args
                ; if node_points then
-                    do call <- getCode $ directCall lbl arity args
-                       emit (mkAssign nodeReg fun <*> call)
+                    do emit $ mkComment $ mkFastString "directEntry"
+                       emit (mkAssign nodeReg fun)
+                       directCall lbl arity args
                     -- directCall lbl (arity+1) (StgVarArg fun_id : args))
                     -- >>= (emit . (mkComment (mkFastString "DirectEntry") <*>))
-                 else directCall lbl arity      args }
+                 else do emit $ mkComment $ mkFastString "directEntry else"
+                          directCall lbl arity args }
 
        JumpToIt {} -> panic "cgTailCall"       -- ???
 
   where
-    fun_name   = idName fun_id
-    fun         = idInfoToAmode fun_info
-    lf_info     = cgIdInfoLF fun_info
+    fun_name   = idName            fun_id
+    fun         = idInfoToAmode     fun_info
+    lf_info     = cgIdInfoLF        fun_info
     node_points = nodeMustPointToIt lf_info
 
 
index 2d5d79e..2a6b794 100644 (file)
 -----------------------------------------------------------------------------
 
 module StgCmmForeign (
-  cgForeignCall,
+  cgForeignCall, loadThreadState, saveThreadState,
   emitPrimCall, emitCCall,
   emitSaveThreadState, -- will be needed by the Cmm parser
   emitLoadThreadState, -- ditto
-  emitCloseNursery,
   emitOpenNursery,
  ) where
 
@@ -27,18 +26,23 @@ import StgCmmMonad
 import StgCmmUtils
 import StgCmmClosure
 
-import MkZipCfgCmm
+import BlockId
 import Cmm
 import CmmUtils
+import MkZipCfg
+import MkZipCfgCmm hiding (CmmAGraph)
 import Type
 import TysPrim
+import UniqSupply
 import CLabel
 import SMRep
 import ForeignCall
 import Constants
 import StaticFlags
+import FastString
 import Maybes
 import Outputable
+import ZipCfgCmmRep
 
 import Control.Monad
 
@@ -64,8 +68,9 @@ cgForeignCall results result_hints (CCall (CCallSpec target cconv safety)) stg_a
                   DynamicTarget    ->  case args of fn:rest -> (rest, fn)
              call_target = ForeignTarget cmm_target fc
        
-       ; srt <- getSRTInfo (panic "emitForeignCall")   -- SLPJ: Not sure what SRT 
-                                                       -- is right here
+       ; srt <- getSRTInfo NoSRT       -- SLPJ: Not sure what SRT 
+                                       -- is right here
+                                        -- JD: Does it matter in the new codegen?
        ; emitForeignCall safety results call_target call_args srt CmmMayReturn }
   where
        -- in the stdcall calling convention, the symbol needs @size appended
@@ -111,50 +116,18 @@ emitForeignCall
         -> CmmReturnInfo       -- This can say "never returns"
                                --   only RTS procedures do this
        -> FCode ()
-emitForeignCall safety results target args _srt _ret
-  | not (playSafe safety) = trace "emitForeignCall; ret is undone" $ do
+emitForeignCall safety results target args _srt ret
+  | not (playSafe safety) = do -- trace "emitForeignCall; ret is undone" $ do
     let (caller_save, caller_load) = callerSaveVolatileRegs
+    updfr_off <- getUpdFrameOff
     emit caller_save
-    emit (mkUnsafeCall target results args)
+    emit $ mkUnsafeCall target results args
     emit caller_load
 
-  | otherwise = panic "ToDo: emitForeignCall'"
-
-{-
   | otherwise = do
-    -- Both 'id' and 'new_base' are KindNonPtr because they're
-    -- RTS only objects and are not subject to garbage collection
-    id <- newTemp bWord
-    new_base <- newTemp (cmmRegType (CmmGlobal BaseReg))
+    updfr_off <- getUpdFrameOff
     temp_target <- load_target_into_temp target
-    let (caller_save, caller_load) = callerSaveVolatileRegs 
-    emitSaveThreadState
-    emit caller_save
-    -- The CmmUnsafe arguments are only correct because this part
-    -- of the code hasn't been moved into the CPS pass yet.
-    -- Once that happens, this function will just emit a (CmmSafe srt) call,
-    -- and the CPS will will be the one to convert that
-    -- to this sequence of three CmmUnsafe calls.
-    emit (mkCmmCall (CmmCallee suspendThread CCallConv)
-                       [ (id,AddrHint) ]
-                       [ (CmmReg (CmmGlobal BaseReg), AddrHint) ]
-                       CmmUnsafe
-                       ret)
-    emit (mkCmmCall temp_target results args CmmUnsafe ret)
-    emit (mkCmmCall (CmmCallee resumeThread CCallConv)
-                       [ (new_base, AddrHint) ]
-                       [ (CmmReg (CmmLocal id), AddrHint) ]
-                       CmmUnsafe
-                       ret )
-    -- Assign the result to BaseReg: we
-    -- might now have a different Capability!
-    emit (mkAssign (CmmGlobal BaseReg) (CmmReg (CmmLocal new_base)))
-    emit caller_load
-    emitLoadThreadState
-
-suspendThread = CmmLit (CmmLabel (mkRtsCodeLabel SLIT("suspendThread")))
-resumeThread  = CmmLit (CmmLabel (mkRtsCodeLabel SLIT("resumeThread")))
--}
+    emit $ mkSafeCall temp_target results args updfr_off
 
 
 {-
@@ -170,23 +143,23 @@ load_args_into_temps = mapM arg_assign_temp
   where arg_assign_temp (e,hint) = do
           tmp <- maybe_assign_temp e
           return (tmp,hint)
+-}
        
-load_target_into_temp (CmmCallee expr conv) = do 
+load_target_into_temp (ForeignTarget expr conv) = do 
   tmp <- maybe_assign_temp expr
-  return (CmmCallee tmp conv)
-load_target_into_temp other_target =
+  return (ForeignTarget tmp conv)
+load_target_into_temp other_target@(PrimTarget _) =
   return other_target
 
 maybe_assign_temp e
   | hasNoGlobalRegs e = return e
-  | otherwise          = do 
+  | otherwise         = do 
        -- don't use assignTemp, it uses its own notion of "trivial"
        -- expressions, which are wrong here.
         -- this is a NonPtr because it only duplicates an existing
        reg <- newTemp (cmmExprType e) --TODO FIXME NOW
        emit (mkAssign (CmmLocal reg) e)
        return (CmmReg (CmmLocal reg))
--}
 
 -- -----------------------------------------------------------------------------
 -- Save/restore the thread state in the TSO
@@ -194,23 +167,34 @@ maybe_assign_temp e
 -- This stuff can't be done in suspendThread/resumeThread, because it
 -- refers to global registers which aren't available in the C world.
 
-emitSaveThreadState :: FCode ()
-emitSaveThreadState = do
+saveThreadState :: CmmAGraph
+saveThreadState =
   -- CurrentTSO->sp = Sp;
-  emit $ mkStore (cmmOffset stgCurrentTSO tso_SP) stgSp
-  emitCloseNursery
+  mkStore (cmmOffset stgCurrentTSO tso_SP) stgSp
+  <*> closeNursery
+  -- and save the current cost centre stack in the TSO when profiling:
+  <*> if opt_SccProfilingOn then
+       mkStore (cmmOffset stgCurrentTSO tso_CCCS) curCCS
+      else mkNop
+
+emitSaveThreadState :: BlockId -> FCode ()
+emitSaveThreadState bid = do
+  -- CurrentTSO->sp = Sp;
+  emit $ mkStore (cmmOffset stgCurrentTSO tso_SP)
+                 (CmmStackSlot (CallArea (Young bid)) (widthInBytes (typeWidth gcWord)))
+  emit closeNursery
   -- and save the current cost centre stack in the TSO when profiling:
   when opt_SccProfilingOn $
        emit (mkStore (cmmOffset stgCurrentTSO tso_CCCS) curCCS)
 
    -- CurrentNursery->free = Hp+1;
-emitCloseNursery :: FCode ()
-emitCloseNursery = emit $ mkStore nursery_bdescr_free (cmmOffsetW stgHp 1)
+closeNursery :: CmmAGraph
+closeNursery = mkStore nursery_bdescr_free (cmmOffsetW stgHp 1)
 
-emitLoadThreadState :: FCode ()
-emitLoadThreadState = do
-  tso <- newTemp gcWord -- TODO FIXME NOW
-  emit $ catAGraphs [
+loadThreadState :: LocalReg -> CmmAGraph
+loadThreadState tso = do
+  -- tso <- newTemp gcWord -- TODO FIXME NOW
+  catAGraphs [
        -- tso = CurrentTSO;
        mkAssign (CmmLocal tso) stgCurrentTSO,
        -- Sp = tso->sp;
@@ -218,16 +202,18 @@ emitLoadThreadState = do
                              bWord),
        -- SpLim = tso->stack + RESERVED_STACK_WORDS;
        mkAssign spLim (cmmOffsetW (cmmOffset (CmmReg (CmmLocal tso)) tso_STACK)
-                                   rESERVED_STACK_WORDS)
-    ]
-  emitOpenNursery
-  -- and load the current cost centre stack from the TSO when profiling:
-  when opt_SccProfilingOn $
-       emit (mkStore curCCSAddr 
-               (CmmLoad (cmmOffset (CmmReg (CmmLocal tso)) tso_CCCS) ccsType))
-
-emitOpenNursery :: FCode ()
-emitOpenNursery = emit $ catAGraphs [
+                                   rESERVED_STACK_WORDS),
+        openNursery,
+        -- and load the current cost centre stack from the TSO when profiling:
+        if opt_SccProfilingOn then
+         mkStore curCCSAddr
+                  (CmmLoad (cmmOffset (CmmReg (CmmLocal tso)) tso_CCCS) ccsType)
+        else mkNop]
+emitLoadThreadState :: LocalReg -> FCode ()
+emitLoadThreadState tso = emit $ loadThreadState tso
+
+openNursery :: CmmAGraph
+openNursery = catAGraphs [
         -- Hp = CurrentNursery->free - 1;
        mkAssign hp (cmmOffsetW (CmmLoad nursery_bdescr_free bWord) (-1)),
 
@@ -246,7 +232,8 @@ emitOpenNursery = emit $ catAGraphs [
                )
            )
    ]
-
+emitOpenNursery :: FCode ()
+emitOpenNursery = emit openNursery
 
 nursery_bdescr_free   = cmmOffset stgCurrentNursery oFFSET_bdescr_free
 nursery_bdescr_start  = cmmOffset stgCurrentNursery oFFSET_bdescr_start
@@ -285,7 +272,7 @@ currentNursery        = CmmGlobal CurrentNursery
 
 getFCallArgs :: [StgArg] -> FCode [(CmmExpr, ForeignHint)]
 -- (a) Drop void args
--- (b) Add foriegn-call shim code
+-- (b) Add foreign-call shim code
 -- It's (b) that makes this differ from getNonVoidArgAmodes
 
 getFCallArgs args
@@ -295,7 +282,7 @@ getFCallArgs args
     get arg | isVoidRep arg_rep 
            = return Nothing
            | otherwise
-           = do { cmm <- getArgAmode arg
+           = do { cmm <- getArgAmode (NonVoid arg)
                 ; return (Just (add_shim arg_ty cmm, hint)) }
            where
              arg_ty  = stgArgType arg
index 6a8a435..3f803d1 100644 (file)
@@ -51,14 +51,14 @@ import Data.List
 
 layOutDynConstr, layOutStaticConstr
        :: DataCon -> [(PrimRep, a)]
-       -> (ClosureInfo, [(a, VirtualHpOffset)])
+       -> (ClosureInfo, [(NonVoid a, VirtualHpOffset)])
 -- No Void arguments in result
 
 layOutDynConstr    = layOutConstr False
 layOutStaticConstr = layOutConstr True
 
 layOutConstr :: Bool -> DataCon -> [(PrimRep, a)]
-            -> (ClosureInfo, [(a, VirtualHpOffset)])
+            -> (ClosureInfo, [(NonVoid a, VirtualHpOffset)])
 layOutConstr is_static data_con args
    = (mkConInfo is_static data_con tot_wds ptr_wds,
       things_w_offsets)
@@ -78,13 +78,16 @@ allocDynClosure
        -> CmmExpr              -- Cost Centre to blame for this alloc
                                -- (usually the same; sometimes "OVERHEAD")
 
-       -> [(StgArg, VirtualHpOffset)]  -- Offsets from start of the object
-                                       -- ie Info ptr has offset zero.
-                                       -- No void args in here
-       -> FCode LocalReg
+       -> [(NonVoid StgArg, VirtualHpOffset)]  -- Offsets from start of the object
+                                               -- ie Info ptr has offset zero.
+                                               -- No void args in here
+       -> FCode (LocalReg, CmmAGraph)
 
 -- allocDynClosure allocates the thing in the heap, 
 -- and modifies the virtual Hp to account for this.
+-- The second return value is the graph that sets the value of the
+-- returned LocalReg, which should point to the closure after executing
+-- the graph.