module MkZipCfgCmm
( mkNop, mkAssign, mkStore, mkCall, mkCmmCall, mkSafeCall, mkUnsafeCall, mkFinalCall
, mkJump, mkForeignJump, mkJumpGC, mkCbranch, mkSwitch, mkReturn
, 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, CmmStackInfo
, Middle, Last, Convention(..), ForeignConvention(..), MidCallTarget(..), Transfer(..)
, stackStubExpr, pprAGraph
)
where
#include "HsVersions.h"
import BlockId
import CmmExpr
import Cmm ( GenCmm(..), GenCmmTop(..), CmmStatic, CmmInfo
, CmmActuals, CmmFormals
)
import CmmCallConv (assignArgumentsPos, ParamLocation(..))
import ZipCfgCmmRep hiding (CmmGraph, CmmAGraph, CmmBlock, CmmZ, CmmTopZ)
import PprCmm()
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 CmmStackInfo = (ByteOff, Maybe ByteOff)
type CmmZ = GenCmm CmmStatic CmmInfo (CmmStackInfo, CmmGraph)
type CmmTopZ = GenCmmTop CmmStatic CmmInfo (CmmStackInfo, CmmGraph)
data Transfer = Call | Jump | Ret deriving Eq
mkNop :: CmmAGraph
mkComment :: FastString -> CmmAGraph
mkAssign :: CmmReg -> CmmExpr -> CmmAGraph
mkStore :: CmmExpr -> CmmExpr -> CmmAGraph
mkCall :: CmmExpr -> (Convention, Convention) -> CmmFormals -> CmmActuals ->
UpdFrameOffset -> CmmAGraph
mkCmmCall :: CmmExpr -> CmmFormals -> CmmActuals ->
UpdFrameOffset -> CmmAGraph
mkSafeCall :: MidCallTarget -> CmmFormals -> CmmActuals -> UpdFrameOffset -> CmmAGraph
mkUnsafeCall :: MidCallTarget -> CmmFormals -> CmmActuals -> CmmAGraph
mkFinalCall :: CmmExpr -> CCallConv -> CmmActuals -> UpdFrameOffset -> CmmAGraph
mkJump :: CmmExpr -> CmmActuals -> UpdFrameOffset -> CmmAGraph
mkJumpGC :: CmmExpr -> CmmActuals -> UpdFrameOffset -> CmmAGraph
mkForeignJump :: Convention -> CmmExpr -> CmmActuals -> UpdFrameOffset -> CmmAGraph
mkCbranch :: CmmExpr -> BlockId -> BlockId -> CmmAGraph
mkSwitch :: CmmExpr -> [Maybe BlockId] -> CmmAGraph
mkReturn :: CmmExpr -> CmmActuals -> UpdFrameOffset -> CmmAGraph
mkReturnSimple :: CmmActuals -> UpdFrameOffset -> CmmAGraph
mkCmmIfThenElse :: CmmExpr -> CmmAGraph -> CmmAGraph -> CmmAGraph
mkCmmIfThen :: CmmExpr -> CmmAGraph -> CmmAGraph
mkCmmWhileDo :: CmmExpr -> CmmAGraph -> CmmAGraph
mkCmmWhileDo e = mkWhileDo (mkCbranch e)
mkCmmIfThenElse e = mkIfThenElse (mkCbranch e)
mkCmmIfThen e tbranch
= withFreshLabel "end of if" $ \endif ->
withFreshLabel "start of then" $ \tid ->
mkCbranch e tid endif <*>
mkLabel tid <*> tbranch <*> mkBranch endif <*>
mkLabel endif
mkNop = emptyAGraph
mkComment fs = mkMiddle $ MidComment fs
mkStore l r = mkMiddle $ MidStore l r
mkAssign l r = if opt_StubDeadValues then assign l r <*> check l else assign l r
where assign l r = mkMiddle (MidAssign l r)
check (CmmGlobal _) = mkNop
check l@(CmmLocal reg) =
if isGcPtrType ty then
mkCmmIfThen (CmmMachOp (MO_Eq w) [r, stackStubExpr w])
(assign l (CmmLoad (CmmLit (CmmInt 0 w)) ty))
else mkNop
where ty = localRegType reg
w = typeWidth ty
r = CmmReg l
mkCbranch pred ifso ifnot = mkLast (LastCondBranch pred ifso ifnot)
mkSwitch e tbl = mkLast $ LastSwitch e tbl
mkSafeCall t fs as upd =
withFreshLabel "safe call" $ \k ->
mkMiddle $ MidForeignCall (Safe k upd) t fs as
mkUnsafeCall t fs as = mkMiddle $ MidForeignCall Unsafe t fs as
stackStubExpr :: Width -> CmmExpr
stackStubExpr w = CmmLit (CmmInt 0 w)
copyInOflow :: Convention -> Area -> CmmFormals -> (Int, CmmAGraph)
copyInSlot :: Convention -> CmmFormals -> CmmAGraph
copyOutOflow :: Convention -> Transfer -> Area -> CmmActuals -> UpdFrameOffset ->
(Int, [Middle])
copyOutSlot :: Convention -> [LocalReg] -> [Middle]
copyInOflow = copyIn oneCopyOflowI
copyInSlot c f = snd $ copyIn oneCopySlotI c (panic "no area for copying to slots") f
type SlotCopier = Area -> (LocalReg, ByteOff) -> (ByteOff, CmmAGraph) ->
(ByteOff, CmmAGraph)
type CopyIn = SlotCopier -> Convention -> Area -> CmmFormals -> (ByteOff, CmmAGraph)
copyIn :: CopyIn
copyIn oflow conv area formals =
foldr ci (init_offset, mkNop) args'
where ci (reg, RegisterParam r) (n, ms) =
(n, mkAssign (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, oneCopySlotI :: SlotCopier
oneCopyOflowI area (reg, off) (n, ms) =
(max n off, mkAssign (CmmLocal reg) (CmmLoad (CmmStackSlot area off) ty) <*> ms)
where ty = localRegType reg
oneCopySlotI _ (reg, _) (n, ms) =
(n, mkAssign (CmmLocal reg) (CmmLoad (CmmStackSlot (RegSlot reg) w) ty) <*> ms)
where ty = localRegType reg
w = widthInBytes (typeWidth ty)
copyOutOflow conv transfer area@(CallArea a) actuals updfr_off =
foldr co (init_offset, []) args'
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 _) ->
if transfer == Call then
([(CmmLit (CmmBlock id), StackParam init_offset)],
widthInBytes wordWidth)
else ([], 0)
Old -> ([], updfr_off)
args = assignArgumentsPos conv 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
copyOutOflow _ _ (RegSlot _) _ _ = panic "cannot copy arguments into a register slot"
copyOutSlot conv 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 localRegType actuals
mkEntry :: BlockId -> Convention -> CmmFormals -> (Int, CmmAGraph)
mkEntry _ conv formals = copyInOflow conv (CallArea Old) formals
lastWithArgs :: Transfer -> Area -> Convention -> CmmActuals -> UpdFrameOffset ->
(ByteOff -> Last) -> CmmAGraph
lastWithArgs transfer area conv actuals updfr_off last =
let (outArgs, copies) = copyOutOflow conv transfer area actuals updfr_off in
mkMiddles copies <*> mkLast (last outArgs)
old :: Area
old = CallArea Old
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 NativeNodeCall 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 0
mkForeignJump conv e actuals updfr_off =
lastWithArgs Jump old conv actuals updfr_off $ toCall e Nothing updfr_off 0
mkReturn e actuals updfr_off =
lastWithArgs Ret old NativeReturn actuals updfr_off $ toCall e Nothing updfr_off 0
mkReturnSimple actuals updfr_off =
lastWithArgs Ret old NativeReturn 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 NativeDirectCall actuals updfr_off $ toCall f Nothing updfr_off 0
mkCmmCall f results actuals = mkCall f (NativeDirectCall, NativeReturn) results actuals
mkCall f (callConv, retConv) results actuals updfr_off =
withFreshLabel "call successor" $ \k ->
let area = CallArea $ Young k
(off, copyin) = copyInOflow retConv area results
copyout = lastWithArgs Call area callConv actuals updfr_off
(toCall f (Just k) updfr_off off)
in (copyout <*> mkLabel k <*> copyin)