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, mkSafeCall, mkUnsafeCall, mkFinalCall
10 , mkJump, mkForeignJump, mkJumpGC, mkCbranch, mkSwitch, mkReturn
11 , mkReturnSimple, mkComment, copyIn, copyOut
12 , mkEntry, mkCmmIfThenElse, mkCmmIfThen, mkCmmWhileDo
13 , (<*>), catAGraphs, mkLabel, mkBranch
14 , emptyAGraph, withFreshLabel, withUnique, outOfLine
15 , lgraphOfAGraph, graphOfAGraph, labelAGraph
16 , CmmZ, CmmTopZ, CmmGraph, CmmBlock, CmmAGraph
17 , Middle, Last, Convention(..), ForeignConvention(..), MidCallTarget(..), Transfer(..)
18 , emptyStackInfo, stackStubExpr, pprAGraph
22 #include "HsVersions.h"
26 import Cmm ( GenCmm(..), GenCmmTop(..), CmmStatic, CmmInfo
27 , CmmActuals, CmmFormals
29 import CmmCallConv (assignArgumentsPos, ParamLocation(..))
30 import ZipCfgCmmRep hiding (CmmGraph, CmmAGraph, CmmBlock, CmmZ, CmmTopZ)
31 -- to make this module more self-contained, the above definitions are
42 type CmmGraph = LGraph Middle Last
43 type CmmAGraph = AGraph Middle Last
44 type CmmBlock = Block Middle Last
45 type CmmZ = GenCmm CmmStatic CmmInfo CmmGraph
46 type CmmTopZ = GenCmmTop CmmStatic CmmInfo CmmGraph
48 data Transfer = Call | Jump | Ret deriving Eq
52 mkComment :: FastString -> CmmAGraph
54 ---------- Assignment and store
55 mkAssign :: CmmReg -> CmmExpr -> CmmAGraph
56 mkStore :: CmmExpr -> CmmExpr -> CmmAGraph
59 mkCall :: CmmExpr -> Convention -> CmmFormals -> CmmActuals ->
60 UpdFrameOffset -> CmmAGraph
61 mkCmmCall :: CmmExpr -> CmmFormals -> CmmActuals ->
62 UpdFrameOffset -> CmmAGraph
63 -- Native C-- calling convention
64 mkSafeCall :: MidCallTarget -> CmmFormals -> CmmActuals -> UpdFrameOffset -> CmmAGraph
65 mkUnsafeCall :: MidCallTarget -> CmmFormals -> CmmActuals -> CmmAGraph
66 mkFinalCall :: CmmExpr -> CCallConv -> CmmActuals -> UpdFrameOffset -> CmmAGraph
67 -- Never returns; like exit() or barf()
69 ---------- Control transfer
70 mkJump :: CmmExpr -> CmmActuals -> UpdFrameOffset -> CmmAGraph
71 mkJumpGC :: CmmExpr -> CmmActuals -> UpdFrameOffset -> CmmAGraph
72 mkForeignJump :: Convention -> CmmExpr -> CmmActuals -> UpdFrameOffset -> CmmAGraph
73 mkCbranch :: CmmExpr -> BlockId -> BlockId -> CmmAGraph
74 mkSwitch :: CmmExpr -> [Maybe BlockId] -> CmmAGraph
75 mkReturn :: CmmExpr -> CmmActuals -> UpdFrameOffset -> CmmAGraph
76 mkReturnSimple :: CmmActuals -> UpdFrameOffset -> CmmAGraph
78 mkCmmIfThenElse :: CmmExpr -> CmmAGraph -> CmmAGraph -> CmmAGraph
79 mkCmmIfThen :: CmmExpr -> CmmAGraph -> CmmAGraph
80 mkCmmWhileDo :: CmmExpr -> CmmAGraph -> CmmAGraph
82 -- Not to be forgotten, but exported by MkZipCfg:
83 -- mkBranch :: BlockId -> CmmAGraph
84 -- mkLabel :: BlockId -> Maybe Int -> CmmAGraph
85 -- outOfLine :: CmmAGraph -> CmmAGraph
86 -- withUnique :: (Unique -> CmmAGraph) -> CmmAGraph
87 -- withFreshLabel :: String -> (BlockId -> CmmAGraph) -> CmmAGraph
89 --------------------------------------------------------------------------
91 mkCmmWhileDo e = mkWhileDo (mkCbranch e)
92 mkCmmIfThenElse e = mkIfThenElse (mkCbranch e)
95 = withFreshLabel "end of if" $ \endif ->
96 withFreshLabel "start of then" $ \tid ->
97 mkCbranch e tid endif <*>
98 mkLabel tid emptyStackInfo <*> tbranch <*> mkBranch endif <*>
99 mkLabel endif emptyStackInfo
103 -- ================ IMPLEMENTATION ================--
106 mkComment fs = mkMiddle $ MidComment fs
107 mkStore l r = mkMiddle $ MidStore l r
109 -- NEED A COMPILER-DEBUGGING FLAG HERE
110 -- Sanity check: any value assigned to a pointer must be non-zero.
111 -- If it's 0, cause a crash immediately.
112 mkAssign l r = if opt_StubDeadValues then assign l r <*> check l else assign l r
113 where assign l r = mkMiddle (MidAssign l r)
114 check (CmmGlobal _) = mkNop
115 check l@(CmmLocal reg) = -- if a ptr arg is NULL, cause a crash!
116 if isGcPtrType ty then
117 mkCmmIfThen (CmmMachOp (MO_Eq w) [r, stackStubExpr w])
118 (assign l (CmmLoad (CmmLit (CmmInt 0 w)) ty))
120 where ty = localRegType reg
125 -- Why are we inserting extra blocks that simply branch to the successors?
126 -- Because in addition to the branch instruction, @mkBranch@ will insert
127 -- a necessary adjustment to the stack pointer.
128 mkCbranch pred ifso ifnot = mkLast (LastCondBranch pred ifso ifnot)
129 mkSwitch e tbl = mkLast $ LastSwitch e tbl
131 mkSafeCall t fs as upd =
132 withFreshLabel "safe call" $ \k ->
133 mkMiddle $ MidForeignCall (Safe k upd) t fs as
134 mkUnsafeCall t fs as = mkMiddle $ MidForeignCall Unsafe t fs as
136 -- For debugging purposes, we can stub out dead stack slots:
137 stackStubExpr :: Width -> CmmExpr
138 stackStubExpr w = CmmLit (CmmInt 0 w)
140 -- Return the number of bytes used for copying arguments, as well as the
141 -- instructions to copy the arguments.
142 copyIn :: Convention -> Bool -> Area -> CmmFormals -> (Int, AGraph Middle Last)
143 copyIn conv isCall area formals =
144 foldr ci (init_offset, mkNop) $ assignArgumentsPos conv isCall localRegType formals
145 where ci (reg, RegisterParam r) (n, ms) =
146 (n, mkAssign (CmmLocal reg) (CmmReg $ CmmGlobal r) <*> ms)
147 ci (reg, StackParam off) (n, ms) =
148 let ty = localRegType reg
149 off' = off + init_offset
151 mkAssign (CmmLocal reg) (CmmLoad (CmmStackSlot area off') ty) <*> ms)
152 init_offset = widthInBytes wordWidth
154 -- The argument layout function ignores the pointer to the info table, so we slot that
155 -- in here. When copying-out to a young area, we set the info table for return
156 -- and adjust the offsets of the other parameters.
157 -- If this is a call instruction, we adjust the offsets of the other parameters.
158 copyOut :: Convention -> Transfer -> Area -> CmmActuals -> UpdFrameOffset -> (Int, [Middle])
159 copyOut conv transfer area@(CallArea a) actuals updfr_off =
160 foldr co (init_offset, []) args'
161 where args = assignArgumentsPos conv skip_node cmmExprType actuals
162 skip_node = transfer /= Ret
163 (setRA, init_offset) =
164 case a of Young id@(BlockId _) -> -- set RA if making a call
165 if transfer == Call then
166 ([(CmmLit (CmmBlock id), StackParam init_offset)], ra_width)
168 Old -> ([], updfr_off)
169 ra_width = widthInBytes wordWidth
170 args' = foldl adjust setRA args
171 where adjust rst (v, StackParam off) = (v, StackParam (off + init_offset)) : rst
172 adjust rst x@(_, RegisterParam _) = x : rst
173 co (v, RegisterParam r) (n, ms) = (n, MidAssign (CmmGlobal r) v : ms)
174 co (v, StackParam off) (n, ms) =
175 (max n off, MidStore (CmmStackSlot area off) v : ms)
176 copyOut _ _ (RegSlot _) _ _ = panic "cannot copy arguments into a register slot"
178 mkEntry :: BlockId -> Convention -> CmmFormals -> (Int, CmmAGraph)
179 mkEntry _ conv formals = copyIn conv False (CallArea Old) formals
181 lastWithArgs :: Transfer -> Area -> Convention -> CmmActuals -> UpdFrameOffset ->
182 (Int -> Last) -> CmmAGraph
183 lastWithArgs transfer area conv actuals updfr_off last =
184 let (outArgs, copies) = copyOut conv transfer area actuals updfr_off in
185 mkMiddles copies <*> mkLast (last outArgs)
187 -- The area created for the jump and return arguments is the same area as the
191 toCall :: CmmExpr -> Maybe BlockId -> UpdFrameOffset -> Int -> Last
192 toCall e cont updfr_off arg_space = LastCall e cont arg_space (Just updfr_off)
193 mkJump e actuals updfr_off =
194 lastWithArgs Jump old Native actuals updfr_off $ toCall e Nothing updfr_off
195 mkJumpGC e actuals updfr_off =
196 lastWithArgs Jump old GC actuals updfr_off $ toCall e Nothing updfr_off
197 mkForeignJump conv e actuals updfr_off =
198 lastWithArgs Jump old conv actuals updfr_off $ toCall e Nothing updfr_off
199 mkReturn e actuals updfr_off =
200 lastWithArgs Ret old Native actuals updfr_off $ toCall e Nothing updfr_off
201 -- where e = CmmLoad (CmmStackSlot (CallArea Old) updfr_off) gcWord
202 mkReturnSimple actuals updfr_off =
203 lastWithArgs Ret old Native actuals updfr_off $ toCall e Nothing updfr_off
204 where e = CmmLoad (CmmStackSlot (CallArea Old) updfr_off) gcWord
206 mkFinalCall f _ actuals updfr_off =
207 lastWithArgs Call old Native actuals updfr_off $ toCall f Nothing updfr_off
209 mkCmmCall f results actuals = mkCall f Native results actuals
211 -- I'm dropping the SRT, but that should be okay: we plan to reconstruct it later.
212 mkCall f conv results actuals updfr_off =
213 withFreshLabel "call successor" $ \k ->
214 let area = CallArea $ Young k
215 (off, copyin) = copyIn conv False area results
216 copyout = lastWithArgs Call area conv actuals updfr_off
217 (toCall f (Just k) updfr_off)
218 in (copyout <*> mkLabel k (StackInfo (Just off) (Just updfr_off))