module MkGraph
( CmmAGraph, CgStmt(..)
, (<*>), catAGraphs
, mkLabel, mkMiddle, mkLast, outOfLine
, lgraphOfAGraph, labelAGraph
, stackStubExpr
, mkNop, mkAssign, mkStore, mkUnsafeCall, mkFinalCall, mkCallReturnsTo
, mkJump, mkDirectJump, mkForeignJump, mkForeignJumpExtra, mkJumpGC
, mkCbranch, mkSwitch
, mkReturn, mkReturnSimple, mkComment, mkCallEntry, mkBranch
, copyInOflow, copyOutOflow
, noExtraStack
, toCall, Transfer(..)
)
where
import BlockId
import Cmm
import CmmCallConv (assignArgumentsPos, ParamLocation(..))
import Compiler.Hoopl hiding (Unique, (<*>), mkFirst, mkMiddle, mkLast, mkLabel, mkBranch, Shape(..))
import FastString
import ForeignCall
import Outputable
import Prelude hiding (succ)
import SMRep (ByteOff)
import UniqSupply
import OrdList
#include "HsVersions.h"
type CmmAGraph = OrdList CgStmt
data CgStmt
= CgLabel BlockId
| CgStmt (CmmNode O O)
| CgLast (CmmNode O C)
| CgFork BlockId CmmAGraph
flattenCmmAGraph :: BlockId -> CmmAGraph -> CmmGraph
flattenCmmAGraph id stmts =
CmmGraph { g_entry = id,
g_graph = GMany NothingO body NothingO }
where
(block, blocks) = flatten (fromOL stmts)
entry = blockJoinHead (CmmEntry id) block
body = foldr addBlock emptyBody (entry:blocks)
flatten :: [CgStmt] -> (Block CmmNode O C, [Block CmmNode C C])
flatten [] = panic "flatten []"
flatten [CgLabel id]
= (goto_id, [blockJoinHead (CmmEntry id) goto_id] )
where goto_id = blockJoinTail emptyBlock (CmmBranch id)
flatten (CgLast stmt : stmts)
= case dropWhile isOrdinaryStmt stmts of
[] ->
( sing, [] )
[CgLabel id] ->
( sing, [blockJoin (CmmEntry id) emptyBlock (CmmBranch id)] )
(CgLabel id : stmts) ->
( sing, blockJoinHead (CmmEntry id) block : blocks )
where (block,blocks) = flatten stmts
(CgFork fork_id stmts : ss) ->
flatten (CgFork fork_id stmts : CgLast stmt : ss)
_ -> panic "MkGraph.flatten"
where
sing = blockJoinTail emptyBlock stmt
flatten (s:ss) =
case s of
CgStmt stmt -> (blockCons stmt block, blocks)
CgLabel id -> (blockJoinTail emptyBlock (CmmBranch id),
blockJoinHead (CmmEntry id) block : blocks)
CgFork fork_id stmts ->
(block, blockJoinHead (CmmEntry fork_id) fork_block : fork_blocks ++ blocks)
where (fork_block, fork_blocks) = flatten (fromOL stmts)
_ -> panic "MkGraph.flatten"
where (block,blocks) = flatten ss
isOrdinaryStmt :: CgStmt -> Bool
isOrdinaryStmt (CgStmt _) = True
isOrdinaryStmt (CgLast _) = True
isOrdinaryStmt _ = False
(<*>) :: CmmAGraph -> CmmAGraph -> CmmAGraph
(<*>) = appOL
catAGraphs :: [CmmAGraph] -> CmmAGraph
catAGraphs = concatOL
mkLabel :: BlockId -> CmmAGraph
mkLabel bid = unitOL (CgLabel bid)
mkMiddle :: CmmNode O O -> CmmAGraph
mkMiddle middle = unitOL (CgStmt middle)
mkLast :: CmmNode O C -> CmmAGraph
mkLast last = unitOL (CgLast last)
outOfLine :: BlockId -> CmmAGraph -> CmmAGraph
outOfLine l g = unitOL (CgFork l g)
lgraphOfAGraph :: CmmAGraph -> UniqSM CmmGraph
lgraphOfAGraph g = do u <- getUniqueM
return (flattenCmmAGraph (mkBlockId u) g)
labelAGraph :: BlockId -> CmmAGraph -> UniqSM CmmGraph
labelAGraph lbl ag = return (flattenCmmAGraph lbl ag)
mkNop :: CmmAGraph
mkNop = nilOL
mkComment :: FastString -> CmmAGraph
#ifdef DEBUG
mkComment fs = mkMiddle $ CmmComment fs
#else
mkComment _ = nilOL
#endif
mkAssign :: CmmReg -> CmmExpr -> CmmAGraph
mkAssign l r = mkMiddle $ CmmAssign l r
mkStore :: CmmExpr -> CmmExpr -> CmmAGraph
mkStore l r = mkMiddle $ CmmStore l r
mkJump :: CmmExpr -> [CmmActual] -> UpdFrameOffset -> CmmAGraph
mkJump e actuals updfr_off =
lastWithArgs Jump Old NativeNodeCall actuals updfr_off $
toCall e Nothing updfr_off 0
mkDirectJump :: CmmExpr -> [CmmActual] -> UpdFrameOffset -> CmmAGraph
mkDirectJump e actuals updfr_off =
lastWithArgs Jump Old NativeDirectCall actuals updfr_off $
toCall e Nothing updfr_off 0
mkJumpGC :: CmmExpr -> [CmmActual] -> UpdFrameOffset -> CmmAGraph
mkJumpGC e actuals updfr_off =
lastWithArgs Jump Old GC actuals updfr_off $
toCall e Nothing updfr_off 0
mkForeignJump :: Convention -> CmmExpr -> [CmmActual] -> UpdFrameOffset
-> CmmAGraph
mkForeignJump conv e actuals updfr_off =
mkForeignJumpExtra conv e actuals updfr_off noExtraStack
mkForeignJumpExtra :: Convention -> CmmExpr -> [CmmActual]
-> UpdFrameOffset -> (ByteOff, [(CmmExpr, ByteOff)])
-> CmmAGraph
mkForeignJumpExtra conv e actuals updfr_off extra_stack =
lastWithArgsAndExtraStack Jump Old conv actuals updfr_off extra_stack $
toCall e Nothing updfr_off 0
mkCbranch :: CmmExpr -> BlockId -> BlockId -> CmmAGraph
mkCbranch pred ifso ifnot = mkLast (CmmCondBranch pred ifso ifnot)
mkSwitch :: CmmExpr -> [Maybe BlockId] -> CmmAGraph
mkSwitch e tbl = mkLast $ CmmSwitch e tbl
mkReturn :: CmmExpr -> [CmmActual] -> UpdFrameOffset -> CmmAGraph
mkReturn e actuals updfr_off =
lastWithArgs Ret Old NativeReturn actuals updfr_off $
toCall e Nothing updfr_off 0
mkReturnSimple :: [CmmActual] -> UpdFrameOffset -> CmmAGraph
mkReturnSimple actuals updfr_off =
mkReturn e actuals updfr_off
where e = CmmLoad (CmmStackSlot Old updfr_off) gcWord
mkBranch :: BlockId -> CmmAGraph
mkBranch bid = mkLast (CmmBranch bid)
mkFinalCall :: CmmExpr -> CCallConv -> [CmmActual] -> UpdFrameOffset
-> CmmAGraph
mkFinalCall f _ actuals updfr_off =
lastWithArgs Call Old NativeDirectCall actuals updfr_off $
toCall f Nothing updfr_off 0
mkCallReturnsTo :: CmmExpr -> Convention -> [CmmActual]
-> BlockId
-> ByteOff
-> UpdFrameOffset
-> (ByteOff, [(CmmExpr,ByteOff)])
-> CmmAGraph
mkCallReturnsTo f callConv actuals ret_lbl ret_off updfr_off extra_stack = do
lastWithArgsAndExtraStack Call (Young ret_lbl) callConv actuals
updfr_off extra_stack $
toCall f (Just ret_lbl) updfr_off ret_off
mkUnsafeCall :: ForeignTarget -> [CmmFormal] -> [CmmActual] -> CmmAGraph
mkUnsafeCall t fs as = mkMiddle $ CmmUnsafeForeignCall t fs as
stackStubExpr :: Width -> CmmExpr
stackStubExpr w = CmmLit (CmmInt 0 w)
copyInOflow :: Convention -> Area -> [CmmFormal] -> (Int, CmmAGraph)
copyInOflow conv area formals = (offset, catAGraphs $ map mkMiddle nodes)
where (offset, nodes) = copyIn oneCopyOflowI conv area formals
type SlotCopier = Area -> (LocalReg, ByteOff) -> (ByteOff, [CmmNode O O]) ->
(ByteOff, [CmmNode O O])
type CopyIn = SlotCopier -> Convention -> Area -> [CmmFormal] -> (ByteOff, [CmmNode O O])
copyIn :: CopyIn
copyIn oflow conv area formals =
foldr ci (init_offset, []) args'
where ci (reg, RegisterParam r) (n, ms) =
(n, CmmAssign (CmmLocal reg) (CmmReg $ CmmGlobal r) : ms)
ci (r, StackParam off) (n, ms) = oflow area (r, off) (n, ms)
init_offset = widthInBytes wordWidth
args = assignArgumentsPos conv localRegType formals
args' = foldl adjust [] args
where adjust rst (v, StackParam off) = (v, StackParam (off + init_offset)) : rst
adjust rst x@(_, RegisterParam _) = x : rst
oneCopyOflowI :: SlotCopier
oneCopyOflowI area (reg, off) (n, ms) =
(max n off, CmmAssign (CmmLocal reg) (CmmLoad (CmmStackSlot area off) ty) : ms)
where ty = localRegType reg
data Transfer = Call | Jump | Ret deriving Eq
copyOutOflow :: Convention -> Transfer -> Area -> [CmmActual]
-> UpdFrameOffset
-> (ByteOff, [(CmmExpr,ByteOff)])
-> (Int, [GlobalReg], CmmAGraph)
copyOutOflow conv transfer area actuals updfr_off
(extra_stack_off, extra_stack_stuff)
= foldr co (init_offset, [], mkNop) (args' ++ stack_params)
where
co (v, RegisterParam r) (n, rs, ms)
= (n, r:rs, mkAssign (CmmGlobal r) v <*> ms)
co (v, StackParam off) (n, rs, ms)
= (max n off, rs, mkStore (CmmStackSlot area off) v <*> ms)
stack_params = [ (e, StackParam (off + init_offset))
| (e,off) <- extra_stack_stuff ]
(setRA, init_offset) =
case area of
Young id -> id `seq`
if transfer == Call then
([(CmmLit (CmmBlock id), StackParam init_offset)],
widthInBytes wordWidth)
else ([], 0)
Old -> ([], updfr_off)
arg_offset = init_offset + extra_stack_off
args :: [(CmmExpr, ParamLocation)]
args = assignArgumentsPos conv cmmExprType actuals
args' = foldl adjust setRA args
where adjust rst (v, StackParam off) = (v, StackParam (off + arg_offset)) : rst
adjust rst x@(_, RegisterParam _) = x : rst
mkCallEntry :: Convention -> [CmmFormal] -> (Int, CmmAGraph)
mkCallEntry conv formals = copyInOflow conv Old formals
lastWithArgs :: Transfer -> Area -> Convention -> [CmmActual]
-> UpdFrameOffset
-> (ByteOff -> [GlobalReg] -> CmmAGraph)
-> CmmAGraph
lastWithArgs transfer area conv actuals updfr_off last =
lastWithArgsAndExtraStack transfer area conv actuals
updfr_off noExtraStack last
lastWithArgsAndExtraStack :: Transfer -> Area -> Convention -> [CmmActual]
-> UpdFrameOffset -> (ByteOff, [(CmmExpr,ByteOff)])
-> (ByteOff -> [GlobalReg] -> CmmAGraph)
-> CmmAGraph
lastWithArgsAndExtraStack transfer area conv actuals updfr_off
extra_stack last =
copies <*> last outArgs regs
where
(outArgs, regs, copies) = copyOutOflow conv transfer area actuals
updfr_off extra_stack
noExtraStack :: (ByteOff, [(CmmExpr,ByteOff)])
noExtraStack = (0,[])
toCall :: CmmExpr -> Maybe BlockId -> UpdFrameOffset -> ByteOff
-> ByteOff -> [GlobalReg]
-> CmmAGraph
toCall e cont updfr_off res_space arg_space regs =
mkLast $ CmmCall e cont regs arg_space res_space updfr_off