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 BlockId
  23 import CmmExpr
  24 import Cmm ( GenCmm(..), GenCmmTop(..), CmmStatic, CmmInfo
  25            , CmmCallTarget(..), CmmActuals, CmmFormals, CmmFormalsWithoutKinds
  26            , CmmKinded (..)
  27            )
  28 import MachOp (MachHint(..), wordRep)
  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 ZipCfg
  38 import MkZipCfg
  39
  40 type CmmGraph  = LGraph Middle Last
  41 type CmmAGraph = AGraph Middle Last
  42 type CmmBlock  = Block  Middle Last
  43 type CmmZ      = GenCmm    CmmStatic CmmInfo CmmGraph
  44 type CmmTopZ   = GenCmmTop CmmStatic CmmInfo CmmGraph
  45
  46 ---------- No-ops
  47 mkNop        :: CmmAGraph
  48 mkComment    :: FastString -> CmmAGraph
  49
  50 ---------- Assignment and store
  51 mkAssign     :: CmmReg  -> CmmExpr -> CmmAGraph
  52 mkStore      :: CmmExpr -> CmmExpr -> CmmAGraph
  53
  54 ---------- Calls
  55 mkCall       :: CmmExpr -> CCallConv -> CmmFormals -> CmmActuals -> C_SRT -> CmmAGraph
  56 mkCmmCall    :: CmmExpr -> CmmFormals -> CmmActuals -> C_SRT -> CmmAGraph
  57                         -- Native C-- calling convention
  58 mkUnsafeCall :: CmmCallTarget -> CmmFormals -> CmmActuals -> CmmAGraph
  59 mkFinalCall  :: CmmExpr -> CCallConv -> CmmActuals -> CmmAGraph
  60                  -- Never returns; like exit() or barf()
  61
  62 ---------- Context manipulation ("return via")
  63 mkAddToContext :: CmmExpr -> [CmmExpr] -> CmmAGraph
  64
  65 ---------- Control transfer
  66 mkJump          :: Area    -> CmmExpr -> CmmActuals -> CmmAGraph
  67 mkCbranch       :: CmmExpr -> BlockId -> BlockId    -> CmmAGraph
  68 mkSwitch        :: CmmExpr -> [Maybe BlockId]       -> CmmAGraph
  69 mkReturn        :: Area    -> CmmActuals            -> CmmAGraph
  70
  71 mkCmmIfThenElse :: CmmExpr -> CmmAGraph -> CmmAGraph -> CmmAGraph
  72 mkCmmIfThen     :: CmmExpr -> CmmAGraph -> CmmAGraph
  73 mkCmmWhileDo    :: CmmExpr -> CmmAGraph -> CmmAGraph
  74
  75 -- Not to be forgotten, but exported by MkZipCfg:
  76 -- mkBranch       :: BlockId -> CmmAGraph
  77 -- mkLabel        :: BlockId -> CmmAGraph
  78 -- outOfLine      :: CmmAGraph -> CmmAGraph
  79 -- withUnique     :: (Unique -> CmmAGraph) -> CmmAGraph
  80 -- withFreshLabel :: String -> (BlockId -> CmmAGraph) -> CmmAGraph
  81
  82 --------------------------------------------------------------------------
  83
  84 mkCmmWhileDo    e = mkWhileDo (mkCbranch e)
  85 mkCmmIfThenElse e = mkIfThenElse (mkCbranch e)
  86
  87 mkCmmIfThen e tbranch
  88   = withFreshLabel "end of if"     $ \endif ->
  89     withFreshLabel "start of then" $ \tid ->
  90     mkCbranch e tid endif <*>
  91     mkLabel tid <*> tbranch <*> mkBranch endif <*>
  92     mkLabel endif
  93
  94
  95
  96 -- ================ IMPLEMENTATION ================--
  97
  98 mkNop                     = emptyAGraph
  99 mkComment fs              = mkMiddle $ MidComment fs
 100 mkAssign l r              = mkMiddle $ MidAssign l r
 101 mkStore  l r              = mkMiddle $ MidStore  l r
 102
 103 mkCbranch pred ifso ifnot = mkLast   $ LastCondBranch pred ifso ifnot
 104 mkSwitch e tbl            = mkLast   $ LastSwitch e tbl
 105
 106 mkUnsafeCall tgt results actuals = mkMiddle $ MidUnsafeCall tgt results actuals
 107 mkAddToContext ra actuals        = mkMiddle $ MidAddToContext ra actuals
 108
 109 cmmResConv :: Convention
 110 cmmResConv = ConventionStandard CmmCallConv Results
 111
 112 copyIn :: Convention -> Area -> CmmFormals -> [Middle]
 113 copyIn _ area formals = reverse $ snd $ foldl ci (1, []) formals
 114   where ci (n, ms) v = (n+1, MidAssign (CmmLocal $ kindlessCmm v)
 115                                        (CmmLoad (CmmStackSlot area n) wordRep) : ms)
 116
 117 copyOut :: Convention -> Area -> CmmActuals -> [Middle]
 118 copyOut conv area actuals = moveSP conv $ snd $ foldl co (1, []) actuals
 119   where moveSP (ConventionStandard _ Arguments) args =
 120            MidAssign spReg (outgoingSlot area) : reverse args
 121         moveSP _ args = reverse $ MidAssign spReg (outgoingSlot area) : args
 122         co (n, ms) v = (n+1, MidStore (CmmStackSlot area n) (kindlessCmm v) : ms)
 123 mkEntry :: Area -> Convention -> CmmFormalsWithoutKinds -> [Middle]
 124 mkEntry area conv formals = copyIn conv area 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' :: BlockId -> Area -> Convention -> CmmActuals -> Maybe CmmFormals ->
 133                  (BlockId -> Last) -> CmmAGraph
 134 lastWithArgs' k area conv actuals formals toLast =
 135   (mkMiddles $ copyOut conv area actuals) <*>
 136   -- adjust the sp
 137   mkLast (toLast k) <*>
 138   case formals of
 139     Just formals -> mkLabel k <*> (mkMiddles $ copyIn conv area formals)
 140     Nothing      -> emptyAGraph
 141 lastWithArgs :: Convention -> CmmActuals -> Maybe CmmFormals -> (BlockId -> Last) -> CmmAGraph
 142 lastWithArgs c a f l =
 143   withFreshLabel "call successor" $ \k -> lastWithArgs' k (mkCallArea k a f) c a f l
 144
 145 always :: a -> b -> a
 146 always x _ = x
 147
 148 -- The area created for the jump and return arguments is the same area as the
 149 -- procedure entry.
 150 mkJump   area e actuals =
 151   lastWithArgs' (areaId area) area cmmResConv actuals Nothing $ always $ LastJump e
 152 mkReturn area   actuals =
 153   lastWithArgs' (areaId area) area cmmResConv actuals Nothing $ always LastReturn
 154
 155 mkFinalCall f conv actuals =
 156   lastWithArgs (ConventionStandard conv Arguments) actuals Nothing
 157       $ always $ LastCall f Nothing --mkFinalCall  f conv actuals =
 158
 159 mkCmmCall f results actuals srt = mkCall f CmmCallConv results actuals srt
 160
 161 -- I'm dropping the SRT, but that should be okay: we plan to reconstruct it later.
 162 mkCall f conv results actuals _ =
 163   lastWithArgs (ConventionStandard conv Arguments) actuals (Just results)
 164         $ \k -> LastCall f (Just k)