summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authordias@eecs.harvard.edu <unknown>2009-03-03 15:02:28 +0000
committerdias@eecs.harvard.edu <unknown>2009-03-03 15:02:28 +0000
commit31a9d04804d9cacda35695c5397590516b964964 (patch)
tree1253be42d69db8ab7a6d104e2eda8d03a44a9be2
parent6d38e24ea3da7ca9b435e9b1e59b2de8fcd91da4 (diff)
downloadhaskell-31a9d04804d9cacda35695c5397590516b964964.tar.gz
A few bug fixes; some improvements spurred by paper writing
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
Diffstat
-rw-r--r--compiler/cmm/Cmm.hs2
-rw-r--r--compiler/cmm/CmmBuildInfoTables.hs66
-rw-r--r--compiler/cmm/CmmCPSZ.hs37
-rw-r--r--compiler/cmm/CmmCallConv.hs5
-rw-r--r--compiler/cmm/CmmCommonBlockElimZ.hs15
-rw-r--r--compiler/cmm/CmmContFlowOpt.hs53
-rw-r--r--compiler/cmm/CmmCvt.hs33
-rw-r--r--compiler/cmm/CmmExpr.hs17
-rw-r--r--compiler/cmm/CmmInfo.hs2
-rw-r--r--compiler/cmm/CmmLiveZ.hs49
-rw-r--r--compiler/cmm/CmmProcPointZ.hs123
-rw-r--r--compiler/cmm/CmmSpillReload.hs129
-rw-r--r--compiler/cmm/CmmStackLayout.hs147
-rw-r--r--compiler/cmm/CmmZipUtil.hs2
-rw-r--r--compiler/cmm/DFMonad.hs22
-rw-r--r--compiler/cmm/MkZipCfg.hs32
-rw-r--r--compiler/cmm/MkZipCfgCmm.hs133
-rw-r--r--compiler/cmm/OptimizationFuel.hs7
-rw-r--r--compiler/cmm/PprCmmZ.hs18
-rw-r--r--compiler/cmm/StackColor.hs8
-rw-r--r--compiler/cmm/ZipCfg.hs95
-rw-r--r--compiler/cmm/ZipCfgCmmRep.hs71
-rw-r--r--compiler/cmm/ZipCfgExtras.hs6
-rw-r--r--compiler/cmm/ZipDataflow.hs176
-rw-r--r--compiler/codeGen/StgCmm.hs3
-rw-r--r--compiler/codeGen/StgCmmExpr.hs53
-rw-r--r--compiler/codeGen/StgCmmHeap.hs4
-rw-r--r--compiler/codeGen/StgCmmLayout.hs4
-rw-r--r--compiler/codeGen/StgCmmMonad.hs11
-rw-r--r--compiler/codeGen/StgCmmUtils.hs7
-rw-r--r--compiler/main/HscMain.lhs8
-rw-r--r--compiler/nativeGen/X86/RegInfo.hs17
-rw-r--r--validate2
33 files changed, 663 insertions, 694 deletions
diff --git a/compiler/cmm/Cmm.hs b/compiler/cmm/Cmm.hs
index 2ee259c78a..383ed060e0 100644
--- a/compiler/cmm/Cmm.hs
+++ b/compiler/cmm/Cmm.hs
@@ -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) =
diff --git a/compiler/cmm/CmmBuildInfoTables.hs b/compiler/cmm/CmmBuildInfoTables.hs
index e3d2ded59e..fa2c009740 100644
--- a/compiler/cmm/CmmBuildInfoTables.hs
+++ b/compiler/cmm/CmmBuildInfoTables.hs
@@ -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) =
diff --git a/compiler/cmm/CmmCPSZ.hs b/compiler/cmm/CmmCPSZ.hs
index aac9372f94..db72c64216 100644
--- a/compiler/cmm/CmmCPSZ.hs
+++ b/compiler/cmm/CmmCPSZ.hs
@@ -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)
diff --git a/compiler/cmm/CmmCallConv.hs b/compiler/cmm/CmmCallConv.hs
index fed3617233..243072e1d5 100644
--- a/compiler/cmm/CmmCallConv.hs
+++ b/compiler/cmm/CmmCallConv.hs
@@ -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 =
diff --git a/compiler/cmm/CmmCommonBlockElimZ.hs b/compiler/cmm/CmmCommonBlockElimZ.hs
index c4d612e337..4c144cf63c 100644
--- a/compiler/cmm/CmmCommonBlockElimZ.hs
+++ b/compiler/cmm/CmmCommonBlockElimZ.hs
@@ -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
diff --git a/compiler/cmm/CmmContFlowOpt.hs b/compiler/cmm/CmmContFlowOpt.hs
index a3239b94a1..c4d048d8e3 100644
--- a/compiler/cmm/CmmContFlowOpt.hs
+++ b/compiler/cmm/CmmContFlowOpt.hs
@@ -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
diff --git a/compiler/cmm/CmmCvt.hs b/compiler/cmm/CmmCvt.hs
index f3c05b8b7b..09d5cd52fa 100644
--- a/compiler/cmm/CmmCvt.hs
+++ b/compiler/cmm/CmmCvt.hs
@@ -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
diff --git a/compiler/cmm/CmmExpr.hs b/compiler/cmm/CmmExpr.hs
index 8e40654352..7ea1c4760a 100644
--- a/compiler/cmm/CmmExpr.hs
+++ b/compiler/cmm/CmmExpr.hs
@@ -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
diff --git a/compiler/cmm/CmmInfo.hs b/compiler/cmm/CmmInfo.hs
index de6e201a18..734896adc8 100644
--- a/compiler/cmm/CmmInfo.hs
+++ b/compiler/cmm/CmmInfo.hs
@@ -21,10 +21,10 @@ import SMRep
import ZipCfgCmmRep
import Constants
+import Panic
import StaticFlags
import Unique
import UniqSupply
-import Panic
import Data.Bits
diff --git a/compiler/cmm/CmmLiveZ.hs b/compiler/cmm/CmmLiveZ.hs
index 70bd51b0fd..3d8f57054c 100644
--- a/compiler/cmm/CmmLiveZ.hs
+++ b/compiler/cmm/CmmLiveZ.hs
@@ -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)
diff --git a/compiler/cmm/CmmProcPointZ.hs b/compiler/cmm/CmmProcPointZ.hs
index 712461db85..5ec65c5d0b 100644
--- a/compiler/cmm/CmmProcPointZ.hs
+++ b/compiler/cmm/CmmProcPointZ.hs
@@ -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]
----------------------------------------------------------------
diff --git a/compiler/cmm/CmmSpillReload.hs b/compiler/cmm/CmmSpillReload.hs
index be570f2bcc..085dc377db 100644
--- a/compiler/cmm/CmmSpillReload.hs
+++ b/compiler/cmm/CmmSpillReload.hs
@@ -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
diff --git a/compiler/cmm/CmmStackLayout.hs b/compiler/cmm/CmmStackLayout.hs
index 17a819f927..6c47043781 100644
--- a/compiler/cmm/CmmStackLayout.hs
+++ b/compiler/cmm/CmmStackLayout.hs
@@ -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 o 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)
diff --git a/compiler/cmm/CmmZipUtil.hs b/compiler/cmm/CmmZipUtil.hs
index 5171218056..a91d76f31d 100644
--- a/compiler/cmm/CmmZipUtil.hs
+++ b/compiler/cmm/CmmZipUtil.hs
@@ -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))
diff --git a/compiler/cmm/DFMonad.hs b/compiler/cmm/DFMonad.hs
index 0bce264de6..4db3b966af 100644
--- a/compiler/cmm/DFMonad.hs
+++ b/compiler/cmm/DFMonad.hs
@@ -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
diff --git a/compiler/cmm/MkZipCfg.hs b/compiler/cmm/MkZipCfg.hs
index 59d50d5e56..fa93f7690a 100644
--- a/compiler/cmm/MkZipCfg.hs
+++ b/compiler/cmm/MkZipCfg.hs
@@ -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 ::
diff --git a/compiler/cmm/MkZipCfgCmm.hs b/compiler/cmm/MkZipCfgCmm.hs
index 4b073e2abf..88adaaebf1 100644
--- a/compiler/cmm/MkZipCfgCmm.hs
+++ b/compiler/cmm/MkZipCfgCmm.hs
@@ -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)
diff --git a/compiler/cmm/OptimizationFuel.hs b/compiler/cmm/OptimizationFuel.hs
index a5d8fa3c09..5e400c4009 100644
--- a/compiler/cmm/OptimizationFuel.hs
+++ b/compiler/cmm/OptimizationFuel.hs
@@ -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)
diff --git a/compiler/cmm/PprCmmZ.hs b/compiler/cmm/PprCmmZ.hs
index 30eb492bba..e9199ffd82 100644
--- a/compiler/cmm/PprCmmZ.hs
+++ b/compiler/cmm/PprCmmZ.hs
@@ -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 ),
diff --git a/compiler/cmm/StackColor.hs b/compiler/cmm/StackColor.hs
index 03af1818af..3bb131741c 100644
--- a/compiler/cmm/StackColor.hs
+++ b/compiler/cmm/StackColor.hs
@@ -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
diff --git a/compiler/cmm/ZipCfg.hs b/compiler/cmm/ZipCfg.hs
index c1bd956e34..1e04f90ae5 100644
--- a/compiler/cmm/ZipCfg.hs
+++ b/compiler/cmm/ZipCfg.hs
@@ -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 0 (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) 0 (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
diff --git a/compiler/cmm/ZipCfgCmmRep.hs b/compiler/cmm/ZipCfgCmmRep.hs
index 453b8f0e9f..348ab5bf2b 100644
--- a/compiler/cmm/ZipCfgCmmRep.hs
+++ b/compiler/cmm/ZipCfgCmmRep.hs
@@ -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 ]
diff --git a/compiler/cmm/ZipCfgExtras.hs b/compiler/cmm/ZipCfgExtras.hs
index 660f8e5af3..0f8eeb0d2b 100644
--- a/compiler/cmm/ZipCfgExtras.hs
+++ b/compiler/cmm/ZipCfgExtras.hs
@@ -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
diff --git a/compiler/cmm/ZipDataflow.hs b/compiler/cmm/ZipDataflow.hs
index 883de762f0..e8fefbfd0d 100644
--- a/compiler/cmm/ZipDataflow.hs
+++ b/compiler/cmm/ZipDataflow.hs
@@ -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 0 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 0 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
diff --git a/compiler/codeGen/StgCmm.hs b/compiler/codeGen/StgCmm.hs
index 0fc6c4c5a8..ae4fa1b623 100644
--- a/compiler/codeGen/StgCmm.hs
+++ b/compiler/codeGen/StgCmm.hs
@@ -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))
diff --git a/compiler/codeGen/StgCmmExpr.hs b/compiler/codeGen/StgCmmExpr.hs
index 369564cba8..df6e8a1a47 100644
--- a/compiler/codeGen/StgCmmExpr.hs
+++ b/compiler/codeGen/StgCmmExpr.hs
@@ -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)
diff --git a/compiler/codeGen/StgCmmHeap.hs b/compiler/codeGen/StgCmmHeap.hs
index 713857929a..676aa4f4aa 100644
--- a/compiler/codeGen/StgCmmHeap.hs
+++ b/compiler/codeGen/StgCmmHeap.hs
@@ -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)
diff --git a/compiler/codeGen/StgCmmLayout.hs b/compiler/codeGen/StgCmmLayout.hs
index 5daceedc43..dbc97d49d8 100644
--- a/compiler/codeGen/StgCmmLayout.hs
+++ b/compiler/codeGen/StgCmmLayout.hs
@@ -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)
diff --git a/compiler/codeGen/StgCmmMonad.hs b/compiler/codeGen/StgCmmMonad.hs
index c1f743dc56..1419773ce0 100644
--- a/compiler/codeGen/StgCmmMonad.hs
+++ b/compiler/codeGen/StgCmmMonad.hs
@@ -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)) }
diff --git a/compiler/codeGen/StgCmmUtils.hs b/compiler/codeGen/StgCmmUtils.hs
index dc7fb8b9d1..f49c266499 100644
--- a/compiler/codeGen/StgCmmUtils.hs
+++ b/compiler/codeGen/StgCmmUtils.hs
@@ -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
diff --git a/compiler/main/HscMain.lhs b/compiler/main/HscMain.lhs
index 03daf34149..12b12e350c 100644
--- a/compiler/main/HscMain.lhs
+++ b/compiler/main/HscMain.lhs
@@ -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
diff --git a/compiler/nativeGen/X86/RegInfo.hs b/compiler/nativeGen/X86/RegInfo.hs
index a3bf8e4655..39ff4063b0 100644
--- a/compiler/nativeGen/X86/RegInfo.hs
+++ b/compiler/nativeGen/X86/RegInfo.hs
@@ -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
diff --git a/validate b/validate
index 5d0afb4d2b..4e2352b9cb 100644
--- 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
View Lorry Controller Status