2 % (c) The AQUA Project, Glasgow University, 1993-1996
6 #include "HsVersions.h"
9 gmpTake1Return1, gmpTake2Return1, gmpTake2Return2, gmpCompare,
10 gmpInteger2Int, gmpInt2Integer, gmpString2Integer,
11 encodeFloatingKind, decodeFloatingKind
15 IMPORT_DELOOPER(NcgLoop) ( amodeToStix )
20 import AbsCSyn -- bits and bobs...
21 import CgCompInfo ( mIN_MP_INT_SIZE )
22 import Literal ( Literal(..) )
23 import OrdList ( OrdList )
24 import PrimOp ( PrimOp(..) )
25 import PrimRep ( PrimRep(..) )
26 import SMRep ( SMRep(..), SMSpecRepKind, SMUpdateKind )
27 import Stix ( getUniqLabelNCG, sStLitLbl, stgHp, stgHpLim,
28 StixTree(..), SYN_IE(StixTreeList),
31 import StixMacro ( macroCode, heapCheck )
32 import UniqSupply ( returnUs, thenUs, SYN_IE(UniqSM) )
38 :: (CAddrMode,CAddrMode,CAddrMode) -- result (3 parts)
39 -> FAST_STRING -- function name
40 -> (CAddrMode, CAddrMode,CAddrMode,CAddrMode)
42 -> UniqSM StixTreeList
44 argument1 = mpStruct 1 -- out here to avoid CAF (sigh)
45 argument2 = mpStruct 2
49 init2 = StCall SLIT("mpz_init") VoidRep [result2]
50 init3 = StCall SLIT("mpz_init") VoidRep [result3]
51 init4 = StCall SLIT("mpz_init") VoidRep [result4]
53 gmpTake1Return1 res@(car,csr,cdr) rtn arg@(clive,caa,csa,cda)
58 liveness= amodeToStix clive
63 space = mpSpace 2 1 [sa]
64 oldHp = StIndex PtrRep stgHp (StPrim IntNegOp [space])
66 save = StAssign PtrRep safeHp oldHp
67 (a1,a2,a3) = toStruct argument1 (aa,sa,da)
68 mpz_op = StCall rtn VoidRep [result2, argument1]
69 restore = StAssign PtrRep stgHp safeHp
70 (r1,r2,r3) = fromStruct result2 (ar,sr,dr)
72 heapCheck liveness space (StInt 0) `thenUs` \ heap_chk ->
75 (\xs -> a1 : a2 : a3 : save : init2 : mpz_op : r1 : r2 : r3 : restore : xs))
78 :: (CAddrMode,CAddrMode,CAddrMode) -- result (3 parts)
79 -> FAST_STRING -- function name
80 -> (CAddrMode,CAddrMode,CAddrMode,CAddrMode,CAddrMode,CAddrMode,CAddrMode)
81 -- liveness + 2 arguments (3 parts each)
82 -> UniqSM StixTreeList
84 gmpTake2Return1 res@(car,csr,cdr) rtn args@(clive, caa1,csa1,cda1, caa2,csa2,cda2)
89 liveness= amodeToStix clive
90 aa1 = amodeToStix caa1
91 sa1 = amodeToStix csa1
92 da1 = amodeToStix cda1
93 aa2 = amodeToStix caa2
94 sa2 = amodeToStix csa2
95 da2 = amodeToStix cda2
97 space = mpSpace 3 1 [sa1, sa2]
98 oldHp = StIndex PtrRep stgHp (StPrim IntNegOp [space])
100 save = StAssign PtrRep safeHp oldHp
101 (a1,a2,a3) = toStruct argument1 (aa1,sa1,da1)
102 (a4,a5,a6) = toStruct argument2 (aa2,sa2,da2)
103 mpz_op = StCall rtn VoidRep [result3, argument1, argument2]
104 restore = StAssign PtrRep stgHp safeHp
105 (r1,r2,r3) = fromStruct result3 (ar,sr,dr)
107 heapCheck liveness space (StInt 0) `thenUs` \ heap_chk ->
110 (\xs -> a1 : a2 : a3 : a4 : a5 : a6
111 : save : init3 : mpz_op : r1 : r2 : r3 : restore : xs))
114 :: (CAddrMode,CAddrMode,CAddrMode,CAddrMode,CAddrMode,CAddrMode)
115 -- 2 results (3 parts each)
116 -> FAST_STRING -- function name
117 -> (CAddrMode,CAddrMode,CAddrMode,CAddrMode,CAddrMode,CAddrMode,CAddrMode)
118 -- liveness + 2 arguments (3 parts each)
119 -> UniqSM StixTreeList
121 gmpTake2Return2 res@(car1,csr1,cdr1, car2,csr2,cdr2)
122 rtn args@(clive, caa1,csa1,cda1, caa2,csa2,cda2)
124 ar1 = amodeToStix car1
125 sr1 = amodeToStix csr1
126 dr1 = amodeToStix cdr1
127 ar2 = amodeToStix car2
128 sr2 = amodeToStix csr2
129 dr2 = amodeToStix cdr2
130 liveness= amodeToStix clive
131 aa1 = amodeToStix caa1
132 sa1 = amodeToStix csa1
133 da1 = amodeToStix cda1
134 aa2 = amodeToStix caa2
135 sa2 = amodeToStix csa2
136 da2 = amodeToStix cda2
138 space = StPrim IntMulOp [mpSpace 2 1 [sa1, sa2], StInt 2]
139 oldHp = StIndex PtrRep stgHp (StPrim IntNegOp [space])
141 save = StAssign PtrRep safeHp oldHp
142 (a1,a2,a3) = toStruct argument1 (aa1,sa1,da1)
143 (a4,a5,a6) = toStruct argument2 (aa2,sa2,da2)
144 mpz_op = StCall rtn VoidRep [result3, result4, argument1, argument2]
145 restore = StAssign PtrRep stgHp safeHp
146 (r1,r2,r3) = fromStruct result3 (ar1,sr1,dr1)
147 (r4,r5,r6) = fromStruct result4 (ar2,sr2,dr2)
150 heapCheck liveness space (StInt 0) `thenUs` \ heap_chk ->
153 (\xs -> a1 : a2 : a3 : a4 : a5 : a6
154 : save : init3 : init4 : mpz_op
155 : r1 : r2 : r3 : r4 : r5 : r6 : restore : xs))
158 Although gmpCompare doesn't allocate space, it does temporarily use
159 some space just beyond the heap pointer. This is safe, because the
160 enclosing routine has already guaranteed that this space will be
161 available. (See ``primOpHeapRequired.'')
165 :: CAddrMode -- result (boolean)
166 -> (CAddrMode,CAddrMode,CAddrMode,CAddrMode,CAddrMode,CAddrMode,CAddrMode)
167 -- alloc hp + 2 arguments (3 parts each)
168 -> UniqSM StixTreeList
170 gmpCompare res args@(chp, caa1,csa1,cda1, caa2,csa2,cda2)
172 result = amodeToStix res
174 aa1 = amodeToStix caa1
175 sa1 = amodeToStix csa1
176 da1 = amodeToStix cda1
177 aa2 = amodeToStix caa2
178 sa2 = amodeToStix csa2
179 da2 = amodeToStix cda2
182 argument2 = StIndex IntRep hp (StInt (toInteger mpIntSize))
183 (a1,a2,a3) = toStruct argument1 (aa1,sa1,da1)
184 (a4,a5,a6) = toStruct argument2 (aa2,sa2,da2)
185 mpz_cmp = StCall SLIT("mpz_cmp") IntRep [argument1, argument2]
186 r1 = StAssign IntRep result mpz_cmp
188 returnUs (\xs -> a1 : a2 : a3 : a4 : a5 : a6 : r1 : xs)
191 See the comment above regarding the heap check (or lack thereof).
195 :: CAddrMode -- result
196 -> (CAddrMode, CAddrMode,CAddrMode,CAddrMode) -- alloc hp + argument (3 parts)
197 -> UniqSM StixTreeList
199 gmpInteger2Int res args@(chp, caa,csa,cda)
201 result = amodeToStix res
207 (a1,a2,a3) = toStruct hp (aa,sa,da)
208 mpz_get_si = StCall SLIT("mpz_get_si") IntRep [hp]
209 r1 = StAssign IntRep result mpz_get_si
211 returnUs (\xs -> a1 : a2 : a3 : r1 : xs)
213 arrayOfData_info = sStLitLbl SLIT("ArrayOfData_info")
217 :: (CAddrMode, CAddrMode, CAddrMode) -- result (3 parts)
218 -> (CAddrMode, CAddrMode) -- allocated heap, Int to convert
219 -> UniqSM StixTreeList
221 gmpInt2Integer res@(car,csr,cdr) args@(chp, n)
222 = getUniqLabelNCG `thenUs` \ zlbl ->
223 getUniqLabelNCG `thenUs` \ nlbl ->
224 getUniqLabelNCG `thenUs` \ jlbl ->
232 h1 = StAssign PtrRep (StInd PtrRep hp) arrayOfData_info
233 size = varHdrSizeInWords (DataRep 0) + mIN_MP_INT_SIZE
234 h2 = StAssign IntRep (StInd IntRep (StIndex IntRep hp (StInt 1)))
235 (StInt (toInteger size))
236 cts = StInd IntRep (StIndex IntRep hp dataHS)
237 test1 = StPrim IntEqOp [i, StInt 0]
238 test2 = StPrim IntLtOp [i, StInt 0]
239 cjmp1 = StCondJump zlbl test1
240 cjmp2 = StCondJump nlbl test2
242 p1 = StAssign IntRep cts i
243 p2 = StAssign IntRep sr (StInt 1)
244 p3 = StJump (StCLbl jlbl)
247 n1 = StAssign IntRep cts (StPrim IntNegOp [i])
248 n2 = StAssign IntRep sr (StInt (-1))
249 n3 = StJump (StCLbl jlbl)
252 z1 = StAssign IntRep sr (StInt 0)
255 a1 = StAssign IntRep ar (StInt 1)
256 a2 = StAssign PtrRep dr hp
260 CLit (MachInt c _) ->
261 if c == 0 then h1 : h2 : z1 : a1 : a2 : xs
262 else if c > 0 then h1 : h2 : p1 : p2 : a1 : a2 : xs
263 else h1 : h2 : n1 : n2 : a1 : a2 : xs
264 _ -> h1 : h2 : cjmp1 : cjmp2 : p1 : p2 : p3
265 : n0 : n1 : n2 : n3 : z0 : z1
269 :: (CAddrMode, CAddrMode, CAddrMode) -- result (3 parts)
270 -> (CAddrMode, CAddrMode) -- liveness, string
271 -> UniqSM StixTreeList
273 gmpString2Integer res@(car,csr,cdr) (liveness, str)
274 = getUniqLabelNCG `thenUs` \ ulbl ->
281 (CString s) -> _LENGTH_ s
282 (CLit (MachStr s)) -> _LENGTH_ s
283 _ -> panic "String2Integer"
284 space = len `quot` 8 + 17 + mpIntSize +
285 varHdrSizeInWords (DataRep 0) + fixedHdrSizeInWords
286 oldHp = StIndex PtrRep stgHp (StInt (toInteger (-space)))
288 save = StAssign PtrRep safeHp oldHp
289 result = StIndex IntRep stgHpLim (StInt (toInteger (-mpIntSize)))
290 set_str = StCall SLIT("mpz_init_set_str") IntRep
291 [result, amodeToStix str, StInt 10]
292 test = StPrim IntEqOp [set_str, StInt 0]
293 cjmp = StCondJump ulbl test
294 abort = StCall SLIT("abort") VoidRep []
296 restore = StAssign PtrRep stgHp safeHp
297 (a1,a2,a3) = fromStruct result (ar,sr,dr)
299 macroCode HEAP_CHK [liveness, mkIntCLit space, mkIntCLit_0]
300 `thenUs` \ heap_chk ->
303 (\xs -> save : cjmp : abort : join : a1 : a2 : a3 : restore : xs))
305 mkIntCLit_0 = mkIntCLit 0 -- out here to avoid CAF (sigh)
309 -> CAddrMode -- result
310 -> (CAddrMode,CAddrMode,CAddrMode,CAddrMode,CAddrMode)
311 -- heap pointer for result, integer argument (3 parts), exponent
312 -> UniqSM StixTreeList
314 encodeFloatingKind pk res args@(chp, caa,csa,cda, cexpon)
316 result = amodeToStix res
321 expon = amodeToStix cexpon
323 pk' = if sizeOf FloatRep == sizeOf DoubleRep
326 (a1,a2,a3) = toStruct hp (aa,sa,da)
328 FloatRep -> SLIT("__encodeFloat")
329 DoubleRep -> SLIT("__encodeDouble")
330 _ -> panic "encodeFloatingKind"
331 encode = StCall fn pk' [hp, expon]
332 r1 = StAssign pk' result encode
334 returnUs (\xs -> a1 : a2 : a3 : r1 : xs)
338 -> (CAddrMode, CAddrMode, CAddrMode, CAddrMode)
339 -- exponent result, integer result (3 parts)
340 -> (CAddrMode, CAddrMode)
341 -- heap pointer for exponent, floating argument
342 -> UniqSM StixTreeList
344 decodeFloatingKind pk res@(cexponr,car,csr,cdr) args@(chp, carg)
346 exponr = amodeToStix cexponr
351 arg = amodeToStix carg
353 pk' = if sizeOf FloatRep == sizeOf DoubleRep
356 setup = StAssign PtrRep mpData_mantissa (StIndex IntRep hp (StInt 1))
358 FloatRep -> SLIT("__decodeFloat")
359 DoubleRep -> SLIT("__decodeDouble")
360 _ -> panic "decodeFloatingKind"
361 decode = StCall fn VoidRep [mantissa, hp, arg]
362 (a1,a2,a3) = fromStruct mantissa (ar,sr,dr)
363 a4 = StAssign IntRep exponr (StInd IntRep hp)
365 returnUs (\xs -> setup : decode : a1 : a2 : a3 : a4 : xs)
367 mantissa = mpStruct 1 -- out here to avoid CAF (sigh)
368 mpData_mantissa = mpData mantissa
371 Support for the Gnu GMP multi-precision package.
376 mpAlloc, mpSize, mpData :: StixTree -> StixTree
377 mpAlloc base = StInd IntRep base
378 mpSize base = StInd IntRep (StIndex IntRep base (StInt 1))
379 mpData base = StInd PtrRep (StIndex IntRep base (StInt 2))
382 :: Int -- gmp structures needed
383 -> Int -- number of results
384 -> [StixTree] -- sizes to add for estimating result size
385 -> StixTree -- total space
387 mpSpace gmp res sizes
388 = foldr sum (StPrim IntAddOp [fixed, hdrs]) sizes
390 sum x y = StPrim IntAddOp [StPrim IntAbsOp [x], y]
391 fixed = StInt (toInteger (17 * res + gmp * mpIntSize))
392 hdrs = StPrim IntMulOp [dataHS, StInt (toInteger res)]
395 We don't have a truly portable way of allocating local temporaries, so
396 we cheat and use space at the end of the heap. (Thus, negative
397 offsets from HpLim are our temporaries.) Note that you must have
398 performed a heap check which includes the space needed for these
399 temporaries before you use them.
402 mpStruct :: Int -> StixTree
403 mpStruct n = StIndex IntRep stgHpLim (StInt (toInteger (-(n * mpIntSize))))
407 -> (StixTree, StixTree, StixTree)
408 -> (StixTree, StixTree, StixTree)
410 toStruct str (alloc,size,arr)
412 f1 = StAssign IntRep (mpAlloc str) alloc
413 f2 = StAssign IntRep (mpSize str) size
414 f3 = StAssign PtrRep (mpData str) (StIndex PtrRep arr dataHS)
420 -> (StixTree, StixTree, StixTree)
421 -> (StixTree, StixTree, StixTree)
423 fromStruct str (alloc,size,arr)
425 e1 = StAssign IntRep alloc (mpAlloc str)
426 e2 = StAssign IntRep size (mpSize str)
427 e3 = StAssign PtrRep arr (StIndex PtrRep (mpData str)
428 (StPrim IntNegOp [dataHS]))