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 #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 201
16 IMPORT_DELOOPER(NcgLoop) ( amodeToStix )
18 import {-# SOURCE #-} StixPrim ( amodeToStix )
23 import AbsCSyn -- bits and bobs...
24 import Constants ( mIN_MP_INT_SIZE )
25 import Literal ( Literal(..) )
26 import OrdList ( OrdList )
27 import PrimOp ( PrimOp(..) )
28 import PrimRep ( PrimRep(..) )
29 import SMRep ( SMRep(..), SMSpecRepKind, SMUpdateKind )
30 import Stix ( getUniqLabelNCG, sStLitLbl, stgHp, stgHpLim,
31 StixTree(..), SYN_IE(StixTreeList),
34 import StixMacro ( macroCode, heapCheck )
35 import UniqSupply ( returnUs, thenUs, SYN_IE(UniqSM) )
41 :: (CAddrMode,CAddrMode,CAddrMode) -- result (3 parts)
42 -> FAST_STRING -- function name
43 -> (CAddrMode, CAddrMode,CAddrMode,CAddrMode)
45 -> UniqSM StixTreeList
47 argument1 = mpStruct 1 -- out here to avoid CAF (sigh)
48 argument2 = mpStruct 2
52 init2 = StCall SLIT("mpz_init") VoidRep [result2]
53 init3 = StCall SLIT("mpz_init") VoidRep [result3]
54 init4 = StCall SLIT("mpz_init") VoidRep [result4]
56 gmpTake1Return1 res@(car,csr,cdr) rtn arg@(clive,caa,csa,cda)
61 liveness= amodeToStix clive
66 space = mpSpace 2 1 [sa]
67 oldHp = StIndex PtrRep stgHp (StPrim IntNegOp [space])
69 save = StAssign PtrRep safeHp oldHp
70 (a1,a2,a3) = toStruct argument1 (aa,sa,da)
71 mpz_op = StCall rtn VoidRep [result2, argument1]
72 restore = StAssign PtrRep stgHp safeHp
73 (r1,r2,r3) = fromStruct result2 (ar,sr,dr)
75 heapCheck liveness space (StInt 0) `thenUs` \ heap_chk ->
78 (\xs -> a1 : a2 : a3 : save : init2 : mpz_op : r1 : r2 : r3 : restore : xs))
81 :: (CAddrMode,CAddrMode,CAddrMode) -- result (3 parts)
82 -> FAST_STRING -- function name
83 -> (CAddrMode,CAddrMode,CAddrMode,CAddrMode,CAddrMode,CAddrMode,CAddrMode)
84 -- liveness + 2 arguments (3 parts each)
85 -> UniqSM StixTreeList
87 gmpTake2Return1 res@(car,csr,cdr) rtn args@(clive, caa1,csa1,cda1, caa2,csa2,cda2)
92 liveness= amodeToStix clive
93 aa1 = amodeToStix caa1
94 sa1 = amodeToStix csa1
95 da1 = amodeToStix cda1
96 aa2 = amodeToStix caa2
97 sa2 = amodeToStix csa2
98 da2 = amodeToStix cda2
100 space = mpSpace 3 1 [sa1, sa2]
101 oldHp = StIndex PtrRep stgHp (StPrim IntNegOp [space])
103 save = StAssign PtrRep safeHp oldHp
104 (a1,a2,a3) = toStruct argument1 (aa1,sa1,da1)
105 (a4,a5,a6) = toStruct argument2 (aa2,sa2,da2)
106 mpz_op = StCall rtn VoidRep [result3, argument1, argument2]
107 restore = StAssign PtrRep stgHp safeHp
108 (r1,r2,r3) = fromStruct result3 (ar,sr,dr)
110 heapCheck liveness space (StInt 0) `thenUs` \ heap_chk ->
113 (\xs -> a1 : a2 : a3 : a4 : a5 : a6
114 : save : init3 : mpz_op : r1 : r2 : r3 : restore : xs))
117 :: (CAddrMode,CAddrMode,CAddrMode,CAddrMode,CAddrMode,CAddrMode)
118 -- 2 results (3 parts each)
119 -> FAST_STRING -- function name
120 -> (CAddrMode,CAddrMode,CAddrMode,CAddrMode,CAddrMode,CAddrMode,CAddrMode)
121 -- liveness + 2 arguments (3 parts each)
122 -> UniqSM StixTreeList
124 gmpTake2Return2 res@(car1,csr1,cdr1, car2,csr2,cdr2)
125 rtn args@(clive, caa1,csa1,cda1, caa2,csa2,cda2)
127 ar1 = amodeToStix car1
128 sr1 = amodeToStix csr1
129 dr1 = amodeToStix cdr1
130 ar2 = amodeToStix car2
131 sr2 = amodeToStix csr2
132 dr2 = amodeToStix cdr2
133 liveness= amodeToStix clive
134 aa1 = amodeToStix caa1
135 sa1 = amodeToStix csa1
136 da1 = amodeToStix cda1
137 aa2 = amodeToStix caa2
138 sa2 = amodeToStix csa2
139 da2 = amodeToStix cda2
141 space = StPrim IntMulOp [mpSpace 2 1 [sa1, sa2], StInt 2]
142 oldHp = StIndex PtrRep stgHp (StPrim IntNegOp [space])
144 save = StAssign PtrRep safeHp oldHp
145 (a1,a2,a3) = toStruct argument1 (aa1,sa1,da1)
146 (a4,a5,a6) = toStruct argument2 (aa2,sa2,da2)
147 mpz_op = StCall rtn VoidRep [result3, result4, argument1, argument2]
148 restore = StAssign PtrRep stgHp safeHp
149 (r1,r2,r3) = fromStruct result3 (ar1,sr1,dr1)
150 (r4,r5,r6) = fromStruct result4 (ar2,sr2,dr2)
153 heapCheck liveness space (StInt 0) `thenUs` \ heap_chk ->
156 (\xs -> a1 : a2 : a3 : a4 : a5 : a6
157 : save : init3 : init4 : mpz_op
158 : r1 : r2 : r3 : r4 : r5 : r6 : restore : xs))
161 Although gmpCompare doesn't allocate space, it does temporarily use
162 some space just beyond the heap pointer. This is safe, because the
163 enclosing routine has already guaranteed that this space will be
164 available. (See ``primOpHeapRequired.'')
168 :: CAddrMode -- result (boolean)
169 -> (CAddrMode,CAddrMode,CAddrMode,CAddrMode,CAddrMode,CAddrMode,CAddrMode)
170 -- alloc hp + 2 arguments (3 parts each)
171 -> UniqSM StixTreeList
173 gmpCompare res args@(chp, caa1,csa1,cda1, caa2,csa2,cda2)
175 result = amodeToStix res
177 aa1 = amodeToStix caa1
178 sa1 = amodeToStix csa1
179 da1 = amodeToStix cda1
180 aa2 = amodeToStix caa2
181 sa2 = amodeToStix csa2
182 da2 = amodeToStix cda2
185 argument2 = StIndex IntRep hp (StInt (toInteger mpIntSize))
186 (a1,a2,a3) = toStruct argument1 (aa1,sa1,da1)
187 (a4,a5,a6) = toStruct argument2 (aa2,sa2,da2)
188 mpz_cmp = StCall SLIT("mpz_cmp") IntRep [argument1, argument2]
189 r1 = StAssign IntRep result mpz_cmp
191 returnUs (\xs -> a1 : a2 : a3 : a4 : a5 : a6 : r1 : xs)
194 See the comment above regarding the heap check (or lack thereof).
198 :: CAddrMode -- result
199 -> (CAddrMode, CAddrMode,CAddrMode,CAddrMode) -- alloc hp + argument (3 parts)
200 -> UniqSM StixTreeList
202 gmpInteger2Int res args@(chp, caa,csa,cda)
204 result = amodeToStix res
210 (a1,a2,a3) = toStruct hp (aa,sa,da)
211 mpz_get_si = StCall SLIT("mpz_get_si") IntRep [hp]
212 r1 = StAssign IntRep result mpz_get_si
214 returnUs (\xs -> a1 : a2 : a3 : r1 : xs)
216 arrayOfData_info = sStLitLbl SLIT("ArrayOfData_info")
220 :: (CAddrMode, CAddrMode, CAddrMode) -- result (3 parts)
221 -> (CAddrMode, CAddrMode) -- allocated heap, Int to convert
222 -> UniqSM StixTreeList
224 gmpInt2Integer res@(car,csr,cdr) args@(chp, n)
225 = getUniqLabelNCG `thenUs` \ zlbl ->
226 getUniqLabelNCG `thenUs` \ nlbl ->
227 getUniqLabelNCG `thenUs` \ jlbl ->
235 h1 = StAssign PtrRep (StInd PtrRep hp) arrayOfData_info
236 size = varHdrSizeInWords (DataRep 0) + mIN_MP_INT_SIZE
237 h2 = StAssign IntRep (StInd IntRep (StIndex IntRep hp (StInt 1)))
238 (StInt (toInteger size))
239 cts = StInd IntRep (StIndex IntRep hp dataHS)
240 test1 = StPrim IntEqOp [i, StInt 0]
241 test2 = StPrim IntLtOp [i, StInt 0]
242 cjmp1 = StCondJump zlbl test1
243 cjmp2 = StCondJump nlbl test2
245 p1 = StAssign IntRep cts i
246 p2 = StAssign IntRep sr (StInt 1)
247 p3 = StJump (StCLbl jlbl)
250 n1 = StAssign IntRep cts (StPrim IntNegOp [i])
251 n2 = StAssign IntRep sr (StInt (-1))
252 n3 = StJump (StCLbl jlbl)
255 z1 = StAssign IntRep sr (StInt 0)
258 a1 = StAssign IntRep ar (StInt 1)
259 a2 = StAssign PtrRep dr hp
263 CLit (MachInt c _) ->
264 if c == 0 then h1 : h2 : z1 : a1 : a2 : xs
265 else if c > 0 then h1 : h2 : p1 : p2 : a1 : a2 : xs
266 else h1 : h2 : n1 : n2 : a1 : a2 : xs
267 _ -> h1 : h2 : cjmp1 : cjmp2 : p1 : p2 : p3
268 : n0 : n1 : n2 : n3 : z0 : z1
272 :: (CAddrMode, CAddrMode, CAddrMode) -- result (3 parts)
273 -> (CAddrMode, CAddrMode) -- liveness, string
274 -> UniqSM StixTreeList
276 gmpString2Integer res@(car,csr,cdr) (liveness, str)
277 = getUniqLabelNCG `thenUs` \ ulbl ->
284 (CString s) -> _LENGTH_ s
285 (CLit (MachStr s)) -> _LENGTH_ s
286 _ -> panic "String2Integer"
287 space = len `quot` 8 + 17 + mpIntSize +
288 varHdrSizeInWords (DataRep 0) + fixedHdrSizeInWords
289 oldHp = StIndex PtrRep stgHp (StInt (toInteger (-space)))
291 save = StAssign PtrRep safeHp oldHp
292 result = StIndex IntRep stgHpLim (StInt (toInteger (-mpIntSize)))
293 set_str = StCall SLIT("mpz_init_set_str") IntRep
294 [result, amodeToStix str, StInt 10]
295 test = StPrim IntEqOp [set_str, StInt 0]
296 cjmp = StCondJump ulbl test
297 abort = StCall SLIT("abort") VoidRep []
299 restore = StAssign PtrRep stgHp safeHp
300 (a1,a2,a3) = fromStruct result (ar,sr,dr)
302 macroCode HEAP_CHK [liveness, mkIntCLit space, mkIntCLit_0]
303 `thenUs` \ heap_chk ->
306 (\xs -> save : cjmp : abort : join : a1 : a2 : a3 : restore : xs))
308 mkIntCLit_0 = mkIntCLit 0 -- out here to avoid CAF (sigh)
312 -> CAddrMode -- result
313 -> (CAddrMode,CAddrMode,CAddrMode,CAddrMode,CAddrMode)
314 -- heap pointer for result, integer argument (3 parts), exponent
315 -> UniqSM StixTreeList
317 encodeFloatingKind pk res args@(chp, caa,csa,cda, cexpon)
319 result = amodeToStix res
324 expon = amodeToStix cexpon
326 pk' = if sizeOf FloatRep == sizeOf DoubleRep
329 (a1,a2,a3) = toStruct hp (aa,sa,da)
331 FloatRep -> SLIT("__encodeFloat")
332 DoubleRep -> SLIT("__encodeDouble")
333 _ -> panic "encodeFloatingKind"
334 encode = StCall fn pk' [hp, expon]
335 r1 = StAssign pk' result encode
337 returnUs (\xs -> a1 : a2 : a3 : r1 : xs)
341 -> (CAddrMode, CAddrMode, CAddrMode, CAddrMode)
342 -- exponent result, integer result (3 parts)
343 -> (CAddrMode, CAddrMode)
344 -- heap pointer for exponent, floating argument
345 -> UniqSM StixTreeList
347 decodeFloatingKind pk res@(cexponr,car,csr,cdr) args@(chp, carg)
349 exponr = amodeToStix cexponr
354 arg = amodeToStix carg
356 pk' = if sizeOf FloatRep == sizeOf DoubleRep
359 setup = StAssign PtrRep mpData_mantissa (StIndex IntRep hp (StInt 1))
361 FloatRep -> SLIT("__decodeFloat")
362 DoubleRep -> SLIT("__decodeDouble")
363 _ -> panic "decodeFloatingKind"
364 decode = StCall fn VoidRep [mantissa, hp, arg]
365 (a1,a2,a3) = fromStruct mantissa (ar,sr,dr)
366 a4 = StAssign IntRep exponr (StInd IntRep hp)
368 returnUs (\xs -> setup : decode : a1 : a2 : a3 : a4 : xs)
370 mantissa = mpStruct 1 -- out here to avoid CAF (sigh)
371 mpData_mantissa = mpData mantissa
374 Support for the Gnu GMP multi-precision package.
379 mpAlloc, mpSize, mpData :: StixTree -> StixTree
380 mpAlloc base = StInd IntRep base
381 mpSize base = StInd IntRep (StIndex IntRep base (StInt 1))
382 mpData base = StInd PtrRep (StIndex IntRep base (StInt 2))
385 :: Int -- gmp structures needed
386 -> Int -- number of results
387 -> [StixTree] -- sizes to add for estimating result size
388 -> StixTree -- total space
390 mpSpace gmp res sizes
391 = foldr sum (StPrim IntAddOp [fixed, hdrs]) sizes
393 sum x y = StPrim IntAddOp [StPrim IntAbsOp [x], y]
394 fixed = StInt (toInteger (17 * res + gmp * mpIntSize))
395 hdrs = StPrim IntMulOp [dataHS, StInt (toInteger res)]
398 We don't have a truly portable way of allocating local temporaries, so
399 we cheat and use space at the end of the heap. (Thus, negative
400 offsets from HpLim are our temporaries.) Note that you must have
401 performed a heap check which includes the space needed for these
402 temporaries before you use them.
405 mpStruct :: Int -> StixTree
406 mpStruct n = StIndex IntRep stgHpLim (StInt (toInteger (-(n * mpIntSize))))
410 -> (StixTree, StixTree, StixTree)
411 -> (StixTree, StixTree, StixTree)
413 toStruct str (alloc,size,arr)
415 f1 = StAssign IntRep (mpAlloc str) alloc
416 f2 = StAssign IntRep (mpSize str) size
417 f3 = StAssign PtrRep (mpData str) (StIndex PtrRep arr dataHS)
423 -> (StixTree, StixTree, StixTree)
424 -> (StixTree, StixTree, StixTree)
426 fromStruct str (alloc,size,arr)
428 e1 = StAssign IntRep alloc (mpAlloc str)
429 e2 = StAssign IntRep size (mpSize str)
430 e3 = StAssign PtrRep arr (StIndex PtrRep (mpData str)
431 (StPrim IntNegOp [dataHS]))