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, copyIn, copyOut
  12          , mkEntry, mkCmmIfThenElse, mkCmmIfThen, mkCmmWhileDo
  13   , (<*>), catAGraphs, mkLabel, mkBranch
  14   , emptyAGraph, withFreshLabel, withUnique, outOfLine
  15   , lgraphOfAGraph, graphOfAGraph, labelAGraph
  16   , CmmZ, CmmTopZ, CmmGraph, CmmBlock, CmmAGraph
  17   , Middle, Last, Convention(..), ForeignConvention(..), MidCallTarget(..), Transfer(..)
  18   , emptyStackInfo, 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 StaticFlags
  40 import ZipCfg
  41
  42 type CmmGraph  = LGraph Middle Last
  43 type CmmAGraph = AGraph Middle Last
  44 type CmmBlock  = Block  Middle Last
  45 type CmmZ      = GenCmm    CmmStatic CmmInfo CmmGraph
  46 type CmmTopZ   = GenCmmTop CmmStatic CmmInfo CmmGraph
  47
  48 data Transfer = Call | Jump | Ret deriving Eq
  49
  50 ---------- No-ops
  51 mkNop        :: CmmAGraph
  52 mkComment    :: FastString -> CmmAGraph
  53
  54 ---------- Assignment and store
  55 mkAssign     :: CmmReg  -> CmmExpr -> CmmAGraph
  56 mkStore      :: CmmExpr -> CmmExpr -> CmmAGraph
  57
  58 ---------- Calls
  59 mkCall       :: CmmExpr -> Convention -> CmmFormals -> CmmActuals ->
  60                   UpdFrameOffset -> CmmAGraph
  61 mkCmmCall    :: CmmExpr ->              CmmFormals -> CmmActuals ->
  62                   UpdFrameOffset -> CmmAGraph
  63                         -- Native C-- calling convention
  64 mkSafeCall    :: MidCallTarget -> CmmFormals -> CmmActuals -> UpdFrameOffset -> CmmAGraph
  65 mkUnsafeCall  :: MidCallTarget -> CmmFormals -> CmmActuals -> CmmAGraph
  66 mkFinalCall   :: CmmExpr -> CCallConv -> CmmActuals -> UpdFrameOffset -> CmmAGraph
  67                  -- Never returns; like exit() or barf()
  68
  69 ---------- Control transfer
  70 mkJump          ::               CmmExpr -> CmmActuals -> UpdFrameOffset -> CmmAGraph
  71 mkJumpGC        ::               CmmExpr -> CmmActuals -> UpdFrameOffset -> CmmAGraph
  72 mkForeignJump   :: Convention -> CmmExpr -> CmmActuals -> UpdFrameOffset -> CmmAGraph
  73 mkCbranch       :: CmmExpr -> BlockId -> BlockId          -> CmmAGraph
  74 mkSwitch        :: CmmExpr -> [Maybe BlockId]             -> CmmAGraph
  75 mkReturn        :: CmmExpr -> CmmActuals -> UpdFrameOffset -> CmmAGraph
  76 mkReturnSimple  :: CmmActuals -> UpdFrameOffset -> CmmAGraph
  77
  78 mkCmmIfThenElse :: CmmExpr -> CmmAGraph -> CmmAGraph -> CmmAGraph
  79 mkCmmIfThen     :: CmmExpr -> CmmAGraph -> CmmAGraph
  80 mkCmmWhileDo    :: CmmExpr -> CmmAGraph -> CmmAGraph
  81
  82 -- Not to be forgotten, but exported by MkZipCfg:
  83 -- mkBranch       :: BlockId -> CmmAGraph
  84 -- mkLabel        :: BlockId -> Maybe Int -> CmmAGraph
  85 -- outOfLine      :: CmmAGraph -> CmmAGraph
  86 -- withUnique     :: (Unique -> CmmAGraph) -> CmmAGraph
  87 -- withFreshLabel :: String -> (BlockId -> CmmAGraph) -> CmmAGraph
  88
  89 --------------------------------------------------------------------------
  90
  91 mkCmmWhileDo    e = mkWhileDo (mkCbranch e)
  92 mkCmmIfThenElse e = mkIfThenElse (mkCbranch e)
  93
  94 mkCmmIfThen e tbranch
  95   = withFreshLabel "end of if"     $ \endif ->
  96     withFreshLabel "start of then" $ \tid ->
  97     mkCbranch e tid endif <*>
  98     mkLabel tid   emptyStackInfo <*> tbranch <*> mkBranch endif <*>
  99     mkLabel endif emptyStackInfo
 100
 101
 102
 103 -- ================ IMPLEMENTATION ================--
 104
 105 mkNop                     = emptyAGraph
 106 mkComment fs              = mkMiddle $ MidComment fs
 107 mkStore  l r              = mkMiddle $ MidStore  l r
 108
 109 -- NEED A COMPILER-DEBUGGING FLAG HERE
 110 -- Sanity check: any value assigned to a pointer must be non-zero.
 111 -- If it's 0, cause a crash immediately.
 112 mkAssign l r = if opt_StubDeadValues then assign l r <*> check l else assign l r
 113   where assign l r = mkMiddle (MidAssign l r)
 114         check (CmmGlobal _) = mkNop
 115         check l@(CmmLocal reg) = -- if a ptr arg is NULL, cause a crash!
 116           if isGcPtrType ty then
 117             mkCmmIfThen (CmmMachOp (MO_Eq w) [r, stackStubExpr w])
 118                         (assign l (CmmLoad (CmmLit (CmmInt 0 w)) ty))
 119           else mkNop
 120             where ty = localRegType reg
 121                   w  = typeWidth ty
 122                   r  = CmmReg l
 123
 124
 125 -- Why are we inserting extra blocks that simply branch to the successors?
 126 -- Because in addition to the branch instruction, @mkBranch@ will insert
 127 -- a necessary adjustment to the stack pointer.
 128 mkCbranch pred ifso ifnot = mkLast (LastCondBranch pred ifso ifnot)
 129 mkSwitch e tbl            = mkLast $ LastSwitch e tbl
 130
 131 mkSafeCall   t fs as upd =
 132   withFreshLabel "safe call" $ \k ->
 133     mkMiddle $ MidForeignCall (Safe k upd) t fs as
 134 mkUnsafeCall t fs as = mkMiddle $ MidForeignCall Unsafe t fs as
 135
 136 -- For debugging purposes, we can stub out dead stack slots:
 137 stackStubExpr :: Width -> CmmExpr
 138 stackStubExpr w = CmmLit (CmmInt 0 w)
 139
 140 -- Return the number of bytes used for copying arguments, as well as the
 141 -- instructions to copy the arguments.
 142 copyIn :: Convention -> Bool -> Area -> CmmFormals -> (Int, AGraph Middle Last)
 143 copyIn conv isCall area formals =
 144   foldr ci (init_offset, mkNop) $ assignArgumentsPos conv isCall localRegType formals
 145   where ci (reg, RegisterParam r) (n, ms) =
 146           (n, mkAssign (CmmLocal reg) (CmmReg $ CmmGlobal r) <*> ms)
 147         ci (reg, StackParam off) (n, ms) =
 148           let ty = localRegType reg
 149               off' = off + init_offset
 150           in (max n off',
 151               mkAssign (CmmLocal reg) (CmmLoad (CmmStackSlot area off') ty) <*> ms)
 152         init_offset = widthInBytes wordWidth
 153
 154 -- The argument layout function ignores the pointer to the info table, so we slot that
 155 -- in here. When copying-out to a young area, we set the info table for return
 156 -- and adjust the offsets of the other parameters.
 157 -- If this is a call instruction, we adjust the offsets of the other parameters.
 158 copyOut :: Convention -> Transfer -> Area -> CmmActuals -> UpdFrameOffset -> (Int, [Middle])
 159 copyOut conv transfer area@(CallArea a) actuals updfr_off =
 160   foldr co (init_offset, []) args'
 161   where args = assignArgumentsPos conv skip_node cmmExprType actuals
 162         skip_node = transfer /= Ret
 163         (setRA, init_offset) =
 164           case a of Young id@(BlockId _) -> -- set RA if making a call
 165                       if transfer == Call then
 166                         ([(CmmLit (CmmBlock id), StackParam init_offset)], ra_width)
 167                       else ([], 0)
 168                     Old -> ([], updfr_off)
 169         ra_width = widthInBytes wordWidth
 170         args' = foldl adjust setRA args
 171           where adjust rst (v, StackParam off) = (v, StackParam (off + init_offset)) : rst
 172                 adjust rst x@(_, RegisterParam _) = x : rst
 173         co (v, RegisterParam r) (n, ms) = (n, MidAssign (CmmGlobal r) v : ms)
 174         co (v, StackParam off)  (n, ms) =
 175           (max n off, MidStore (CmmStackSlot area off) v : ms)
 176 copyOut _ _ (RegSlot _) _ _ = panic "cannot copy arguments into a register slot"
 177
 178 mkEntry :: BlockId -> Convention -> CmmFormals -> (Int, CmmAGraph)
 179 mkEntry _ conv formals = copyIn conv False (CallArea Old) formals
 180
 181 lastWithArgs :: Transfer -> Area -> Convention -> CmmActuals -> UpdFrameOffset ->
 182                 (Int -> Last) -> CmmAGraph
 183 lastWithArgs transfer area conv actuals updfr_off last =
 184   let (outArgs, copies) = copyOut conv transfer area actuals updfr_off in
 185   mkMiddles copies <*> mkLast (last outArgs)
 186
 187 -- The area created for the jump and return arguments is the same area as the
 188 -- procedure entry.
 189 old :: Area
 190 old = CallArea Old
 191 toCall :: CmmExpr -> Maybe BlockId -> UpdFrameOffset -> Int -> Last
 192 toCall e cont updfr_off arg_space = LastCall e cont arg_space (Just updfr_off)
 193 mkJump e actuals updfr_off =
 194   lastWithArgs Jump old Native actuals updfr_off $ toCall e Nothing updfr_off
 195 mkJumpGC e actuals updfr_off =
 196   lastWithArgs Jump old GC actuals updfr_off $ toCall e Nothing updfr_off
 197 mkForeignJump conv e actuals updfr_off =
 198   lastWithArgs Jump old conv actuals updfr_off $ toCall e Nothing updfr_off
 199 mkReturn e actuals updfr_off =
 200   lastWithArgs Ret  old Native actuals updfr_off $ toCall e Nothing updfr_off
 201     -- where e = CmmLoad (CmmStackSlot (CallArea Old) updfr_off) gcWord
 202 mkReturnSimple actuals updfr_off =
 203   lastWithArgs Ret  old Native actuals updfr_off $ toCall e Nothing updfr_off
 204     where e = CmmLoad (CmmStackSlot (CallArea Old) updfr_off) gcWord
 205
 206 mkFinalCall f _ actuals updfr_off =
 207   lastWithArgs Call old Native actuals updfr_off $ toCall f Nothing updfr_off
 208
 209 mkCmmCall f results actuals = mkCall f Native results actuals
 210
 211 -- I'm dropping the SRT, but that should be okay: we plan to reconstruct it later.
 212 mkCall f conv results actuals updfr_off =
 213   withFreshLabel "call successor" $ \k ->
 214     let area = CallArea $ Young k
 215         (off, copyin) = copyIn conv False area results
 216         copyout = lastWithArgs Call area conv actuals updfr_off
 217                                (toCall f (Just k) updfr_off)
 218     in (copyout <*> mkLabel k (StackInfo (Just off) (Just updfr_off))
 219                 <*> copyin)