A few bug fixes; some improvements spurred by paper writing
authordias@eecs.harvard.edu <unknown>
Tue, 3 Mar 2009 15:02:28 +0000 (15:02 +0000)
committerdias@eecs.harvard.edu <unknown>
Tue, 3 Mar 2009 15:02:28 +0000 (15:02 +0000)
Among others:
- Fixed Stg->C-- translation of let-no-escapes -- it's important to use the
  right continuation...
- Fixed infinite recursion in X86 backend (shortcutJump mishandled infinite loops)
- Fixed yet another wrong calling convention -- primops take args only in vanilla regs,
  but they may return results on the stack!
- Removed StackInfo from LGraph and Block -- now in LastCall and CmmZ
- Updated avail-variable and liveness code

33 files changed:
compiler/cmm/Cmm.hs
compiler/cmm/CmmBuildInfoTables.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/CmmLiveZ.hs
compiler/cmm/CmmProcPointZ.hs
compiler/cmm/CmmSpillReload.hs
compiler/cmm/CmmStackLayout.hs
compiler/cmm/CmmZipUtil.hs
compiler/cmm/DFMonad.hs
compiler/cmm/MkZipCfg.hs
compiler/cmm/MkZipCfgCmm.hs
compiler/cmm/OptimizationFuel.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/StgCmm.hs
compiler/codeGen/StgCmmExpr.hs
compiler/codeGen/StgCmmHeap.hs
compiler/codeGen/StgCmmLayout.hs
compiler/codeGen/StgCmmMonad.hs
compiler/codeGen/StgCmmUtils.hs
compiler/main/HscMain.lhs
compiler/nativeGen/X86/RegInfo.hs
validate

