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
  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
  25            )
  26 import ZipCfgCmmRep hiding (CmmGraph, CmmAGraph, CmmBlock, CmmZ, CmmTopZ)
  27   -- ^ to make this module more self-contained, these definitions are duplicated below
  28 import PprCmm()
  29
  30 import ClosureInfo
  31 import FastString
  32 import ForeignCall
  33 import ZipCfg
  34 import MkZipCfg
  35
  36 type CmmGraph  = LGraph Middle Last
  37 type CmmAGraph = AGraph Middle Last
  38 type CmmBlock  = Block  Middle Last
  39 type CmmZ      = GenCmm    CmmStatic CmmInfo CmmGraph
  40 type CmmTopZ   = GenCmmTop CmmStatic CmmInfo CmmGraph
  41
  42 ---------- No-ops
  43 mkNop        :: CmmAGraph
  44 mkComment    :: FastString -> CmmAGraph
  45
  46 ---------- Assignment and store
  47 mkAssign     :: CmmReg  -> CmmExpr -> CmmAGraph
  48 mkStore      :: CmmExpr -> CmmExpr -> CmmAGraph
  49
  50 ---------- Calls
  51 mkCall       :: CmmExpr -> CCallConv -> CmmFormals -> CmmActuals -> C_SRT -> CmmAGraph
  52 mkCmmCall    :: CmmExpr -> CmmFormals -> CmmActuals -> C_SRT -> CmmAGraph
  53                         -- Native C-- calling convention
  54 mkUnsafeCall :: CmmCallTarget -> CmmFormals -> CmmActuals -> CmmAGraph
  55 mkFinalCall  :: CmmExpr -> CCallConv -> CmmActuals -> CmmAGraph
  56                  -- Never returns; like exit() or barf()
  57
  58 ---------- Context manipulation ('return via')
  59 mkAddToContext :: CmmExpr -> [CmmExpr] -> CmmAGraph
  60
  61 ---------- Control transfer
  62 mkJump          :: CmmExpr -> CmmActuals -> CmmAGraph
  63 mkCbranch       :: CmmExpr -> BlockId -> BlockId -> CmmAGraph
  64 mkSwitch        :: CmmExpr -> [Maybe BlockId] -> CmmAGraph
  65 mkReturn        :: CmmActuals -> CmmAGraph
  66
  67 mkCmmIfThenElse :: CmmExpr -> CmmAGraph -> CmmAGraph -> CmmAGraph
  68 mkCmmIfThen     :: CmmExpr -> CmmAGraph -> CmmAGraph
  69 mkCmmWhileDo    :: CmmExpr -> CmmAGraph -> CmmAGraph
  70
  71 -- Not to be forgotten, but exported by MkZipCfg:
  72 -- mkBranch       :: BlockId -> CmmAGraph
  73 -- mkLabel        :: BlockId -> CmmAGraph
  74 -- outOfLine      :: CmmAGraph -> CmmAGraph
  75 -- withUnique     :: (Unique -> CmmAGraph) -> CmmAGraph
  76 -- withFreshLabel :: String -> (BlockId -> CmmAGraph) -> CmmAGraph
  77
  78 --------------------------------------------------------------------------
  79
  80 mkCmmWhileDo    e = mkWhileDo (mkCbranch e)
  81 mkCmmIfThenElse e = mkIfThenElse (mkCbranch e)
  82
  83 mkCmmIfThen e tbranch
  84   = withFreshLabel "end of if"     $ \endif ->
  85     withFreshLabel "start of then" $ \tid ->
  86     mkCbranch e tid endif <*>
  87     mkLabel tid <*> tbranch <*> mkBranch endif <*>
  88     mkLabel endif
  89
  90
  91
  92 -- ================ IMPLEMENTATION ================--
  93
  94 mkNop                     = emptyAGraph
  95 mkComment fs              = mkMiddle $ MidComment fs
  96 mkAssign l r              = mkMiddle $ MidAssign l r
  97 mkStore  l r              = mkMiddle $ MidStore  l r
  98
  99 mkCbranch pred ifso ifnot = mkLast   $ LastCondBranch pred ifso ifnot
 100 mkSwitch e tbl            = mkLast   $ LastSwitch e tbl
 101
 102 mkUnsafeCall tgt results actuals = mkMiddle $ MidUnsafeCall tgt results actuals
 103 mkAddToContext ra actuals         = mkMiddle $ MidAddToContext ra actuals
 104
 105 cmmArgConv, cmmResConv :: Convention
 106 cmmArgConv = ConventionStandard CmmCallConv Arguments
 107 cmmResConv = ConventionStandard CmmCallConv Arguments
 108
 109 mkJump e actuals = mkMiddle (CopyOut cmmArgConv actuals) <*> mkLast (LastJump e)
 110 mkReturn actuals = mkMiddle (CopyOut cmmResConv actuals) <*> mkLast LastReturn
 111
 112 mkFinalCall  f conv actuals =
 113     mkMiddle (CopyOut (ConventionStandard conv Arguments) actuals) <*>
 114     mkLast   (LastCall f Nothing)
 115
 116 mkCmmCall f results actuals srt = mkCall f CmmCallConv results actuals srt
 117
 118 mkCall f conv results actuals srt =
 119     withFreshLabel "call successor" $ \k ->
 120       mkMiddle (CopyOut (ConventionStandard conv Arguments) actuals) <*>
 121       mkLast (LastCall f (Just k)) <*>
 122       mkLabel k <*>
 123       mkMiddle (CopyIn (ConventionStandard conv Results) results srt)