2 % (c) The AQUA Project, Glasgow University, 1993-1996
7 gmpTake1Return1, gmpTake2Return1, gmpTake2Return2, gmpCompare,
8 gmpInteger2Int, gmpInteger2Word,
9 gmpInt2Integer, gmpString2Integer,
10 encodeFloatingKind, decodeFloatingKind
13 #include "HsVersions.h"
15 import {-# SOURCE #-} StixPrim ( amodeToStix )
19 import AbsCSyn -- bits and bobs...
20 import Constants ( mIN_MP_INT_SIZE )
21 import Literal ( Literal(..) )
22 import OrdList ( OrdList )
23 import PrimOp ( PrimOp(..) )
24 import PrimRep ( PrimRep(..) )
25 import SMRep ( SMRep(..), SMSpecRepKind, SMUpdateKind )
26 import Stix ( getUniqLabelNCG, sStLitLbl, stgHp, stgHpLim,
27 StixTree(..), StixTreeList,
30 import StixMacro ( macroCode, heapCheck )
31 import UniqSupply ( returnUs, thenUs, UniqSM )
37 :: (CAddrMode,CAddrMode,CAddrMode) -- result (3 parts)
38 -> FAST_STRING -- function name
39 -> (CAddrMode, CAddrMode,CAddrMode,CAddrMode)
41 -> UniqSM StixTreeList
43 argument1 = mpStruct 1 -- out here to avoid CAF (sigh)
44 argument2 = mpStruct 2
48 init2 = StCall SLIT("mpz_init") VoidRep [result2]
49 init3 = StCall SLIT("mpz_init") VoidRep [result3]
50 init4 = StCall SLIT("mpz_init") VoidRep [result4]
52 gmpTake1Return1 res@(car,csr,cdr) rtn arg@(clive,caa,csa,cda)
57 liveness= amodeToStix clive
62 space = mpSpace 2 1 [sa]
63 oldHp = StIndex PtrRep stgHp (StPrim IntNegOp [space])
65 save = StAssign PtrRep safeHp oldHp
66 (a1,a2,a3) = toStruct argument1 (aa,sa,da)
67 mpz_op = StCall rtn VoidRep [result2, argument1]
68 restore = StAssign PtrRep stgHp safeHp
69 (r1,r2,r3) = fromStruct result2 (ar,sr,dr)
71 heapCheck liveness space (StInt 0) `thenUs` \ heap_chk ->
74 (\xs -> a1 : a2 : a3 : save : init2 : mpz_op : r1 : r2 : r3 : restore : xs))
77 :: (CAddrMode,CAddrMode,CAddrMode) -- result (3 parts)
78 -> FAST_STRING -- function name
79 -> (CAddrMode,CAddrMode,CAddrMode,CAddrMode,CAddrMode,CAddrMode,CAddrMode)
80 -- liveness + 2 arguments (3 parts each)
81 -> UniqSM StixTreeList
83 gmpTake2Return1 res@(car,csr,cdr) rtn args@(clive, caa1,csa1,cda1, caa2,csa2,cda2)
88 liveness= amodeToStix clive
89 aa1 = amodeToStix caa1
90 sa1 = amodeToStix csa1
91 da1 = amodeToStix cda1
92 aa2 = amodeToStix caa2
93 sa2 = amodeToStix csa2
94 da2 = amodeToStix cda2
96 space = mpSpace 3 1 [sa1, sa2]
97 oldHp = StIndex PtrRep stgHp (StPrim IntNegOp [space])
99 save = StAssign PtrRep safeHp oldHp
100 (a1,a2,a3) = toStruct argument1 (aa1,sa1,da1)
101 (a4,a5,a6) = toStruct argument2 (aa2,sa2,da2)
102 mpz_op = StCall rtn VoidRep [result3, argument1, argument2]
103 restore = StAssign PtrRep stgHp safeHp
104 (r1,r2,r3) = fromStruct result3 (ar,sr,dr)
106 heapCheck liveness space (StInt 0) `thenUs` \ heap_chk ->
109 (\xs -> a1 : a2 : a3 : a4 : a5 : a6
110 : save : init3 : mpz_op : r1 : r2 : r3 : restore : xs))
113 :: (CAddrMode,CAddrMode,CAddrMode,CAddrMode,CAddrMode,CAddrMode)
114 -- 2 results (3 parts each)
115 -> FAST_STRING -- function name
116 -> (CAddrMode,CAddrMode,CAddrMode,CAddrMode,CAddrMode,CAddrMode,CAddrMode)
117 -- liveness + 2 arguments (3 parts each)
118 -> UniqSM StixTreeList
120 gmpTake2Return2 res@(car1,csr1,cdr1, car2,csr2,cdr2)
121 rtn args@(clive, caa1,csa1,cda1, caa2,csa2,cda2)
123 ar1 = amodeToStix car1
124 sr1 = amodeToStix csr1
125 dr1 = amodeToStix cdr1
126 ar2 = amodeToStix car2
127 sr2 = amodeToStix csr2
128 dr2 = amodeToStix cdr2
129 liveness= amodeToStix clive
130 aa1 = amodeToStix caa1
131 sa1 = amodeToStix csa1
132 da1 = amodeToStix cda1
133 aa2 = amodeToStix caa2
134 sa2 = amodeToStix csa2
135 da2 = amodeToStix cda2
137 space = StPrim IntMulOp [mpSpace 2 1 [sa1, sa2], StInt 2]
138 oldHp = StIndex PtrRep stgHp (StPrim IntNegOp [space])
140 save = StAssign PtrRep safeHp oldHp
141 (a1,a2,a3) = toStruct argument1 (aa1,sa1,da1)
142 (a4,a5,a6) = toStruct argument2 (aa2,sa2,da2)
143 mpz_op = StCall rtn VoidRep [result3, result4, argument1, argument2]
144 restore = StAssign PtrRep stgHp safeHp
145 (r1,r2,r3) = fromStruct result3 (ar1,sr1,dr1)
146 (r4,r5,r6) = fromStruct result4 (ar2,sr2,dr2)
149 heapCheck liveness space (StInt 0) `thenUs` \ heap_chk ->
152 (\xs -> a1 : a2 : a3 : a4 : a5 : a6
153 : save : init3 : init4 : mpz_op
154 : r1 : r2 : r3 : r4 : r5 : r6 : restore : xs))
157 Although gmpCompare doesn't allocate space, it does temporarily use
158 some space just beyond the heap pointer. This is safe, because the
159 enclosing routine has already guaranteed that this space will be
160 available. (See ``primOpHeapRequired.'')
164 :: CAddrMode -- result (boolean)
165 -> (CAddrMode,CAddrMode,CAddrMode,CAddrMode,CAddrMode,CAddrMode,CAddrMode)
166 -- alloc hp + 2 arguments (3 parts each)
167 -> UniqSM StixTreeList
169 gmpCompare res args@(chp, caa1,csa1,cda1, caa2,csa2,cda2)
171 result = amodeToStix res
173 aa1 = amodeToStix caa1
174 sa1 = amodeToStix csa1
175 da1 = amodeToStix cda1
176 aa2 = amodeToStix caa2
177 sa2 = amodeToStix csa2
178 da2 = amodeToStix cda2
181 argument2 = StIndex IntRep hp (StInt (toInteger mpIntSize))
182 (a1,a2,a3) = toStruct argument1 (aa1,sa1,da1)
183 (a4,a5,a6) = toStruct argument2 (aa2,sa2,da2)
184 mpz_cmp = StCall SLIT("mpz_cmp") IntRep [argument1, argument2]
185 r1 = StAssign IntRep result mpz_cmp
187 returnUs (\xs -> a1 : a2 : a3 : a4 : a5 : a6 : r1 : xs)
190 See the comment above regarding the heap check (or lack thereof).
194 :: CAddrMode -- result
195 -> (CAddrMode, CAddrMode,CAddrMode,CAddrMode) -- alloc hp + argument (3 parts)
196 -> UniqSM StixTreeList
198 gmpInteger2Int res args@(chp, caa,csa,cda)
200 result = amodeToStix res
206 (a1,a2,a3) = toStruct hp (aa,sa,da)
207 mpz_get_si = StCall SLIT("mpz_get_si") IntRep [hp]
208 r1 = StAssign IntRep result mpz_get_si
210 returnUs (\xs -> a1 : a2 : a3 : r1 : xs)
213 :: CAddrMode -- result
214 -> (CAddrMode, CAddrMode,CAddrMode,CAddrMode) -- alloc hp + argument (3 parts)
215 -> UniqSM StixTreeList
217 gmpInteger2Word res args@(chp, caa,csa,cda)
219 result = amodeToStix res
225 (a1,a2,a3) = toStruct hp (aa,sa,da)
226 mpz_get_ui = StCall SLIT("mpz_get_ui") IntRep [hp]
227 r1 = StAssign WordRep result mpz_get_ui
229 returnUs (\xs -> a1 : a2 : a3 : r1 : xs)
231 arrayOfData_info = sStLitLbl SLIT("ArrayOfData_info")
235 :: (CAddrMode, CAddrMode, CAddrMode) -- result (3 parts)
236 -> (CAddrMode, CAddrMode) -- allocated heap, Int to convert
237 -> UniqSM StixTreeList
239 gmpInt2Integer res@(car,csr,cdr) args@(chp, n)
240 = getUniqLabelNCG `thenUs` \ zlbl ->
241 getUniqLabelNCG `thenUs` \ nlbl ->
242 getUniqLabelNCG `thenUs` \ jlbl ->
250 h1 = StAssign PtrRep (StInd PtrRep hp) arrayOfData_info
251 size = varHdrSizeInWords (DataRep 0) + mIN_MP_INT_SIZE
252 h2 = StAssign IntRep (StInd IntRep (StIndex IntRep hp (StInt 1)))
253 (StInt (toInteger size))
254 cts = StInd IntRep (StIndex IntRep hp dataHS)
255 test1 = StPrim IntEqOp [i, StInt 0]
256 test2 = StPrim IntLtOp [i, StInt 0]
257 cjmp1 = StCondJump zlbl test1
258 cjmp2 = StCondJump nlbl test2
260 p1 = StAssign IntRep cts i
261 p2 = StAssign IntRep sr (StInt 1)
262 p3 = StJump (StCLbl jlbl)
265 n1 = StAssign IntRep cts (StPrim IntNegOp [i])
266 n2 = StAssign IntRep sr (StInt (-1))
267 n3 = StJump (StCLbl jlbl)
270 z1 = StAssign IntRep sr (StInt 0)
273 a1 = StAssign IntRep ar (StInt 1)
274 a2 = StAssign PtrRep dr hp
278 CLit (MachInt c _) ->
279 if c == 0 then h1 : h2 : z1 : a1 : a2 : xs
280 else if c > 0 then h1 : h2 : p1 : p2 : a1 : a2 : xs
281 else h1 : h2 : n1 : n2 : a1 : a2 : xs
282 _ -> h1 : h2 : cjmp1 : cjmp2 : p1 : p2 : p3
283 : n0 : n1 : n2 : n3 : z0 : z1
287 :: (CAddrMode, CAddrMode, CAddrMode) -- result (3 parts)
288 -> (CAddrMode, CAddrMode) -- liveness, string
289 -> UniqSM StixTreeList
291 gmpString2Integer res@(car,csr,cdr) (liveness, str)
292 = getUniqLabelNCG `thenUs` \ ulbl ->
299 (CString s) -> _LENGTH_ s
300 (CLit (MachStr s)) -> _LENGTH_ s
301 _ -> panic "String2Integer"
302 space = len `quot` 8 + 17 + mpIntSize +
303 varHdrSizeInWords (DataRep 0) + fixedHdrSizeInWords
304 oldHp = StIndex PtrRep stgHp (StInt (toInteger (-space)))
306 save = StAssign PtrRep safeHp oldHp
307 result = StIndex IntRep stgHpLim (StInt (toInteger (-mpIntSize)))
308 set_str = StCall SLIT("mpz_init_set_str") IntRep
309 [result, amodeToStix str, StInt 10]
310 test = StPrim IntEqOp [set_str, StInt 0]
311 cjmp = StCondJump ulbl test
312 abort = StCall SLIT("abort") VoidRep []
314 restore = StAssign PtrRep stgHp safeHp
315 (a1,a2,a3) = fromStruct result (ar,sr,dr)
317 macroCode HEAP_CHK [liveness, mkIntCLit space, mkIntCLit_0]
318 `thenUs` \ heap_chk ->
321 (\xs -> save : cjmp : abort : join : a1 : a2 : a3 : restore : xs))
323 mkIntCLit_0 = mkIntCLit 0 -- out here to avoid CAF (sigh)
327 -> CAddrMode -- result
328 -> (CAddrMode,CAddrMode,CAddrMode,CAddrMode,CAddrMode)
329 -- heap pointer for result, integer argument (3 parts), exponent
330 -> UniqSM StixTreeList
332 encodeFloatingKind pk res args@(chp, caa,csa,cda, cexpon)
334 result = amodeToStix res
339 expon = amodeToStix cexpon
341 pk' = if sizeOf FloatRep == sizeOf DoubleRep
344 (a1,a2,a3) = toStruct hp (aa,sa,da)
346 FloatRep -> SLIT("__encodeFloat")
347 DoubleRep -> SLIT("__encodeDouble")
348 _ -> panic "encodeFloatingKind"
349 encode = StCall fn pk' [hp, expon]
350 r1 = StAssign pk' result encode
352 returnUs (\xs -> a1 : a2 : a3 : r1 : xs)
356 -> (CAddrMode, CAddrMode, CAddrMode, CAddrMode)
357 -- exponent result, integer result (3 parts)
358 -> (CAddrMode, CAddrMode)
359 -- heap pointer for exponent, floating argument
360 -> UniqSM StixTreeList
362 decodeFloatingKind pk res@(cexponr,car,csr,cdr) args@(chp, carg)
364 exponr = amodeToStix cexponr
369 arg = amodeToStix carg
371 pk' = if sizeOf FloatRep == sizeOf DoubleRep
374 setup = StAssign PtrRep mpData_mantissa (StIndex IntRep hp (StInt 1))
376 FloatRep -> SLIT("__decodeFloat")
377 DoubleRep -> SLIT("__decodeDouble")
378 _ -> panic "decodeFloatingKind"
379 decode = StCall fn VoidRep [mantissa, hp, arg]
380 (a1,a2,a3) = fromStruct mantissa (ar,sr,dr)
381 a4 = StAssign IntRep exponr (StInd IntRep hp)
383 returnUs (\xs -> setup : decode : a1 : a2 : a3 : a4 : xs)
385 mantissa = mpStruct 1 -- out here to avoid CAF (sigh)
386 mpData_mantissa = mpData mantissa
389 Support for the Gnu GMP multi-precision package.
392 -- size (in words) of __MP_INT
395 mpAlloc, mpSize, mpData :: StixTree -> StixTree
396 mpAlloc base = StInd IntRep base
397 mpSize base = StInd IntRep (StIndex IntRep base (StInt 1))
398 mpData base = StInd PtrRep (StIndex IntRep base (StInt 2))
401 :: Int -- gmp structures needed
402 -> Int -- number of results
403 -> [StixTree] -- sizes to add for estimating result size
404 -> StixTree -- total space
406 mpSpace gmp res sizes
407 = foldr sum (StPrim IntAddOp [fixed, hdrs]) sizes
409 sum x y = StPrim IntAddOp [StPrim IntAbsOp [x], y]
410 -- what's the magical 17 for?
411 fixed = StInt (toInteger (17 * res + gmp * mpIntSize))
412 hdrs = StPrim IntMulOp [dataHS, StInt (toInteger res)]
415 We don't have a truly portable way of allocating local temporaries, so
416 we cheat and use space at the end of the heap. (Thus, negative
417 offsets from HpLim are our temporaries.) Note that you must have
418 performed a heap check which includes the space needed for these
419 temporaries before you use them.
422 mpStruct :: Int -> StixTree
423 mpStruct n = StIndex IntRep stgHpLim (StInt (toInteger (-(n * mpIntSize))))
427 -> (StixTree, StixTree, StixTree)
428 -> (StixTree, StixTree, StixTree)
430 toStruct str (alloc,size,arr)
432 f1 = StAssign IntRep (mpAlloc str) alloc
433 f2 = StAssign IntRep (mpSize str) size
434 f3 = StAssign PtrRep (mpData str) (StIndex PtrRep arr dataHS)
440 -> (StixTree, StixTree, StixTree)
441 -> (StixTree, StixTree, StixTree)
443 fromStruct str (alloc,size,arr)
445 e1 = StAssign IntRep alloc (mpAlloc str)
446 e2 = StAssign IntRep size (mpSize str)
447 e3 = StAssign PtrRep arr (StIndex PtrRep (mpData str)
448 (StPrim IntNegOp [dataHS]))