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, Middle, Last, Convention(..)
  17   )
  18 where
  19
  20 #include "HsVersions.h"
  21
  22 import CmmExpr
  23 import Cmm ( GenCmm(..), GenCmmTop(..), CmmStatic, CmmInfo
  24            , CmmCallTarget(..), CmmActuals, CmmFormals, CmmFormalsWithoutKinds
  25            , CmmKinded (..)
  26            )
  27 import MachOp (MachHint(..))
  28 import ZipCfgCmmRep hiding (CmmGraph, CmmAGraph, CmmBlock, CmmZ, CmmTopZ)
  29   -- ^ to make this module more self-contained, these definitions are duplicated below
  30 import PprCmm()
  31 import StackSlot
  32
  33 import ClosureInfo
  34 import FastString
  35 import ForeignCall
  36 import ZipCfg
  37 import MkZipCfg
  38
  39 type CmmGraph  = LGraph Middle Last
  40 type CmmAGraph = AGraph Middle Last
  41 type CmmBlock  = Block  Middle Last
  42 type CmmZ      = GenCmm    CmmStatic CmmInfo CmmGraph
  43 type CmmTopZ   = GenCmmTop CmmStatic CmmInfo CmmGraph
  44
  45 ---------- No-ops
  46 mkNop        :: CmmAGraph
  47 mkComment    :: FastString -> CmmAGraph
  48
  49 ---------- Assignment and store
  50 mkAssign     :: CmmReg  -> CmmExpr -> CmmAGraph
  51 mkStore      :: CmmExpr -> CmmExpr -> CmmAGraph
  52
  53 ---------- Calls
  54 mkCall       :: CmmExpr -> CCallConv -> CmmFormals -> CmmActuals -> C_SRT -> CmmAGraph
  55 mkCmmCall    :: CmmExpr -> CmmFormals -> CmmActuals -> C_SRT -> CmmAGraph
  56                         -- Native C-- calling convention
  57 mkUnsafeCall :: CmmCallTarget -> CmmFormals -> CmmActuals -> CmmAGraph
  58 mkFinalCall  :: CmmExpr -> CCallConv -> CmmActuals -> CmmAGraph
  59                  -- Never returns; like exit() or barf()
  60
  61 ---------- Context manipulation ('return via')
  62 mkAddToContext :: CmmExpr -> [CmmExpr] -> CmmAGraph
  63
  64 ---------- Control transfer
  65 mkJump          :: CmmExpr -> CmmActuals -> CmmAGraph
  66 mkCbranch       :: CmmExpr -> BlockId -> BlockId -> CmmAGraph
  67 mkSwitch        :: CmmExpr -> [Maybe BlockId] -> CmmAGraph
  68 mkReturn        :: CmmActuals -> CmmAGraph
  69
  70 mkCmmIfThenElse :: CmmExpr -> CmmAGraph -> CmmAGraph -> CmmAGraph
  71 mkCmmIfThen     :: CmmExpr -> CmmAGraph -> CmmAGraph
  72 mkCmmWhileDo    :: CmmExpr -> CmmAGraph -> CmmAGraph
  73
  74 -- Not to be forgotten, but exported by MkZipCfg:
  75 -- mkBranch       :: BlockId -> CmmAGraph
  76 -- mkLabel        :: BlockId -> CmmAGraph
  77 -- outOfLine      :: CmmAGraph -> CmmAGraph
  78 -- withUnique     :: (Unique -> CmmAGraph) -> CmmAGraph
  79 -- withFreshLabel :: String -> (BlockId -> CmmAGraph) -> CmmAGraph
  80
  81 --------------------------------------------------------------------------
  82
  83 mkCmmWhileDo    e = mkWhileDo (mkCbranch e)
  84 mkCmmIfThenElse e = mkIfThenElse (mkCbranch e)
  85
  86 mkCmmIfThen e tbranch
  87   = withFreshLabel "end of if"     $ \endif ->
  88     withFreshLabel "start of then" $ \tid ->
  89     mkCbranch e tid endif <*>
  90     mkLabel tid <*> tbranch <*> mkBranch endif <*>
  91     mkLabel endif
  92
  93
  94
  95 -- ================ IMPLEMENTATION ================--
  96
  97 mkNop                     = emptyAGraph
  98 mkComment fs              = mkMiddle $ MidComment fs
  99 mkAssign l r              = mkMiddle $ MidAssign l r
 100 mkStore  l r              = mkMiddle $ MidStore  l r
 101
 102 mkCbranch pred ifso ifnot = mkLast   $ LastCondBranch pred ifso ifnot
 103 mkSwitch e tbl            = mkLast   $ LastSwitch e tbl
 104
 105 mkUnsafeCall tgt results actuals = mkMiddle $ MidUnsafeCall tgt results actuals
 106 mkAddToContext ra actuals        = mkMiddle $ MidAddToContext ra actuals
 107
 108 --cmmArgConv :: Convention
 109 cmmResConv :: Convention
 110 --cmmArgConv = ConventionStandard CmmCallConv Arguments
 111 cmmResConv = ConventionStandard CmmCallConv Arguments
 112
 113 copyIn :: Convention -> StackArea -> CmmFormals -> [Middle]
 114 copyIn _ area formals = reverse $ snd $ foldl ci (1, []) formals
 115   where ci (n, ms) v = (n+1, MidAssign (CmmLocal $ kindlessCmm v)
 116                                        (CmmReg $ CmmStack $ StackSlot area n) : ms)
 117
 118 copyOut :: Convention -> StackArea -> CmmActuals -> [Middle]
 119 copyOut _ area actuals = moveSP : reverse (snd $ foldl co (1, []) actuals)
 120   where moveSP = MidAssign spReg $ CmmReg $ CmmStack $ outgoingSlot area
 121         co (n, ms) v = (n+1, MidAssign (CmmStack $ StackSlot area n)
 122                                        (kindlessCmm v) : ms)
 123 mkEntry :: BlockId -> Convention -> CmmFormalsWithoutKinds -> [Middle]
 124 mkEntry entryId conv formals = copyIn conv (mkStackArea entryId [] $ Just fs) fs
 125   where fs = map (\f -> CmmKinded f NoHint) formals
 126
 127 -- I'm not sure how to get the calling conventions right yet,
 128 -- and I suspect this should not be resolved until sometime after
 129 -- Simon's patch is applied.
 130 -- For now, I apply a bogus calling convention: all arguments go on the
 131 -- stack, using the same amount of stack space.
 132 lastWithArgs :: Convention -> CmmActuals -> Maybe CmmFormals -> (BlockId -> Last) ->
 133                 CmmAGraph
 134 lastWithArgs conv actuals formals toLast =
 135   withFreshLabel "call successor" $ \k ->
 136     let area = mkStackArea k actuals formals
 137     in (mkMiddles $ copyOut conv area actuals) <*>
 138        -- adjust the sp
 139        mkLast (toLast k) <*>
 140        case formals of
 141          Just formals -> mkLabel k <*> (mkMiddles $ copyIn conv area formals)
 142          Nothing      -> emptyAGraph
 143 always :: a -> b -> a
 144 always x _ = x
 145
 146 mkJump e actuals = lastWithArgs cmmResConv actuals Nothing $ always $ LastJump e
 147 mkReturn actuals = lastWithArgs cmmResConv actuals Nothing $ always LastReturn
 148 --mkJump e actuals = mkMiddle (CopyOut cmmArgConv actuals) <*> mkLast (LastJump e)
 149 --mkReturn actuals = mkMiddle (CopyOut cmmResConv actuals) <*> mkLast LastReturn
 150
 151 mkFinalCall f conv actuals =
 152   lastWithArgs (ConventionStandard conv Arguments) actuals Nothing
 153       $ always $ LastCall f Nothing --mkFinalCall  f conv actuals =
 154 --    mkMiddle (CopyOut (ConventionStandard conv Arguments) actuals) <*>
 155 --    mkLast   (LastCall f Nothing)
 156 --
 157
 158 mkCmmCall f results actuals srt = mkCall f CmmCallConv results actuals srt
 159
 160 -- I'm dropping the SRT, but that should be okay: we plan to reconstruct it later.
 161 mkCall f conv results actuals _ =
 162   lastWithArgs (ConventionStandard conv Arguments) actuals (Just results)
 163         $ \k -> LastCall f (Just k)
 164 --mkCall f conv results actuals srt =
 165 --    withFreshLabel "call successor" $ \k ->
 166 --      mkMiddle (CopyOut (ConventionStandard conv Arguments) actuals) <*>
 167 --      mkLast (LastCall f (Just k)) <*>
 168 --      mkLabel k <*>
 169 --      mkMiddle (CopyIn (ConventionStandard conv Results) results srt)