{-# OPTIONS -Wall -fno-warn-name-shadowing #-} -- This is the module to import to be able to build C-- programs. -- It should not be necessary to import MkZipCfg or ZipCfgCmmRep. -- If you find it necessary to import these other modules, please -- complain to Norman Ramsey. 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) -- to make this module more self-contained, the above definitions are -- duplicated below 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) -- 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 ---------- No-ops mkNop :: CmmAGraph mkComment :: FastString -> CmmAGraph ---------- Assignment and store mkAssign :: CmmReg -> CmmExpr -> CmmAGraph mkStore :: CmmExpr -> CmmExpr -> CmmAGraph ---------- Calls mkCall :: CmmExpr -> (Convention, Convention) -> CmmFormals -> CmmActuals -> UpdFrameOffset -> CmmAGraph mkCmmCall :: CmmExpr -> CmmFormals -> CmmActuals -> UpdFrameOffset -> CmmAGraph -- Native C-- calling convention mkSafeCall :: MidCallTarget -> CmmFormals -> CmmActuals -> UpdFrameOffset -> CmmAGraph mkUnsafeCall :: MidCallTarget -> CmmFormals -> CmmActuals -> CmmAGraph mkFinalCall :: CmmExpr -> CCallConv -> CmmActuals -> UpdFrameOffset -> CmmAGraph -- Never returns; like exit() or barf() ---------- Control transfer 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 -- Not to be forgotten, but exported by MkZipCfg: -- mkBranch :: BlockId -> CmmAGraph -- mkLabel :: BlockId -> Maybe Int -> CmmAGraph -- outOfLine :: CmmAGraph -> CmmAGraph -- withUnique :: (Unique -> CmmAGraph) -> CmmAGraph -- withFreshLabel :: String -> (BlockId -> 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 -- ================ IMPLEMENTATION ================-- mkNop = emptyAGraph mkComment fs = mkMiddle $ MidComment fs mkStore l r = mkMiddle $ MidStore l r -- NEED A COMPILER-DEBUGGING FLAG HERE -- Sanity check: any value assigned to a pointer must be non-zero. -- If it's 0, cause a crash immediately. 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 a ptr arg is NULL, cause a crash! 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 -- Why are we inserting extra blocks that simply branch to the successors? -- Because in addition to the branch instruction, @mkBranch@ will insert -- a necessary adjustment to the stack pointer. 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 -- For debugging purposes, we can stub out dead stack slots: 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 -> Area -> CmmFormals -> (Int, CmmAGraph) copyInSlot :: Convention -> CmmFormals -> CmmAGraph copyOutOflow :: Convention -> Transfer -> Area -> CmmActuals -> UpdFrameOffset -> (Int, [Middle]) copyOutSlot :: Convention -> [LocalReg] -> [Middle] -- why a list of middles here instead of an AGraph? 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) -- Return the number of bytes used for copying arguments, as well as the -- instructions to copy the arguments. 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 -- infotable 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 -- 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. 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 _) -> -- set RA if making a call 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" -- Args passed only in registers and stack slots; no overflow space. -- No return address may apply! 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 -- 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 = 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) -- 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 -> 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 -- where e = CmmLoad (CmmStackSlot (CallArea Old) updfr_off) gcWord 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 -- I'm dropping the SRT, but that should be okay: we plan to reconstruct it later. 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)