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"
23 import Cmm ( GenCmm(..), GenCmmTop(..), CmmStatic, CmmInfo
24 , CmmCallTarget(..), CmmActuals, CmmFormals, CmmFormalsWithoutKinds
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
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
47 mkComment :: FastString -> CmmAGraph
49 ---------- Assignment and store
50 mkAssign :: CmmReg -> CmmExpr -> CmmAGraph
51 mkStore :: CmmExpr -> CmmExpr -> CmmAGraph
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()
61 ---------- Context manipulation ('return via')
62 mkAddToContext :: CmmExpr -> [CmmExpr] -> CmmAGraph
64 ---------- Control transfer
65 mkJump :: CmmExpr -> CmmActuals -> CmmAGraph
66 mkCbranch :: CmmExpr -> BlockId -> BlockId -> CmmAGraph
67 mkSwitch :: CmmExpr -> [Maybe BlockId] -> CmmAGraph
68 mkReturn :: CmmActuals -> CmmAGraph
70 mkCmmIfThenElse :: CmmExpr -> CmmAGraph -> CmmAGraph -> CmmAGraph
71 mkCmmIfThen :: CmmExpr -> CmmAGraph -> CmmAGraph
72 mkCmmWhileDo :: CmmExpr -> CmmAGraph -> CmmAGraph
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
81 --------------------------------------------------------------------------
83 mkCmmWhileDo e = mkWhileDo (mkCbranch e)
84 mkCmmIfThenElse e = mkIfThenElse (mkCbranch e)
87 = withFreshLabel "end of if" $ \endif ->
88 withFreshLabel "start of then" $ \tid ->
89 mkCbranch e tid endif <*>
90 mkLabel tid <*> tbranch <*> mkBranch endif <*>
95 -- ================ IMPLEMENTATION ================--
98 mkComment fs = mkMiddle $ MidComment fs
99 mkAssign l r = mkMiddle $ MidAssign l r
100 mkStore l r = mkMiddle $ MidStore l r
102 mkCbranch pred ifso ifnot = mkLast $ LastCondBranch pred ifso ifnot
103 mkSwitch e tbl = mkLast $ LastSwitch e tbl
105 mkUnsafeCall tgt results actuals = mkMiddle $ MidUnsafeCall tgt results actuals
106 mkAddToContext ra actuals = mkMiddle $ MidAddToContext ra actuals
108 --cmmArgConv :: Convention
109 cmmResConv :: Convention
110 --cmmArgConv = ConventionStandard CmmCallConv Arguments
111 cmmResConv = ConventionStandard CmmCallConv Arguments
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)
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
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) ->
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) <*>
139 mkLast (toLast k) <*>
141 Just formals -> mkLabel k <*> (mkMiddles $ copyIn conv area formals)
142 Nothing -> emptyAGraph
143 always :: a -> b -> a
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
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)
158 mkCmmCall f results actuals srt = mkCall f CmmCallConv results actuals srt
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)) <*>
169 -- mkMiddle (CopyIn (ConventionStandard conv Results) results srt)