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 -> 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 -> Bool -> Area -> CmmFormals -> (Int, CmmAGraph)
 150 copyInSlot   :: Convention -> Bool -> CmmFormals -> CmmAGraph
 151 copyOutOflow :: Convention -> Transfer -> Area -> CmmActuals -> UpdFrameOffset ->
 152                               (Int, [Middle])
 153 copyOutSlot  :: Convention -> Transfer -> [LocalReg] -> [Middle]
 154   -- why a list of middles here instead of an AGraph?
 155
 156 copyInOflow      = copyIn oneCopyOflowI
 157 copyInSlot c i f = snd $ copyIn oneCopySlotI c i (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 -> Bool -> Area -> CmmFormals ->
 162                           (ByteOff, CmmAGraph)
 163
 164 -- Return the number of bytes used for copying arguments, as well as the
 165 -- instructions to copy the arguments.
 166 copyIn :: CopyIn
 167 copyIn oflow conv isCall area formals =
 168   foldr ci (init_offset, mkNop) args'
 169   where ci (reg, RegisterParam r) (n, ms) =
 170           (n, mkAssign (CmmLocal reg) (CmmReg $ CmmGlobal r) <*> ms)
 171         ci (r, StackParam off) (n, ms) = oflow area (r, off) (n, ms)
 172         init_offset = widthInBytes wordWidth -- infotable
 173         args  = assignArgumentsPos conv isCall localRegType formals
 174         args' = foldl adjust [] args
 175           where adjust rst (v, StackParam off) = (v, StackParam (off + init_offset)) : rst
 176                 adjust rst x@(_, RegisterParam _) = x : rst
 177
 178 -- Copy-in one arg, using overflow space if needed.
 179 oneCopyOflowI, oneCopySlotI :: SlotCopier
 180 oneCopyOflowI area (reg, off) (n, ms) =
 181   (max n off, mkAssign (CmmLocal reg) (CmmLoad (CmmStackSlot area off) ty) <*> ms)
 182   where ty = localRegType reg
 183
 184 -- Copy-in one arg, using spill slots if needed -- used for calling conventions at
 185 -- a procpoint that is not a return point. The offset is irrelevant here...
 186 oneCopySlotI _ (reg, _) (n, ms) =
 187   (n, mkAssign (CmmLocal reg) (CmmLoad (CmmStackSlot (RegSlot reg) w) ty) <*> ms)
 188   where ty = localRegType reg
 189         w  = widthInBytes (typeWidth ty)
 190
 191
 192 -- Factoring out the common parts of the copyout functions yielded something
 193 -- more complicated:
 194
 195 -- The argument layout function ignores the pointer to the info table, so we slot that
 196 -- in here. When copying-out to a young area, we set the info table for return
 197 -- and adjust the offsets of the other parameters.
 198 -- If this is a call instruction, we adjust the offsets of the other parameters.
 199 copyOutOflow conv transfer area@(CallArea a) actuals updfr_off =
 200   foldr co (init_offset, []) args'
 201   where co (v, RegisterParam r) (n, ms) = (n, MidAssign (CmmGlobal r) v : ms)
 202         co (v, StackParam off)  (n, ms) =
 203           (max n off, MidStore (CmmStackSlot area off) v : ms)
 204         (setRA, init_offset) =
 205           case a of Young id@(BlockId _) -> -- set RA if making a call
 206                       if transfer == Call then
 207                         ([(CmmLit (CmmBlock id), StackParam init_offset)],
 208                          widthInBytes wordWidth)
 209                       else ([], 0)
 210                     Old -> ([], updfr_off)
 211         args = assignArgumentsPos conv (transfer /= Ret) cmmExprType actuals
 212         args' = foldl adjust setRA args
 213           where adjust rst (v, StackParam off) = (v, StackParam (off + init_offset)) : rst
 214                 adjust rst x@(_, RegisterParam _) = x : rst
 215 copyOutOflow _ _ (RegSlot _) _ _ = panic "cannot copy arguments into a register slot"
 216
 217 -- Args passed only in registers and stack slots; no overflow space.
 218 -- No return address may apply!
 219 copyOutSlot conv transfer actuals = foldr co [] args
 220   where co (v, RegisterParam r) ms = MidAssign (CmmGlobal r) (toExp v) : ms
 221         co (v, StackParam off)  ms =
 222           MidStore (CmmStackSlot (RegSlot v) off) (toExp v) : ms
 223         toExp r = CmmReg (CmmLocal r)
 224         args = assignArgumentsPos conv (transfer /= Ret) localRegType actuals
 225
 226 -- oneCopySlotO _ (reg, _) (n, ms) =
 227 --   (n, MidStore (CmmStackSlot (RegSlot reg) w) reg : ms)
 228 --   where w = widthInBytes (typeWidth (localRegType reg))
 229
 230 mkEntry :: BlockId -> Convention -> CmmFormals -> (Int, CmmAGraph)
 231 mkEntry _ conv formals = copyInOflow conv False (CallArea Old) formals
 232
 233 lastWithArgs :: Transfer -> Area -> Convention -> CmmActuals -> UpdFrameOffset ->
 234                 (ByteOff -> Last) -> CmmAGraph
 235 lastWithArgs transfer area conv actuals updfr_off last =
 236   let (outArgs, copies) = copyOutOflow conv transfer area actuals updfr_off in
 237   mkMiddles copies <*> mkLast (last outArgs)
 238
 239 -- The area created for the jump and return arguments is the same area as the
 240 -- procedure entry.
 241 old :: Area
 242 old = CallArea Old
 243 toCall :: CmmExpr -> Maybe BlockId -> UpdFrameOffset -> ByteOff -> ByteOff -> Last
 244 toCall e cont updfr_off res_space arg_space =
 245   LastCall e cont arg_space res_space (Just updfr_off)
 246 mkJump e actuals updfr_off =
 247   lastWithArgs Jump old NativeCall actuals updfr_off $ toCall e Nothing updfr_off 0
 248 mkJumpGC e actuals updfr_off =
 249   lastWithArgs Jump old GC actuals updfr_off $ toCall e Nothing updfr_off 0
 250 mkForeignJump conv e actuals updfr_off =
 251   lastWithArgs Jump old conv actuals updfr_off $ toCall e Nothing updfr_off 0
 252 mkReturn e actuals updfr_off =
 253   lastWithArgs Ret  old NativeReturn actuals updfr_off $ toCall e Nothing updfr_off 0
 254     -- where e = CmmLoad (CmmStackSlot (CallArea Old) updfr_off) gcWord
 255 mkReturnSimple actuals updfr_off =
 256   lastWithArgs Ret  old NativeReturn actuals updfr_off $ toCall e Nothing updfr_off 0
 257     where e = CmmLoad (CmmStackSlot (CallArea Old) updfr_off) gcWord
 258
 259 mkFinalCall f _ actuals updfr_off =
 260   lastWithArgs Call old NativeCall actuals updfr_off $ toCall f Nothing updfr_off 0
 261
 262 mkCmmCall f results actuals = mkCall f NativeCall results actuals
 263
 264 -- I'm dropping the SRT, but that should be okay: we plan to reconstruct it later.
 265 mkCall f conv results actuals updfr_off =
 266  pprTrace "mkCall" (ppr f <+> ppr actuals <+> ppr results <+> ppr conv) $
 267   withFreshLabel "call successor" $ \k ->
 268     let area = CallArea $ Young k
 269         (off, copyin) = copyInOflow conv False area results
 270         copyout = lastWithArgs Call area conv actuals updfr_off
 271                                (toCall f (Just k) updfr_off off)
 272     in (copyout <*> mkLabel k <*> copyin)