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