2 % (c) The AQUA Project, Glasgow University, 1993-1995
6 #include "HsVersions.h"
9 gmpTake1Return1, gmpTake2Return1, gmpTake2Return2,
10 gmpCompare, gmpInteger2Int, gmpInt2Integer, gmpString2Integer,
11 encodeFloatingKind, decodeFloatingKind
14 IMPORT_Trace -- ToDo: rm debugging
17 import CgCompInfo ( mIN_MP_INT_SIZE )
20 import PrelInfo ( PrimOp(..)
21 IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
22 IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
24 import SMRep ( SMRep(..), SMSpecRepKind, SMUpdateKind(..) )
35 -> (CAddrMode,CAddrMode,CAddrMode) -- result (3 parts)
36 -> FAST_STRING -- function name
37 -> (CAddrMode, CAddrMode,CAddrMode,CAddrMode)
39 -> UniqSM StixTreeList
41 argument1 = mpStruct 1 -- out here to avoid CAF (sigh)
42 argument2 = mpStruct 2
46 init2 = StCall SLIT("mpz_init") VoidRep [result2]
47 init3 = StCall SLIT("mpz_init") VoidRep [result3]
48 init4 = StCall SLIT("mpz_init") VoidRep [result4]
50 -- hacking with Uncle Will:
51 #define target_STRICT target@(Target _ _ _ _ _ _ _ _)
53 gmpTake1Return1 target_STRICT res@(car,csr,cdr) rtn arg@(clive,caa,csa,cda) =
55 a2stix = amodeToStix target
56 data_hs = dataHS target
61 liveness= a2stix clive
66 space = mpSpace data_hs 2 1 [sa]
67 oldHp = StIndex PtrRep stgHp (StPrim IntNegOp [space])
68 safeHp = saveLoc target Hp
69 save = StAssign PtrRep safeHp oldHp
70 (a1,a2,a3) = toStruct data_hs argument1 (aa,sa,da)
71 mpz_op = StCall rtn VoidRep [result2, argument1]
72 restore = StAssign PtrRep stgHp safeHp
73 (r1,r2,r3) = fromStruct data_hs result2 (ar,sr,dr)
75 heapCheck target liveness space (StInt 0) `thenUs` \ heap_chk ->
78 (\xs -> a1 : a2 : a3 : save : init2 : mpz_op : r1 : r2 : r3 : restore : xs))
82 -> (CAddrMode,CAddrMode,CAddrMode) -- result (3 parts)
83 -> FAST_STRING -- function name
84 -> (CAddrMode,CAddrMode,CAddrMode,CAddrMode,CAddrMode,CAddrMode,CAddrMode)
85 -- liveness + 2 arguments (3 parts each)
86 -> UniqSM StixTreeList
88 gmpTake2Return1 target_STRICT res@(car,csr,cdr) rtn args@(clive, caa1,csa1,cda1, caa2,csa2,cda2) =
90 a2stix = amodeToStix target
91 data_hs = dataHS target
96 liveness= a2stix clive
104 space = mpSpace data_hs 3 1 [sa1, sa2]
105 oldHp = StIndex PtrRep stgHp (StPrim IntNegOp [space])
106 safeHp = saveLoc target Hp
107 save = StAssign PtrRep safeHp oldHp
108 (a1,a2,a3) = toStruct data_hs argument1 (aa1,sa1,da1)
109 (a4,a5,a6) = toStruct data_hs argument2 (aa2,sa2,da2)
110 mpz_op = StCall rtn VoidRep [result3, argument1, argument2]
111 restore = StAssign PtrRep stgHp safeHp
112 (r1,r2,r3) = fromStruct data_hs result3 (ar,sr,dr)
114 heapCheck target liveness space (StInt 0) `thenUs` \ heap_chk ->
117 (\xs -> a1 : a2 : a3 : a4 : a5 : a6
118 : save : init3 : mpz_op : r1 : r2 : r3 : restore : xs))
122 -> (CAddrMode,CAddrMode,CAddrMode,CAddrMode,CAddrMode,CAddrMode)
123 -- 2 results (3 parts each)
124 -> FAST_STRING -- function name
125 -> (CAddrMode,CAddrMode,CAddrMode,CAddrMode,CAddrMode,CAddrMode,CAddrMode)
126 -- liveness + 2 arguments (3 parts each)
127 -> UniqSM StixTreeList
129 gmpTake2Return2 target_STRICT res@(car1,csr1,cdr1, car2,csr2,cdr2)
130 rtn args@(clive, caa1,csa1,cda1, caa2,csa2,cda2) =
132 a2stix = amodeToStix target
133 data_hs = dataHS target
141 liveness= a2stix clive
149 space = StPrim IntMulOp [mpSpace data_hs 2 1 [sa1, sa2], StInt 2]
150 oldHp = StIndex PtrRep stgHp (StPrim IntNegOp [space])
151 safeHp = saveLoc target Hp
152 save = StAssign PtrRep safeHp oldHp
153 (a1,a2,a3) = toStruct data_hs argument1 (aa1,sa1,da1)
154 (a4,a5,a6) = toStruct data_hs argument2 (aa2,sa2,da2)
155 mpz_op = StCall rtn VoidRep [result3, result4, argument1, argument2]
156 restore = StAssign PtrRep stgHp safeHp
157 (r1,r2,r3) = fromStruct data_hs result3 (ar1,sr1,dr1)
158 (r4,r5,r6) = fromStruct data_hs result4 (ar2,sr2,dr2)
161 heapCheck target liveness space (StInt 0) `thenUs` \ heap_chk ->
164 (\xs -> a1 : a2 : a3 : a4 : a5 : a6
165 : save : init3 : init4 : mpz_op
166 : r1 : r2 : r3 : r4 : r5 : r6 : restore : xs))
170 Although gmpCompare doesn't allocate space, it does temporarily use
171 some space just beyond the heap pointer. This is safe, because the
172 enclosing routine has already guaranteed that this space will be
173 available. (See ``primOpHeapRequired.'')
179 -> CAddrMode -- result (boolean)
180 -> (CAddrMode,CAddrMode,CAddrMode,CAddrMode,CAddrMode,CAddrMode,CAddrMode)
181 -- alloc hp + 2 arguments (3 parts each)
182 -> UniqSM StixTreeList
184 gmpCompare target_STRICT res args@(chp, caa1,csa1,cda1, caa2,csa2,cda2) =
186 a2stix = amodeToStix target
187 data_hs = dataHS target
199 argument2 = StIndex IntRep hp (StInt (toInteger mpIntSize))
200 (a1,a2,a3) = toStruct data_hs argument1 (aa1,sa1,da1)
201 (a4,a5,a6) = toStruct data_hs argument2 (aa2,sa2,da2)
202 mpz_cmp = StCall SLIT("mpz_cmp") IntRep [argument1, argument2]
203 r1 = StAssign IntRep result mpz_cmp
205 returnUs (\xs -> a1 : a2 : a3 : a4 : a5 : a6 : r1 : xs)
209 See the comment above regarding the heap check (or lack thereof).
215 -> CAddrMode -- result
216 -> (CAddrMode, CAddrMode,CAddrMode,CAddrMode) -- alloc hp + argument (3 parts)
217 -> UniqSM StixTreeList
219 gmpInteger2Int target_STRICT res args@(chp, caa,csa,cda) =
221 a2stix = amodeToStix target
222 data_hs = dataHS target
230 (a1,a2,a3) = toStruct data_hs hp (aa,sa,da)
231 mpz_get_si = StCall SLIT("mpz_get_si") IntRep [hp]
232 r1 = StAssign IntRep result mpz_get_si
234 returnUs (\xs -> a1 : a2 : a3 : r1 : xs)
236 arrayOfData_info = sStLitLbl SLIT("ArrayOfData_info")
240 -> (CAddrMode, CAddrMode, CAddrMode) -- result (3 parts)
241 -> (CAddrMode, CAddrMode) -- allocated heap, Int to convert
242 -> UniqSM StixTreeList
244 gmpInt2Integer target_STRICT res@(car,csr,cdr) args@(chp, n) =
245 getUniqLabelNCG `thenUs` \ zlbl ->
246 getUniqLabelNCG `thenUs` \ nlbl ->
247 getUniqLabelNCG `thenUs` \ jlbl ->
249 a2stix = amodeToStix target
257 h1 = StAssign PtrRep (StInd PtrRep hp) arrayOfData_info
258 size = varHeaderSize target (DataRep 0) + mIN_MP_INT_SIZE
259 h2 = StAssign IntRep (StInd IntRep (StIndex IntRep hp (StInt 1)))
260 (StInt (toInteger size))
261 cts = StInd IntRep (StIndex IntRep hp (dataHS target))
262 test1 = StPrim IntEqOp [i, StInt 0]
263 test2 = StPrim IntLtOp [i, StInt 0]
264 cjmp1 = StCondJump zlbl test1
265 cjmp2 = StCondJump nlbl test2
267 p1 = StAssign IntRep cts i
268 p2 = StAssign IntRep sr (StInt 1)
269 p3 = StJump (StCLbl jlbl)
272 n1 = StAssign IntRep cts (StPrim IntNegOp [i])
273 n2 = StAssign IntRep sr (StInt (-1))
274 n3 = StJump (StCLbl jlbl)
277 z1 = StAssign IntRep sr (StInt 0)
280 a1 = StAssign IntRep ar (StInt 1)
281 a2 = StAssign PtrRep dr hp
285 CLit (MachInt c _) ->
286 if c == 0 then h1 : h2 : z1 : a1 : a2 : xs
287 else if c > 0 then h1 : h2 : p1 : p2 : a1 : a2 : xs
288 else h1 : h2 : n1 : n2 : a1 : a2 : xs
289 _ -> h1 : h2 : cjmp1 : cjmp2 : p1 : p2 : p3
290 : n0 : n1 : n2 : n3 : z0 : z1
295 -> (CAddrMode, CAddrMode, CAddrMode) -- result (3 parts)
296 -> (CAddrMode, CAddrMode) -- liveness, string
297 -> UniqSM StixTreeList
299 gmpString2Integer target_STRICT res@(car,csr,cdr) (liveness, str) =
300 getUniqLabelNCG `thenUs` \ ulbl ->
302 a2stix = amodeToStix target
303 data_hs = dataHS target
310 (CString s) -> _LENGTH_ s
311 (CLit (MachStr s)) -> _LENGTH_ s
312 _ -> panic "String2Integer"
313 space = len `quot` 8 + 17 + mpIntSize +
314 varHeaderSize target (DataRep 0) + fixedHeaderSize target
315 oldHp = StIndex PtrRep stgHp (StInt (toInteger (-space)))
316 safeHp = saveLoc target Hp
317 save = StAssign PtrRep safeHp oldHp
318 result = StIndex IntRep stgHpLim (StInt (toInteger (-mpIntSize)))
319 set_str = StCall SLIT("mpz_init_set_str") IntRep
320 [result, a2stix str, StInt 10]
321 test = StPrim IntEqOp [set_str, StInt 0]
322 cjmp = StCondJump ulbl test
323 abort = StCall SLIT("abort") VoidRep []
325 restore = StAssign PtrRep stgHp safeHp
326 (a1,a2,a3) = fromStruct data_hs result (ar,sr,dr)
328 macroCode target HEAP_CHK [liveness, mkIntCLit space, mkIntCLit_0]
329 `thenUs` \ heap_chk ->
332 (\xs -> save : cjmp : abort : join : a1 : a2 : a3 : restore : xs))
334 mkIntCLit_0 = mkIntCLit 0 -- out here to avoid CAF (sigh)
339 -> CAddrMode -- result
340 -> (CAddrMode,CAddrMode,CAddrMode,CAddrMode,CAddrMode)
341 -- heap pointer for result, integer argument (3 parts), exponent
342 -> UniqSM StixTreeList
344 encodeFloatingKind pk target_STRICT res args@(chp, caa,csa,cda, cexpon) =
346 a2stix = amodeToStix target
347 size_of = sizeof target
348 data_hs = dataHS target
355 expon = a2stix cexpon
357 pk' = if size_of FloatRep == size_of DoubleRep
360 (a1,a2,a3) = toStruct data_hs hp (aa,sa,da)
362 FloatRep -> SLIT("__encodeFloat")
363 DoubleRep -> SLIT("__encodeDouble")
364 _ -> panic "encodeFloatingKind"
365 encode = StCall fn pk' [hp, expon]
366 r1 = StAssign pk' result encode
368 returnUs (\xs -> a1 : a2 : a3 : r1 : xs)
373 -> (CAddrMode, CAddrMode, CAddrMode, CAddrMode)
374 -- exponent result, integer result (3 parts)
375 -> (CAddrMode, CAddrMode)
376 -- heap pointer for exponent, floating argument
377 -> UniqSM StixTreeList
379 decodeFloatingKind pk target_STRICT res@(cexponr,car,csr,cdr) args@(chp, carg) =
381 a2stix = amodeToStix target
382 size_of = sizeof target
383 data_hs = dataHS target
385 exponr = a2stix cexponr
392 pk' = if size_of FloatRep == size_of DoubleRep
395 setup = StAssign PtrRep mpData_mantissa (StIndex IntRep hp (StInt 1))
397 FloatRep -> SLIT("__decodeFloat")
398 DoubleRep -> SLIT("__decodeDouble")
399 _ -> panic "decodeFloatingKind"
400 decode = StCall fn VoidRep [mantissa, hp, arg]
401 (a1,a2,a3) = fromStruct data_hs mantissa (ar,sr,dr)
402 a4 = StAssign IntRep exponr (StInd IntRep hp)
404 returnUs (\xs -> setup : decode : a1 : a2 : a3 : a4 : xs)
406 mantissa = mpStruct 1 -- out here to avoid CAF (sigh)
407 mpData_mantissa = mpData mantissa
410 Support for the Gnu GMP multi-precision package.
416 mpAlloc, mpSize, mpData :: StixTree -> StixTree
417 mpAlloc base = StInd IntRep base
418 mpSize base = StInd IntRep (StIndex IntRep base (StInt 1))
419 mpData base = StInd PtrRep (StIndex IntRep base (StInt 2))
422 :: StixTree -- dataHs from Target
423 -> Int -- gmp structures needed
424 -> Int -- number of results
425 -> [StixTree] -- sizes to add for estimating result size
426 -> StixTree -- total space
428 mpSpace data_hs gmp res sizes =
429 foldr sum (StPrim IntAddOp [fixed, hdrs]) sizes
431 sum x y = StPrim IntAddOp [StPrim IntAbsOp [x], y]
432 fixed = StInt (toInteger (17 * res + gmp * mpIntSize))
433 hdrs = StPrim IntMulOp [data_hs, StInt (toInteger res)]
437 We don't have a truly portable way of allocating local temporaries, so we
438 cheat and use space at the end of the heap. (Thus, negative offsets from
439 HpLim are our temporaries.) Note that you must have performed a heap check
440 which includes the space needed for these temporaries before you use them.
443 mpStruct :: Int -> StixTree
444 mpStruct n = StIndex IntRep stgHpLim (StInt (toInteger (-(n * mpIntSize))))
447 :: StixTree -- dataHS, from Target
449 -> (StixTree, StixTree, StixTree)
450 -> (StixTree, StixTree, StixTree)
452 toStruct data_hs str (alloc,size,arr) =
454 f1 = StAssign IntRep (mpAlloc str) alloc
455 f2 = StAssign IntRep (mpSize str) size
456 f3 = StAssign PtrRep (mpData str) (StIndex PtrRep arr data_hs)
461 :: StixTree -- dataHS, from Target
463 -> (StixTree, StixTree, StixTree)
464 -> (StixTree, StixTree, StixTree)
466 fromStruct data_hs str (alloc,size,arr) =
468 e1 = StAssign IntRep alloc (mpAlloc str)
469 e2 = StAssign IntRep size (mpSize str)
470 e3 = StAssign PtrRep arr (StIndex PtrRep (mpData str)
471 (StPrim IntNegOp [data_hs]))