- replB :: FuelMonad (BlockEnv CmmBlock) -> CmmBlock -> FuelMonad (BlockEnv CmmBlock)
- 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
- replTail :: (ZTail Middle Last -> CmmBlock) -> Int -> (ZTail Middle Last) ->
- FuelMonad ([CmmBlock])
- replTail h spOff (ZTail m@(MidForeignCall (Safe bid _ _) _ _ _) t) =
- replTail (\t' -> h (setSp spOff spOff' (ZTail (middle spOff m) t'))) spOff' t
- where spOff' = slot' (Just bid) + widthInBytes (typeWidth gcWord)
- replTail h spOff (ZTail m t) = replTail (h . ZTail (middle spOff m)) spOff t
- replTail h spOff (ZLast (LastOther l)) = fixSp h spOff l
- replTail h _ l@(ZLast LastExit) = return [h l]
- middle spOff m = mapExpDeepMiddle (replSlot spOff) m
- last spOff l = mapExpDeepLast (replSlot spOff) l
- replSlot spOff (CmmStackSlot a i) = CmmRegOff (CmmGlobal Sp) (spOff - (slot a + i))
- replSlot _ (CmmLit CmmHighStackMark) = -- replacing the high water mark
- CmmLit (CmmInt (toInteger (max 0 (sp_high - proc_entry_sp))) (typeWidth bWord))
- 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@(LastBranch k) =
- let succSp = sp_on_entry k in
- if succSp /= spOff then
- -- pprTrace "updSp" (ppr k <> ppr spOff <> ppr (sp_on_entry k)) $
- updSp h spOff succSp l
- else return $ [h (ZLast (LastOther (last spOff l)))]
- fixSp h spOff l = liftM (uncurry (:)) $ fold_succs succ l $ return (b, [])
- where b = h (ZLast (LastOther (last spOff l)))
- succ succId z =
- let succSp = sp_on_entry succId in
- if succSp /= spOff then
- do (b, bs) <- z
- (b', bs') <- insertBetween b [setSpMid spOff succSp] succId
- return (b', bs ++ bs')
- else z
- updSp h old new l = return [h $ setSp old new $ ZLast $ LastOther (last new l)]
- setSpMid sp sp' = MidAssign (CmmGlobal Sp) e
- where e = CmmMachOp (MO_Add wordWidth) [CmmReg (CmmGlobal Sp), off]
- off = CmmLit $ CmmInt (toInteger $ sp - sp') wordWidth
- setSp sp sp' t = if sp == sp' then t else ZTail (setSpMid sp sp') t
+ replB :: FuelUniqSM (BlockEnv CmmBlock) -> CmmBlock -> FuelUniqSM (BlockEnv CmmBlock)
+ replB blocks block =
+ do let (head, middles, JustC tail :: MaybeC C (CmmNode O C)) = blockToNodeList block
+ middles' = map (middle spIn) middles
+ bs <- replLast head middles' tail
+ flip (foldr insertBlock) bs `liftM` blocks
+ where spIn = sp_on_entry (entryLabel block)
+
+ middle spOff m = mapExpDeep (replSlot spOff) m
+ -- XXX there shouldn't be any global registers in the
+ -- CmmCall, so there shouldn't be any slots in
+ -- CmmCall... check that...
+ last spOff l = mapExpDeep (replSlot spOff) l
+ replSlot spOff (CmmStackSlot a i) = CmmRegOff (CmmGlobal Sp) (spOff - (slot a + i))
+ replSlot _ (CmmLit CmmHighStackMark) = -- replacing the high water mark
+ CmmLit (CmmInt (toInteger (max 0 (sp_high - proc_entry_sp))) (typeWidth bWord))
+ -- Invariant: Sp is always greater than SpLim. Thus, if
+ -- the high water mark is zero, we can optimize away the
+ -- conditional branch. Relies on dead code elimination
+ -- to get rid of the dead GC blocks.
+ -- EZY: Maybe turn this into a guard that checks if a
+ -- statement is stack-check ish? Maybe we should make
+ -- an actual mach-op for it, so there's no chance of
+ -- mixing this up with something else...
+ replSlot _ (CmmMachOp (MO_U_Lt _)
+ [CmmMachOp (MO_Sub _)
+ [ CmmReg (CmmGlobal Sp)
+ , CmmLit (CmmInt 0 _)],
+ CmmReg (CmmGlobal SpLim)]) = CmmLit (CmmInt 0 wordWidth)
+ replSlot _ e = e
+
+ replLast :: MaybeC C (CmmNode C O) -> [CmmNode O O] -> CmmNode O C -> FuelUniqSM [CmmBlock]
+ replLast h m l@(CmmCall _ k n _ _) = updSp (slot' k + n) h m l
+ -- JD: LastForeignCall probably ought to have an outgoing
+ -- arg size, just like LastCall
+ replLast h m l@(CmmForeignCall {succ=k}) = updSp (slot' (Just k) + wORD_SIZE) h m l
+ replLast h m l@(CmmBranch k) = updSp (sp_on_entry k) h m l
+ replLast h m l = uncurry (:) `liftM` foldr succ (return (b, [])) (successors l)
+ where b :: CmmBlock
+ b = updSp' spIn h m l
+ succ succId z =
+ let succSp = sp_on_entry succId in
+ if succSp /= spIn then
+ do (b, bs) <- z
+ (b', bs') <- insertBetween b (adjustSp succSp) succId
+ return (b', bs' ++ bs)
+ else z
+
+ updSp sp h m l = return [updSp' sp h m l]
+ updSp' sp h m l | sp == spIn = blockOfNodeList (h, m, JustC $ last sp l)
+ | otherwise = blockOfNodeList (h, m ++ adjustSp sp, JustC $ last sp l)
+ adjustSp sp = [CmmAssign (CmmGlobal Sp) e]
+ where e = CmmMachOp (MO_Add wordWidth) [CmmReg (CmmGlobal Sp), off]
+ off = CmmLit $ CmmInt (toInteger $ spIn - sp) wordWidth