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