index 2ee259c..383ed06 100644 (file)
@@ -135,7 +135,7 @@ cmmTopMapGraphM :: Monad m => (String -> g -> m g') -> GenCmmTop d h g -> m (Gen
 
 cmmMapGraph f (Cmm tops) = Cmm $ map (cmmTopMapGraph f) tops
 cmmTopMapGraph f (CmmProc h l args g) = CmmProc h l args (f g)
-cmmTopMapGraph _ (CmmData s ds)       = CmmData s ds
+cmmTopMapGraph _ (CmmData s ds)             = CmmData s ds
 
 cmmMapGraphM f (Cmm tops) = mapM (cmmTopMapGraphM f) tops >>= return . Cmm
 cmmTopMapGraphM f (CmmProc h l args g) =
index e3d2ded..fa2c009 100644 (file)
@@ -39,7 +39,7 @@ import Panic
 import SMRep
 import StgCmmClosure
 import StgCmmForeign
-import StgCmmMonad
+-- import StgCmmMonad
 import StgCmmUtils
 import UniqSupply
 import ZipCfg hiding (zip, unzip, last)
@@ -130,35 +130,13 @@ setInfoTableStackMap _ _ t@(NoInfoTable _) = t
 setInfoTableStackMap slotEnv areaMap t@(FloatingInfoTable _ bid updfr_off) =
   updInfo (const (live_ptrs updfr_off slotEnv areaMap bid)) id t
 setInfoTableStackMap slotEnv areaMap
-     t@(ProcInfoTable (CmmProc (CmmInfo _ _ infoTbl) _ _ g@(LGraph _ _ blocks))
-                      procpoints) =
+     t@(ProcInfoTable (CmmProc (CmmInfo _ _ _) _ _ ((_, Just updfr_off), _)) procpoints) =
   case blockSetToList procpoints of
-    [bid] ->
-      let oldByte = case infoTbl of
-                         CmmInfoTable _ _ _ (ContInfo _ _) -> 
-                           case lookupBlockEnv blocks bid of
-                              Just (Block _ (StackInfo {returnOff = Just n}) _) -> n
-                              _ -> pprPanic "misformed graph at procpoint" (ppr g)
-                         _ -> initUpdFrameOff -- entry to top-level function
-          stack_vars = live_ptrs oldByte slotEnv areaMap bid
-      in updInfo (const stack_vars) id t
-    _ -> panic "setInfoTableStackMap: unexpect number of procpoints"
+    [bid] -> updInfo (const (live_ptrs updfr_off slotEnv areaMap bid)) id t
+    _ -> panic "setInfoTableStackMap: unexpected number of procpoints"
            -- until we stop splitting the graphs at procpoints in the native path
-setInfoTableStackMap _ _ _ = panic "unexpected case for setInfoTableStackMap"
-{-
-setInfoTableStackMap slotEnv areaMap
-      (Just bid, p@(CmmProc (CmmInfo _ _ infoTbl) _ _ g@(LGraph entry _ blocks))) =
-  let oldByte = case infoTbl of
-                     CmmInfoTable _ _ _ (ContInfo _ _) -> 
-                       case lookupBlockEnv blocks bid of
-                          Just (Block _ (StackInfo {returnOff = Just n}) _) -> n
-                          _ -> pprPanic "misformed graph at procpoint" (ppr g)
-                     _ -> initUpdFrameOff -- entry to top-level function
-      stack_vars = live_ptrs oldByte slotEnv areaMap bid
-  in (Just bid, upd_info_tbl (const stack_vars) id p)
-setInfoTableStackMap _ _ t@(_, CmmData {}) = t
-setInfoTableStackMap _ _ _ = panic "bad args to setInfoTableStackMap"
--}
+setInfoTableStackMap _ _ t = pprPanic "unexpected case for setInfoTableStackMap" (ppr t)
+                 
 
 
 -----------------------------------------------------------------------
@@ -187,9 +165,9 @@ cafLattice = DataflowLattice "live cafs" emptyFM add False
 
 cafTransfers :: BackwardTransfers Middle Last CAFSet
 cafTransfers = BackwardTransfers first middle last
-    where first  live _ = live
-          middle live m = foldExpDeepMiddle addCaf m live
-          last   env  l = foldExpDeepLast addCaf l (joinOuts cafLattice env l)
+    where first  _ live = live
+          middle m live = foldExpDeepMiddle addCaf m live
+          last   l env  = 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
@@ -330,7 +308,7 @@ to_SRT top_srt off len bmp
 -- any CAF that is reachable from c.
 localCAFInfo :: CAFEnv -> CmmTopZ -> Maybe (CLabel, CAFSet)
 localCAFInfo _      (CmmData _ _) = Nothing
-localCAFInfo cafEnv (CmmProc (CmmInfo _ _ infoTbl) top_l _ (LGraph entry _ _)) =
+localCAFInfo cafEnv (CmmProc (CmmInfo _ _ infoTbl) top_l _ (_, LGraph entry _)) =
   case infoTbl of
     CmmInfoTable False _ _ _ ->
       Just (cvtToClosureLbl top_l,
@@ -436,13 +414,13 @@ extendEnvsForSafeForeignCalls :: CAFEnv -> SlotEnv -> CmmGraph -> (CAFEnv, SlotE
 extendEnvsForSafeForeignCalls cafEnv slotEnv g =
   fold_blocks block (cafEnv, slotEnv) g
     where block b z =
-            tail ( bt_last_in cafTransfers      (lookupFn cafEnv)  l
-                 , bt_last_in liveSlotTransfers (lookupFn slotEnv) l)
+            tail ( bt_last_in cafTransfers      l (lookupFn cafEnv)
+                 , bt_last_in liveSlotTransfers l (lookupFn slotEnv))
                  z head
              where (head, last) = goto_end (G.unzip b)
                    l = case last of LastOther l -> l
                                     LastExit -> panic "extendEnvs lastExit"
-          tail _ z (ZFirst _ _) = z
+          tail _ z (ZFirst _) = z
           tail lives@(cafs, slots) (cafEnv, slotEnv)
                (ZHead h m@(MidForeignCall (Safe bid _) _ _ _)) =
             let slots'   = removeLiveSlotDefs slots m
@@ -452,7 +430,7 @@ extendEnvsForSafeForeignCalls cafEnv slotEnv g =
           tail lives z (ZHead h m) = tail (upd lives m) z h
           lookupFn map k = expectJust "extendEnvsForSafeFCalls" $ lookupBlockEnv map k
           upd (cafs, slots) m =
-            (bt_middle_in cafTransfers cafs m, bt_middle_in liveSlotTransfers slots m)
+            (bt_middle_in cafTransfers m cafs, bt_middle_in liveSlotTransfers m slots)
 
 -- Safe foreign calls: We need to insert the code that suspends and resumes
 -- the thread before and after a safe foreign call.
@@ -489,9 +467,9 @@ data SafeState = State { s_blocks    :: BlockEnv CmmBlock
 lowerSafeForeignCalls
   :: [[CmmTopForInfoTables]] -> CmmTopZ -> FuelMonad [[CmmTopForInfoTables]]
 lowerSafeForeignCalls rst t@(CmmData _ _) = return $ [NoInfoTable t] : rst
-lowerSafeForeignCalls rst (CmmProc info l args g@(LGraph entry off _)) = do
+lowerSafeForeignCalls rst (CmmProc info l args (off, g@(LGraph entry _))) = do
   let init = return $ State emptyBlockEnv emptyBlockSet []
-  let block b@(Block bid _ _) z = do
+  let block b@(Block bid _) z = do
         state@(State {s_pps = ppset, s_blocks = blocks}) <- z
         let ppset' = if bid == entry then extendBlockSet ppset bid else ppset
             state' = state { s_pps = ppset' }
@@ -499,13 +477,15 @@ lowerSafeForeignCalls rst (CmmProc info l args g@(LGraph entry off _)) = do
          then lowerSafeCallBlock state' b
          else return (state' { s_blocks = insertBlock b blocks })
   State blocks' g_procpoints safeCalls <- fold_blocks block init g
-  return $ safeCalls
-           : [ProcInfoTable (CmmProc info l args (LGraph entry off blocks')) g_procpoints]
-           : rst
+  let proc = (CmmProc info l args (off, LGraph entry blocks'))
+      procTable = case off of
+                    (_, Just _) -> [ProcInfoTable proc g_procpoints]
+                    _ -> [NoInfoTable proc] -- not a successor of a call
+  return $ safeCalls : procTable : rst
 
 -- Check for foreign calls -- if none, then we can avoid copying the block.
 hasSafeForeignCall :: CmmBlock -> Bool
-hasSafeForeignCall (Block _ t) = tail t
+hasSafeForeignCall (Block _ t) = tail t
   where tail (ZTail (MidForeignCall (Safe _ _) _ _ _) _) = True
         tail (ZTail _ t) = tail t
         tail (ZLast _)   = False
@@ -515,7 +495,7 @@ hasSafeForeignCall (Block _ _ t) = tail t
 lowerSafeCallBlock :: SafeState-> CmmBlock -> FuelMonad SafeState
 lowerSafeCallBlock state b = tail (return state) (ZBlock head (ZLast last))
   where (head, last) = goto_end (G.unzip b)
-        tail s b@(ZBlock (ZFirst _ _) _) =
+        tail s b@(ZBlock (ZFirst _) _) =
           do state <- s
              return $ state { s_blocks = insertBlock (G.zip b) (s_blocks state) }
         tail  s (ZBlock (ZHead h m@(MidForeignCall (Safe bid updfr_off) _ _ _)) t) =
index aac9372..db72c64 100644 (file)
@@ -71,14 +71,16 @@ cpsTop :: HscEnv -> CmmTopZ ->
           IO ([(CLabel, CAFSet)],
               [(CAFSet, CmmTopForInfoTables)])
 cpsTop _ p@(CmmData {}) = return ([], [(emptyFM, NoInfoTable p)])
-cpsTop hsc_env (CmmProc h l args g) =
+cpsTop hsc_env (CmmProc h l args (stackInfo@(entry_off, _), 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
+       -- Why bother doing it this early?
+       -- g <- dual_rewrite Opt_D_dump_cmmz "spills and reloads"
+       --                       (dualLivenessWithInsertion callPPs) g
+       -- g <- run $ insertLateReloads g -- Duplicate reloads just before uses
+       -- 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
@@ -96,23 +98,21 @@ cpsTop hsc_env (CmmProc h l args 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
        mbpprTrace "live slot analysis results: " (ppr slotEnv) $ return ()
        cafEnv <- run $ cafAnal g
        (cafEnv, slotEnv) <- return $ extendEnvsForSafeForeignCalls cafEnv slotEnv g
        mbpprTrace "slotEnv extended for safe foreign calls: " (ppr slotEnv) $ return ()
-       let areaMap = layout procPoints slotEnv g
+       let areaMap = layout procPoints slotEnv entry_off g
        mbpprTrace "areaMap" (ppr areaMap) $ return ()
-       g  <- run $ manifestSP procPoints procPointMap areaMap g
+       g  <- run $ manifestSP areaMap entry_off 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
        dump Opt_D_dump_cmmz "procpoint map" procPointMap
-       gs <- run $ splitAtProcPoints l callPPs procPoints procPointMap areaMap
-                                       (CmmProc h l args g)
+       gs <- run $ splitAtProcPoints l callPPs procPoints procPointMap
+                                       (CmmProc h l args (stackInfo, g))
        mapM (dump Opt_D_dump_cmmz "after splitting") gs
        let localCAFs = catMaybes $ map (localCAFInfo cafEnv) gs
        mbpprTrace "localCAFs" (ppr localCAFs) $ return ()
@@ -125,18 +125,6 @@ cpsTop hsc_env (CmmProc h l args g) =
        let gs'' = map (bundleCAFs cafEnv) gs'
        mapM (dump Opt_D_dump_cmmz "after bundleCAFs") gs''
        return (localCAFs, 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')
-                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)
@@ -157,7 +145,6 @@ toTops hsc_env topCAFEnv (topSRT, tops) gs =
   do let setSRT (topSRT, rst) g =
            do (topSRT, gs) <- setInfoTableSRT topCAFEnv topSRT g
               return (topSRT, gs : rst)
-     (topSRT, gs') <- run $ foldM setSRT (topSRT, []) gs
+     (topSRT, gs') <- runFuelIO (hsc_OptFuel hsc_env) $ foldM setSRT (topSRT, []) gs
      gs' <- mapM finishInfoTables (concat gs')
      return (topSRT, concat gs' : tops)
-  where run = runFuelIO (hsc_OptFuel hsc_env)
index fed3617..243072e 100644 (file)
@@ -56,9 +56,10 @@ assignArgumentsPos conv isCall arg_ty reps = map cvt assignments
     where
       regs = case conv of Native -> getRegs isCall
                           GC     -> getRegs False
-                          PrimOp -> noStack
+                          PrimOp -> if isCall then noStack else getRegs isCall
                           Slow   -> noRegs
-                          _      -> panic "unrecognized calling convention"
+                          _   -> getRegs isCall
+                          -- _      -> panic "unrecognized calling convention"
       (sizes, assignments) = unzip $ assignArguments' reps (sum sizes) regs
       assignArguments' [] _ _ = []
       assignArguments' (r:rs) offset avails =
index c4d612e..4c144cf 100644 (file)
@@ -73,8 +73,8 @@ upd_graph g subst = map_nodes id middle last g
         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' (LastCall t (Just bid) args res u) = LastCall t (Just $ sub bid) args res 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) =
@@ -87,7 +87,7 @@ upd_graph g subst = map_nodes id middle last g
 -- 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_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
@@ -118,7 +118,7 @@ hash_block (Block _ _ t) =
         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 (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 `shiftL` 1
         hash_tail (ZLast (LastOther l)) v = hash_last l + (v `shiftL` 1)
@@ -136,8 +136,7 @@ lookupBid subst bid = case lookupBlockEnv subst bid of
 
 -- 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 _ sinfo t) (Block _ sinfo' t') =
-  sinfo == sinfo' && eqTailWith eqBid t t'
+eqBlockBodyWith eqBid (Block _ t) (Block _ t') = eqTailWith eqBid t t'
 
 type CmmTail = ZTail Middle Last
 eqTailWith :: (BlockId -> BlockId -> Bool) -> CmmTail -> CmmTail -> Bool
@@ -150,8 +149,8 @@ eqLastWith :: (BlockId -> BlockId -> Bool) -> Last -> Last -> Bool
 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 (LastCall t1 c1 a1 r1 u1) (LastCall t2 c2 a2 r2 u2) =
+  t1 == t2 && eqMaybeWith eqBid c1 c2 && a1 == a2 && r1 == r2 && u1 == u2
 eqLastWith eqBid (LastSwitch e1 bs1) (LastSwitch e2 bs2) =
   e1 == e2 && eqLstWith (eqMaybeWith eqBid) bs1 bs2
 eqLastWith _ _ _ = False
index a3239b9..c4d048d 100644 (file)
@@ -16,7 +16,6 @@ import ZipCfgCmmRep
 import Maybes
 import Monad
 import Outputable
-import Panic
 import Prelude hiding (unzip, zip)
 import Util
 
@@ -27,20 +26,25 @@ runCmmContFlowOptsZs prog
     | cmm_top <- prog ]
 
 cmmCfgOpts  :: Tx (ListGraph CmmStmt)
-cmmCfgOptsZ :: Tx CmmGraph
+cmmCfgOptsZ :: Tx (a, CmmGraph)
 
 cmmCfgOpts  = branchChainElim  -- boring, but will get more exciting later
 cmmCfgOptsZ g =
+  optGraph
     (branchChainElimZ `seqTx` blockConcatZ `seqTx` removeUnreachableBlocksZ) g
         -- Here branchChainElim can ultimately be replaced
         -- with a more exciting combination of optimisations
 
 runCmmOpts :: Tx g -> Tx (GenCmm d h g)
-runCmmOpts opt = mapProcs (optGraph opt)
+runCmmOpts opt = mapProcs (optProc opt)
 
-optGraph :: Tx g -> Tx (GenCmmTop d h g)
-optGraph _   top@(CmmData {}) = noTx top
-optGraph opt (CmmProc info lbl formals g) = fmap (CmmProc info lbl formals) (opt g)
+optProc :: Tx g -> Tx (GenCmmTop d h g)
+optProc _   top@(CmmData {}) = noTx top
+optProc opt (CmmProc info lbl formals g) =
+  fmap (CmmProc info lbl formals) (opt g)
+
+optGraph :: Tx g -> Tx (a, g)
+optGraph opt (a, g) = fmap (\g' -> (a, g')) (opt g)
 
 ------------------------------------
 mapProcs :: Tx (GenCmmTop d h s) -> Tx (GenCmm d h s)
@@ -80,28 +84,25 @@ replaceLabels env (BasicBlock id stmts)
 branchChainElimZ :: Tx CmmGraph
 -- Remove any basic block of the form L: goto L',
 -- and replace L with L' everywhere else
-branchChainElimZ g@(G.LGraph eid args _)
+branchChainElimZ g@(G.LGraph eid _)
   | null lone_branch_blocks     -- No blocks to remove
   = noTx g
   | otherwise
-  = aTx $ replaceLabelsZ env $ G.of_block_list eid args (self_branches ++ others)
+  = aTx $ replaceLabelsZ env $ G.of_block_list eid (self_branches ++ others)
   where
     (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 emptyStackInfo (G.ZLast (G.mkBranchNode id)))
+              Just (G.Block id (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 (StackInfo {argBytes = Nothing, returnOff = Nothing})
-              (G.ZLast (G.LastOther (LastBranch target))))
+isLoneBranchZ (G.Block id (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!
@@ -109,13 +110,13 @@ isLoneBranchZ other = Right other
 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
+    replace_eid (G.LGraph eid blocks) = G.LGraph (lookup eid) blocks
     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
+    last' (LastCall t k a res r) = LastCall t (liftM lookup k) a res r
     exp (CmmLit (CmmBlock bid)) = CmmLit (CmmBlock (lookup bid))
     exp   (CmmStackSlot (CallArea (Young id)) i) =
       CmmStackSlot (CallArea (Young (lookup id))) i
@@ -136,7 +137,7 @@ replaceBranches env g = map_nodes id id last g
 predMap :: G.LastNode l => G.LGraph m l -> BlockEnv BlockSet
 predMap g = G.fold_blocks add_preds emptyBlockEnv g -- find the back edges
   where add_preds b env = foldl (add b) env (G.succs b)
-        add (G.Block bid _ _) env b' =
+        add (G.Block bid _) env b' =
           extendBlockEnv env b' $
                 extendBlockSet (lookupBlockEnv env b' `orElse` emptyBlockSet) bid
 ----------------------------------------------------------------
@@ -153,11 +154,11 @@ predMap g = G.fold_blocks add_preds emptyBlockEnv g -- find the back edges
 blockConcatZ  :: Tx CmmGraph
 blockConcatZ = removeUnreachableBlocksZ `seqTx` blockConcatZ'
 blockConcatZ' :: Tx CmmGraph
-blockConcatZ' g@(G.LGraph eid off blocks) =
-  tx $ replaceLabelsZ concatMap $ G.LGraph eid off blocks'
+blockConcatZ' g@(G.LGraph eid blocks) =
+  tx $ replaceLabelsZ concatMap $ G.LGraph eid blocks'
   where (changed, blocks', concatMap) =
            foldr maybe_concat (False, blocks, emptyBlockEnv) $ G.postorder_dfs g
-        maybe_concat b@(G.Block bid _ _) (changed, blocks', concatMap) =
+        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')) ->
@@ -167,17 +168,11 @@ blockConcatZ' g@(G.LGraph eid off blocks) =
                   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
+        canConcatWith b' = num_preds b' == 1
         backEdges = predMap g
         splice blocks' h bid' =
           case lookupBlockEnv blocks' bid' of
-            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"
+            Just (G.Block _ t) -> G.zip $ G.ZBlock h t
             Nothing -> pprPanic "unknown successor block" (ppr bid' <+> ppr blocks' <+> ppr blocks)
         tx = if changed then aTx else noTx
 ----------------------------------------------------------------
@@ -197,7 +192,7 @@ mkClosureBlockEnvZ blocks = mkBlockEnv $ map follow blocks
                                _ -> id
 ----------------------------------------------------------------
 removeUnreachableBlocksZ :: Tx CmmGraph
-removeUnreachableBlocksZ g@(G.LGraph id off blocks) =
-  if length blocks' < sizeBEnv blocks then aTx $ G.of_block_list id off blocks'
+removeUnreachableBlocksZ g@(G.LGraph id blocks) =
+  if length blocks' < sizeBEnv blocks then aTx $ G.of_block_list id blocks'
   else noTx g
     where blocks' = G.postorder_dfs g
index f3c05b8..09d5cd5 100644 (file)
@@ -22,24 +22,27 @@ import UniqSupply
 
 import Maybe
 
-cmmToZgraph :: GenCmm d h (ListGraph CmmStmt) -> UniqSM (GenCmm d h CmmGraph)
-cmmOfZgraph :: GenCmm d h (CmmGraph)          ->         GenCmm d h (ListGraph CmmStmt)
+cmmToZgraph :: GenCmm d h (ListGraph CmmStmt) -> UniqSM (GenCmm d h (CmmStackInfo, CmmGraph))
+cmmOfZgraph :: GenCmm d h (CmmStackInfo, CmmGraph)          ->         GenCmm d h (ListGraph CmmStmt)
 
 cmmToZgraph (Cmm tops) = liftM Cmm $ mapM mapTop tops
   where mapTop (CmmProc h l args g) =
           toZgraph (showSDoc $ ppr l) args g >>= return . CmmProc h l args
         mapTop (CmmData s ds) = return $ CmmData s ds
-cmmOfZgraph = cmmMapGraph ofZgraph
+cmmOfZgraph = cmmMapGraph (ofZgraph . snd)
 
-toZgraph :: String -> CmmFormals -> ListGraph CmmStmt -> UniqSM CmmGraph
-toZgraph _ _ (ListGraph []) = lgraphOfAGraph 0 emptyAGraph
+toZgraph :: String -> CmmFormals -> ListGraph CmmStmt -> UniqSM (CmmStackInfo, CmmGraph)
+toZgraph _ _ (ListGraph []) =
+  do g <- lgraphOfAGraph emptyAGraph
+     return ((0, Nothing), g)
 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
+           do g <- labelAGraph id $
+                     entry <*> mkStmts ss <*> foldr addBlock emptyAGraph other_blocks
+              return ((offset, Nothing), g)
   where addBlock (BasicBlock id ss) g =
-          mkLabel id emptyStackInfo <*> mkStmts ss <*> g
-        updfr_sz = panic "upd frame size lost in cmm conversion"
+          mkLabel id <*> mkStmts ss <*> g
+        updfr_sz = 0 -- 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
@@ -106,11 +109,11 @@ ofZgraph g = ListGraph $ swallow blocks
           extend_block _id stmts = stmts
           _extend_entry stmts = scomment showblocks : scomment cscomm : stmts
           showblocks = "LGraph has " ++ show (length blocks) ++ " blocks:" ++
-                       concat (map (\(G.Block id _ _) -> " " ++ show id) blocks)
+                       concat (map (\(G.Block id _) -> " " ++ show id) blocks)
           cscomm = "Call successors are" ++
                    (concat $ map (\id -> " " ++ show id) $ blockSetToList call_succs)
           swallow [] = []
-          swallow (G.Block id t : rest) = tail id [] t rest
+          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
           tail id prev' (G.ZLast G.LastExit)      rest = exit id prev' rest
           tail id prev' (G.ZLast (G.LastOther l)) rest = last id prev' l rest
@@ -139,7 +142,7 @@ ofZgraph g = ListGraph $ swallow blocks
                     _ -> endblock (CmmBranch tgt)
               LastCondBranch expr tid fid ->
                   case n of
-                    G.Block id' t : bs
+                    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' ->
@@ -152,11 +155,11 @@ ofZgraph g = ListGraph $ swallow blocks
                     _ -> let instrs' = CmmBranch fid : CmmCondBranch expr tid : prev'
                          in block' id instrs' : swallow n
               LastSwitch arg ids   -> endblock $ CmmSwitch arg $ ids
-              LastCall e _ _ _ -> endblock $ CmmJump e []
+              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")
-                        G.Block id' t : bs -> 
+                        G.Block id' t : bs -> 
                             if unique_pred id' then
                                 tail id (scomment "went thru exit" : prev') t bs 
                             else
@@ -175,7 +178,7 @@ ofZgraph g = ListGraph $ swallow blocks
           call_succs = 
               let add b succs =
                       case G.last (G.unzip b) of
-                        G.LastOther (LastCall _ (Just id) _ _) ->
+                        G.LastOther (LastCall _ (Just id) _ _ _) ->
                           extendBlockSet succs id
                         _ -> succs
               in  G.fold_blocks add emptyBlockSet g
index 8e40654..7ea1c47 100644 (file)
@@ -22,7 +22,7 @@ module CmmExpr
     , DefinerOfSlots, UserOfSlots, foldSlotsDefd, foldSlotsUsed
     , RegSet, emptyRegSet, elemRegSet, extendRegSet, deleteFromRegSet, mkRegSet
             , plusRegSet, minusRegSet, timesRegSet
-    , Area(..), AreaId(..), SubArea, SubAreaSet, AreaMap, StackSlotMap, getSlot
+    , Area(..), AreaId(..), SubArea, SubAreaSet, AreaMap, isStackSlotOf
  
    -- MachOp
     , MachOp(..) 
@@ -263,23 +263,14 @@ instance DefinerOfLocalRegs a => DefinerOfLocalRegs (Maybe a) where
 --    Stack slots
 -----------------------------------------------------------------------------
 
-mkVarSlot :: LocalReg -> CmmExpr
-mkVarSlot r = CmmStackSlot (RegSlot r) 0
-
--- Usually, we either want to lookup a variable's spill slot in an environment
--- or else allocate it and add it to the environment.
--- For a variable, we just need a single area of the appropriate size.
-type StackSlotMap = FiniteMap LocalReg CmmExpr
-getSlot :: StackSlotMap -> LocalReg -> (StackSlotMap, CmmExpr)
-getSlot map r = case lookupFM map r of
-                  Just s  -> (map, s)
-                  Nothing -> (addToFM map r s, s) where s = mkVarSlot r
+isStackSlotOf :: CmmExpr -> LocalReg -> Bool
+isStackSlotOf (CmmStackSlot (RegSlot r) _) r' = r == r'
+isStackSlotOf _ _ = False
 
 -----------------------------------------------------------------------------
 --    Stack slot use information for expressions and other types [_$_]
 -----------------------------------------------------------------------------
 
-
 -- Fold over the area, the offset into the area, and the width of the subarea.
 class UserOfSlots a where
   foldSlotsUsed :: (b -> SubArea -> b) -> b -> a -> b
index de6e201..734896a 100644 (file)
@@ -21,10 +21,10 @@ import SMRep
 import ZipCfgCmmRep
 
 import Constants
+import Panic
 import StaticFlags
 import Unique
 import UniqSupply
-import Panic
 
 import Data.Bits
 
index 70bd51b..3d8f570 100644 (file)
@@ -3,7 +3,7 @@ module CmmLiveZ
     ( CmmLive
     , cmmLivenessZ
     , liveLattice
-    , middleLiveness, lastLiveness, noLiveOnEntry
+    , middleLiveness, noLiveOnEntry
     ) 
 where
 
@@ -43,17 +43,22 @@ type BlockEntryLiveness = BlockEnv CmmLive
 -- | Calculated liveness info for a CmmGraph
 -----------------------------------------------------------------------------
 cmmLivenessZ :: CmmGraph -> FuelMonad BlockEntryLiveness
-cmmLivenessZ g@(LGraph entry _ _) =
+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  =
+        transfers = BackwardTransfers (flip const) mid last
+        mid  m = gen_kill m . midLive  m
+        last l = gen_kill l . lastLive l 
+        check facts   =
           noLiveOnEntry entry (expectJust "check" $ lookupBlockEnv facts entry) facts
 
+gen_kill :: (DefinerOfLocalRegs a, UserOfLocalRegs a) => a -> CmmLive -> CmmLive
+gen_kill a = gen a . kill a
+
+middleLiveness :: Middle -> CmmLive -> CmmLive
+middleLiveness = gen_kill
+
 -- | 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 =
@@ -62,22 +67,18 @@ noLiveOnEntry bid in_fact x =
 
 -- | The transfer equations use the traditional 'gen' and 'kill'
 -- notations, which should be familiar from the dragon book.
-gen, kill :: UserOfLocalRegs a => a -> RegSet -> RegSet
-gen  a live = foldRegsUsed extendRegSet      live a
-kill a live = foldRegsUsed delOneFromUniqSet live a
+gen  :: UserOfLocalRegs    a => a -> RegSet -> RegSet
+gen  a live = foldRegsUsed    extendRegSet      live a
+kill :: DefinerOfLocalRegs a => a -> RegSet -> RegSet
+kill a live = foldRegsDefd delOneFromUniqSet live a
 
--- Why aren't these function using the typeclasses on Middle and Last?
-middleLiveness :: Middle -> CmmLive -> CmmLive
-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
+midLive :: Middle -> CmmLive -> CmmLive
+midLive (MidForeignCall {}) _ = emptyUniqSet
+midLive _                live = live
 
-lastLiveness :: Last -> (BlockId -> CmmLive) -> CmmLive
-lastLiveness l env = last l
-  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)
+lastLive :: Last -> (BlockId -> CmmLive) -> CmmLive
+lastLive l env = last l
+  where last (LastBranch id)        = env id
+        last (LastCall _ _  _ _ _)  = emptyUniqSet
+        last (LastCondBranch _ t f) = unionUniqSets (env t) (env f)
+        last (LastSwitch _ tbl)     = unionManyUniqSets $ map env (catMaybes tbl)
index 712461d..5ec65c5 100644 (file)
@@ -119,11 +119,11 @@ 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 $ unitBlockSet id
-          first  x _ = x
-          middle x _ = x
-          last _ (LastCall _ (Just id) _ _) = LastOutFacts [(id, ProcPoint)]
-          last x l = LastOutFacts $ map (\id -> (id, x)) (succs l)
+    where first id ProcPoint = ReachedBy $ unitBlockSet id
+          first  _ x = x
+          middle _ x = x
+          last (LastCall _ (Just id) _ _ _) _ = LastOutFacts [(id, ProcPoint)]
+          last l x = LastOutFacts $ map (\id -> (id, x)) (succs l)
           exit x   = x
                 
 -- It is worth distinguishing two sets of proc points:
@@ -134,7 +134,7 @@ minimalProcPointSet :: ProcPointSet -> CmmGraph -> FuelMonad ProcPointSet
 
 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
+                      LastOther (LastCall _ (Just k) _ _ _) -> extendBlockSet set k
                       _ -> set
 
 minimalProcPointSet callProcPoints g = extendPPSet g (postorder_dfs g) callProcPoints
@@ -159,7 +159,7 @@ extendPPSet g blocks procPoints =
            procPoints' = fold_blocks add emptyBlockSet g
            newPoints = mapMaybe ppSuccessor blocks
            newPoint  = listToMaybe newPoints 
-           ppSuccessor b@(Block bid _ _) =
+           ppSuccessor b@(Block bid _) =
                let nreached id = case lookupBlockEnv env id `orElse`
                                        pprPanic "no ppt" (ppr id <+> ppr b) of
                                    ProcPoint -> 1
@@ -246,15 +246,14 @@ addProcPointProtocols callPPs procPoints g =
   do liveness <- cmmLivenessZ g
      (protos, g') <- optimize_calls liveness g
      blocks'' <- add_CopyOuts protos procPoints g'
-     return $ LGraph (lg_entry g) (lg_argoffset g) blocks''
+     return $ LGraph (lg_entry g) blocks''
     where optimize_calls liveness g =  -- see Note [Separate Adams optimization]
             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)
+               let g' = LGraph (lg_entry 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)
@@ -263,10 +262,11 @@ 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) u s))
+                (h, LastOther (LastCall tgt (Just k) args res s))
                     | Just proto <- lookupBlockEnv protos k,
                       Just pee   <- branchesToProcPoint k
-                    -> let newblock = zipht h (tailOfLast (LastCall tgt (Just pee) u s))
+                    -> let newblock = zipht h (tailOfLast (LastCall tgt (Just pee)
+                                                                    args res s))
                            changed_blocks   = insertBlock newblock blocks
                            unchanged_blocks = insertBlock block    blocks
                        in case lookupBlockEnv protos pee of
@@ -279,7 +279,7 @@ addProcPointProtocols callPPs procPoints g =
           branchesToProcPoint :: BlockId -> Maybe BlockId
           -- ^ Tells whether the named block is just a branch to a proc point
           branchesToProcPoint id =
-              let (Block _ t) = lookupBlockEnv (lg_blocks g) id `orElse`
+              let (Block _ t) = lookupBlockEnv (lg_blocks g) id `orElse`
                                     panic "branch out of graph"
               in case t of
                    ZLast (LastOther (LastBranch pee))
@@ -290,6 +290,8 @@ addProcPointProtocols callPPs procPoints g =
           --maybe_add_proto (Block id (ZTail (CopyIn c _ fs _srt) _)) env =
           --    extendBlockEnv env id (Protocol c fs $ toArea id fs)
           maybe_add_proto _ env = env
+          -- JD: Is this proto stuff even necessary, now that we have
+          -- common blockification?
 
 -- | For now, following a suggestion by Ben Lippmeier, we pass all
 -- live variables as arguments, hoping that a clever register
@@ -322,18 +324,14 @@ 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))
+    where maybe_insert_CopyIns (_, b@(Block id 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)
+           = case lookupBlockEnv protos id of
+               Just (Protocol c fs _area) ->
+                 do LGraph _ blocks <-
+                      lgraphOfAGraph (mkLabel id <*> copyInSlot c False fs <*> mkZTail t)
                     return (map snd $ blockEnvToList blocks)
-               (_, Nothing) -> return [b]
+               Nothing -> return [b]
            | otherwise = return [b]
 
 -- | Add a CopyOut node before each procpoint.
@@ -347,30 +345,28 @@ add_CopyOuts :: BlockEnv Protocol -> ProcPointSet -> CmmGraph ->
 add_CopyOuts protos procPoints g = fold_blocks mb_copy_out (return emptyBlockEnv) g
     where mb_copy_out :: CmmBlock -> FuelMonad (BlockEnv CmmBlock) ->
                                      FuelMonad (BlockEnv CmmBlock)
-          mb_copy_out b@(Block bid _ _) z | bid == lg_entry g = skip b z 
+          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
-              _ -> mb_copy_out' b z
-          mb_copy_out' b z = fold_succs trySucc b init >>= finish
+              LastOther (LastCall _ _ _ _ _) -> skip b z -- copy out done by callee
+              _ -> copy_out b z
+          copy_out b z = fold_succs trySucc b init >>= finish
             where init = z >>= (\bmap -> return (b, bmap))
                   trySucc succId z =
                     if elemBlockSet succId procPoints then
                       case lookupBlockEnv protos succId of
                         Nothing -> z
-                        Just (Protocol c fs area) ->
-                          let (_, copies) =
-                                copyOut c Jump area (map (CmmReg . CmmLocal) fs) 0
-                          in  insert z succId copies
+                        Just (Protocol c fs _area) ->
+                          insert z succId $ copyOutSlot c Jump fs
                     else z
                   insert z succId m =
                     do (b, bmap) <- z
                        (b, bs)   <- insertBetween b m succId
                        -- pprTrace "insert for succ" (ppr succId <> ppr m) $ do
                        return $ (b, foldl (flip insertBlock) bmap bs)
-                  finish (b@(Block bid _ _), bmap) =
+                  finish (b@(Block bid _), bmap) =
                     return $ (extendBlockEnv bmap bid b)
-          skip b@(Block bid _ _) bs =
+          skip b@(Block bid _) bs =
             bs >>= (\bmap -> return (extendBlockEnv bmap bid b))
 
 -- At this point, we have found a set of procpoints, each of which should be
@@ -384,12 +380,12 @@ 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 ->
-                     AreaMap -> CmmTopZ -> FuelMonad [CmmTopZ]
-splitAtProcPoints entry_label callPPs procPoints procMap _areaMap
+                     CmmTopZ -> FuelMonad [CmmTopZ]
+splitAtProcPoints entry_label callPPs procPoints procMap
                   (CmmProc (CmmInfo gc upd_fr info_tbl) top_l top_args
-                           g@(LGraph entry e_off blocks)) =
+                           (stackInfo, g@(LGraph entry blocks))) =
   do -- Build a map from procpoints to the blocks they reach
-     let addBlock b@(Block bid _ _) graphEnv =
+     let addBlock b@(Block bid _) graphEnv =
            case lookupBlockEnv procMap bid of
              Just ProcPoint -> add graphEnv bid bid b
              Just (ReachedBy set) ->
@@ -401,25 +397,32 @@ splitAtProcPoints entry_label callPPs procPoints procMap _areaMap
          add graphEnv procId bid b = extendBlockEnv graphEnv procId graph'
                where graph  = lookupBlockEnv graphEnv procId `orElse` emptyBlockEnv
                      graph' = extendBlockEnv graph bid b
-     graphEnv_pre <- return $ fold_blocks addBlock emptyBlockEnv g
-     graphEnv <- {- pprTrace "graphEnv" (ppr graphEnv_pre) -} return graphEnv_pre
+     graphEnv <- return $ fold_blocks addBlock emptyBlockEnv g
      -- Build a map from proc point BlockId to labels for their new procedures
+     -- Due to common blockification, we may overestimate the set of procpoints.
      let add_label map pp = return $ addToFM map pp lbl
            where lbl = if pp == entry then entry_label else blockLbl pp
-     -- Due to common blockification, we may overestimate the set of procpoints.
      procLabels <- foldM add_label emptyFM
                          (filter (elemBlockEnv blocks) (blockSetToList procPoints))
+     -- For each procpoint, we need to know the SP offset on entry.
+     -- If the procpoint is:
+     --  - continuation of a call, the SP offset is in the call
+     --  - otherwise, 0 -- no overflow for passing those variables
+     let add_sp_off b env =
+           case last (unzip b) of
+             LastOther (LastCall {cml_cont = Just succ, cml_ret_args = off,
+                                  cml_ret_off = updfr_off}) ->
+               extendBlockEnv env succ (off, updfr_off)
+             _ -> env
+         spEntryMap = fold_blocks add_sp_off (mkBlockEnv [(entry, stackInfo)]) g
+         getStackInfo id = lookupBlockEnv spEntryMap id `orElse` (0, Nothing)
      -- 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 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
+              let b = Block bid (ZLast (LastOther jump))
+                  (argSpace, _) = getStackInfo pp
+                  jump = LastCall (CmmLit (CmmLabel l')) Nothing argSpace 0 Nothing
                   l' = if elemBlockSet pp callPPs then entryLblToInfoLbl l else l
               return (extendBlockEnv env pp bid, b : bs)
          add_jumps (newGraphEnv) (ppId, blockEnv) =
@@ -435,30 +438,20 @@ splitAtProcPoints entry_label callPPs procPoints procMap _areaMap
                   add_if_pp id rst = case lookupFM procLabels id of
                                        Just x -> (id, x) : rst
                                        Nothing -> rst
-                     -- fmToList procLabels
               (jumpEnv, jumpBlocks) <-
                  foldM add_jump_block (emptyBlockEnv, []) needed_jumps
                   -- update the entry block
-              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"
+              let b = expectJust "block in env" $ lookupBlockEnv blockEnv ppId
+                  off = getStackInfo ppId
                   blockEnv' = extendBlockEnv blockEnv ppId b
-                  off = if ppId == entry then e_off else b_off
                   -- replace branches to procpoints with branches to jumps
-                  LGraph _ _ blockEnv'' = 
-                    replaceBranches jumpEnv $ LGraph ppId off blockEnv'
+                  LGraph _ blockEnv'' = replaceBranches jumpEnv $ LGraph ppId blockEnv'
                   -- add the jump blocks to the graph
                   blockEnv''' = foldl (flip insertBlock) blockEnv'' jumpBlocks
-              let g' = LGraph ppId off blockEnv'''
+              let g' = (off, LGraph ppId blockEnv''')
               -- pprTrace "g' pre jumps" (ppr g') $ do
               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
+     graphEnv <- foldM add_jumps emptyBlockEnv $ blockEnvToList graphEnv
      let to_proc (bid, g) | elemBlockSet bid callPPs =
            if bid == entry then 
              CmmProc (CmmInfo gc upd_fr info_tbl) top_l top_args g
@@ -471,7 +464,7 @@ splitAtProcPoints entry_label callPPs procPoints procMap _areaMap
      -- 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)
+         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')
@@ -479,7 +472,7 @@ splitAtProcPoints entry_label callPPs procPoints procMap _areaMap
      return -- pprTrace "procLabels" (ppr procLabels)
             -- pprTrace "splitting graphs" (ppr procs)
             procs
-splitAtProcPoints _ _ _ _ t@(CmmData _ _) = return [t]
+splitAtProcPoints _ _ _ _ t@(CmmData _ _) = return [t]
 
 ----------------------------------------------------------------
 
index be570f2..085dc37 100644 (file)
@@ -77,7 +77,7 @@ dualLiveLattice =
 type LiveReloadFix a = FuelMonad (BackwardFixedPoint Middle Last DualLive a)
 
 dualLivenessWithInsertion :: BlockSet -> (LGraph Middle Last) -> FuelMonad (LGraph Middle Last)
-dualLivenessWithInsertion procPoints g@(LGraph entry _ _) =
+dualLivenessWithInsertion procPoints g@(LGraph entry _) =
   liftM zdfFpContents $ (res :: LiveReloadFix (LGraph Middle Last))
     where res = zdfBRewriteFromL RewriteDeep emptyBlockEnv "dual liveness with insertion"
                                  dualLiveLattice (dualLiveTransfers entry procPoints)
@@ -85,7 +85,7 @@ dualLivenessWithInsertion procPoints g@(LGraph entry _ _) =
           empty = fact_bot dualLiveLattice
 
 dualLiveness :: BlockSet -> LGraph Middle Last -> FuelMonad (BlockEnv DualLive)
-dualLiveness procPoints g@(LGraph entry _ _) =
+dualLiveness procPoints g@(LGraph entry _) =
   liftM zdfFpFacts $ (res :: LiveReloadFix ())
     where res = zdfSolveFromL emptyBlockEnv "dual liveness" dualLiveLattice
                               (dualLiveTransfers entry procPoints) empty g
@@ -95,15 +95,15 @@ dualLiveTransfers :: BlockId -> BlockSet -> BackwardTransfers Middle Last DualLi
 dualLiveTransfers entry procPoints = BackwardTransfers first middle last
     where last   = lastDualLiveness
           middle = middleDualLiveness
-          first live id = check live id $  -- live at procPoint => spill
+          first id live = 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 =
+middleDualLiveness :: Middle -> DualLive -> DualLive
+middleDualLiveness m live =
   changeStack updSlots $ changeRegs (middleLiveness m) (changeRegs regs_in live)
     where regs_in live = case m of MidForeignCall {} -> emptyRegSet
                                    _ -> live
@@ -116,11 +116,11 @@ middleDualLiveness live m =
              | o == w && w == widthInBytes (typeWidth ty) = x
           check _ _ = panic "middleDualLiveness unsupported: slices"
 
-lastDualLiveness :: (BlockId -> DualLive) -> Last -> DualLive
-lastDualLiveness env l = last l
+lastDualLiveness :: Last -> (BlockId -> DualLive) -> DualLive
+lastDualLiveness l env = last l
   where last (LastBranch id)          = env id
-        last l@(LastCall _ Nothing  _ _) = changeRegs (gen l . kill l) empty
-        last l@(LastCall _ (Just k) _ _) = 
+        last l@(LastCall _ Nothing  _ _ _) = changeRegs (gen l . kill l) empty
+        last l@(LastCall _ (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)
@@ -145,15 +145,15 @@ insertSpillAndReloadRewrites entry procPoints =
     where middle = middleInsertSpillsAndReloads
           last _ _ = Nothing
           exit     = Nothing
-          first live id =
+          first id live =
             if id /= entry && elemBlockSet id procPoints then
               case map reload (uniqSetToList (in_regs live)) of
                 [] -> Nothing
                 is -> Just (mkMiddles is)
             else Nothing
 
-middleInsertSpillsAndReloads :: DualLive -> Middle -> Maybe (AGraph Middle Last)
-middleInsertSpillsAndReloads live m = middle m
+middleInsertSpillsAndReloads :: Middle -> DualLive -> Maybe (AGraph Middle Last)
+middleInsertSpillsAndReloads m live = middle m
   where middle (MidAssign (CmmLocal reg) (CmmLoad (CmmStackSlot (RegSlot reg') _) _))
           | reg == reg' = Nothing
         middle (MidAssign (CmmLocal reg) _) = 
@@ -177,10 +177,6 @@ spill, reload :: LocalReg -> Middle
 spill  r = MidStore  (regSlot r) (CmmReg $ CmmLocal r)
 reload r = MidAssign (CmmLocal r) (CmmLoad (regSlot r) $ localRegType r)
 
-reloadTail :: RegSet       -> ZTail Middle Last -> ZTail Middle Last
-reloadTail regset t = foldl rel t $ uniqSetToList regset
-  where rel t r = ZTail (reload r) t
-
 ----------------------------------------------------------------
 --- sinking reloads
 
@@ -196,7 +192,6 @@ data AvailRegs = UniverseMinus RegSet
 
 availRegsLattice :: DataflowLattice AvailRegs
 availRegsLattice = DataflowLattice "register gotten from reloads" empty add False
-                            -- last True <==> debugging on
     where empty = UniverseMinus emptyRegSet
           -- | compute in the Tx monad to track whether anything has changed
           add new old =
@@ -216,89 +211,79 @@ smallerAvail (UniverseMinus _) (AvailRegs     _)  = False
 smallerAvail (AvailRegs     s) (AvailRegs    s')  = sizeUniqSet s < sizeUniqSet s'
 smallerAvail (UniverseMinus s) (UniverseMinus s') = sizeUniqSet s > sizeUniqSet s'
 
---extendAvail :: AvailRegs -> LocalReg -> AvailRegs
---extendAvail (UniverseMinus s) r = UniverseMinus (deleteFromRegSet s r)
---extendAvail (AvailRegs     s) r = AvailRegs (extendRegSet s r)
+extendAvail :: AvailRegs -> LocalReg -> AvailRegs
+extendAvail (UniverseMinus s) r = UniverseMinus (deleteFromRegSet s r)
+extendAvail (AvailRegs     s) r = AvailRegs (extendRegSet s r)
 
-deleteFromAvail :: AvailRegs -> LocalReg -> AvailRegs
-deleteFromAvail (UniverseMinus s) r = UniverseMinus (extendRegSet s r)
-deleteFromAvail (AvailRegs     s) r = AvailRegs (deleteFromRegSet s r)
+delFromAvail :: AvailRegs -> LocalReg -> AvailRegs
+delFromAvail (UniverseMinus s) r = UniverseMinus (extendRegSet s r)
+delFromAvail (AvailRegs     s) r = AvailRegs (deleteFromRegSet s r)
 
 elemAvail :: AvailRegs -> LocalReg -> Bool
 elemAvail (UniverseMinus s) r = not $ elemRegSet r s
 elemAvail (AvailRegs     s) r = elemRegSet r s
 
-type CmmAvail = BlockEnv AvailRegs
 type AvailFix = FuelMonad (ForwardFixedPoint Middle Last AvailRegs ())
 
-cmmAvailableReloads :: LGraph Middle Last -> FuelMonad CmmAvail
+cmmAvailableReloads :: LGraph Middle Last -> FuelMonad (BlockEnv AvailRegs)
 cmmAvailableReloads g = liftM zdfFpFacts $ (res :: AvailFix)
     where res = zdfSolveFromL emptyBlockEnv "available reloads" availRegsLattice
                               avail_reloads_transfer empty g
           empty = fact_bot availRegsLattice
 
 avail_reloads_transfer :: ForwardTransfers Middle Last AvailRegs
-avail_reloads_transfer = ForwardTransfers first middle last id
-  where first avail _ = avail
-        middle        = flip middleAvail
-        last          = lastAvail
-
--- | The transfer equations use the traditional 'gen' and 'kill'
--- notations, which should be familiar from the dragon book.
---agen, 
-akill :: UserOfLocalRegs a => a -> AvailRegs -> AvailRegs
---agen  a live = foldRegsUsed extendAvail     live a
-akill a live = foldRegsUsed deleteFromAvail live a
-
--- Note: you can't sink the reload past a use.
-middleAvail :: Middle -> AvailRegs -> AvailRegs
-middleAvail m = middle m
-  where middle m live = middle' m $ foldRegsUsed deleteFromAvail live m
-        middle' (MidComment {})       live = live
-        middle' (MidAssign lhs _expr) live = akill lhs live
-        middle' (MidStore {})         live = live
-        middle' (MidForeignCall {})   _    = AvailRegs emptyRegSet
+avail_reloads_transfer = ForwardTransfers (flip const) middleAvail lastAvail id
 
-lastAvail :: AvailRegs -> Last -> LastOutFacts AvailRegs
-lastAvail _ (LastCall _ (Just k) _ _) = LastOutFacts [(k, AvailRegs emptyRegSet)]
-lastAvail avail l = LastOutFacts $ map (\id -> (id, avail)) $ succs l
+middleAvail :: Middle -> AvailRegs -> AvailRegs
+middleAvail (MidAssign (CmmLocal r) (CmmLoad l _)) avail
+               | l `isStackSlotOf` r = extendAvail avail r
+middleAvail (MidAssign lhs _)        avail = foldRegsDefd delFromAvail avail lhs
+middleAvail (MidStore l (CmmReg (CmmLocal r))) avail
+               | l `isStackSlotOf` r = avail
+middleAvail (MidStore (CmmStackSlot (RegSlot r) _) _) avail = delFromAvail avail r
+middleAvail (MidStore {})            avail = avail
+middleAvail (MidForeignCall {})      _     = AvailRegs emptyRegSet
+middleAvail (MidComment {})          avail = avail
+
+lastAvail :: Last -> AvailRegs -> LastOutFacts AvailRegs
+lastAvail (LastCall _ (Just k) _ _ _) _ = LastOutFacts [(k, AvailRegs emptyRegSet)]
+lastAvail l avail = LastOutFacts $ map (\id -> (id, avail)) $ succs l
 
 type LateReloadFix = FuelMonad (ForwardFixedPoint Middle Last AvailRegs CmmGraph)
 
+availRewrites :: ForwardRewrites Middle Last AvailRegs
+availRewrites = ForwardRewrites first middle last exit
+  where first _ _ = Nothing
+        middle m avail = maybe_reload_before avail m (mkMiddle m)
+        last   l avail = maybe_reload_before avail l (mkLast l)
+        exit _ = Nothing
+        maybe_reload_before avail node tail =
+            let used = filterRegsUsed (elemAvail avail) node
+            in  if isEmptyUniqSet used then Nothing
+                else Just $ reloadTail used tail
+        reloadTail regset t = foldl rel t $ uniqSetToList regset
+          where rel t r = mkMiddle (reload r) <*> t
+
+
 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
+                                 availRegsLattice avail_reloads_transfer availRewrites bot g
           bot = fact_bot availRegsLattice
-          rewrites = ForwardRewrites first middle last exit
-          first _ _ = Nothing
-          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))
-          exit _ = Nothing
-          maybe_reload_before avail node tail =
-              let used = filterRegsUsed (elemAvail avail) node
-              in  if isEmptyUniqSet used then Nothing
-                  else Just $ mkZTail $ reloadTail used tail
           
 removeDeadAssignmentsAndReloads :: BlockSet -> (LGraph Middle Last) -> FuelMonad (LGraph Middle Last)
-removeDeadAssignmentsAndReloads procPoints g@(LGraph entry _ _) =
+removeDeadAssignmentsAndReloads procPoints g@(LGraph entry _) =
    liftM zdfFpContents $ (res :: LiveReloadFix (LGraph Middle Last))
      where res = zdfBRewriteFromL RewriteDeep emptyBlockEnv "dead-assignment & -reload elim"
                    dualLiveLattice (dualLiveTransfers entry procPoints)
                    rewrites (fact_bot dualLiveLattice) g
-           rewrites = BackwardRewrites first middle last exit
-           exit   = Nothing
-           last   = \_ _ -> Nothing
-           middle = middleRemoveDeads
-           first _ _ = Nothing
-
-middleRemoveDeads :: DualLive -> Middle -> Maybe (AGraph Middle Last)
-middleRemoveDeads live m = middle m 
-  where middle (MidAssign (CmmLocal reg') _)
-               | not (reg' `elemRegSet` in_regs live) = Just emptyAGraph
-        middle _ = Nothing
+           rewrites = BackwardRewrites nothing middleRemoveDeads nothing Nothing
+           nothing _ _ = Nothing
+
+middleRemoveDeads :: Middle -> DualLive -> Maybe (AGraph Middle Last)
+middleRemoveDeads  (MidAssign (CmmLocal reg') _) live
+       | not (reg' `elemRegSet` in_regs live) = Just emptyAGraph
+middleRemoveDeads  _ _ = Nothing
                       
 
 
index 17a819f..6c47043 100644 (file)
@@ -20,7 +20,9 @@ import MkZipCfgCmm hiding (CmmBlock, CmmGraph)
 import Monad
 import Outputable
 import Panic
+import SMRep (ByteOff)
 import ZipCfg
+import ZipCfg as Z
 import ZipCfgCmmRep
 import ZipDataflow
 
@@ -114,7 +116,7 @@ liveKill (a, hi, w) set = -- pprTrace "killing slots in area" (ppr a) $
 liveSlotTransfers :: BackwardTransfers Middle Last SubAreaSet
 liveSlotTransfers =
   BackwardTransfers first liveInSlots liveLastIn
-    where first live id = delFromFM live (CallArea (Young id))
+    where first id live = delFromFM live (CallArea (Young id))
 
 -- Slot sets: adding slots, removing slots, and checking for membership.
 liftToArea :: Area -> ([SubArea] -> [SubArea]) -> SubAreaSet -> SubAreaSet 
@@ -129,11 +131,11 @@ elemSlot   live (a, i, w) =
 removeLiveSlotDefs :: (DefinerOfSlots s, UserOfSlots s) => SubAreaSet -> s -> SubAreaSet
 removeLiveSlotDefs = foldSlotsDefd removeSlot
 
-liveInSlots :: (DefinerOfSlots s, UserOfSlots s) => SubAreaSet -> s -> SubAreaSet
-liveInSlots live x = foldSlotsUsed addSlot (removeLiveSlotDefs live x) x
+liveInSlots :: (DefinerOfSlots s, UserOfSlots s) => s -> SubAreaSet -> SubAreaSet
+liveInSlots x live = foldSlotsUsed addSlot (removeLiveSlotDefs live x) x
 
-liveLastIn :: (BlockId -> SubAreaSet) -> Last -> SubAreaSet
-liveLastIn env l = liveInSlots (liveLastOut env l) l
+liveLastIn :: Last -> (BlockId -> SubAreaSet) -> SubAreaSet
+liveLastIn l env = liveInSlots l (liveLastOut env l)
 
 -- Don't forget to keep the outgoing parameters in the CallArea live,
 -- as well as the update frame.
@@ -145,11 +147,11 @@ liveLastIn env l = liveInSlots (liveLastOut env l) l
 liveLastOut :: (BlockId -> SubAreaSet) -> Last -> SubAreaSet
 liveLastOut env l =
   case l of
-    LastCall _ Nothing n _ -> 
+    LastCall _ Nothing n _ -> 
       add_area (CallArea Old) n out -- add outgoing args (includes upd frame)
-    LastCall _ (Just k) n (Just _) ->
+    LastCall _ (Just k) n (Just _) ->
       add_area (CallArea Old) n (add_area (CallArea (Young k)) n out)
-    LastCall _ (Just k) n Nothing ->
+    LastCall _ (Just k) n Nothing ->
       add_area (CallArea (Young k)) n out
     _ -> out
   where out = joinOuts slotLattice env l
@@ -195,9 +197,9 @@ igraph builder env g = foldr interfere emptyFM (postorder_dfs g)
         interfere block igraph =
           let (h, l) = goto_end (unzip block)
               --heads :: ZHead Middle -> (IGraph x, SubAreaSet) -> IGraph x
-              heads (ZFirst _ _) (igraph, _)       = igraph
+              heads (ZFirst _) (igraph, _)       = igraph
               heads (ZHead h m)    (igraph, liveOut) =
-                heads h (addEdges igraph m liveOut, liveInSlots liveOut m)
+                heads h (addEdges igraph m liveOut, liveInSlots m liveOut)
               -- 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, _, _) =
@@ -212,24 +214,26 @@ igraph builder env g = foldr interfere emptyFM (postorder_dfs g)
               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)
+                                                 liveLastIn l env')
 
 -- 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 _) =
+getAreaSize :: ByteOff -> LGraph Middle Last -> AreaMap
+getAreaSize entry_off g@(LGraph _ _) =
   fold_blocks (fold_fwd_block first add_regslots last)
-              (unitFM (CallArea Old) off) g
-  where first id (StackInfo {argBytes = Just off}) z = add z (CallArea (Young id)) off
-        first _  _          z = z
-        add_regslots i z = foldSlotsUsed addSlot (foldSlotsDefd addSlot z i) i
-        last l@(LastOther (LastCall _ Nothing off _)) z =
-          add_regslots l (add z (CallArea Old) off)
-        last l@(LastOther (LastCall _ (Just k) off _)) z =
-          add_regslots l (add z (CallArea (Young k)) off)
+              (unitFM (CallArea Old) entry_off) g
+  where first _  z = z
+        last l@(LastOther (LastCall _ Nothing args res _)) z =
+          add_regslots l (add (add z area args) area res)
+          where area = CallArea Old
+        last l@(LastOther (LastCall _ (Just k) args res _)) z =
+          add_regslots l (add (add z area args) area res)
+          where area = CallArea (Young k)
         last l z = add_regslots l z
-        addSlot z (a@(RegSlot _), off, _) = add z a off
+        add_regslots i z = foldSlotsUsed addSlot (foldSlotsDefd addSlot z i) i
+        addSlot z (a@(RegSlot (LocalReg _ ty)), _, _) =
+          add z a $ widthInBytes $ typeWidth ty
         addSlot z _ = z
         add z a off = addToFM z a (max off (lookupWithDefaultFM z 0 a))
 
@@ -285,35 +289,41 @@ allocSlotFrom ig areaSize from areaMap area =
 
 -- 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 -> SlotEnv -> LGraph Middle Last -> AreaMap
-layout procPoints env g =
-  let builder = areaBuilder
-      ig = (igraph builder env g, builder)
+layout :: ProcPointSet -> SlotEnv -> ByteOff -> LGraph Middle Last -> AreaMap
+layout procPoints env entry_off g =
+  let ig = (igraph areaBuilder env g, areaBuilder)
       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
+      areaSize = getAreaSize entry_off g
+      -- Find the slots that are live-in to a block tail
+      live_in (ZTail m l) = liveInSlots m (live_in l)
+      live_in (ZLast (LastOther l)) = liveLastIn l env'
       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
-      fold_subareas :: (SubArea -> z -> z) -> SubAreaSet -> z -> z
-      fold_subareas f m z = foldFM (\_ s z -> foldr f z s) z m
+              fold_subareas f m z = foldFM (\_ s z -> foldr f z s) z m
       -- Allocate space for spill slots and call areas
       allocVarSlot = allocSlotFrom ig areaSize 0
-      allocCallSlot areaMap (Block id stackInfo t)
-        | elemBlockSet id procPoints =
-        let young  = youngest_live areaMap $ live_in t
-            start = case returnOff stackInfo of Just b  -> max b young
-                                                Nothing -> young
-            z = allocSlotFrom ig areaSize start areaMap (CallArea (Young id))
-        in -- pprTrace "allocCallSlot for" (ppr id <+> ppr young <+> ppr (live_in t) <+> ppr z) 
-           z
-      allocCallSlot areaMap _ = areaMap
-      -- mid foreign calls need to have info tables placed on the stack
+      -- Update the successor's incoming SP.
+      setSuccSPs inSp bid areaMap =
+        case (lookupFM areaMap area, lookupBlockEnv (lg_blocks g) bid) of
+          (Just _, _) -> areaMap -- succ already knows incoming SP
+          (Nothing, Just (Block _ _)) ->
+            if elemBlockSet bid procPoints then
+              let young = youngest_live areaMap $ env' bid
+                  -- start = case returnOff stackInfo of Just b  -> max b young
+                  --                                     Nothing -> young
+                  start = young -- maybe wrong, but I don't understand
+                                -- why the preceding is necessary...
+              in  allocSlotFrom ig areaSize start areaMap area
+            else addToFM areaMap area inSp
+          (_, Nothing) -> panic "Block not found in cfg"
+        where area = CallArea (Young bid)
+      allocLast (Block id _) areaMap l =
+        fold_succs (setSuccSPs inSp) l areaMap
+        where inSp = expectJust "sp in" $ lookupFM areaMap (CallArea (Young id))
       allocMidCall m@(MidForeignCall (Safe bid _) _ _ _) t areaMap =
         let young     = youngest_live areaMap $ removeLiveSlotDefs (live_in t) m
             area      = CallArea (Young bid)
@@ -324,12 +334,14 @@ layout procPoints env g =
           foldSlotsDefd alloc' (foldSlotsUsed alloc' (allocMidCall m t areaMap) m) m
         where alloc' areaMap (a@(RegSlot _), _, _) = allocVarSlot areaMap a
               alloc' areaMap _ = areaMap
-      layoutAreas areaMap b@(Block _ t) = layout areaMap t
+      layoutAreas areaMap b@(Block _ t) = layout areaMap t
         where layout areaMap (ZTail m t) = layout (alloc m t areaMap) t
-              layout areaMap (ZLast _)   = allocCallSlot areaMap b
-      areaMap = foldl layoutAreas (addToFM emptyFM (CallArea Old) 0) (postorder_dfs g)
+              layout areaMap (ZLast l)   = allocLast b areaMap l
+      initMap = addToFM (addToFM emptyFM (CallArea Old) 0)
+                        (CallArea (Young (lg_entry g))) 0
+      areaMap = foldl layoutAreas initMap (postorder_dfs g)
   in -- pprTrace "ProcPoints" (ppr procPoints) $
-       -- pprTrace "Area SizeMap" (ppr areaSize) $
+        -- pprTrace "Area SizeMap" (ppr areaSize) $
          -- pprTrace "Entry SP" (ppr entrySp) $
            -- pprTrace "Area Map" (ppr areaMap) $
      areaMap
@@ -343,35 +355,32 @@ layout procPoints env g =
 --    stack pointer to be younger than the live values on the stack at proc points.
 -- 3. Compute the maximum stack offset used in the procedure and replace
 --    the stack high-water mark with that offset.
-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) $
+manifestSP :: AreaMap -> ByteOff -> LGraph Middle Last -> FuelMonad (LGraph Middle Last)
+manifestSP areaMap entry_off g@(LGraph entry _blocks) =
+  liftM (LGraph entry) $ foldl replB (return emptyBlockEnv) (postorder_dfs g)
+  where slot a = -- pprTrace "slot" (ppr a) $
                    lookupFM areaMap a `orElse` panic "unallocated Area"
         slot' (Just id) = slot $ CallArea (Young id)
         slot' Nothing   = slot $ CallArea Old
         sp_high = maxSlot slot g
-        proc_entry_sp = slot (CallArea Old) + args
+        proc_entry_sp = slot (CallArea Old) + entry_off
+
+        add_sp_off b env =
+          case Z.last (unzip b) of
+            LastOther (LastCall {cml_cont = Just succ, cml_ret_args = off}) ->
+              extendBlockEnv env succ off
+            _ -> env
+        spEntryMap = fold_blocks add_sp_off (mkBlockEnv [(entry, entry_off)]) g
+        spOffset id = lookupBlockEnv spEntryMap id `orElse` 0
+
         sp_on_entry id | id == entry = proc_entry_sp
-        sp_on_entry id =
-          case lookupBlockEnv blocks id of
-            Just (Block _ (StackInfo {argBytes = Just o}) _) -> slot' (Just id) + o
-            _ -> 
-             case expectJust "sp_on_entry" (lookupBlockEnv procMap id) of
-               ReachedBy pp ->
-                 case blockSetToList pp of
-                   [id] -> sp_on_entry id
-                   _    -> panic "block not reached by one proc point"
-               ProcPoint -> pprPanic "procpoint doesn't take any arguments?"
-                               (ppr id <+> ppr g <+> ppr procPoints <+> ppr procMap)
+        sp_on_entry id = slot' (Just id) + spOffset id
 
         -- 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 t) =
-          do bs <- replTail (Block id o) spIn t
+        replB blocks (Block id t) =
+          do bs <- replTail (Block id) spIn t
              -- pprTrace "spIn" (ppr id <+> ppr spIn) $ do
              liftM (flip (foldr insertBlock) bs) blocks
           where spIn = sp_on_entry id
@@ -391,7 +400,7 @@ manifestSP procPoints procMap areaMap g@(LGraph entry args blocks) =
         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@(LastCall _ k n _) = updSp h spOff (slot' k + n) l
+        fixSp h spOff l@(LastCall _ k n _ _) = updSp h spOff (slot' k + n) l
         fixSp h spOff l@(LastBranch k) =
           let succSp = sp_on_entry k in
           if succSp /= spOff then
@@ -417,7 +426,7 @@ manifestSP procPoints procMap areaMap g@(LGraph entry args blocks) =
 -- To compute the stack high-water mark, we fold over the graph and
 -- compute the highest slot offset.
 maxSlot :: (Area -> Int) -> CmmGraph -> Int
-maxSlot slotOff g = fold_blocks (fold_fwd_block (\ _ x -> x) highSlot highSlot) 0 g
+maxSlot slotOff g = fold_blocks (fold_fwd_block (\ _ x -> x) highSlot highSlot) 0 g
   where highSlot i z = foldSlotsUsed add (foldSlotsDefd add z i) i
         add z (a, i, _) = max z (slotOff a + i)
 
@@ -436,7 +445,7 @@ stubSlotsOnDeath g = liftM zdfFpContents $ (res :: StubPtrFix)
           rewrites = BackwardRewrites first middle last Nothing
           first _ _ = Nothing
           last  _ _ = Nothing
-          middle liveSlots m = foldSlotsUsed (stub liveSlots m) Nothing m
+          middle m liveSlots = foldSlotsUsed (stub liveSlots m) Nothing m
           stub liveSlots m rst subarea@(a, off, w) =
             if elemSlot liveSlots subarea then rst
             else let store = mkStore (CmmStackSlot a off)
index 5171218..a91d76f 100644 (file)
@@ -13,7 +13,7 @@ import Maybes
 -- | Compute the predecessors of each /reachable/ block
 zipPreds :: LastNode l => LGraph m l -> BlockEnv BlockSet
 zipPreds g = foldl add emptyBlockEnv (postorder_dfs g)
-    where add env block@(Block id _ _) =
+    where add env block@(Block id _) =
             foldl (\env sid ->
                        let preds = lookupBlockEnv env sid `orElse` emptyBlockSet
                        in  extendBlockEnv env sid (extendBlockSet preds id))
index 0bce264..4db3b96 100644 (file)
@@ -45,11 +45,11 @@ conjunction with the join, so we have [[fact_add_to]]:
 -}
 
 data DataflowLattice a = DataflowLattice  { 
-  fact_name    :: String,                 -- documentation
-  fact_bot     :: a,                      -- lattice bottom element
-  fact_add_to  :: a -> a -> TxRes a,      -- lattice join and compare
+  fact_name       :: String,                 -- documentation
+  fact_bot        :: a,                      -- lattice bottom element
+  fact_add_to     :: a -> a -> TxRes a,      -- lattice join and compare
     -- ^ compute join of two args; something changed iff join is greater than 2nd arg
-  fact_do_logging :: Bool  -- log changes
+  fact_do_logging :: Bool                    -- log changes
 }
 
 
@@ -136,15 +136,11 @@ instance Monad m => DataflowAnalysis (DFM' m) where
   getExitFact = DFM' get
     where get _ s = return (df_exit_fact s, s)
   setExitFact a =
-    do old <- getExitFact
-       DataflowLattice { fact_add_to = add_fact
-                       , fact_name = name, fact_do_logging = log } <- lattice
-       case add_fact a old of
-         TxRes NoChange _ -> return ()
-         TxRes SomeChange join -> DFM' $ \_ s ->
-             let debug = if log then pprTrace else \_ _ a -> a
-             in  debug name (pprSetFact "exit" old a join) $
-                 return ((), s { df_exit_fact = join, df_facts_change = SomeChange })
+    do DataflowLattice { fact_name = name, fact_do_logging = log} <- lattice
+       DFM' $ \_ s ->
+                let debug = if log then pprTrace else \_ _ a -> a
+                in  debug name (pprSetFact "exit" a a a) $
+                    return ((), s { df_exit_fact = a })
   getAllFacts = DFM' f
     where f _ s = return (df_facts s, s)
   setAllFacts env = DFM' f
index 59d50d5..fa93f76 100644 (file)
@@ -165,8 +165,7 @@ catAGraphs :: [AGraph m l] -> AGraph m l
 -- splicing operation <*>, are constant-time operations.
 
 emptyAGraph :: AGraph m l
-mkLabel     :: (LastNode l) =>
-               BlockId -> StackInfo -> AGraph m l -- graph contains the label
+mkLabel     :: (LastNode l) => BlockId -> 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
@@ -230,9 +229,9 @@ mkWhileDo    :: (Outputable m, Outputable l, LastNode l)
 -- because it may require the allocation of fresh, unique labels.
 
 graphOfAGraph  :: AGraph m l -> UniqSM (Graph  m l)
-lgraphOfAGraph :: Int -> AGraph m l -> UniqSM (LGraph m l)
+lgraphOfAGraph :: AGraph m l -> UniqSM (LGraph m l)
   -- ^ allocate a fresh label for the entry point
-labelAGraph    :: BlockId -> Int -> AGraph m l -> UniqSM (LGraph m l)
+labelAGraph    :: BlockId -> AGraph m l -> UniqSM (LGraph m l)
   -- ^ use the given BlockId as the label of the entry point
 
 
@@ -261,21 +260,20 @@ emptyAGraph = AGraph return
 graphOfAGraph (AGraph f) = f emptyGraph
 emptyGraph = Graph (ZLast LastExit) emptyBlockEnv
 
-labelAGraph id args g =
+labelAGraph id g =
     do Graph tail blocks <- graphOfAGraph g
-       return $ LGraph id args $ insertBlock (Block id stackInfo tail) blocks
-    where stackInfo = StackInfo Nothing Nothing
+       return $ LGraph id $ insertBlock (Block id tail) blocks
 
-lgraphOfAGraph args g = do id <- freshBlockId "graph entry"
-                           labelAGraph id args g
+lgraphOfAGraph g = do id <- freshBlockId "graph entry"
+                      labelAGraph id g
 
 -------------------------------------
 -- constructors
 
-mkLabel id args = AGraph f
+mkLabel id = AGraph f
     where f (Graph tail blocks) =
             return $ Graph (ZLast (mkBranchNode id))
-                           (insertBlock (Block id args tail) blocks)
+                           (insertBlock (Block id tail) blocks)
 
 mkBranch target = mkLast $ mkBranchNode target
 
@@ -320,18 +318,18 @@ mkIfThenElse cbranch tbranch fbranch =
     withFreshLabel "start of then" $ \tid ->
     withFreshLabel "start of else" $ \fid ->
         cbranch tid fid <*>
-        mkLabel tid emptyStackInfo <*> tbranch <*> mkBranch endif <*>
-        mkLabel fid emptyStackInfo <*> fbranch <*>
-        mkLabel endif emptyStackInfo 
+        mkLabel tid <*> tbranch <*> mkBranch endif <*>
+        mkLabel fid <*> fbranch <*>
+        mkLabel endif
 
 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 emptyStackInfo <*> body
-                   <*> mkLabel test emptyStackInfo <*> cbranch head endwhile
-                   <*> mkLabel endwhile emptyStackInfo 
+     mkBranch test <*> mkLabel head <*> body
+                   <*> mkLabel test <*> cbranch head endwhile
+                   <*> mkLabel endwhile
 
 -- | Bleat if the insertion of a last node will create unreachable code
 note_this_code_becomes_unreachable ::
index 4b073e2..88adaae 100644 (file)
@@ -8,14 +8,14 @@
 module MkZipCfgCmm
   ( mkNop, mkAssign, mkStore, mkCall, mkCmmCall, mkSafeCall, mkUnsafeCall, mkFinalCall
          , mkJump, mkForeignJump, mkJumpGC, mkCbranch, mkSwitch, mkReturn
-         , mkReturnSimple, mkComment, copyIn, copyOut
+         , mkReturnSimple, mkComment, copyInOflow, copyInSlot, copyOutOflow, copyOutSlot
          , mkEntry, mkCmmIfThenElse, mkCmmIfThen, mkCmmWhileDo
   , (<*>), catAGraphs, mkLabel, mkBranch
   , emptyAGraph, withFreshLabel, withUnique, outOfLine
   , lgraphOfAGraph, graphOfAGraph, labelAGraph
-  , CmmZ, CmmTopZ, CmmGraph, CmmBlock, CmmAGraph
+  , CmmZ, CmmTopZ, CmmGraph, CmmBlock, CmmAGraph, CmmStackInfo
   , Middle, Last, Convention(..), ForeignConvention(..), MidCallTarget(..), Transfer(..)
-  , emptyStackInfo, stackStubExpr, pprAGraph
+  , stackStubExpr, pprAGraph
   )
 where
 
@@ -36,14 +36,17 @@ import FastString
 import ForeignCall
 import MkZipCfg
 import Panic 
+import SMRep (ByteOff) 
 import StaticFlags 
 import ZipCfg 
 
 type CmmGraph  = LGraph Middle Last
 type CmmAGraph = AGraph Middle Last
 type CmmBlock  = Block  Middle Last
-type CmmZ      = GenCmm    CmmStatic CmmInfo CmmGraph
-type CmmTopZ   = GenCmmTop CmmStatic CmmInfo CmmGraph
+type CmmStackInfo            = (ByteOff, Maybe ByteOff)
+  -- probably want a record; (SP offset on entry, update frame space)
+type CmmZ                    = GenCmm    CmmStatic CmmInfo (CmmStackInfo, CmmGraph)
+type CmmTopZ                 = GenCmmTop CmmStatic CmmInfo (CmmStackInfo, CmmGraph)
 
 data Transfer = Call | Jump | Ret deriving Eq
 
@@ -95,8 +98,8 @@ mkCmmIfThen e tbranch
   = withFreshLabel "end of if"     $ \endif ->
     withFreshLabel "start of then" $ \tid ->
     mkCbranch e tid endif <*>
-    mkLabel tid   emptyStackInfo <*> tbranch <*> mkBranch endif <*>
-    mkLabel endif emptyStackInfo
+    mkLabel tid   <*> tbranch <*> mkBranch endif <*>
+    mkLabel endif
 
 
 
@@ -137,74 +140,123 @@ mkUnsafeCall t fs as = mkMiddle $ MidForeignCall Unsafe t fs as
 stackStubExpr :: Width -> CmmExpr
 stackStubExpr w = CmmLit (CmmInt 0 w)
 
+-- When we copy in parameters, we usually want to put overflow
+-- parameters on the stack, but sometimes we want to pass
+-- the variables in their spill slots.
+-- Therefore, for copying arguments and results, we provide different
+-- functions to pass the arguments in an overflow area and to pass them in spill slots.
+copyInOflow  :: Convention -> Bool -> Area -> CmmFormals -> (Int, CmmAGraph)
+copyInSlot   :: Convention -> Bool -> CmmFormals -> CmmAGraph
+copyOutOflow :: Convention -> Transfer -> Area -> CmmActuals -> UpdFrameOffset ->
+                              (Int, [Middle])
+copyOutSlot  :: Convention -> Transfer -> [LocalReg] -> [Middle]
+  -- why a list of middles here instead of an AGraph?
+
+copyInOflow      = copyIn oneCopyOflowI
+copyInSlot c i f = snd $ copyIn oneCopySlotI c i (panic "no area for copying to slots") f
+
+type SlotCopier = Area -> (LocalReg, ByteOff) -> (ByteOff, CmmAGraph) ->
+                          (ByteOff, CmmAGraph)
+type CopyIn  = SlotCopier -> Convention -> Bool -> Area -> CmmFormals ->
+                          (ByteOff, CmmAGraph)
+
 -- Return the number of bytes used for copying arguments, as well as the
 -- instructions to copy the arguments.
-copyIn :: Convention -> Bool -> Area -> CmmFormals -> (Int, AGraph Middle Last)
-copyIn conv isCall area formals =
-  foldr ci (init_offset, mkNop) $ assignArgumentsPos conv isCall localRegType formals
+copyIn :: CopyIn
+copyIn oflow conv isCall area formals =
+  foldr ci (init_offset, mkNop) args'
   where ci (reg, RegisterParam r) (n, 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',
-              mkAssign (CmmLocal reg) (CmmLoad (CmmStackSlot area off') ty) <*> ms)
-        init_offset = widthInBytes wordWidth
+        ci (r, StackParam off) (n, ms) = oflow area (r, off) (n, ms)
+        init_offset = widthInBytes wordWidth -- infotable
+        args  = assignArgumentsPos conv isCall localRegType formals
+        args' = foldl adjust [] args
+          where adjust rst (v, StackParam off) = (v, StackParam (off + init_offset)) : rst
+                adjust rst x@(_, RegisterParam _) = x : rst
+
+-- Copy-in one arg, using overflow space if needed.
+oneCopyOflowI, oneCopySlotI :: SlotCopier
+oneCopyOflowI area (reg, off) (n, ms) =
+  (max n off, mkAssign (CmmLocal reg) (CmmLoad (CmmStackSlot area off) ty) <*> ms)
+  where ty = localRegType reg
+
+-- Copy-in one arg, using spill slots if needed -- used for calling conventions at
+-- a procpoint that is not a return point. The offset is irrelevant here...
+oneCopySlotI _ (reg, _) (n, ms) =
+  (n, mkAssign (CmmLocal reg) (CmmLoad (CmmStackSlot (RegSlot reg) w) ty) <*> ms)
+  where ty = localRegType reg
+        w  = widthInBytes (typeWidth ty)
+
+
+-- Factoring out the common parts of the copyout functions yielded something
+-- more complicated:
 
 -- 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 -> UpdFrameOffset -> (Int, [Middle])
-copyOut conv transfer area@(CallArea a) actuals updfr_off =
+copyOutOflow conv transfer area@(CallArea a) actuals updfr_off =
   foldr co (init_offset, []) args'
-  where args = assignArgumentsPos conv skip_node cmmExprType actuals
-        skip_node = transfer /= Ret
+  where 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)
         (setRA, init_offset) =
           case a of Young id@(BlockId _) -> -- set RA if making a call
                       if transfer == Call then
-                        ([(CmmLit (CmmBlock id), StackParam init_offset)], ra_width)
+                        ([(CmmLit (CmmBlock id), StackParam init_offset)],
+                         widthInBytes wordWidth)
                       else ([], 0)
                     Old -> ([], updfr_off)
-        ra_width = widthInBytes wordWidth
+        args = assignArgumentsPos conv (transfer /= Ret) cmmExprType actuals
         args' = foldl adjust setRA args
           where adjust rst (v, StackParam off) = (v, StackParam (off + init_offset)) : rst
                 adjust rst x@(_, RegisterParam _) = x : rst
-        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"
+copyOutOflow _ _ (RegSlot _) _ _ = panic "cannot copy arguments into a register slot"
+
+-- Args passed only in registers and stack slots; no overflow space.
+-- No return address may apply!
+copyOutSlot conv transfer actuals = foldr co [] args
+  where co (v, RegisterParam r) ms = MidAssign (CmmGlobal r) (toExp v) : ms
+        co (v, StackParam off)  ms =
+          MidStore (CmmStackSlot (RegSlot v) off) (toExp v) : ms
+        toExp r = CmmReg (CmmLocal r)
+        args = assignArgumentsPos conv (transfer /= Ret) localRegType actuals
+
+-- oneCopySlotO _ (reg, _) (n, ms) =
+--   (n, MidStore (CmmStackSlot (RegSlot reg) w) reg : ms)
+--   where w = widthInBytes (typeWidth (localRegType reg))
 
 mkEntry :: BlockId -> Convention -> CmmFormals -> (Int, CmmAGraph)
-mkEntry _ conv formals = copyIn conv False (CallArea Old) formals
+mkEntry _ conv formals = copyInOflow conv False (CallArea Old) formals
 
 lastWithArgs :: Transfer -> Area -> Convention -> CmmActuals -> UpdFrameOffset ->
-                (Int -> Last) -> CmmAGraph
+                (ByteOff -> Last) -> CmmAGraph
 lastWithArgs transfer area conv actuals updfr_off last =
-  let (outArgs, copies) = copyOut conv transfer area actuals updfr_off in
+  let (outArgs, copies) = copyOutOflow 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.
 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)
+toCall :: CmmExpr -> Maybe BlockId -> UpdFrameOffset -> ByteOff -> ByteOff -> Last
+toCall e cont updfr_off res_space arg_space =
+  LastCall e cont arg_space res_space (Just updfr_off)
 mkJump e actuals updfr_off =
-  lastWithArgs Jump old Native actuals updfr_off $ toCall e Nothing updfr_off
+  lastWithArgs Jump old Native actuals updfr_off $ toCall e Nothing updfr_off 0
 mkJumpGC e actuals updfr_off =
-  lastWithArgs Jump old GC actuals updfr_off $ toCall e Nothing updfr_off
+  lastWithArgs Jump old GC actuals updfr_off $ toCall e Nothing updfr_off 0
 mkForeignJump conv e actuals updfr_off =
-  lastWithArgs Jump old conv actuals updfr_off $ toCall e Nothing updfr_off
+  lastWithArgs Jump old conv actuals updfr_off $ toCall e Nothing updfr_off 0
 mkReturn e actuals updfr_off =
-  lastWithArgs Ret  old Native actuals updfr_off $ toCall e Nothing updfr_off
+  lastWithArgs Ret  old Native actuals updfr_off $ toCall e Nothing updfr_off 0
     -- 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
+  lastWithArgs Ret  old Native actuals updfr_off $ toCall e Nothing updfr_off 0
     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
+  lastWithArgs Call old Native actuals updfr_off $ toCall f Nothing updfr_off 0
 
 mkCmmCall f results actuals = mkCall f Native results actuals
 
@@ -212,8 +264,7 @@ mkCmmCall f results actuals = mkCall f Native results actuals
 mkCall f conv results actuals updfr_off =
   withFreshLabel "call successor" $ \k ->
     let area = CallArea $ Young k
-        (off, copyin) = copyIn conv False area results
+        (off, copyin) = copyInOflow 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)
+                               (toCall f (Just k) updfr_off off)
+    in (copyout <*> mkLabel k <*> copyin)
index a5d8fa3..5e400c4 100644 (file)
@@ -128,8 +128,7 @@ fuelDecrementState new_optimizer old new s =
         optimizer = if diffFuel old new > 0 then new_optimizer else fs_lastpass s
 
 -- lGraphOfGraph is here because we need uniques to implement it.
-lGraphOfGraph :: Graph m l -> Int -> FuelMonad (LGraph m l)
-lGraphOfGraph (Graph tail blocks) args =
+lGraphOfGraph :: Graph m l -> FuelMonad (LGraph m l)
+lGraphOfGraph (Graph tail blocks) =
   do entry <- liftM BlockId $ getUniqueM
-     return $ LGraph entry args
-                     (insertBlock (Block entry emptyStackInfo tail) blocks)
+     return $ LGraph entry (insertBlock (Block entry tail) blocks)
index 30eb492..e9199ff 100644 (file)
@@ -26,35 +26,35 @@ pprCmmGraphLikeCmm g = vcat (swallow blocks)
     where blocks = Z.postorder_dfs g
           swallow :: [G.CmmBlock] -> [SDoc]
           swallow [] = []
-          swallow (Z.Block id off t : rest) = tail (id, off) [] Nothing t rest
+          swallow (Z.Block id t : rest) = tail id [] Nothing t rest
           tail id prev' out (Z.ZTail m t) rest = tail id (mid m : prev') out t rest
           tail id prev' out (Z.ZLast (Z.LastOther l)) rest = last id prev' out l rest
           tail id prev' _   (Z.ZLast Z.LastExit)      rest = exit id prev' rest
           mid m = ppr m
-          block' (id, off) prev'
+          block' id prev'
               | id == Z.lg_entry g, entry_has_no_pred =
-                            vcat (text "<entry>" <> parens (ppr off) : reverse prev')
-              | otherwise = hang (ppr id <> parens (ppr off) <> colon) 4 (vcat (reverse prev'))
+                            vcat (text "<entry>" : reverse prev')
+              | otherwise = hang (ppr id <> colon) 4 (vcat (reverse prev'))
           last id prev' out l n =
               let endblock stmt = block' id (stmt : prev') : swallow n in
               case l of
                 G.LastBranch tgt ->
                     case n of
-                      Z.Block id' t : bs
+                      Z.Block id' t : bs
                           | tgt == id', unique_pred id' 
                           -> tail id prev' out t bs  -- optimize out redundant labels
                       _ -> endblock (ppr $ CmmBranch tgt)
                 l@(G.LastCondBranch expr tid fid) ->
                   let ft id = text "// fall through to " <> ppr id in
                   case n of
-                    Z.Block id' t : bs
+                    Z.Block id' t : bs
                       | id' == fid, isNothing out ->
                           tail id (ft fid : ppr (CmmCondBranch expr tid) : prev') Nothing t bs
                       | 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.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>")
@@ -76,7 +76,7 @@ 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 ),
index 03af181..3bb1317 100644 (file)
@@ -27,13 +27,13 @@ fold_edge_facts_b f comp graph env z =
     fold_block_facts z b =              
       let (h, l) = goto_end (ZipCfg.unzip b) 
           last_in _ LastExit = fact_bot dualLiveLattice
-          last_in env (LastOther l) = bt_last_in comp env l
+          last_in env (LastOther l) = bt_last_in comp l env
       in head_fold h (last_in env l) z
-    head_fold (ZHead h m)   out z = head_fold h (bt_middle_in comp out m) (f out z)
-    head_fold (ZFirst id _) out z = f (bt_first_in comp out id) (f out z)
+    head_fold (ZHead h m)   out z = head_fold h (bt_middle_in comp m out) (f out z)
+    head_fold (ZFirst id) out z = f (bt_first_in comp id out) (f out z)
 
 foldConflicts :: (RegSet -> a -> a) -> a -> LGraph Middle Last -> FuelMonad a
-foldConflicts f z g@(LGraph entry _ _) =
+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
index c1bd956..1e04f90 100644 (file)
@@ -2,7 +2,6 @@ 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
@@ -152,7 +151,7 @@ instance UserOfLocalRegs a => UserOfLocalRegs (ZLast a) where
     foldRegsUsed _f z LastExit      = z
 
 
-data ZHead m   = ZFirst BlockId StackInfo
+data ZHead m   = ZFirst BlockId
                | 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)
@@ -160,26 +159,12 @@ data ZTail m l = ZLast (ZLast l) | ZTail m (ZTail m l)
 
 -- | Blocks and flow graphs; see Note [Kinds of graphs]
 
--- 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)) }
 
 data LGraph m l = LGraph  { lg_entry     :: BlockId
-                          , lg_argoffset :: Int -- space (bytes) for incoming args
                           , lg_blocks    :: BlockEnv (Block m l)}
        -- Invariant: lg_entry is in domain( lg_blocks )
 
@@ -254,12 +239,12 @@ splice_head_only' :: ZHead m -> Graph m l  -> LGraph m l
 -- layout or dataflow, however, one will want to use 'postorder_dfs'
 -- in order to get the blocks in an order that relates to the control
 -- flow in the procedure.
-of_block_list :: BlockId -> Int -> [Block m l] -> LGraph m l  -- N log N
+of_block_list :: BlockId -> [Block m l] -> LGraph m l  -- N log N
 to_block_list :: LGraph m l -> [Block m l]  -- N log N
 
 -- | Conversion from LGraph to Graph
 graphOfLGraph :: LastNode l => LGraph m l -> Graph m l
-graphOfLGraph (LGraph eid blocks) = Graph (ZLast $ mkBranchNode eid) blocks
+graphOfLGraph (LGraph eid blocks) = Graph (ZLast $ mkBranchNode eid) blocks
 
 
 -- | Traversal: 'postorder_dfs' returns a list of blocks reachable
@@ -298,7 +283,7 @@ fold_layout ::
 fold_blocks :: (Block m l -> a -> a) -> a -> LGraph m l -> a
 
 -- | Fold from first to last
-fold_fwd_block :: (BlockId -> StackInfo -> a -> a) -> (m -> a -> a) ->
+fold_fwd_block :: (BlockId -> 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'
@@ -371,14 +356,14 @@ instance LastNode l => HavingSuccessors (ZTail m l) where
 
 ----- block manipulations
 
-blockId (Block id _ _) = id
+blockId (Block id _) = id
 
 -- | Convert block between forms.
 -- These functions are tail-recursive, so we can go as deep as we like
 -- without fear of stack overflow.  
 
 ht_to_block head tail = case head of
-  ZFirst id off -> Block id off tail
+  ZFirst id -> Block id tail
   ZHead h m -> ht_to_block h (ZTail m tail) 
 
 ht_to_last head (ZLast l)   = (head, l)
@@ -388,10 +373,10 @@ zipht            h t  = ht_to_block h t
 zip      (ZBlock h t) = ht_to_block h t
 goto_end (ZBlock h t) = ht_to_last  h t
 
-unzip (Block id off t) = ZBlock (ZFirst id off) t
+unzip (Block id t) = ZBlock (ZFirst id) t
 
 head_id :: ZHead m -> BlockId
-head_id (ZFirst id _) = id
+head_id (ZFirst id) = id
 head_id (ZHead  h  _)   = head_id h
 
 last (ZBlock _ t) = lastTail t
@@ -406,13 +391,13 @@ tailOfLast l = ZLast (LastOther l) -- tedious to write in every client
 ------------------ simple graph manipulations
 
 focus :: BlockId -> LGraph m l -> FGraph m l -- focus on edge out of node with id 
-focus id (LGraph entry blocks) =
+focus id (LGraph entry blocks) =
     case lookupBlockEnv blocks id of
       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 
-entry g@(LGraph eid _ _) = focus eid g
+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) ->
@@ -473,7 +458,7 @@ single_exitg (Graph tail blocks) = foldBlockEnv' add (exit_count (lastTail tail)
 -- Better to get [A,B,C,D]
 
 
-postorder_dfs g@(LGraph _ blockenv) =
+postorder_dfs g@(LGraph _ blockenv) =
     let FGraph id eblock _ = entry g in
      zip eblock : postorder_dfs_from_except blockenv eblock (unitBlockSet id)
 
@@ -484,7 +469,7 @@ postorder_dfs_from_except blocks b visited =
   where
     -- vnode ::
     --    Block m l -> ([Block m l] -> BlockSet -> a) -> [Block m l] -> BlockSet -> a
-    vnode block@(Block id _ _) cont acc visited =
+    vnode block@(Block id _) cont acc visited =
         if elemBlockSet id visited then
             cont acc visited
         else
@@ -510,42 +495,42 @@ postorder_dfs_from blocks b = postorder_dfs_from_except blocks b emptyBlockSet
 -- 'b1' what its inline successor is going to be, so that if 'b1' ends with
 -- 'goto b2', the goto can be omitted.
 
-fold_layout f z g@(LGraph eid _ _) = fold (postorder_dfs g) z
+fold_layout f z g@(LGraph eid _) = fold (postorder_dfs g) z
   where fold blocks z =
             case blocks of [] -> z
                            [b] -> f b Nothing z
                            b1 : b2 : bs -> fold (b2 : bs) (f b1 (nextlabel b2) z)
-        nextlabel (Block id _ _) =
+        nextlabel (Block id _) =
             if id == eid then panic "entry as successor"
             else Just id
 
 -- | The rest of the traversals are straightforward
 
-map_blocks f (LGraph eid off blocks) = LGraph eid off (mapBlockEnv f blocks)
+map_blocks f (LGraph eid blocks) = LGraph eid (mapBlockEnv f blocks)
 
-map_nodes idm middle last (LGraph eid off blocks) =
-  LGraph (idm eid) off (mapBlockEnv (map_one_block idm middle last) blocks)
+map_nodes idm middle last (LGraph eid blocks) =
+  LGraph (idm eid) (mapBlockEnv (map_one_block idm middle last) blocks)
 
-map_one_block idm middle last (Block id off t) = Block (idm id) off (tail t)
+map_one_block idm middle last (Block id t) = Block (idm id) (tail t)
     where tail (ZTail m t) = ZTail (middle m) (tail t)
           tail (ZLast LastExit) = ZLast LastExit
           tail (ZLast (LastOther l)) = ZLast (LastOther (last l))
 
 
-mapM_blocks f (LGraph eid off blocks) = blocks' >>= return . LGraph eid off
+mapM_blocks f (LGraph eid blocks) = blocks' >>= return . LGraph eid
     where blocks' =
             foldBlockEnv' (\b mblocks -> do { blocks <- mblocks
                                       ; b <- f b
                                       ; return $ insertBlock b blocks })
                     (return emptyBlockEnv) blocks
 
-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)
+fold_blocks f z (LGraph _ blocks) = foldBlockEnv' f z blocks
+fold_fwd_block first middle last (Block id t) z = tail t (first id 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) = eltsBlockEnv blocks
+of_block_list e blocks = LGraph e $ foldr insertBlock emptyBlockEnv blocks 
+to_block_list (LGraph _ blocks) = eltsBlockEnv blocks
 
 
 -- We want to be able to scrutinize a single-entry, single-exit 'LGraph' for
@@ -589,15 +574,15 @@ prepare_for_splicing' (Graph etail gblocks) single multi =
 is_exit :: Block m l -> Bool
 is_exit b = case last (unzip b) of { LastExit -> True; _ -> False }
 
-splice_head head g@(LGraph _ off _) = 
+splice_head head g@(LGraph _ _) = 
   ASSERT (single_exit g) prepare_for_splicing g splice_one_block splice_many_blocks
    where eid = head_id head
          splice_one_block tail' =
              case ht_to_last head tail' of
-               (head, LastExit) -> (LGraph eid off emptyBlockEnv, head)
+               (head, LastExit) -> (LGraph eid emptyBlockEnv, head)
                _ -> panic "spliced LGraph without exit" 
          splice_many_blocks entry exit others =
-             (LGraph eid off (insertBlock (zipht head entry) others), exit)
+             (LGraph eid (insertBlock (zipht head entry) others), exit)
 
 splice_head' head g = 
   ASSERT (single_exitg g) prepare_for_splicing' g splice_one_block splice_many_blocks
@@ -635,27 +620,27 @@ splice_tail g tail =
 splice_head_only head g =
   let FGraph eid gentry gblocks = entry g
   in case gentry of
-       ZBlock (ZFirst _ _) tail ->
-         LGraph eid (insertBlock (zipht head tail) gblocks)
+       ZBlock (ZFirst _) tail ->
+         LGraph eid (insertBlock (zipht head tail) gblocks)
        _ -> panic "entry not at start of block?!"
 
 splice_head_only' head (Graph tail gblocks) =
   let eblock = zipht head tail in
-  LGraph (blockId eblock) (insertBlock eblock gblocks)
+  LGraph (blockId eblock) (insertBlock eblock gblocks)
   -- the offset probably should never be used, but well, it's correct for this LGraph
 
 
 --- Translation
 
-translate txm txl (LGraph eid off blocks) =
+translate txm txl (LGraph eid blocks) =
     do blocks' <- foldBlockEnv' txblock (return emptyBlockEnv) blocks
-       return $ LGraph eid off blocks'
+       return $ LGraph eid blocks'
     where
       -- txblock ::
       -- Block m l -> tm (BlockEnv (Block m' l')) -> tm (BlockEnv (Block m' l'))
-      txblock (Block id boff t) expanded =
+      txblock (Block id t) expanded =
         do blocks' <- expanded
-           txtail (ZFirst id boff) t blocks'
+           txtail (ZFirst id) t blocks'
       -- txtail :: ZHead m' -> ZTail m l -> BlockEnv (Block m' l') ->
       --           tm (BlockEnv (Block m' l'))
       txtail h (ZTail m t) blocks' =
@@ -686,9 +671,6 @@ 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
 
@@ -700,18 +682,13 @@ 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 stackInfo tail) =
-  ppr id <>  parens (ppr stackInfo) <> colon
+pprBlock (Block id tail) =
+  ppr id <>  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) $$
+pprLgraph g = text "{" <> text "offset" $$
               nest 2 (vcat $ map ppr blocks) $$ text "}"
     where blocks = postorder_dfs g
 
index 453b8f0..348ab5b 100644 (file)
@@ -50,8 +50,10 @@ import UniqSupply
 type CmmGraph                = LGraph Middle Last
 type CmmAGraph               = AGraph Middle Last
 type CmmBlock                = Block  Middle Last
-type CmmZ                    = GenCmm    CmmStatic CmmInfo CmmGraph
-type CmmTopZ                 = GenCmmTop CmmStatic CmmInfo CmmGraph
+type CmmStackInfo            = (ByteOff, Maybe ByteOff)
+  -- probably want a record; (SP offset on entry, update frame space)
+type CmmZ                    = GenCmm    CmmStatic CmmInfo (CmmStackInfo, CmmGraph)
+type CmmTopZ                 = GenCmmTop CmmStatic CmmInfo (CmmStackInfo, CmmGraph)
 type CmmBackwardFixedPoint a = DF.BackwardFixedPoint Middle Last a ()
 type CmmForwardFixedPoint  a = DF.ForwardFixedPoint  Middle Last a ()
 
@@ -90,6 +92,7 @@ data Last
             -- BlockId of continuation (Nothing for return or tail call)
         cml_args    :: ByteOff,  -- byte offset for youngest outgoing arg
                                  -- (includes update frame, which must be younger)
+        cml_ret_args:: ByteOff,  -- byte offset for youngest incoming arg
         cml_ret_off :: Maybe UpdFrameOffset}
           -- stack offset for return (update frames);
           -- The return offset should be Nothing only if we have to create
@@ -203,7 +206,7 @@ insertBetween b ms succId = insert $ goto_end $ unzip b
           panic "unimp: insertBetween after a call -- probably not a good idea"
         insert (_, LastExit) = panic "cannot insert after exit"
         newBlocks = do id <- liftM BlockId $ getUniqueM
-                       return $ (id, [Block id emptyStackInfo $
+                       return $ (id, [Block id $
                                    foldr ZTail (ZLast (LastOther (LastBranch succId))) ms])
         mbNewBlocks (Just k) = if k == succId then liftM lift newBlocks
                                else return (Just k, [])
@@ -225,18 +228,18 @@ instance LastNode Last where
     branchNodeTarget _ = panic "asked for target of non-branch"
 
 cmmSuccs :: Last -> [BlockId]
-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
+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 (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
+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
@@ -268,16 +271,16 @@ instance (UserOfSlots a) => UserOfSlots (Maybe a) where
 instance UserOfLocalRegs Last where
     foldRegsUsed f z l = last l
       where last (LastBranch _id)       = z
-            last (LastCall tgt _ _ _)   = foldRegsUsed f z tgt
+            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 (MidForeignCall _ _ fs _)  = fold f z fs
+      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
@@ -298,7 +301,7 @@ instance UserOfSlots Middle where
 instance UserOfSlots Last where
     foldSlotsUsed f z l = last l
       where last (LastBranch _id)       = z
-            last (LastCall tgt _ _ _)   = foldSlotsUsed f z tgt
+            last (LastCall tgt _ _ _ _) = foldSlotsUsed f z tgt
             last (LastCondBranch e _ _) = foldSlotsUsed f z e
             last (LastSwitch e _tbl)    = foldSlotsUsed f z e
 
@@ -342,13 +345,13 @@ 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 u s) = LastCall (exp tgt) mb_id u s
+mapExpLast exp (LastCall tgt mb_id o i s) = LastCall (exp tgt) mb_id o i 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 (LastCall tgt _ _ _ _) z = exp tgt z
 
 mapExpMidcall :: (CmmExpr -> CmmExpr) -> MidCallTarget -> MidCallTarget 
 mapExpMidcall exp   (ForeignTarget e c) = ForeignTarget (exp e) c
@@ -388,11 +391,11 @@ joinOuts lattice env l =
   let bot  = fact_bot lattice
       join x y = txVal $ fact_add_to lattice x y
   in case l of
-       (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)
@@ -476,10 +479,10 @@ 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
-       LastSwitch arg ids           -> ppr $ CmmSwitch arg ids
-       LastCall tgt k off updfr_off -> genBareCall tgt k off updfr_off
+       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 out res updfr_off -> genBareCall tgt k out res updfr_off
 
     pp_debug = text " //" <+> case stmt of
            LastBranch {} -> text "LastBranch"
@@ -487,11 +490,13 @@ pprLast stmt = pp_stmt <+> pp_debug
            LastSwitch {} -> text "LastSwitch"
            LastCall {} -> text "LastCall"
 
-genBareCall :: CmmExpr -> Maybe BlockId -> Int -> Maybe UpdFrameOffset -> SDoc
-genBareCall fn k off updfr_off =
+genBareCall :: CmmExpr -> Maybe BlockId -> ByteOff -> ByteOff ->
+                          Maybe UpdFrameOffset -> SDoc
+genBareCall fn k out res updfr_off =
         hcat [ ptext (sLit "call"), space
              , pprFun fn, ptext (sLit "(...)"), space
-             , ptext (sLit "returns to") <+> ppr k <+> parens (ppr off)
+             , ptext (sLit "returns to") <+> ppr k <+> parens (ppr out)
+                                                   <+> parens (ppr res)
              , ptext (sLit " with update frame") <+> ppr updfr_off
              , semi ]
 
index 660f8e5..0f8eeb0 100644 (file)
@@ -43,10 +43,10 @@ _unused = all `seq` ()
 
 --unfocus (FGraph e bz bs) = LGraph e (insertBlock (zip bz) bs)
 
-focusp p (LGraph entry blocks) =
+focusp p (LGraph entry blocks) =
     fmap (\(b, bs) -> FGraph entry (unzip b) bs) (splitp_blocks p blocks)
 
-exit g@(LGraph eid _ _) = FGraph eid (ZBlock h (ZLast l)) others
+exit g@(LGraph eid _) = FGraph eid (ZBlock h (ZLast l)) others
     where FGraph _ b others = focusp is_exit g `orElse` panic "no exit in flow graph"
           (h, l) = goto_end b
 
@@ -65,7 +65,7 @@ splice_focus_exit (FGraph eid (ZBlock head tail) blocks) g =
 foldM_fwd_block ::
   Monad m => (BlockId -> a -> m a) -> (mid -> a -> m a) -> (ZLast l -> a -> m a) ->
              Block mid l -> a -> m a
-foldM_fwd_block first middle last (Block id t) z = do { z <- first id z; tail t z }
+foldM_fwd_block first middle last (Block id t) z = do { z <- first id z; tail t z }
     where tail (ZTail m t) z = do { z <- middle m z; tail t z }
           tail (ZLast l)   z = last l z
 
index 883de76..e8fefbf 100644 (file)
@@ -88,10 +88,10 @@ N.B. 'A set of facts' is shorthand for 'A finite map from CFG label to fact'.
 
 The types of transfer equations, rewrites, and fixed points are
 different for forward and backward problems.  To avoid cluttering the
-name space with two versions of every names, other names such as
+name space with two versions of every name, other names such as
 zdfSolveFrom are overloaded to work in both forward or backward
 directions.  This design decision is based on experience with the
-predecessor module, now called ZipDataflow0 and destined for the bit bucket.
+predecessor module, which has been mercifully deleted.
 
 
 This module is deliberately very abstract.  It is a completely general
@@ -122,9 +122,9 @@ the time being.
 -- block, so instead of a fact it is given a mapping from BlockId to fact.
 
 data BackwardTransfers middle last a = BackwardTransfers
-    { bt_first_in  :: a              -> BlockId -> a
-    , bt_middle_in :: a              -> middle  -> a
-    , bt_last_in   :: (BlockId -> a) -> last    -> a
+    { bt_first_in  :: BlockId -> a              -> a
+    , bt_middle_in :: middle  -> a              -> a
+    , bt_last_in   :: last    -> (BlockId -> a) -> a
     } 
 
 -- | For a forward transfer, you're given the fact on a node's 
@@ -133,10 +133,10 @@ data BackwardTransfers middle last a = BackwardTransfers
 -- block, so instead of a fact it produces a list of (BlockId, fact) pairs.
 
 data ForwardTransfers middle last a = ForwardTransfers
-    { ft_first_out  :: a -> BlockId -> a
-    , ft_middle_out :: a -> middle  -> a
-    , ft_last_outs  :: a -> last    -> LastOutFacts a
-    , ft_exit_out   :: a            -> a
+    { ft_first_out  :: BlockId -> a -> a
+    , ft_middle_out :: middle  -> a -> a
+    , ft_last_outs  :: last    -> a -> LastOutFacts a
+    , ft_exit_out   ::            a -> a
     } 
 
 newtype LastOutFacts a = LastOutFacts [(BlockId, a)] 
@@ -149,9 +149,9 @@ newtype LastOutFacts a = LastOutFacts [(BlockId, a)]
 -- but instead of producing a fact, it produces a replacement graph or Nothing.
 
 data BackwardRewrites middle last a = BackwardRewrites
-    { br_first  :: a              -> BlockId -> Maybe (AGraph middle last)
-    , br_middle :: a              -> middle  -> Maybe (AGraph middle last)
-    , br_last   :: (BlockId -> a) -> last    -> Maybe (AGraph middle last)
+    { br_first  :: BlockId -> a              -> Maybe (AGraph middle last)
+    , br_middle :: middle  -> a              -> Maybe (AGraph middle last)
+    , br_last   :: last    -> (BlockId -> a) -> Maybe (AGraph middle last)
     , br_exit   ::                              Maybe (AGraph middle last)
     } 
 
@@ -159,10 +159,10 @@ data BackwardRewrites middle last a = BackwardRewrites
 -- but instead of producing a fact, it produces a replacement graph or Nothing.
 
 data ForwardRewrites middle last a = ForwardRewrites
-    { fr_first  :: a -> BlockId -> Maybe (AGraph middle last)
-    , fr_middle :: a -> middle  -> Maybe (AGraph middle last)
-    , fr_last   :: a -> last    -> Maybe (AGraph middle last)
-    , fr_exit   :: a            -> Maybe (AGraph middle last)
+    { fr_first  :: BlockId -> a -> Maybe (AGraph middle last)
+    , fr_middle :: middle  -> a -> Maybe (AGraph middle last)
+    , fr_last   :: last    -> a -> Maybe (AGraph middle last)
+    , fr_exit   ::            a -> Maybe (AGraph middle last)
     } 
 
 {- ===================== FIXED POINTS =================== -}
@@ -284,28 +284,17 @@ instance DataflowSolverDirection BackwardTransfers BackwardFixedPoint
 -- forward and backward directions.
 -- 
 -- The type parameters of the class include not only transfer
--- functions and the fixed point but also rewrites and the type
--- constructor (here called 'graph') for making rewritten graphs.  As
--- above, in the definitoins of the rewrites, it might simplify
--- matters if 'graph' were replaced with 'AGraph'.
+-- functions and the fixed point but also rewrites.
 --
 -- The type signature of 'zdfRewriteFrom' is that of 'zdfSolveFrom'
--- with additional parameters and a different result.  Of course the
--- rewrites are an additional parameter, but there are further
--- parameters which reflect the fact that rewriting consumes both
--- OptimizationFuel and Uniqs.
---
--- The result type is changed to reflect fuel consumption, and also
--- the resulting fixed point containts a rewritten graph.
---
--- John Dias is going to improve the management of Uniqs and Fuel so
--- that it doesn't make us sick to look at the types.
+-- with the rewrites and a rewriting depth as additional parameters,
+-- as well as a different result, which contains a rewritten graph.
 
 class DataflowSolverDirection transfers fixedpt =>
       DataflowDirection transfers fixedpt rewrites where
   zdfRewriteFrom :: (DebugNodes m l, Outputable a)
                  => RewritingDepth      -- whether to rewrite a rewritten graph
-                 -> BlockEnv a          -- initial facts (unbound == botton)
+                 -> BlockEnv a          -- initial facts (unbound == bottom)
                  -> PassName
                  -> DataflowLattice a
                  -> transfers m l a
@@ -321,26 +310,26 @@ class DataflowSolverDirection transfers fixedpt =>
 quickGraph :: LastNode l => LGraph m l -> Graph m l
 quickGraph g = Graph (ZLast $ mkBranchNode $ lg_entry g) $ lg_blocks g
 
-quickLGraph :: LastNode l => Int -> Graph m l -> FuelMonad (LGraph m l)
-quickLGraph args (Graph (ZLast (LastOther l)) blockenv)
-    | isBranchNode l = return $ LGraph (branchNodeTarget l) args blockenv
-quickLGraph args g = F.lGraphOfGraph g args
+quickLGraph :: LastNode l => Graph m l -> FuelMonad (LGraph m l)
+quickLGraph (Graph (ZLast (LastOther l)) blockenv)
+    | isBranchNode l = return $ LGraph (branchNodeTarget l) blockenv
+quickLGraph g = F.lGraphOfGraph g
 
-fixptWithLGraph :: LastNode l => Int -> CommonFixedPoint m l fact (Graph m l) ->
+fixptWithLGraph :: LastNode l => CommonFixedPoint m l fact (Graph m l) ->
                                  FuelMonad (CommonFixedPoint m l fact (LGraph m l))
-fixptWithLGraph args cfp =
-  do fp_c <- quickLGraph args $ fp_contents cfp
+fixptWithLGraph cfp =
+  do fp_c <- quickLGraph $ fp_contents cfp
      return $ cfp {fp_contents = fp_c}
 
-ffixptWithLGraph :: LastNode l => Int -> ForwardFixedPoint m l fact (Graph m l) ->
+ffixptWithLGraph :: LastNode l => ForwardFixedPoint m l fact (Graph m l) ->
                                   FuelMonad (ForwardFixedPoint m l fact (LGraph m l))
-ffixptWithLGraph args fp =
-  do common <- fixptWithLGraph args $ ffp_common fp
+ffixptWithLGraph fp =
+  do common <- fixptWithLGraph $ ffp_common fp
      return $ fp {ffp_common = common}
 
 zdfFRewriteFromL :: (DebugNodes m l, Outputable a)
                => RewritingDepth      -- whether to rewrite a rewritten graph
-               -> BlockEnv a          -- initial facts (unbound == botton)
+               -> BlockEnv a          -- initial facts (unbound == bottom)
                -> PassName
                -> DataflowLattice a
                -> ForwardTransfers m l a
@@ -348,13 +337,13 @@ zdfFRewriteFromL :: (DebugNodes m l, Outputable a)
                -> a                   -- fact flowing in (at entry or exit)
                -> LGraph m l
                -> FuelMonad (ForwardFixedPoint m l a (LGraph m l))
-zdfFRewriteFromL d b p l t r a g@(LGraph _ args _) =
+zdfFRewriteFromL d b p l t r a g@(LGraph _ _) =
   do fp <- zdfRewriteFrom d b p l t r a $ quickGraph g
-     ffixptWithLGraph args fp
+     ffixptWithLGraph fp
 
 zdfBRewriteFromL :: (DebugNodes m l, Outputable a)
                => RewritingDepth      -- whether to rewrite a rewritten graph
-               -> BlockEnv a          -- initial facts (unbound == botton)
+               -> BlockEnv a          -- initial facts (unbound == bottom)
                -> PassName
                -> DataflowLattice a
                -> BackwardTransfers m l a
@@ -362,9 +351,9 @@ zdfBRewriteFromL :: (DebugNodes m l, Outputable a)
                -> a                   -- fact flowing in (at entry or exit)
                -> LGraph m l
                -> FuelMonad (BackwardFixedPoint m l a (LGraph m l))
-zdfBRewriteFromL d b p l t r a g@(LGraph _ args _) =
+zdfBRewriteFromL d b p l t r a g@(LGraph _ _) =
   do fp <- zdfRewriteFrom d b p l t r a $ quickGraph g
-     fixptWithLGraph args fp
+     fixptWithLGraph fp
 
 
 data RewritingDepth = RewriteShallow | RewriteDeep
@@ -427,11 +416,11 @@ areturn g = liftToDFM $ liftUniq $ graphOfAGraph g
 -- introduces an unnecessary basic block at each rewrite, and we don't
 -- want to stress out the finite map more than necessary
 lgraphToGraph :: LastNode l => LGraph m l -> Graph m l
-lgraphToGraph (LGraph eid blocks) =
+lgraphToGraph (LGraph eid blocks) =
     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!"
+        let Block _ entry = lookupBlockEnv blocks eid `orElse` panic "missing entry!"
         in  Graph entry (delFromBlockEnv blocks eid)
     
 
@@ -522,11 +511,11 @@ forward_sol check_maybe = forw
        solve finish in_fact (Graph entry blockenv) fuel =
          let blocks = G.postorder_dfs_from blockenv entry
              set_or_save = mk_set_or_save (isJust . lookupBlockEnv blockenv)
-             set_successor_facts (Block id tail) fuel =
+             set_successor_facts (Block id tail) fuel =
                do { idfact <- getFact id
                   ; (last_outs, fuel) <-
-                      case check_maybe fuel $ fr_first rewrites idfact id of
-                        Nothing -> solve_tail (ft_first_out transfers idfact id) tail fuel
+                      case check_maybe fuel $ fr_first rewrites id idfact of
+                        Nothing -> solve_tail (ft_first_out transfers id idfact) tail fuel
                         Just g ->
                           do g <- areturn g
                              (a, fuel) <- subAnalysis' $
@@ -547,8 +536,8 @@ forward_sol check_maybe = forw
                }
 
        solve_tail in' (G.ZTail m t) fuel =
-         case check_maybe fuel $ fr_middle rewrites in' m of
-           Nothing -> solve_tail (ft_middle_out transfers in' m) t fuel
+         case check_maybe fuel $ fr_middle rewrites m in' of
+           Nothing -> solve_tail (ft_middle_out transfers m in') t fuel
            Just g ->
              do { g <- areturn g
                 ; (a, fuel) <- subAnalysis' $
@@ -561,7 +550,7 @@ forward_sol check_maybe = forw
        solve_tail in' (G.ZLast l) fuel = 
          case check_maybe fuel $ either_last rewrites in' l of
            Nothing ->
-               case l of LastOther l -> return (ft_last_outs transfers in' l, fuel)
+               case l of LastOther l -> return (ft_last_outs transfers l in', fuel)
                          LastExit -> do { setExitFact (ft_exit_out transfers in')
                                         ; return (LastOutFacts [], fuel) }
            Just g ->
@@ -584,8 +573,8 @@ forward_sol check_maybe = forw
             ; return (fp, fuel)
             }
 
-       either_last rewrites in' (LastExit) = fr_exit rewrites in'
-       either_last rewrites in' (LastOther l) = fr_last rewrites in' l
+       either_last rewrites in' (LastExit)    = fr_exit rewrites in'
+       either_last rewrites in' (LastOther l) = fr_last rewrites l in'
 
    in fixed_point
 
@@ -635,11 +624,10 @@ 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 emptyStackInfo)
-                               in_fact entry emptyBlockEnv fuel
+                      rew_tail (ZFirst eid) in_fact entry emptyBlockEnv fuel
                   ; (rewritten, fuel) <- rewrite_blocks blocks rewritten fuel
                   ; a <- finish
-                  ; return (a, lgraphToGraph (LGraph eid rewritten), fuel)
+                  ; return (a, lgraphToGraph (LGraph eid rewritten), fuel)
                   }
           don't_rewrite facts finish in_fact g fuel =
               do  { solve depth name facts transfers rewrites in_fact g fuel
@@ -662,12 +650,12 @@ forward_rew check_maybe = forw
           rewrite_blocks :: [Block m l] -> (BlockEnv (Block m l))
                          -> Fuel -> DFM a (BlockEnv (Block m l), Fuel)
           rewrite_blocks [] rewritten fuel = return (rewritten, fuel)
-          rewrite_blocks (G.Block id off t : bs) rewritten fuel =
-            do let h = ZFirst id off
+          rewrite_blocks (G.Block id t : bs) rewritten fuel =
+            do let h = ZFirst id
                a <- getFact id
-               case check_maybe fuel $ fr_first rewrites a id of
+               case check_maybe fuel $ fr_first rewrites id a of
                  Nothing -> do { (rewritten, fuel) <-
-                                    rew_tail h (ft_first_out transfers a id)
+                                    rew_tail h (ft_first_out transfers id a)
                                              t rewritten fuel
                                ; rewrite_blocks bs rewritten fuel }
                  Just g  -> do { markGraphRewritten
@@ -680,8 +668,8 @@ forward_rew check_maybe = forw
 
           rew_tail head in' (G.ZTail m t) rewritten fuel =
             my_trace "Rewriting middle node" (ppr m) $
-            case check_maybe fuel $ fr_middle rewrites in' m of
-              Nothing -> rew_tail (G.ZHead head m) (ft_middle_out transfers in' m) t
+            case check_maybe fuel $ fr_middle rewrites m in' of
+              Nothing -> rew_tail (G.ZHead head m) (ft_middle_out transfers m in') t
                          rewritten fuel
               Just g -> do { markGraphRewritten
                            ; g <- areturn g
@@ -701,9 +689,9 @@ forward_rew check_maybe = forw
                            ; 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
+          either_last rewrites in' (LastOther l) = fr_last rewrites l in'
           check_facts in' (LastOther l) =
-            let LastOutFacts last_outs = ft_last_outs transfers in' l
+            let LastOutFacts last_outs = ft_last_outs transfers l in'
             in mapM (uncurry checkFactMatch) last_outs
           check_facts _ LastExit = return []
       in  fixed_pt_and_fuel
@@ -788,9 +776,9 @@ backward_sol check_maybe = back
        solve (Graph entry blockenv) exit_fact fuel =
          let blocks = reverse $ G.postorder_dfs_from blockenv entry
              last_in  _env (LastExit)    = exit_fact
-             last_in   env (LastOther l) = bt_last_in transfers env l
+             last_in   env (LastOther l) = bt_last_in transfers l env
              last_rew _env (LastExit)    = br_exit rewrites 
-             last_rew  env (LastOther l) = br_last rewrites env l
+             last_rew  env (LastOther l) = br_last rewrites l env
              set_block_fact block fuel =
                  let (h, l) = G.goto_end (G.unzip block) in
                  do { env <- factsEnv
@@ -806,28 +794,28 @@ backward_sol check_maybe = back
 
          in do { fuel <- run "backward" name set_block_fact blocks fuel
                ; eid <- freshBlockId "temporary entry id"
-               ; fuel <- set_block_fact (Block eid emptyStackInfo entry) fuel
+               ; fuel <- set_block_fact (Block eid entry) fuel
                ; a <- getFact eid
                ; forgetFact eid
                ; return (a, fuel)
                }
 
-       set_head_fact (G.ZFirst id _) a fuel =
-         case check_maybe fuel $ br_first rewrites a id of
+       set_head_fact (G.ZFirst id) a fuel =
+         case check_maybe fuel $ br_first rewrites id a of
            Nothing -> do { my_trace "set_head_fact" (ppr id <+> text "=" <+>
-                                                     ppr (bt_first_in transfers a id)) $
-                           setFact id $ bt_first_in transfers a id
+                                                     ppr (bt_first_in transfers id a)) $
+                           setFact id $ bt_first_in transfers id a
                          ; return fuel }
            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
+                         ; setFact id $ bt_first_in transfers id a
                          ; 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
+         case check_maybe fuel $ br_middle rewrites m a of
+           Nothing -> set_head_fact h (bt_middle_in transfers m a) fuel
            Just g -> do { g' <- areturn g
                         ; (a, fuel) <- my_trace "analysis rewrites middle node"
                                       (ppr m <+> pprGraph g') $
@@ -903,12 +891,11 @@ backward_rew check_maybe = back
                  ; (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 emptyStackInfo entry]
-                                    rewritten fuel
+                     rewrite_blocks False [Block eid 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 ()
-                 ; return (in_fact, lgraphToGraph (LGraph eid rewritten), fuel)
+                 ; return (in_fact, lgraphToGraph (LGraph eid rewritten), fuel)
                  } -- Remember: the entry fact computed by @solve@ accounts for rewriting
           don't_rewrite facts g exit_fact fuel =
             do { (fp, _) <-
@@ -946,13 +933,13 @@ backward_rew check_maybe = back
                    ; propagate check fuel h a t rewritten' -- continue at entry of g
                    } 
           either_last _env (LastExit)    = br_exit rewrites 
-          either_last  env (LastOther l) = br_last rewrites env l
+          either_last  env (LastOther l) = br_last rewrites l env
           last_in _env (LastExit)    = exit_fact
-          last_in  env (LastOther l) = bt_last_in transfers env l
+          last_in  env (LastOther l) = bt_last_in transfers l env
           propagate check fuel (ZHead h m) a tail rewritten =
-            case maybeRewriteWithFuel fuel $ br_middle rewrites a m of
+            case maybeRewriteWithFuel fuel $ br_middle rewrites m a of
               Nothing ->
-                propagate check fuel h (bt_middle_in transfers a m) (ZTail m tail) rewritten
+                propagate check fuel h (bt_middle_in transfers m a) (ZTail m tail) rewritten
               Just g  ->
                 do { markGraphRewritten
                    ; g <- areturn g
@@ -964,22 +951,22 @@ backward_rew check_maybe = back
                    ; let Graph t newblocks = G.splice_tail g tail
                    ; my_trace "propagating facts" (ppr a) $
                      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
+          propagate check fuel (ZFirst id) a tail rewritten =
+            case maybeRewriteWithFuel fuel $ br_first rewrites id a of
               Nothing -> do { if check then
-                                checkFactMatch id $ bt_first_in transfers a id
+                                checkFactMatch id $ bt_first_in transfers id a
                               else return ()
-                            ; return (insertBlock (Block id off tail) rewritten, fuel) }
+                            ; return (insertBlock (Block id tail) rewritten, fuel) }
               Just g ->
                 do { markGraphRewritten
                    ; g <- areturn g
                    ; 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 (bt_first_in transfers a id)
+                   ; if check then checkFactMatch id (bt_first_in transfers id a)
                      else return ()
                    ; let Graph t newblocks = G.splice_tail g tail
-                   ; let r = insertBlock (Block id off t) (newblocks `plusBlockEnv` rewritten)
+                   ; let r = insertBlock (Block id t) (newblocks `plusBlockEnv` rewritten)
                    ; return (r, fuel) }
       in  fixed_pt_and_fuel
 
@@ -1003,7 +990,7 @@ instance FixedPoint ForwardFixedPoint where
 
 
 dump_things :: Bool
-dump_things = False
+dump_things = True
 
 my_trace :: String -> SDoc -> a -> a
 my_trace = if dump_things then pprTrace else \_ _ a -> a
@@ -1046,14 +1033,13 @@ run dir name do_block blocks b =
      unchanged depth =
        my_nest depth (text "facts for" <+> graphId <+> text "are unchanged")
 
-     graphId = case blocks of { Block id _ : _ -> ppr id ; [] -> text "<empty>" }
+     graphId = case blocks of { Block id _ : _ -> ppr id ; [] -> text "<empty>" }
      show_blocks = my_trace "Blocks:" (vcat (map pprBlock blocks))
-     pprBlock (Block id off t) = nest 2 (pprFact' (id, off, t))
+     pprBlock (Block id t) = nest 2 (pprFact (id, t))
      pprFacts depth n env =
          my_nest depth (text "facts for iteration" <+> pp_i n <+> text "are:" $$
                         (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)
 
 
 f4sep :: [SDoc] -> SDoc
index 0fc6c4c..ae4fa1b 100644 (file)
@@ -239,8 +239,7 @@ mkModuleInit way cost_centre_info this_mod main_mod imported_mods hpc_info
     mod_reg_val = CmmLoad (mkLblExpr moduleRegdLabel) bWord
     check_already_done retId updfr_sz
      = mkCmmIfThenElse (cmmNeWord (CmmLit zeroCLit) mod_reg_val)
-                      (mkLabel retId emptyStackInfo
-                    <*> mkReturn (ret_e updfr_sz) [] (pop_ret_loc updfr_sz)) mkNop
+                      (mkLabel retId <*> 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))
 
index 369564c..df6e8a1 100644 (file)
@@ -42,6 +42,7 @@ import Maybes
 import Util
 import FastString
 import Outputable
+import UniqSupply
 
 ------------------------------------------------------------------------
 --             cgExpr: the main function
@@ -57,8 +58,13 @@ cgExpr (StgTick m n expr) = do { emit (mkTickBox m n); cgExpr expr }
 cgExpr (StgLit lit)       = do cmm_lit <- cgLit lit
                                emitReturn [CmmLit cmm_lit]
 
-cgExpr (StgLet binds expr)            = do { cgBind binds; cgExpr expr }
-cgExpr (StgLetNoEscape _ _ binds expr) = do { cgLneBinds binds; cgExpr expr }
+cgExpr (StgLet binds expr)             = do { cgBind binds;     cgExpr expr }
+cgExpr (StgLetNoEscape _ _ binds expr) =
+  do { us <- newUniqSupply
+     ; let join_id = mkBlockId (uniqFromSupply us)
+     ; cgLneBinds join_id binds
+     ; cgExpr expr 
+     ; emit $ mkLabel join_id}
 
 cgExpr (StgCase expr _live_vars _save_vars bndr srt alt_type alts) =
   cgCase expr bndr srt alt_type alts
@@ -84,37 +90,42 @@ bound only to stable things like stack locations..  The 'e' part will
 execute *next*, just like the scrutinee of a case. -}
 
 -------------------------
-cgLneBinds :: StgBinding -> FCode ()
-cgLneBinds (StgNonRec bndr rhs)
-  = do { local_cc <- saveCurrentCostCentre
-               -- See Note [Saving the current cost centre]
-       ; info <- cgLetNoEscapeRhs local_cc bndr rhs 
-       ; addBindC (cg_id info) info }
-
-cgLneBinds (StgRec pairs)
-  = do { local_cc <- saveCurrentCostCentre
-       ; new_bindings <- fixC (\ new_bindings -> do
-               { addBindsC new_bindings
-               ; listFCs [ cgLetNoEscapeRhs local_cc b e 
-                         | (b,e) <- pairs ] })
-
-       ; addBindsC new_bindings }
+cgLneBinds :: BlockId -> StgBinding -> FCode ()
+cgLneBinds join_id (StgNonRec bndr rhs)
+  = do  { local_cc <- saveCurrentCostCentre
+                -- See Note [Saving the current cost centre]
+        ; info <- cgLetNoEscapeRhs join_id local_cc bndr rhs 
+        ; addBindC (cg_id info) info }
+
+cgLneBinds join_id (StgRec pairs)
+  = do  { local_cc <- saveCurrentCostCentre
+        ; new_bindings <- fixC (\ new_bindings -> do
+                { addBindsC new_bindings
+                ; listFCs [ cgLetNoEscapeRhs join_id local_cc b e 
+                          | (b,e) <- pairs ] })
+        ; addBindsC new_bindings }
 
 
 -------------------------
-cgLetNoEscapeRhs, cgLetNoEscapeRhsBody
-    :: Maybe LocalReg  -- Saved cost centre
+cgLetNoEscapeRhs
+    :: BlockId          -- join point for successor of let-no-escape
+    -> Maybe LocalReg  -- Saved cost centre
     -> Id
     -> StgRhs
     -> FCode CgIdInfo
 
-cgLetNoEscapeRhs local_cc bndr rhs =
+cgLetNoEscapeRhs join_id 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)
+     ; emit (outOfLine $ mkLabel bid <*> rhs_body <*> mkBranch join_id)
      ; return info
      }
 
+cgLetNoEscapeRhsBody
+    :: Maybe LocalReg  -- Saved cost centre
+    -> Id
+    -> StgRhs
+    -> FCode CgIdInfo
 cgLetNoEscapeRhsBody local_cc bndr (StgRhsClosure cc _bi _ _upd _ args body)
   = cgLetNoEscapeClosure bndr local_cc cc (nonVoidIds args) body
 cgLetNoEscapeRhsBody local_cc bndr (StgRhsCon cc con args)
index 7138579..676aa4f 100644 (file)
@@ -437,7 +437,7 @@ do_checks :: Bool       -- Should we check the stack?
 do_checks checkStack alloc do_gc
   = withFreshLabel "gc" $ \ loop_id ->
     withFreshLabel "gc" $ \ gc_id   ->
-      mkLabel loop_id emptyStackInfo
+      mkLabel loop_id 
       <*> (let hpCheck = if alloc == 0 then mkNop
                          else mkAssign hpReg bump_hp <*>
                               mkCmmIfThen hp_oflo (save_alloc <*> mkBranch gc_id)
@@ -445,7 +445,7 @@ do_checks checkStack alloc do_gc
                 mkCmmIfThenElse sp_oflo (mkBranch gc_id) hpCheck
               else hpCheck)
       <*> mkComment (mkFastString "outOfLine should follow:")
-      <*> outOfLine (mkLabel gc_id emptyStackInfo
+      <*> outOfLine (mkLabel gc_id 
                      <*> mkComment (mkFastString "outOfLine here")
                      <*> do_gc
                      <*> mkBranch loop_id)
index 5daceed..dbc97d4 100644 (file)
@@ -80,7 +80,7 @@ emitReturn :: [CmmExpr] -> FCode ()
 emitReturn results
   = do { sequel    <- getSequel;
        ; updfr_off <- getUpdFrameOff
-       ; emit $ mkComment $ mkFastString "emitReturn"
+       ; emit $ mkComment $ mkFastString ("emitReturn: " ++ show sequel)
        ; case sequel of
            Return _ ->
              do { adjustHpBackwards
@@ -97,7 +97,7 @@ emitCall conv fun args
   = do { adjustHpBackwards
        ; sequel <- getSequel
        ; updfr_off <- getUpdFrameOff
-        ; emit $ mkComment $ mkFastString "emitCall"
+        ; emit $ mkComment $ mkFastString ("emitCall: " ++ show sequel)
        ; case sequel of
            Return _            -> emit (mkForeignJump conv fun args updfr_off)
            AssignTo res_regs _ -> emit (mkCall fun conv res_regs args updfr_off)
index c1f743d..1419773 100644 (file)
@@ -213,6 +213,9 @@ data Sequel
                         -- space that's unused on this path?
                         -- We need to do this only if the expression may
                         -- allocate (e.g. it's a foreign call or allocating primOp)
+instance Show Sequel where
+  show (Return _) = "Sequel: Return"
+  show (AssignTo _ _) = "Sequel: Assign"
 
 initCgInfoDown :: DynFlags -> Module -> CgInfoDownwards
 initCgInfoDown dflags mod
@@ -504,7 +507,7 @@ forkProc body_code
   = do { info_down <- getInfoDown
        ; us    <- newUniqSupply
        ; state <- getState
-       ; let   info_down' = info_down { cgd_sequel = initSequel }
+       ; let   info_down' = info_down -- { cgd_sequel = initSequel }
                 fork_state_in = (initCgState us) { cgs_binds = cgs_binds state }
                (result, fork_state_out) = doFCode body_code info_down' fork_state_in
        ; setState $ state `addCodeBlocksFrom` fork_state_out
@@ -598,8 +601,8 @@ emitProcWithConvention :: Convention -> CmmInfo -> CLabel -> CmmFormals ->
 emitProcWithConvention conv info lbl args blocks
   = do  { us <- newUniqSupply
         ; let (offset, entry) = mkEntry (mkBlockId $ uniqFromSupply us) conv args
-              blks = initUs_ us $ lgraphOfAGraph offset $ entry <*> blocks
-        ; let proc_block = CmmProc info lbl args blks
+              blks = initUs_ us $ lgraphOfAGraph $ entry <*> blocks
+        ; let proc_block = CmmProc info lbl args ((offset, Just initUpdFrameOff), blks)
         ; state <- getState
         ; setState $ state { cgs_tops = cgs_tops state `snocOL` proc_block } }
 
@@ -630,5 +633,5 @@ getCmm code
 cgStmtsToBlocks :: CmmAGraph -> FCode CmmGraph
 cgStmtsToBlocks stmts
   = do  { us <- newUniqSupply
-       ; return (initUs_ us (lgraphOfAGraph 0 stmts)) }        
+       ; return (initUs_ us (lgraphOfAGraph stmts)) }  
 
index dc7fb8b..f49c266 100644 (file)
@@ -52,7 +52,6 @@ import BlockId
 import Cmm
 import CmmExpr
 import MkZipCfgCmm
-import ZipCfg hiding (last, unzip, zip)
 import CLabel
 import CmmUtils
 import PprCmm          ( {- instances -} )
@@ -636,7 +635,7 @@ mkCmmSwitch via_C tag_expr branches mb_deflt lo_tag hi_tag
     mk_switch tag_expr' (sortLe le branches) mb_deflt 
              lo_tag hi_tag via_C
          -- Sort the branches before calling mk_switch
-    <*> mkLabel join_lbl emptyStackInfo
+    <*> mkLabel join_lbl
 
   where
     (t1,_) `le` (t2,_) = t1 <= t2
@@ -791,7 +790,7 @@ mkCmmLitSwitch scrut  branches deflt
     label_code join_lbl deflt          $ \ deflt ->
     label_branches join_lbl branches   $ \ branches ->
     mk_lit_switch scrut' deflt (sortLe le branches)
-    <*> mkLabel join_lbl emptyStackInfo
+    <*> mkLabel join_lbl
   where
     le (t1,_) (t2,_) = t1 <= t2
 
@@ -850,7 +849,7 @@ label_code :: BlockId -> CmmAGraph -> (BlockId -> CmmAGraph) -> CmmAGraph
 --  [L: code; goto J] fun L
 label_code join_lbl code thing_inside
   = withFreshLabel "switch"    $ \lbl -> 
-    outOfLine (mkLabel lbl emptyStackInfo <*> code <*> mkBranch join_lbl)
+    outOfLine (mkLabel lbl <*> code <*> mkBranch join_lbl)
     <*> thing_inside lbl
  
 
index 03daf34..12b12e3 100644 (file)
@@ -717,10 +717,11 @@ hscGenHardCode cgguts mod_summary
                                stg_binds hpc_info
 
          --- Optionally run experimental Cmm transformations ---
-         cmms <- optionallyConvertAndOrCPS hsc_env cmms
+         -- cmms <- optionallyConvertAndOrCPS hsc_env cmms
                  -- unless certain dflags are on, the identity function
          ------------------  Code output -----------------------
          rawcmms <- cmmToRawCmm cmms
+         dumpIfSet_dyn dflags Opt_D_dump_cmmz "Raw Cmm" (ppr rawcmms)
          (_stub_h_exists, stub_c_exists)
              <- codeOutput dflags this_mod location foreign_stubs 
                 dependencies rawcmms
@@ -811,10 +812,8 @@ tryNewCodeGen hsc_env this_mod data_tycons imported_mods
        ; prog <- return $ map (runTx $ runCmmOpts cmmCfgOptsZ) (srtToData topSRT : prog)
                -- Control flow optimisation, again
 
-       ; dumpIfSet_dyn dflags Opt_D_dump_cmmz "Output Cmm" (pprCmms prog)
-
        ; let prog' = map cmmOfZgraph prog
-       ; dumpIfSet_dyn dflags Opt_D_dump_cmmz "Raw Cmm" (ppr prog')
+       ; dumpIfSet_dyn dflags Opt_D_dump_cmmz "Output Cmm" (ppr prog')
        ; return prog' }
 
 
@@ -853,7 +852,6 @@ testCmmConversion hsc_env cmm =
        let cvt = cmmOfZgraph $ cfopts $ chosen_graph
        dumpIfSet_dyn dflags Opt_D_dump_cvt_cmm "C-- post-conversion" (ppr cvt)
        return cvt
-       -- return cmm -- don't use the conversion
 
 myCoreToStg :: DynFlags -> Module -> [CoreBind]
             -> IO ( [(StgBinding,[(Id,[Id])])]  -- output program
index a3bf8e4..39ff406 100644 (file)
@@ -51,14 +51,17 @@ canShortcut (JMP (OpImm imm))       = Just (DestImm imm)
 canShortcut _                  = Nothing
 
 
+-- The helper ensures that we don't follow cycles.
 shortcutJump :: (BlockId -> Maybe JumpDest) -> Instr -> Instr
-shortcutJump fn insn@(JXX cc id) = 
-  case fn id of
-    Nothing                -> insn
-    Just (DestBlockId id') -> shortcutJump fn (JXX cc id')
-    Just (DestImm imm)     -> shortcutJump fn (JXX_GBL cc imm)
-
-shortcutJump _ other = other
+shortcutJump fn insn = shortcutJump' fn emptyBlockSet insn
+  where shortcutJump' fn seen insn@(JXX cc id) =
+          if elemBlockSet id seen then insn
+          else case fn id of
+                 Nothing                -> insn
+                 Just (DestBlockId id') -> shortcutJump' fn seen' (JXX cc id')
+                 Just (DestImm imm)     -> shortcutJump' fn seen' (JXX_GBL cc imm)
+               where seen' = extendBlockSet seen id
+        shortcutJump' _ _ other = other
 
 
 -- Here because it knows about JumpDest
index 5d0afb4..4e2352b 100644 (file)
--- a/validate
+++ b/validate
@@ -48,7 +48,7 @@ done
 if [ "$CPUS" = "" ]; then
     threads=2
 else
-    threads=`expr $CPUS + 1`
+    threads=$((($CPUS + 1) * 2)) # `expr $CPUS + 1`
 fi
 
 if [ $testsuite_only -eq 0 ]; then