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, copyInOflow, copyInSlot, copyOutOflow, copyOutSlot
12 , mkEntry, mkCmmIfThenElse, mkCmmIfThen, mkCmmWhileDo
13 , (<*>), catAGraphs, mkLabel, mkBranch
14 , emptyAGraph, withFreshLabel, withUnique, outOfLine
15 , lgraphOfAGraph, graphOfAGraph, labelAGraph
16 , CmmZ, CmmTopZ, CmmGraph, CmmBlock, CmmAGraph, CmmStackInfo
17 , Middle, Last, Convention(..), ForeignConvention(..), MidCallTarget(..), Transfer(..)
18 , 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
40 import SMRep (ByteOff)
44 type CmmGraph = LGraph Middle Last
45 type CmmAGraph = AGraph Middle Last
46 type CmmBlock = Block Middle Last
47 type CmmStackInfo = (ByteOff, Maybe ByteOff)
48 -- probably want a record; (SP offset on entry, update frame space)
49 type CmmZ = GenCmm CmmStatic CmmInfo (CmmStackInfo, CmmGraph)
50 type CmmTopZ = GenCmmTop CmmStatic CmmInfo (CmmStackInfo, CmmGraph)
52 data Transfer = Call | Jump | Ret deriving Eq
56 mkComment :: FastString -> CmmAGraph
58 ---------- Assignment and store
59 mkAssign :: CmmReg -> CmmExpr -> CmmAGraph
60 mkStore :: CmmExpr -> CmmExpr -> CmmAGraph
63 mkCall :: CmmExpr -> (Convention, Convention) -> CmmFormals -> CmmActuals ->
64 UpdFrameOffset -> CmmAGraph
65 mkCmmCall :: CmmExpr -> CmmFormals -> CmmActuals ->
66 UpdFrameOffset -> CmmAGraph
67 -- Native C-- calling convention
68 mkSafeCall :: MidCallTarget -> CmmFormals -> CmmActuals -> UpdFrameOffset -> CmmAGraph
69 mkUnsafeCall :: MidCallTarget -> CmmFormals -> CmmActuals -> CmmAGraph
70 mkFinalCall :: CmmExpr -> CCallConv -> CmmActuals -> UpdFrameOffset -> CmmAGraph
71 -- Never returns; like exit() or barf()
73 ---------- Control transfer
74 mkJump :: CmmExpr -> CmmActuals -> UpdFrameOffset -> CmmAGraph
75 mkJumpGC :: CmmExpr -> CmmActuals -> UpdFrameOffset -> CmmAGraph
76 mkForeignJump :: Convention -> CmmExpr -> CmmActuals -> UpdFrameOffset -> CmmAGraph
77 mkCbranch :: CmmExpr -> BlockId -> BlockId -> CmmAGraph
78 mkSwitch :: CmmExpr -> [Maybe BlockId] -> CmmAGraph
79 mkReturn :: CmmExpr -> CmmActuals -> UpdFrameOffset -> CmmAGraph
80 mkReturnSimple :: CmmActuals -> UpdFrameOffset -> CmmAGraph
82 mkCmmIfThenElse :: CmmExpr -> CmmAGraph -> CmmAGraph -> CmmAGraph
83 mkCmmIfThen :: CmmExpr -> CmmAGraph -> CmmAGraph
84 mkCmmWhileDo :: CmmExpr -> CmmAGraph -> CmmAGraph
86 -- Not to be forgotten, but exported by MkZipCfg:
87 -- mkBranch :: BlockId -> CmmAGraph
88 -- mkLabel :: BlockId -> Maybe Int -> CmmAGraph
89 -- outOfLine :: CmmAGraph -> CmmAGraph
90 -- withUnique :: (Unique -> CmmAGraph) -> CmmAGraph
91 -- withFreshLabel :: String -> (BlockId -> CmmAGraph) -> CmmAGraph
93 --------------------------------------------------------------------------
95 mkCmmWhileDo e = mkWhileDo (mkCbranch e)
96 mkCmmIfThenElse e = mkIfThenElse (mkCbranch e)
99 = withFreshLabel "end of if" $ \endif ->
100 withFreshLabel "start of then" $ \tid ->
101 mkCbranch e tid endif <*>
102 mkLabel tid <*> tbranch <*> mkBranch endif <*>
107 -- ================ IMPLEMENTATION ================--
110 mkComment fs = mkMiddle $ MidComment fs
111 mkStore l r = mkMiddle $ MidStore l r
113 -- NEED A COMPILER-DEBUGGING FLAG HERE
114 -- Sanity check: any value assigned to a pointer must be non-zero.
115 -- If it's 0, cause a crash immediately.
116 mkAssign l r = if opt_StubDeadValues then assign l r <*> check l else assign l r
117 where assign l r = mkMiddle (MidAssign l r)
118 check (CmmGlobal _) = mkNop
119 check l@(CmmLocal reg) = -- if a ptr arg is NULL, cause a crash!
120 if isGcPtrType ty then
121 mkCmmIfThen (CmmMachOp (MO_Eq w) [r, stackStubExpr w])
122 (assign l (CmmLoad (CmmLit (CmmInt 0 w)) ty))
124 where ty = localRegType reg
129 -- Why are we inserting extra blocks that simply branch to the successors?
130 -- Because in addition to the branch instruction, @mkBranch@ will insert
131 -- a necessary adjustment to the stack pointer.
132 mkCbranch pred ifso ifnot = mkLast (LastCondBranch pred ifso ifnot)
133 mkSwitch e tbl = mkLast $ LastSwitch e tbl
135 mkSafeCall t fs as upd =
136 withFreshLabel "safe call" $ \k ->
137 mkMiddle $ MidForeignCall (Safe k upd) t fs as
138 mkUnsafeCall t fs as = mkMiddle $ MidForeignCall Unsafe t fs as
140 -- For debugging purposes, we can stub out dead stack slots:
141 stackStubExpr :: Width -> CmmExpr
142 stackStubExpr w = CmmLit (CmmInt 0 w)
144 -- When we copy in parameters, we usually want to put overflow
145 -- parameters on the stack, but sometimes we want to pass
146 -- the variables in their spill slots.
147 -- Therefore, for copying arguments and results, we provide different
148 -- functions to pass the arguments in an overflow area and to pass them in spill slots.
149 copyInOflow :: Convention -> Area -> CmmFormals -> (Int, CmmAGraph)
150 copyInSlot :: Convention -> CmmFormals -> CmmAGraph
151 copyOutOflow :: Convention -> Transfer -> Area -> CmmActuals -> UpdFrameOffset ->
153 copyOutSlot :: Convention -> [LocalReg] -> [Middle]
154 -- why a list of middles here instead of an AGraph?
156 copyInOflow = copyIn oneCopyOflowI
157 copyInSlot c f = snd $ copyIn oneCopySlotI c (panic "no area for copying to slots") f
159 type SlotCopier = Area -> (LocalReg, ByteOff) -> (ByteOff, CmmAGraph) ->
161 type CopyIn = SlotCopier -> Convention -> Area -> CmmFormals -> (ByteOff, CmmAGraph)
163 -- Return the number of bytes used for copying arguments, as well as the
164 -- instructions to copy the arguments.
166 copyIn oflow conv area formals =
167 foldr ci (init_offset, mkNop) args'
168 where ci (reg, RegisterParam r) (n, ms) =
169 (n, mkAssign (CmmLocal reg) (CmmReg $ CmmGlobal r) <*> ms)
170 ci (r, StackParam off) (n, ms) = oflow area (r, off) (n, ms)
171 init_offset = widthInBytes wordWidth -- infotable
172 args = assignArgumentsPos conv localRegType formals
173 args' = foldl adjust [] args
174 where adjust rst (v, StackParam off) = (v, StackParam (off + init_offset)) : rst
175 adjust rst x@(_, RegisterParam _) = x : rst
177 -- Copy-in one arg, using overflow space if needed.
178 oneCopyOflowI, oneCopySlotI :: SlotCopier
179 oneCopyOflowI area (reg, off) (n, ms) =
180 (max n off, mkAssign (CmmLocal reg) (CmmLoad (CmmStackSlot area off) ty) <*> ms)
181 where ty = localRegType reg
183 -- Copy-in one arg, using spill slots if needed -- used for calling conventions at
184 -- a procpoint that is not a return point. The offset is irrelevant here...
185 oneCopySlotI _ (reg, _) (n, ms) =
186 (n, mkAssign (CmmLocal reg) (CmmLoad (CmmStackSlot (RegSlot reg) w) ty) <*> ms)
187 where ty = localRegType reg
188 w = widthInBytes (typeWidth ty)
191 -- Factoring out the common parts of the copyout functions yielded something
194 -- The argument layout function ignores the pointer to the info table, so we slot that
195 -- in here. When copying-out to a young area, we set the info table for return
196 -- and adjust the offsets of the other parameters.
197 -- If this is a call instruction, we adjust the offsets of the other parameters.
198 copyOutOflow conv transfer area@(CallArea a) actuals updfr_off =
199 foldr co (init_offset, []) args'
200 where co (v, RegisterParam r) (n, ms) = (n, MidAssign (CmmGlobal r) v : ms)
201 co (v, StackParam off) (n, ms) =
202 (max n off, MidStore (CmmStackSlot area off) v : ms)
203 (setRA, init_offset) =
204 case a of Young id@(BlockId _) -> -- set RA if making a call
205 if transfer == Call then
206 ([(CmmLit (CmmBlock id), StackParam init_offset)],
207 widthInBytes wordWidth)
209 Old -> ([], updfr_off)
210 args = assignArgumentsPos conv cmmExprType actuals
211 args' = foldl adjust setRA args
212 where adjust rst (v, StackParam off) = (v, StackParam (off + init_offset)) : rst
213 adjust rst x@(_, RegisterParam _) = x : rst
214 copyOutOflow _ _ (RegSlot _) _ _ = panic "cannot copy arguments into a register slot"
216 -- Args passed only in registers and stack slots; no overflow space.
217 -- No return address may apply!
218 copyOutSlot conv actuals = foldr co [] args
219 where co (v, RegisterParam r) ms = MidAssign (CmmGlobal r) (toExp v) : ms
220 co (v, StackParam off) ms =
221 MidStore (CmmStackSlot (RegSlot v) off) (toExp v) : ms
222 toExp r = CmmReg (CmmLocal r)
223 args = assignArgumentsPos conv localRegType actuals
225 -- oneCopySlotO _ (reg, _) (n, ms) =
226 -- (n, MidStore (CmmStackSlot (RegSlot reg) w) reg : ms)
227 -- where w = widthInBytes (typeWidth (localRegType reg))
229 mkEntry :: BlockId -> Convention -> CmmFormals -> (Int, CmmAGraph)
230 mkEntry _ conv formals = copyInOflow conv (CallArea Old) formals
232 lastWithArgs :: Transfer -> Area -> Convention -> CmmActuals -> UpdFrameOffset ->
233 (ByteOff -> Last) -> CmmAGraph
234 lastWithArgs transfer area conv actuals updfr_off last =
235 let (outArgs, copies) = copyOutOflow conv transfer area actuals updfr_off in
236 mkMiddles copies <*> mkLast (last outArgs)
238 -- The area created for the jump and return arguments is the same area as the
242 toCall :: CmmExpr -> Maybe BlockId -> UpdFrameOffset -> ByteOff -> ByteOff -> Last
243 toCall e cont updfr_off res_space arg_space =
244 LastCall e cont arg_space res_space (Just updfr_off)
245 mkJump e actuals updfr_off =
246 lastWithArgs Jump old NativeNodeCall actuals updfr_off $ toCall e Nothing updfr_off 0
247 mkJumpGC e actuals updfr_off =
248 lastWithArgs Jump old GC actuals updfr_off $ toCall e Nothing updfr_off 0
249 mkForeignJump conv e actuals updfr_off =
250 lastWithArgs Jump old conv actuals updfr_off $ toCall e Nothing updfr_off 0
251 mkReturn e actuals updfr_off =
252 lastWithArgs Ret old NativeReturn actuals updfr_off $ toCall e Nothing updfr_off 0
253 -- where e = CmmLoad (CmmStackSlot (CallArea Old) updfr_off) gcWord
254 mkReturnSimple actuals updfr_off =
255 lastWithArgs Ret old NativeReturn actuals updfr_off $ toCall e Nothing updfr_off 0
256 where e = CmmLoad (CmmStackSlot (CallArea Old) updfr_off) gcWord
258 mkFinalCall f _ actuals updfr_off =
259 lastWithArgs Call old NativeDirectCall actuals updfr_off $ toCall f Nothing updfr_off 0
261 mkCmmCall f results actuals = mkCall f (NativeDirectCall, NativeReturn) results actuals
263 -- I'm dropping the SRT, but that should be okay: we plan to reconstruct it later.
264 mkCall f (callConv, retConv) results actuals updfr_off =
265 withFreshLabel "call successor" $ \k ->
266 let area = CallArea $ Young k
267 (off, copyin) = copyInOflow retConv area results
268 copyout = lastWithArgs Call area callConv actuals updfr_off
269 (toCall f (Just k) updfr_off off)
270 in (copyout <*> mkLabel k <*> copyin)