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, these definitions are duplicated below
  31 import PprCmm()
  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          :: Area    -> CmmExpr -> CmmActuals -> CmmAGraph
  66 mkCbranch       :: CmmExpr -> BlockId -> BlockId    -> CmmAGraph
  67 mkSwitch        :: CmmExpr -> [Maybe BlockId]       -> CmmAGraph
  68 mkReturn        :: Area    -> 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 cmmResConv :: Convention
 109 cmmResConv = ConventionStandard CmmCallConv Results
 110
 111 copyIn :: Convention -> Area -> CmmFormals -> [Middle]
 112 copyIn _ area formals = reverse $ snd $ foldl ci (1, []) formals
 113   where ci (n, ms) v = (n+1, MidAssign (CmmLocal $ kindlessCmm v)
 114                                        (CmmLoad (CmmStackSlot area n) wordRep) : ms)
 115
 116 copyOut :: Convention -> Area -> CmmActuals -> [Middle]
 117 copyOut conv area actuals = moveSP conv $ snd $ foldl co (1, []) actuals
 118   where moveSP (ConventionStandard _ Arguments) args =
 119            MidAssign spReg (outgoingSlot area) : reverse args
 120         moveSP _ args = reverse $ MidAssign spReg (outgoingSlot area) : args
 121         co (n, ms) v = (n+1, MidStore (CmmStackSlot area n) (kindlessCmm v) : ms)
 122 mkEntry :: Area -> Convention -> CmmFormalsWithoutKinds -> [Middle]
 123 mkEntry area conv formals = copyIn conv area fs
 124   where fs = map (\f -> CmmKinded f NoHint) formals
 125
 126 -- I'm not sure how to get the calling conventions right yet,
 127 -- and I suspect this should not be resolved until sometime after
 128 -- Simon's patch is applied.
 129 -- For now, I apply a bogus calling convention: all arguments go on the
 130 -- stack, using the same amount of stack space.
 131 lastWithArgs' :: BlockId -> Area -> Convention -> CmmActuals -> Maybe CmmFormals ->
 132                  (BlockId -> Last) -> CmmAGraph
 133 lastWithArgs' k area conv actuals formals toLast =
 134   (mkMiddles $ copyOut conv area actuals) <*>
 135   -- adjust the sp
 136   mkLast (toLast k) <*>
 137   case formals of
 138     Just formals -> mkLabel k <*> (mkMiddles $ copyIn conv area formals)
 139     Nothing      -> emptyAGraph
 140 lastWithArgs :: Convention -> CmmActuals -> Maybe CmmFormals -> (BlockId -> Last) -> CmmAGraph
 141 lastWithArgs c a f l =
 142   withFreshLabel "call successor" $ \k -> lastWithArgs' k (mkCallArea k a f) c a f l
 143
 144 always :: a -> b -> a
 145 always x _ = x
 146
 147 -- The area created for the jump and return arguments is the same area as the
 148 -- procedure entry.
 149 mkJump   area e actuals =
 150   lastWithArgs' (areaId area) area cmmResConv actuals Nothing $ always $ LastJump e
 151 mkReturn area   actuals =
 152   lastWithArgs' (areaId area) area cmmResConv actuals Nothing $ always LastReturn
 153
 154 mkFinalCall f conv actuals =
 155   lastWithArgs (ConventionStandard conv Arguments) actuals Nothing
 156       $ always $ LastCall f Nothing --mkFinalCall  f conv actuals =
 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)