Big collection of patches for the new codegen branch.

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.

1 files changed, 62 insertions, 77 deletions

diff --git a/compiler/cmm/CmmSpillReload.hs b/compiler/cmm/CmmSpillReload.hs
index 67cf8d31df..be043fe26c 100644
--- a/compiler/cmm/CmmSpillReload.hs
+++ b/compiler/cmm/CmmSpillReload.hs
@@ -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