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 -> CmmFormals -> CmmActuals ->
  63                   UpdFrameOffset -> CmmAGraph
  64 mkCmmCall    :: CmmExpr ->              CmmFormals -> CmmActuals ->
  65                   UpdFrameOffset -> CmmAGraph
  66                         -- Native C-- calling convention
  67 mkSafeCall    :: MidCallTarget -> CmmFormals -> CmmActuals -> UpdFrameOffset -> 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 =
 135   withFreshLabel "safe call" $ \k ->
 136     mkMiddle $ MidForeignCall (Safe k upd) 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 -> Bool -> Area -> CmmFormals -> (Int, CmmAGraph)
 149 copyInSlot   :: Convention -> Bool -> CmmFormals -> CmmAGraph
 150 copyOutOflow :: Convention -> Transfer -> Area -> CmmActuals -> UpdFrameOffset ->
 151                               (Int, [Middle])
 152 copyOutSlot  :: Convention -> Transfer -> [LocalReg] -> [Middle]
 153   -- why a list of middles here instead of an AGraph?
 154
 155 copyInOflow      = copyIn oneCopyOflowI
 156 copyInSlot c i f = snd $ copyIn oneCopySlotI c i (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 -> Bool -> Area -> CmmFormals ->
 161                           (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 isCall 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 isCall 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 (transfer /= Ret) 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 transfer 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 (transfer /= Ret) 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 False (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 Native 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 Native 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 Native 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 Native actuals updfr_off $ toCall f Nothing updfr_off 0
 260
 261 mkCmmCall f results actuals = mkCall f Native results actuals
 262
 263 -- I'm dropping the SRT, but that should be okay: we plan to reconstruct it later.
 264 mkCall f conv results actuals updfr_off =
 265   withFreshLabel "call successor" $ \k ->
 266     let area = CallArea $ Young k
 267         (off, copyin) = copyInOflow conv False area results
 268         copyout = lastWithArgs Call area conv actuals updfr_off
 269                                (toCall f (Just k) updfr_off off)
 270     in (copyout <*> mkLabel k <*> copyin)