compiler/cmm/MkZipCfgCmm.hs

   1 {-# OPTIONS -Wall -fno-warn-name-shadowing #-}
   2
   3 -- This is the module to import to be able to build C-- programs.
   4 -- It should not be necessary to import MkZipCfg or ZipCfgCmmRep.
   5 -- If you find it necessary to import these other modules, please
   6 -- complain to Norman Ramsey.
   7
   8 module MkZipCfgCmm
   9   ( mkNop, mkAssign, mkStore, mkCall, mkCmmCall, mkSafeCall, mkUnsafeCall, mkFinalCall
  10          , mkJump, mkForeignJump, mkJumpGC, mkCbranch, mkSwitch, mkReturn
  11          , mkReturnSimple, mkComment, copyInOflow, copyInSlot, copyOutOflow, copyOutSlot
  12          , mkEntry, mkCmmIfThenElse, mkCmmIfThen, mkCmmWhileDo
  13   , (<*>), catAGraphs, mkLabel, mkBranch
  14   , emptyAGraph, withFreshLabel, withUnique, outOfLine
  15   , lgraphOfAGraph, graphOfAGraph, labelAGraph
  16   , CmmZ, CmmTopZ, CmmGraph, CmmBlock, CmmAGraph, CmmStackInfo
  17   , Middle, Last, Convention(..), ForeignConvention(..), MidCallTarget(..), Transfer(..)
  18   , stackStubExpr, pprAGraph
  19   )
  20 where
  21
  22 #include "HsVersions.h"
  23
  24 import BlockId
  25 import CmmExpr
  26 import Cmm ( GenCmm(..), GenCmmTop(..), CmmStatic, CmmInfo
  27            , CmmActuals, CmmFormals
  28            )
  29 import CmmCallConv (assignArgumentsPos, ParamLocation(..))
  30 import ZipCfgCmmRep hiding (CmmGraph, CmmAGraph, CmmBlock, CmmZ, CmmTopZ)
  31   -- to make this module more self-contained, the above definitions are
  32   -- duplicated below
  33 import PprCmm()
  34
  35 import FastString
  36 import ForeignCall
  37 import MkZipCfg
  38 import Panic
  39 import SMRep (ByteOff)
  40 import StaticFlags
  41 import ZipCfg
  42
  43 type CmmGraph  = LGraph Middle Last
  44 type CmmAGraph = AGraph Middle Last
  45 type CmmBlock  = Block  Middle Last
  46 type CmmStackInfo            = (ByteOff, Maybe ByteOff)
  47   -- probably want a record; (SP offset on entry, update frame space)
  48 type CmmZ                    = GenCmm    CmmStatic CmmInfo (CmmStackInfo, CmmGraph)
  49 type CmmTopZ                 = GenCmmTop CmmStatic CmmInfo (CmmStackInfo, CmmGraph)
  50
  51 data Transfer = Call | Jump | Ret deriving Eq
  52
  53 ---------- No-ops
  54 mkNop        :: CmmAGraph
  55 mkComment    :: FastString -> CmmAGraph
  56
  57 ---------- Assignment and store
  58 mkAssign     :: CmmReg  -> CmmExpr -> CmmAGraph
  59 mkStore      :: CmmExpr -> CmmExpr -> CmmAGraph
  60
  61 ---------- Calls
  62 mkCall       :: CmmExpr -> (Convention, Convention) -> CmmFormals -> CmmActuals ->
  63                   UpdFrameOffset -> CmmAGraph
  64 mkCmmCall    :: CmmExpr ->              CmmFormals -> CmmActuals ->
  65                   UpdFrameOffset -> CmmAGraph
  66   -- Native C-- calling convention
  67 mkSafeCall    :: MidCallTarget -> CmmFormals -> CmmActuals -> UpdFrameOffset -> Bool -> CmmAGraph
  68 mkUnsafeCall  :: MidCallTarget -> CmmFormals -> CmmActuals -> CmmAGraph
  69 mkFinalCall   :: CmmExpr -> CCallConv -> CmmActuals -> UpdFrameOffset -> CmmAGraph
  70   -- Never returns; like exit() or barf()
  71
  72 ---------- Control transfer
  73 mkJump          ::               CmmExpr -> CmmActuals -> UpdFrameOffset -> CmmAGraph
  74 mkJumpGC        ::               CmmExpr -> CmmActuals -> UpdFrameOffset -> CmmAGraph
  75 mkForeignJump   :: Convention -> CmmExpr -> CmmActuals -> UpdFrameOffset -> CmmAGraph
  76 mkCbranch       :: CmmExpr -> BlockId -> BlockId          -> CmmAGraph
  77 mkSwitch        :: CmmExpr -> [Maybe BlockId]             -> CmmAGraph
  78 mkReturn        :: CmmExpr -> CmmActuals -> UpdFrameOffset -> CmmAGraph
  79 mkReturnSimple  :: CmmActuals -> UpdFrameOffset -> CmmAGraph
  80
  81 mkCmmIfThenElse :: CmmExpr -> CmmAGraph -> CmmAGraph -> CmmAGraph
  82 mkCmmIfThen     :: CmmExpr -> CmmAGraph -> CmmAGraph
  83 mkCmmWhileDo    :: CmmExpr -> CmmAGraph -> CmmAGraph
  84
  85 -- Not to be forgotten, but exported by MkZipCfg:
  86 -- mkBranch       :: BlockId -> CmmAGraph
  87 -- mkLabel        :: BlockId -> Maybe Int -> CmmAGraph
  88 -- outOfLine      :: CmmAGraph -> CmmAGraph
  89 -- withUnique     :: (Unique -> CmmAGraph) -> CmmAGraph
  90 -- withFreshLabel :: String -> (BlockId -> CmmAGraph) -> CmmAGraph
  91
  92 --------------------------------------------------------------------------
  93
  94 mkCmmWhileDo    e = mkWhileDo (mkCbranch e)
  95 mkCmmIfThenElse e = mkIfThenElse (mkCbranch e)
  96
  97 mkCmmIfThen e tbranch
  98   = withFreshLabel "end of if"     $ \endif ->
  99     withFreshLabel "start of then" $ \tid ->
 100     mkCbranch e tid endif <*>
 101     mkLabel tid   <*> tbranch <*> mkBranch endif <*>
 102     mkLabel endif
 103
 104
 105
 106 -- ================ IMPLEMENTATION ================--
 107
 108 mkNop                     = emptyAGraph
 109 mkComment fs              = mkMiddle $ MidComment fs
 110 mkStore  l r              = mkMiddle $ MidStore  l r
 111
 112 -- NEED A COMPILER-DEBUGGING FLAG HERE
 113 -- Sanity check: any value assigned to a pointer must be non-zero.
 114 -- If it's 0, cause a crash immediately.
 115 mkAssign l r = if opt_StubDeadValues then assign l r <*> check l else assign l r
 116   where assign l r = mkMiddle (MidAssign l r)
 117         check (CmmGlobal _) = mkNop
 118         check l@(CmmLocal reg) = -- if a ptr arg is NULL, cause a crash!
 119           if isGcPtrType ty then
 120             mkCmmIfThen (CmmMachOp (MO_Eq w) [r, stackStubExpr w])
 121                         (assign l (CmmLoad (CmmLit (CmmInt 0 w)) ty))
 122           else mkNop
 123             where ty = localRegType reg
 124                   w  = typeWidth ty
 125                   r  = CmmReg l
 126
 127
 128 -- Why are we inserting extra blocks that simply branch to the successors?
 129 -- Because in addition to the branch instruction, @mkBranch@ will insert
 130 -- a necessary adjustment to the stack pointer.
 131 mkCbranch pred ifso ifnot = mkLast (LastCondBranch pred ifso ifnot)
 132 mkSwitch e tbl            = mkLast $ LastSwitch e tbl
 133
 134 mkSafeCall   t fs as upd interruptible =
 135   withFreshLabel "safe call" $ \k ->
 136     mkMiddle $ MidForeignCall (Safe k upd interruptible) t fs as
 137 mkUnsafeCall t fs as = mkMiddle $ MidForeignCall Unsafe t fs as
 138
 139 -- For debugging purposes, we can stub out dead stack slots:
 140 stackStubExpr :: Width -> CmmExpr
 141 stackStubExpr w = CmmLit (CmmInt 0 w)
 142
 143 -- When we copy in parameters, we usually want to put overflow
 144 -- parameters on the stack, but sometimes we want to pass
 145 -- the variables in their spill slots.
 146 -- Therefore, for copying arguments and results, we provide different
 147 -- functions to pass the arguments in an overflow area and to pass them in spill slots.
 148 copyInOflow  :: Convention -> Area -> CmmFormals -> (Int, CmmAGraph)
 149 copyInSlot   :: Convention -> CmmFormals -> CmmAGraph
 150 copyOutOflow :: Convention -> Transfer -> Area -> CmmActuals -> UpdFrameOffset ->
 151                               (Int, [Middle])
 152 copyOutSlot  :: Convention -> [LocalReg] -> [Middle]
 153   -- why a list of middles here instead of an AGraph?
 154
 155 copyInOflow      = copyIn oneCopyOflowI
 156 copyInSlot c f = snd $ copyIn oneCopySlotI c (panic "no area for copying to slots") f
 157
 158 type SlotCopier = Area -> (LocalReg, ByteOff) -> (ByteOff, CmmAGraph) ->
 159                           (ByteOff, CmmAGraph)
 160 type CopyIn  = SlotCopier -> Convention -> Area -> CmmFormals -> (ByteOff, CmmAGraph)
 161
 162 -- Return the number of bytes used for copying arguments, as well as the
 163 -- instructions to copy the arguments.
 164 copyIn :: CopyIn
 165 copyIn oflow conv area formals =
 166   foldr ci (init_offset, mkNop) args'
 167   where ci (reg, RegisterParam r) (n, ms) =
 168           (n, mkAssign (CmmLocal reg) (CmmReg $ CmmGlobal r) <*> ms)
 169         ci (r, StackParam off) (n, ms) = oflow area (r, off) (n, ms)
 170         init_offset = widthInBytes wordWidth -- infotable
 171         args  = assignArgumentsPos conv localRegType formals
 172         args' = foldl adjust [] args
 173           where adjust rst (v, StackParam off) = (v, StackParam (off + init_offset)) : rst
 174                 adjust rst x@(_, RegisterParam _) = x : rst
 175
 176 -- Copy-in one arg, using overflow space if needed.
 177 oneCopyOflowI, oneCopySlotI :: SlotCopier
 178 oneCopyOflowI area (reg, off) (n, ms) =
 179   (max n off, mkAssign (CmmLocal reg) (CmmLoad (CmmStackSlot area off) ty) <*> ms)
 180   where ty = localRegType reg
 181
 182 -- Copy-in one arg, using spill slots if needed -- used for calling conventions at
 183 -- a procpoint that is not a return point. The offset is irrelevant here...
 184 oneCopySlotI _ (reg, _) (n, ms) =
 185   (n, mkAssign (CmmLocal reg) (CmmLoad (CmmStackSlot (RegSlot reg) w) ty) <*> ms)
 186   where ty = localRegType reg
 187         w  = widthInBytes (typeWidth ty)
 188
 189
 190 -- Factoring out the common parts of the copyout functions yielded something
 191 -- more complicated:
 192
 193 -- The argument layout function ignores the pointer to the info table, so we slot that
 194 -- in here. When copying-out to a young area, we set the info table for return
 195 -- and adjust the offsets of the other parameters.
 196 -- If this is a call instruction, we adjust the offsets of the other parameters.
 197 copyOutOflow conv transfer area@(CallArea a) actuals updfr_off =
 198   foldr co (init_offset, []) args'
 199   where co (v, RegisterParam r) (n, ms) = (n, MidAssign (CmmGlobal r) v : ms)
 200         co (v, StackParam off)  (n, ms) =
 201           (max n off, MidStore (CmmStackSlot area off) v : ms)
 202         (setRA, init_offset) =
 203           case a of Young id@(BlockId _) -> -- set RA if making a call
 204                       if transfer == Call then
 205                         ([(CmmLit (CmmBlock id), StackParam init_offset)],
 206                          widthInBytes wordWidth)
 207                       else ([], 0)
 208                     Old -> ([], updfr_off)
 209         args = assignArgumentsPos conv cmmExprType actuals
 210         args' = foldl adjust setRA args
 211           where adjust rst (v, StackParam off) = (v, StackParam (off + init_offset)) : rst
 212                 adjust rst x@(_, RegisterParam _) = x : rst
 213 copyOutOflow _ _ (RegSlot _) _ _ = panic "cannot copy arguments into a register slot"
 214
 215 -- Args passed only in registers and stack slots; no overflow space.
 216 -- No return address may apply!
 217 copyOutSlot conv actuals = foldr co [] args
 218   where co (v, RegisterParam r) ms = MidAssign (CmmGlobal r) (toExp v) : ms
 219         co (v, StackParam off)  ms =
 220           MidStore (CmmStackSlot (RegSlot v) off) (toExp v) : ms
 221         toExp r = CmmReg (CmmLocal r)
 222         args = assignArgumentsPos conv localRegType actuals
 223
 224 -- oneCopySlotO _ (reg, _) (n, ms) =
 225 --   (n, MidStore (CmmStackSlot (RegSlot reg) w) reg : ms)
 226 --   where w = widthInBytes (typeWidth (localRegType reg))
 227
 228 mkEntry :: BlockId -> Convention -> CmmFormals -> (Int, CmmAGraph)
 229 mkEntry _ conv formals = copyInOflow conv (CallArea Old) formals
 230
 231 lastWithArgs :: Transfer -> Area -> Convention -> CmmActuals -> UpdFrameOffset ->
 232                 (ByteOff -> Last) -> CmmAGraph
 233 lastWithArgs transfer area conv actuals updfr_off last =
 234   let (outArgs, copies) = copyOutOflow conv transfer area actuals updfr_off in
 235   mkMiddles copies <*> mkLast (last outArgs)
 236
 237 -- The area created for the jump and return arguments is the same area as the
 238 -- procedure entry.
 239 old :: Area
 240 old = CallArea Old
 241 toCall :: CmmExpr -> Maybe BlockId -> UpdFrameOffset -> ByteOff -> ByteOff -> Last
 242 toCall e cont updfr_off res_space arg_space =
 243   LastCall e cont arg_space res_space (Just updfr_off)
 244 mkJump e actuals updfr_off =
 245   lastWithArgs Jump old NativeNodeCall actuals updfr_off $ toCall e Nothing updfr_off 0
 246 mkJumpGC e actuals updfr_off =
 247   lastWithArgs Jump old GC actuals updfr_off $ toCall e Nothing updfr_off 0
 248 mkForeignJump conv e actuals updfr_off =
 249   lastWithArgs Jump old conv actuals updfr_off $ toCall e Nothing updfr_off 0
 250 mkReturn e actuals updfr_off =
 251   lastWithArgs Ret  old NativeReturn actuals updfr_off $ toCall e Nothing updfr_off 0
 252     -- where e = CmmLoad (CmmStackSlot (CallArea Old) updfr_off) gcWord
 253 mkReturnSimple actuals updfr_off =
 254   lastWithArgs Ret  old NativeReturn actuals updfr_off $ toCall e Nothing updfr_off 0
 255     where e = CmmLoad (CmmStackSlot (CallArea Old) updfr_off) gcWord
 256
 257 mkFinalCall f _ actuals updfr_off =
 258   lastWithArgs Call old NativeDirectCall actuals updfr_off $ toCall f Nothing updfr_off 0
 259
 260 mkCmmCall f results actuals = mkCall f (NativeDirectCall, NativeReturn) results actuals
 261
 262 -- I'm dropping the SRT, but that should be okay: we plan to reconstruct it later.
 263 mkCall f (callConv, retConv) results actuals updfr_off =
 264   withFreshLabel "call successor" $ \k ->
 265     let area = CallArea $ Young k
 266         (off, copyin) = copyInOflow retConv area results
 267         copyout = lastWithArgs Call area callConv actuals updfr_off
 268                                (toCall f (Just k) updfr_off off)
 269     in (copyout <*> mkLabel k <*> copyin)