1 {-# OPTIONS -Wall -fno-warn-name-shadowing #-}
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.
9 ( mkNop, mkAssign, mkStore, mkCall, mkCmmCall, mkUnsafeCall, mkFinalCall
10 , mkJump, mkCbranch, mkSwitch, mkReturn, mkComment, copyIn, copyOut, mkEntry
11 , mkCmmIfThenElse, mkCmmIfThen, mkCmmWhileDo
13 , (<*>), catAGraphs, mkLabel, mkBranch
14 , emptyAGraph, withFreshLabel, withUnique, outOfLine
15 , lgraphOfAGraph, graphOfAGraph, labelAGraph
16 , CmmZ, CmmTopZ, CmmGraph, CmmBlock, CmmAGraph, Middle, Last, Convention(..)
20 #include "HsVersions.h"
24 import Cmm ( GenCmm(..), GenCmmTop(..), CmmStatic, CmmInfo
25 , CmmCallTarget(..), CmmActuals, CmmFormals, CmmFormalsWithoutKinds
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
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
48 mkComment :: FastString -> CmmAGraph
50 ---------- Assignment and store
51 mkAssign :: CmmReg -> CmmExpr -> CmmAGraph
52 mkStore :: CmmExpr -> CmmExpr -> CmmAGraph
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()
62 ---------- Context manipulation ("return via")
63 mkAddToContext :: CmmExpr -> [CmmExpr] -> CmmAGraph
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
71 mkCmmIfThenElse :: CmmExpr -> CmmAGraph -> CmmAGraph -> CmmAGraph
72 mkCmmIfThen :: CmmExpr -> CmmAGraph -> CmmAGraph
73 mkCmmWhileDo :: CmmExpr -> CmmAGraph -> CmmAGraph
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
82 --------------------------------------------------------------------------
84 mkCmmWhileDo e = mkWhileDo (mkCbranch e)
85 mkCmmIfThenElse e = mkIfThenElse (mkCbranch e)
88 = withFreshLabel "end of if" $ \endif ->
89 withFreshLabel "start of then" $ \tid ->
90 mkCbranch e tid endif <*>
91 mkLabel tid <*> tbranch <*> mkBranch endif <*>
96 -- ================ IMPLEMENTATION ================--
99 mkComment fs = mkMiddle $ MidComment fs
100 mkAssign l r = mkMiddle $ MidAssign l r
101 mkStore l r = mkMiddle $ MidStore l r
103 mkCbranch pred ifso ifnot = mkLast $ LastCondBranch pred ifso ifnot
104 mkSwitch e tbl = mkLast $ LastSwitch e tbl
106 mkUnsafeCall tgt results actuals = mkMiddle $ MidUnsafeCall tgt results actuals
107 mkAddToContext ra actuals = mkMiddle $ MidAddToContext ra actuals
109 cmmResConv :: Convention
110 cmmResConv = ConventionStandard CmmCallConv Results
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)
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
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) <*>
137 mkLast (toLast k) <*>
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
145 always :: a -> b -> a
148 -- The area created for the jump and return arguments is the same area as the
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
155 mkFinalCall f conv actuals =
156 lastWithArgs (ConventionStandard conv Arguments) actuals Nothing
157 $ always $ LastCall f Nothing --mkFinalCall f conv actuals =
159 mkCmmCall f results actuals srt = mkCall f CmmCallConv results actuals srt
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)