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, mkUnsafeCall, mkFinalCall
  10          , mkJump, mkCbranch, mkSwitch, mkReturn, mkComment, copyIn, copyOut, mkEntry
  11          , mkCmmIfThenElse, mkCmmIfThen, mkCmmWhileDo
  12          , mkAddToContext
  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   )
  19 where
  20
  21 #include "HsVersions.h"
  22
  23 import BlockId
  24 import CmmExpr
  25 import Cmm ( GenCmm(..), GenCmmTop(..), CmmStatic, CmmInfo
  26            , CmmActuals, CmmFormals
  27            )
  28 import CmmCallConv (assignArgumentsPos, ParamLocation(..))
  29 import ZipCfgCmmRep hiding (CmmGraph, CmmAGraph, CmmBlock, CmmZ, CmmTopZ)
  30   -- to make this module more self-contained, the above definitions are
  31   -- duplicated below
  32 import PprCmm()
  33
  34 import ClosureInfo
  35 import FastString
  36 import ForeignCall
  37 import MkZipCfg
  38 import Panic
  39 import ZipCfg
  40
  41 type CmmGraph  = LGraph Middle Last
  42 type CmmAGraph = AGraph Middle Last
  43 type CmmBlock  = Block  Middle Last
  44 type CmmZ      = GenCmm    CmmStatic CmmInfo CmmGraph
  45 type CmmTopZ   = GenCmmTop CmmStatic CmmInfo CmmGraph
  46
  47 data Transfer = Call | Jump | Ret deriving Eq
  48
  49 ---------- No-ops
  50 mkNop        :: CmmAGraph
  51 mkComment    :: FastString -> CmmAGraph
  52
  53 ---------- Assignment and store
  54 mkAssign     :: CmmReg  -> CmmExpr -> CmmAGraph
  55 mkStore      :: CmmExpr -> CmmExpr -> CmmAGraph
  56
  57 ---------- Calls
  58 mkCall       :: CmmExpr -> CCallConv -> CmmFormals -> CmmActuals -> C_SRT -> CmmAGraph
  59 mkCmmCall    :: CmmExpr -> CmmFormals -> CmmActuals -> C_SRT -> CmmAGraph
  60                         -- Native C-- calling convention
  61 mkUnsafeCall :: MidCallTarget -> CmmFormals -> CmmActuals -> CmmAGraph
  62 mkFinalCall  :: CmmExpr -> CCallConv -> CmmActuals -> CmmAGraph
  63                  -- Never returns; like exit() or barf()
  64
  65 ---------- Context manipulation ("return via")
  66 mkAddToContext :: CmmExpr -> [CmmExpr] -> CmmAGraph
  67
  68 ---------- Control transfer
  69 mkJump          :: CmmExpr -> CmmActuals -> CmmAGraph
  70 mkCbranch       :: CmmExpr -> BlockId -> BlockId          -> CmmAGraph
  71 mkSwitch        :: CmmExpr -> [Maybe BlockId]             -> CmmAGraph
  72 mkReturn        :: CmmActuals -> CmmAGraph
  73
  74 mkCmmIfThenElse :: CmmExpr -> CmmAGraph -> CmmAGraph -> CmmAGraph
  75 mkCmmIfThen     :: CmmExpr -> CmmAGraph -> CmmAGraph
  76 mkCmmWhileDo    :: CmmExpr -> CmmAGraph -> CmmAGraph
  77
  78 -- Not to be forgotten, but exported by MkZipCfg:
  79 -- mkBranch       :: BlockId -> CmmAGraph
  80 -- mkLabel        :: BlockId -> Maybe Int -> CmmAGraph
  81 -- outOfLine      :: CmmAGraph -> CmmAGraph
  82 -- withUnique     :: (Unique -> CmmAGraph) -> CmmAGraph
  83 -- withFreshLabel :: String -> (BlockId -> CmmAGraph) -> CmmAGraph
  84
  85 --------------------------------------------------------------------------
  86
  87 mkCmmWhileDo    e = mkWhileDo (mkCbranch e)
  88 mkCmmIfThenElse e = mkIfThenElse (mkCbranch e)
  89
  90 mkCmmIfThen e tbranch
  91   = withFreshLabel "end of if"     $ \endif ->
  92     withFreshLabel "start of then" $ \tid ->
  93     mkCbranch e tid endif <*>
  94     mkLabel tid Nothing <*> tbranch <*> mkBranch endif <*>
  95     mkLabel endif Nothing
  96
  97
  98
  99 -- ================ IMPLEMENTATION ================--
 100
 101 mkNop                     = emptyAGraph
 102 mkComment fs              = mkMiddle $ MidComment fs
 103 mkAssign l r              = mkMiddle $ MidAssign l r
 104 mkStore  l r              = mkMiddle $ MidStore  l r
 105
 106
 107 -- Why are we inserting extra blocks that simply branch to the successors?
 108 -- Because in addition to the branch instruction, @mkBranch@ will insert
 109 -- a necessary adjustment to the stack pointer.
 110 mkCbranch pred ifso ifnot = mkLast (LastCondBranch pred ifso ifnot)
 111 mkSwitch e tbl            = mkLast   $ LastSwitch e tbl
 112
 113 mkUnsafeCall tgt results actuals = mkMiddle $ MidUnsafeCall tgt results actuals
 114 mkAddToContext ra actuals        = mkMiddle $ MidAddToContext ra actuals
 115
 116 cmmResConv :: Convention
 117 cmmResConv = Native
 118
 119 -- Return the number of bytes used for copying arguments, as well as the
 120 -- instructions to copy the arguments.
 121 copyIn :: Convention -> Bool -> Area -> CmmFormals -> (Int, [Middle])
 122 copyIn _ isCall area formals =
 123   foldr ci (init_offset, []) $ assignArgumentsPos isCall localRegType formals
 124   where ci (reg, RegisterParam r) (n, ms) =
 125           (n, MidAssign (CmmLocal reg) (CmmReg $ CmmGlobal r) : ms)
 126         ci (reg, StackParam off) (n, ms) =
 127           let ty = localRegType reg
 128               off' = off + init_offset
 129           in (max n off',
 130               MidAssign (CmmLocal reg) (CmmLoad (CmmStackSlot area off') ty) : ms)
 131         init_offset = widthInBytes wordWidth
 132
 133 -- The argument layout function ignores the pointer to the info table, so we slot that
 134 -- in here. When copying-out to a young area, we set the info table for return
 135 -- and adjust the offsets of the other parameters.
 136 -- If this is a call instruction, we adjust the offsets of the other parameters.
 137 copyOut :: Convention -> Transfer -> Area -> CmmActuals -> (Int, [Middle])
 138 copyOut _ transfer area@(CallArea a) actuals =
 139   foldr co (init_offset, []) args'
 140   where args = assignArgumentsPos skip_node cmmExprType actuals
 141         skip_node = transfer /= Ret
 142         (setRA, init_offset) =
 143           case a of Young id -> -- set RA if making a call
 144                       if transfer == Call then
 145                         ([(CmmLit (CmmLabel (infoTblLbl id)),
 146                            StackParam init_offset)], ra_width)
 147                       else ([], 0)
 148                     Old -> ([], ra_width)
 149         ra_width = widthInBytes wordWidth
 150         args' = foldl adjust setRA args
 151           where adjust rst (v, StackParam off) = (v, StackParam (off + init_offset)) : rst
 152                 adjust rst x@(_, RegisterParam _) = x : rst
 153         co (v, RegisterParam r) (n, ms) = (n, MidAssign (CmmGlobal r) v : ms)
 154         co (v, StackParam off)  (n, ms) =
 155           (max n off, MidStore (CmmStackSlot area off) v : ms)
 156 copyOut _ _ (RegSlot _) _ = panic "cannot copy arguments into a register slot"
 157
 158 mkEntry :: BlockId -> Convention -> CmmFormals -> (Int, CmmAGraph)
 159 mkEntry _ conv formals =
 160   let (off, copies) = copyIn conv False (CallArea Old) formals in
 161   (off, mkMiddles copies)
 162
 163 -- I'm not sure how to get the calling conventions right yet,
 164 -- and I suspect this should not be resolved until sometime after
 165 -- Simon's patch is applied.
 166 -- For now, I apply a bogus calling convention: all arguments go on the
 167 -- stack, using the same amount of stack space.
 168
 169 lastWithArgs :: Transfer -> Area -> Convention -> CmmActuals -> (Int -> Last) -> CmmAGraph
 170 lastWithArgs transfer area conv actuals last =
 171   let (outArgs, copies) = copyOut conv transfer area actuals in
 172   mkMiddles copies <*> mkLast (last outArgs)
 173
 174 -- The area created for the jump and return arguments is the same area as the
 175 -- procedure entry.
 176 mkJump e actuals = lastWithArgs Jump (CallArea Old) cmmResConv actuals $ LastJump e
 177 mkReturn actuals = lastWithArgs Ret  (CallArea Old) cmmResConv actuals $ LastJump e
 178   where e = CmmStackSlot (CallArea Old) (widthInBytes wordWidth)
 179
 180 mkFinalCall f _ actuals =
 181   lastWithArgs Call (CallArea Old) Native actuals $ LastCall f Nothing
 182
 183 mkCmmCall f results actuals srt = mkCall f CmmCallConv results actuals srt
 184
 185 -- I'm dropping the SRT, but that should be okay: we plan to reconstruct it later.
 186 mkCall f _ results actuals _ =
 187   withFreshLabel "call successor" $ \k ->
 188   let area = CallArea $ Young k
 189       (off, copyin) = copyIn Native False area results
 190       copyout = lastWithArgs Call area Native actuals $ LastCall f (Just k)
 191   in copyout <*> mkLabel k (Just off) <*> (mkMiddles copyin)