2 % (c) The AQUA Project, Glasgow University, 1993-1996
7 gmpTake1Return1, gmpTake2Return1, gmpTake2Return2, gmpCompare,
8 gmpInteger2Int, gmpInt2Integer, gmpString2Integer,
9 encodeFloatingKind, decodeFloatingKind
12 #include "HsVersions.h"
14 import {-# SOURCE #-} StixPrim ( amodeToStix )
18 import AbsCSyn -- bits and bobs...
19 import Constants ( mIN_MP_INT_SIZE )
20 import Literal ( Literal(..) )
21 import OrdList ( OrdList )
22 import PrimOp ( PrimOp(..) )
23 import PrimRep ( PrimRep(..) )
24 import SMRep ( SMRep(..), SMSpecRepKind, SMUpdateKind )
25 import Stix ( getUniqLabelNCG, sStLitLbl, stgHp, stgHpLim,
26 StixTree(..), StixTreeList,
29 import StixMacro ( macroCode, heapCheck )
30 import UniqSupply ( returnUs, thenUs, UniqSM )
36 :: (CAddrMode,CAddrMode,CAddrMode) -- result (3 parts)
37 -> FAST_STRING -- function name
38 -> (CAddrMode, CAddrMode,CAddrMode,CAddrMode)
40 -> UniqSM StixTreeList
42 argument1 = mpStruct 1 -- out here to avoid CAF (sigh)
43 argument2 = mpStruct 2
47 init2 = StCall SLIT("mpz_init") VoidRep [result2]
48 init3 = StCall SLIT("mpz_init") VoidRep [result3]
49 init4 = StCall SLIT("mpz_init") VoidRep [result4]
51 gmpTake1Return1 res@(car,csr,cdr) rtn arg@(clive,caa,csa,cda)
56 liveness= amodeToStix clive
61 space = mpSpace 2 1 [sa]
62 oldHp = StIndex PtrRep stgHp (StPrim IntNegOp [space])
64 save = StAssign PtrRep safeHp oldHp
65 (a1,a2,a3) = toStruct argument1 (aa,sa,da)
66 mpz_op = StCall rtn VoidRep [result2, argument1]
67 restore = StAssign PtrRep stgHp safeHp
68 (r1,r2,r3) = fromStruct result2 (ar,sr,dr)
70 heapCheck liveness space (StInt 0) `thenUs` \ heap_chk ->
73 (\xs -> a1 : a2 : a3 : save : init2 : mpz_op : r1 : r2 : r3 : restore : xs))
76 :: (CAddrMode,CAddrMode,CAddrMode) -- result (3 parts)
77 -> FAST_STRING -- function name
78 -> (CAddrMode,CAddrMode,CAddrMode,CAddrMode,CAddrMode,CAddrMode,CAddrMode)
79 -- liveness + 2 arguments (3 parts each)
80 -> UniqSM StixTreeList
82 gmpTake2Return1 res@(car,csr,cdr) rtn args@(clive, caa1,csa1,cda1, caa2,csa2,cda2)
87 liveness= amodeToStix clive
88 aa1 = amodeToStix caa1
89 sa1 = amodeToStix csa1
90 da1 = amodeToStix cda1
91 aa2 = amodeToStix caa2
92 sa2 = amodeToStix csa2
93 da2 = amodeToStix cda2
95 space = mpSpace 3 1 [sa1, sa2]
96 oldHp = StIndex PtrRep stgHp (StPrim IntNegOp [space])
98 save = StAssign PtrRep safeHp oldHp
99 (a1,a2,a3) = toStruct argument1 (aa1,sa1,da1)
100 (a4,a5,a6) = toStruct argument2 (aa2,sa2,da2)
101 mpz_op = StCall rtn VoidRep [result3, argument1, argument2]
102 restore = StAssign PtrRep stgHp safeHp
103 (r1,r2,r3) = fromStruct result3 (ar,sr,dr)
105 heapCheck liveness space (StInt 0) `thenUs` \ heap_chk ->
108 (\xs -> a1 : a2 : a3 : a4 : a5 : a6
109 : save : init3 : mpz_op : r1 : r2 : r3 : restore : xs))
112 :: (CAddrMode,CAddrMode,CAddrMode,CAddrMode,CAddrMode,CAddrMode)
113 -- 2 results (3 parts each)
114 -> FAST_STRING -- function name
115 -> (CAddrMode,CAddrMode,CAddrMode,CAddrMode,CAddrMode,CAddrMode,CAddrMode)
116 -- liveness + 2 arguments (3 parts each)
117 -> UniqSM StixTreeList
119 gmpTake2Return2 res@(car1,csr1,cdr1, car2,csr2,cdr2)
120 rtn args@(clive, caa1,csa1,cda1, caa2,csa2,cda2)
122 ar1 = amodeToStix car1
123 sr1 = amodeToStix csr1
124 dr1 = amodeToStix cdr1
125 ar2 = amodeToStix car2
126 sr2 = amodeToStix csr2
127 dr2 = amodeToStix cdr2
128 liveness= amodeToStix clive
129 aa1 = amodeToStix caa1
130 sa1 = amodeToStix csa1
131 da1 = amodeToStix cda1
132 aa2 = amodeToStix caa2
133 sa2 = amodeToStix csa2
134 da2 = amodeToStix cda2
136 space = StPrim IntMulOp [mpSpace 2 1 [sa1, sa2], StInt 2]
137 oldHp = StIndex PtrRep stgHp (StPrim IntNegOp [space])
139 save = StAssign PtrRep safeHp oldHp
140 (a1,a2,a3) = toStruct argument1 (aa1,sa1,da1)
141 (a4,a5,a6) = toStruct argument2 (aa2,sa2,da2)
142 mpz_op = StCall rtn VoidRep [result3, result4, argument1, argument2]
143 restore = StAssign PtrRep stgHp safeHp
144 (r1,r2,r3) = fromStruct result3 (ar1,sr1,dr1)
145 (r4,r5,r6) = fromStruct result4 (ar2,sr2,dr2)
148 heapCheck liveness space (StInt 0) `thenUs` \ heap_chk ->
151 (\xs -> a1 : a2 : a3 : a4 : a5 : a6
152 : save : init3 : init4 : mpz_op
153 : r1 : r2 : r3 : r4 : r5 : r6 : restore : xs))
156 Although gmpCompare doesn't allocate space, it does temporarily use
157 some space just beyond the heap pointer. This is safe, because the
158 enclosing routine has already guaranteed that this space will be
159 available. (See ``primOpHeapRequired.'')
163 :: CAddrMode -- result (boolean)
164 -> (CAddrMode,CAddrMode,CAddrMode,CAddrMode,CAddrMode,CAddrMode,CAddrMode)
165 -- alloc hp + 2 arguments (3 parts each)
166 -> UniqSM StixTreeList
168 gmpCompare res args@(chp, caa1,csa1,cda1, caa2,csa2,cda2)
170 result = amodeToStix res
172 aa1 = amodeToStix caa1
173 sa1 = amodeToStix csa1
174 da1 = amodeToStix cda1
175 aa2 = amodeToStix caa2
176 sa2 = amodeToStix csa2
177 da2 = amodeToStix cda2
180 argument2 = StIndex IntRep hp (StInt (toInteger mpIntSize))
181 (a1,a2,a3) = toStruct argument1 (aa1,sa1,da1)
182 (a4,a5,a6) = toStruct argument2 (aa2,sa2,da2)
183 mpz_cmp = StCall SLIT("mpz_cmp") IntRep [argument1, argument2]
184 r1 = StAssign IntRep result mpz_cmp
186 returnUs (\xs -> a1 : a2 : a3 : a4 : a5 : a6 : r1 : xs)
189 See the comment above regarding the heap check (or lack thereof).
193 :: CAddrMode -- result
194 -> (CAddrMode, CAddrMode,CAddrMode,CAddrMode) -- alloc hp + argument (3 parts)
195 -> UniqSM StixTreeList
197 gmpInteger2Int res args@(chp, caa,csa,cda)
199 result = amodeToStix res
205 (a1,a2,a3) = toStruct hp (aa,sa,da)
206 mpz_get_si = StCall SLIT("mpz_get_si") IntRep [hp]
207 r1 = StAssign IntRep result mpz_get_si
209 returnUs (\xs -> a1 : a2 : a3 : r1 : xs)
211 arrayOfData_info = sStLitLbl SLIT("ArrayOfData_info")
215 :: (CAddrMode, CAddrMode, CAddrMode) -- result (3 parts)
216 -> (CAddrMode, CAddrMode) -- allocated heap, Int to convert
217 -> UniqSM StixTreeList
219 gmpInt2Integer res@(car,csr,cdr) args@(chp, n)
220 = getUniqLabelNCG `thenUs` \ zlbl ->
221 getUniqLabelNCG `thenUs` \ nlbl ->
222 getUniqLabelNCG `thenUs` \ jlbl ->
230 h1 = StAssign PtrRep (StInd PtrRep hp) arrayOfData_info
231 size = varHdrSizeInWords (DataRep 0) + mIN_MP_INT_SIZE
232 h2 = StAssign IntRep (StInd IntRep (StIndex IntRep hp (StInt 1)))
233 (StInt (toInteger size))
234 cts = StInd IntRep (StIndex IntRep hp dataHS)
235 test1 = StPrim IntEqOp [i, StInt 0]
236 test2 = StPrim IntLtOp [i, StInt 0]
237 cjmp1 = StCondJump zlbl test1
238 cjmp2 = StCondJump nlbl test2
240 p1 = StAssign IntRep cts i
241 p2 = StAssign IntRep sr (StInt 1)
242 p3 = StJump (StCLbl jlbl)
245 n1 = StAssign IntRep cts (StPrim IntNegOp [i])
246 n2 = StAssign IntRep sr (StInt (-1))
247 n3 = StJump (StCLbl jlbl)
250 z1 = StAssign IntRep sr (StInt 0)
253 a1 = StAssign IntRep ar (StInt 1)
254 a2 = StAssign PtrRep dr hp
258 CLit (MachInt c _) ->
259 if c == 0 then h1 : h2 : z1 : a1 : a2 : xs
260 else if c > 0 then h1 : h2 : p1 : p2 : a1 : a2 : xs
261 else h1 : h2 : n1 : n2 : a1 : a2 : xs
262 _ -> h1 : h2 : cjmp1 : cjmp2 : p1 : p2 : p3
263 : n0 : n1 : n2 : n3 : z0 : z1
267 :: (CAddrMode, CAddrMode, CAddrMode) -- result (3 parts)
268 -> (CAddrMode, CAddrMode) -- liveness, string
269 -> UniqSM StixTreeList
271 gmpString2Integer res@(car,csr,cdr) (liveness, str)
272 = getUniqLabelNCG `thenUs` \ ulbl ->
279 (CString s) -> _LENGTH_ s
280 (CLit (MachStr s)) -> _LENGTH_ s
281 _ -> panic "String2Integer"
282 space = len `quot` 8 + 17 + mpIntSize +
283 varHdrSizeInWords (DataRep 0) + fixedHdrSizeInWords
284 oldHp = StIndex PtrRep stgHp (StInt (toInteger (-space)))
286 save = StAssign PtrRep safeHp oldHp
287 result = StIndex IntRep stgHpLim (StInt (toInteger (-mpIntSize)))
288 set_str = StCall SLIT("mpz_init_set_str") IntRep
289 [result, amodeToStix str, StInt 10]
290 test = StPrim IntEqOp [set_str, StInt 0]
291 cjmp = StCondJump ulbl test
292 abort = StCall SLIT("abort") VoidRep []
294 restore = StAssign PtrRep stgHp safeHp
295 (a1,a2,a3) = fromStruct result (ar,sr,dr)
297 macroCode HEAP_CHK [liveness, mkIntCLit space, mkIntCLit_0]
298 `thenUs` \ heap_chk ->
301 (\xs -> save : cjmp : abort : join : a1 : a2 : a3 : restore : xs))
303 mkIntCLit_0 = mkIntCLit 0 -- out here to avoid CAF (sigh)
307 -> CAddrMode -- result
308 -> (CAddrMode,CAddrMode,CAddrMode,CAddrMode,CAddrMode)
309 -- heap pointer for result, integer argument (3 parts), exponent
310 -> UniqSM StixTreeList
312 encodeFloatingKind pk res args@(chp, caa,csa,cda, cexpon)
314 result = amodeToStix res
319 expon = amodeToStix cexpon
321 pk' = if sizeOf FloatRep == sizeOf DoubleRep
324 (a1,a2,a3) = toStruct hp (aa,sa,da)
326 FloatRep -> SLIT("__encodeFloat")
327 DoubleRep -> SLIT("__encodeDouble")
328 _ -> panic "encodeFloatingKind"
329 encode = StCall fn pk' [hp, expon]
330 r1 = StAssign pk' result encode
332 returnUs (\xs -> a1 : a2 : a3 : r1 : xs)
336 -> (CAddrMode, CAddrMode, CAddrMode, CAddrMode)
337 -- exponent result, integer result (3 parts)
338 -> (CAddrMode, CAddrMode)
339 -- heap pointer for exponent, floating argument
340 -> UniqSM StixTreeList
342 decodeFloatingKind pk res@(cexponr,car,csr,cdr) args@(chp, carg)
344 exponr = amodeToStix cexponr
349 arg = amodeToStix carg
351 pk' = if sizeOf FloatRep == sizeOf DoubleRep
354 setup = StAssign PtrRep mpData_mantissa (StIndex IntRep hp (StInt 1))
356 FloatRep -> SLIT("__decodeFloat")
357 DoubleRep -> SLIT("__decodeDouble")
358 _ -> panic "decodeFloatingKind"
359 decode = StCall fn VoidRep [mantissa, hp, arg]
360 (a1,a2,a3) = fromStruct mantissa (ar,sr,dr)
361 a4 = StAssign IntRep exponr (StInd IntRep hp)
363 returnUs (\xs -> setup : decode : a1 : a2 : a3 : a4 : xs)
365 mantissa = mpStruct 1 -- out here to avoid CAF (sigh)
366 mpData_mantissa = mpData mantissa
369 Support for the Gnu GMP multi-precision package.
374 mpAlloc, mpSize, mpData :: StixTree -> StixTree
375 mpAlloc base = StInd IntRep base
376 mpSize base = StInd IntRep (StIndex IntRep base (StInt 1))
377 mpData base = StInd PtrRep (StIndex IntRep base (StInt 2))
380 :: Int -- gmp structures needed
381 -> Int -- number of results
382 -> [StixTree] -- sizes to add for estimating result size
383 -> StixTree -- total space
385 mpSpace gmp res sizes
386 = foldr sum (StPrim IntAddOp [fixed, hdrs]) sizes
388 sum x y = StPrim IntAddOp [StPrim IntAbsOp [x], y]
389 fixed = StInt (toInteger (17 * res + gmp * mpIntSize))
390 hdrs = StPrim IntMulOp [dataHS, StInt (toInteger res)]
393 We don't have a truly portable way of allocating local temporaries, so
394 we cheat and use space at the end of the heap. (Thus, negative
395 offsets from HpLim are our temporaries.) Note that you must have
396 performed a heap check which includes the space needed for these
397 temporaries before you use them.
400 mpStruct :: Int -> StixTree
401 mpStruct n = StIndex IntRep stgHpLim (StInt (toInteger (-(n * mpIntSize))))
405 -> (StixTree, StixTree, StixTree)
406 -> (StixTree, StixTree, StixTree)
408 toStruct str (alloc,size,arr)
410 f1 = StAssign IntRep (mpAlloc str) alloc
411 f2 = StAssign IntRep (mpSize str) size
412 f3 = StAssign PtrRep (mpData str) (StIndex PtrRep arr dataHS)
418 -> (StixTree, StixTree, StixTree)
419 -> (StixTree, StixTree, StixTree)
421 fromStruct str (alloc,size,arr)
423 e1 = StAssign IntRep alloc (mpAlloc str)
424 e2 = StAssign IntRep size (mpSize str)
425 e3 = StAssign PtrRep arr (StIndex PtrRep (mpData str)
426 (StPrim IntNegOp [dataHS]))