2 % (c) The AQUA Project, Glasgow University, 1993-1998
14 #include "HsVersions.h"
16 import {-# SOURCE #-} StixPrim ( amodeToStix )
18 import AbsCSyn hiding (spRel) -- bits and bobs..
19 import ForeignCall ( CCallConv(..) )
20 import PrimOp ( PrimOp(..) )
21 import PrimRep ( PrimRep(..) )
22 import Stix ( StixTree(..), StixTreeList, arrWordsHS )
23 import UniqSupply ( returnUs, UniqSM )
26 Although gmpCompare doesn't allocate space, it does temporarily use
27 some space just beyond the heap pointer. This is safe, because the
28 enclosing routine has already guaranteed that this space will be
29 available. (See ``primOpHeapRequired.'')
32 stgArrWords__words :: StixTree -> StixTree
33 stgArrWords__BYTE_ARR_CTS :: StixTree -> StixTree
35 stgArrWords__BYTE_ARR_CTS arr
36 = StIndex WordRep arr arrWordsHS
37 stgArrWords__words arr
39 StInt i -> StInd WordRep (StIndex PtrRep arr (StInt (i-1)))
42 :: CAddrMode -- result (boolean)
43 -> (CAddrMode,CAddrMode,CAddrMode,CAddrMode)
44 -- alloc hp + 2 arguments (2 parts each)
45 -> UniqSM StixTreeList
47 gmpCompare res args@(csa1,cda1, csa2,cda2)
49 result = amodeToStix res
50 sa1 = amodeToStix csa1
51 sa2 = amodeToStix csa2
52 aa1 = stgArrWords__words (amodeToStix cda1)
53 aa2 = stgArrWords__words (amodeToStix cda2)
54 da1 = stgArrWords__BYTE_ARR_CTS (amodeToStix cda1)
55 da2 = stgArrWords__BYTE_ARR_CTS (amodeToStix cda2)
57 (a1,a2,a3) = toStruct scratch1 (aa1,sa1,da1)
58 (a4,a5,a6) = toStruct scratch2 (aa2,sa2,da2)
59 mpz_cmp = StCall SLIT("__gmpz_cmp") CCallConv IntRep [scratch1, scratch2]
60 r1 = StAssign IntRep result mpz_cmp
62 returnUs (\xs -> a1 : a2 : a3 : a4 : a5 : a6 : r1 : xs)
66 :: CAddrMode -- result (boolean)
67 -> (CAddrMode,CAddrMode,CAddrMode)
68 -> UniqSM StixTreeList -- alloc hp + 1 arg (??)
70 gmpCompareInt res args@(csa1,cda1, cai)
72 result = amodeToStix res
73 sa1 = amodeToStix csa1
74 aa1 = stgArrWords__words (amodeToStix cda1)
75 da1 = stgArrWords__BYTE_ARR_CTS (amodeToStix cda1)
77 (a1,a2,a3) = toStruct scratch1 (aa1,sa1,da1)
78 mpz_cmp_si = StCall SLIT("__gmpz_cmp_si") CCallConv IntRep [scratch1, ai]
79 r1 = StAssign IntRep result mpz_cmp_si
81 returnUs (\xs -> a1 : a2 : a3 : r1 : xs)
86 :: CAddrMode -- result
87 -> (CAddrMode,CAddrMode) -- alloc hp + argument (2 parts)
88 -> UniqSM StixTreeList
90 gmpInteger2Int res args@(csa,cda)
92 result = amodeToStix res
94 aa = stgArrWords__words (amodeToStix cda)
95 da = stgArrWords__BYTE_ARR_CTS (amodeToStix cda)
97 (a1,a2,a3) = toStruct scratch1 (aa,sa,da)
98 mpz_get_si = StCall SLIT("__gmpz_get_si") CCallConv IntRep [scratch1]
99 r1 = StAssign IntRep result mpz_get_si
101 returnUs (\xs -> a1 : a2 : a3 : r1 : xs)
104 :: CAddrMode -- result
105 -> (CAddrMode,CAddrMode) -- alloc hp + argument (2 parts)
106 -> UniqSM StixTreeList
108 gmpInteger2Word res args@(csa,cda)
110 result = amodeToStix res
112 aa = stgArrWords__words (amodeToStix cda)
113 da = stgArrWords__BYTE_ARR_CTS (amodeToStix cda)
115 (a1,a2,a3) = toStruct scratch1 (aa,sa,da)
116 mpz_get_ui = StCall SLIT("__gmpz_get_ui") CCallConv IntRep [scratch1]
117 r1 = StAssign WordRep result mpz_get_ui
119 returnUs (\xs -> a1 : a2 : a3 : r1 : xs)
122 :: (CAddrMode,CAddrMode) -- result
123 -> (CAddrMode,CAddrMode) -- argument (2 parts)
124 -> UniqSM StixTreeList
126 gmpNegate (rcs, rcd) args@(cs, cd)
129 a = stgArrWords__words (amodeToStix cd)
130 d = stgArrWords__BYTE_ARR_CTS (amodeToStix cd)
132 ra = stgArrWords__words (amodeToStix rcd)
133 rd = stgArrWords__BYTE_ARR_CTS (amodeToStix rcd)
134 a1 = StAssign IntRep ra a
135 a2 = StAssign IntRep rs (StPrim IntNegOp [s])
136 a3 = StAssign PtrRep rd d
138 returnUs (\xs -> a1 : a2 : a3 : xs)
141 Support for the Gnu GMP multi-precision package.
144 -- size (in words) of __MP_INT
147 mpAlloc, mpSize, mpData :: StixTree -> StixTree
148 mpAlloc base = StInd IntRep base
149 mpSize base = StInd IntRep (StIndex IntRep base (StInt 1))
150 mpData base = StInd PtrRep (StIndex IntRep base (StInt 2))
156 -> (StixTree, StixTree, StixTree)
157 -> (StixTree, StixTree, StixTree)
159 toStruct str (alloc,size,arr)
161 f1 = StAssign IntRep (mpAlloc str) alloc
162 f2 = StAssign IntRep (mpSize str) size
163 f3 = StAssign PtrRep (mpData str) arr
167 scratch1 = StScratchWord 0
168 scratch2 = StScratchWord mpIntSize