gmpTake1Return1
:: Target
- -> [CAddrMode] -- result (3 parts)
- -> FAST_STRING -- function name
- -> [CAddrMode] -- argument (3 parts)
+ -> (CAddrMode,CAddrMode,CAddrMode) -- result (3 parts)
+ -> FAST_STRING -- function name
+ -> (CAddrMode, CAddrMode,CAddrMode,CAddrMode)
+ -- argument (4 parts)
-> SUniqSM StixTreeList
argument1 = mpStruct 1 -- out here to avoid CAF (sigh)
init3 = StCall SLIT("mpz_init") VoidKind [result3]
init4 = StCall SLIT("mpz_init") VoidKind [result4]
-gmpTake1Return1 target res rtn arg =
- let [ar,sr,dr] = map (amodeToStix target) res
- [liveness, aa,sa,da] = map (amodeToStix target) arg
- space = mpSpace target 2 1 [sa]
+-- hacking with Uncle Will:
+#define target_STRICT target@(Target _ _ _ _ _ _ _ _)
+
+gmpTake1Return1 target_STRICT res@(car,csr,cdr) rtn arg@(clive,caa,csa,cda) =
+ let
+ a2stix = amodeToStix target
+ data_hs = dataHS target
+
+ ar = a2stix car
+ sr = a2stix csr
+ dr = a2stix cdr
+ liveness= a2stix clive
+ aa = a2stix caa
+ sa = a2stix csa
+ da = a2stix cda
+
+ space = mpSpace data_hs 2 1 [sa]
oldHp = StIndex PtrKind stgHp (StPrim IntNegOp [space])
safeHp = saveLoc target Hp
save = StAssign PtrKind safeHp oldHp
- (a1,a2,a3) = toStruct target argument1 (aa,sa,da)
+ (a1,a2,a3) = toStruct data_hs argument1 (aa,sa,da)
mpz_op = StCall rtn VoidKind [result2, argument1]
restore = StAssign PtrKind stgHp safeHp
- (r1,r2,r3) = fromStruct target result2 (ar,sr,dr)
+ (r1,r2,r3) = fromStruct data_hs result2 (ar,sr,dr)
in
- heapCheck target liveness space (StInt 0)
- `thenSUs` \ heap_chk ->
+ heapCheck target liveness space (StInt 0) `thenSUs` \ heap_chk ->
returnSUs (heap_chk .
(\xs -> a1 : a2 : a3 : save : init2 : mpz_op : r1 : r2 : r3 : restore : xs))
gmpTake2Return1
:: Target
- -> [CAddrMode] -- result (3 parts)
- -> FAST_STRING -- function name
- -> [CAddrMode] -- arguments (3 parts each)
+ -> (CAddrMode,CAddrMode,CAddrMode) -- result (3 parts)
+ -> FAST_STRING -- function name
+ -> (CAddrMode,CAddrMode,CAddrMode,CAddrMode,CAddrMode,CAddrMode,CAddrMode)
+ -- liveness + 2 arguments (3 parts each)
-> SUniqSM StixTreeList
-gmpTake2Return1 target res rtn args =
- let [ar,sr,dr] = map (amodeToStix target) res
- [liveness, aa1,sa1,da1, aa2,sa2,da2] = map (amodeToStix target) args
- space = mpSpace target 3 1 [sa1, sa2]
+gmpTake2Return1 target_STRICT res@(car,csr,cdr) rtn args@(clive, caa1,csa1,cda1, caa2,csa2,cda2) =
+ let
+ a2stix = amodeToStix target
+ data_hs = dataHS target
+
+ ar = a2stix car
+ sr = a2stix csr
+ dr = a2stix cdr
+ liveness= a2stix clive
+ aa1 = a2stix caa1
+ sa1 = a2stix csa1
+ da1 = a2stix cda1
+ aa2 = a2stix caa2
+ sa2 = a2stix csa2
+ da2 = a2stix cda2
+
+ space = mpSpace data_hs 3 1 [sa1, sa2]
oldHp = StIndex PtrKind stgHp (StPrim IntNegOp [space])
safeHp = saveLoc target Hp
save = StAssign PtrKind safeHp oldHp
- (a1,a2,a3) = toStruct target argument1 (aa1,sa1,da1)
- (a4,a5,a6) = toStruct target argument2 (aa2,sa2,da2)
+ (a1,a2,a3) = toStruct data_hs argument1 (aa1,sa1,da1)
+ (a4,a5,a6) = toStruct data_hs argument2 (aa2,sa2,da2)
mpz_op = StCall rtn VoidKind [result3, argument1, argument2]
restore = StAssign PtrKind stgHp safeHp
- (r1,r2,r3) = fromStruct target result3 (ar,sr,dr)
+ (r1,r2,r3) = fromStruct data_hs result3 (ar,sr,dr)
in
- heapCheck target liveness space (StInt 0)
- `thenSUs` \ heap_chk ->
+ heapCheck target liveness space (StInt 0) `thenSUs` \ heap_chk ->
returnSUs (heap_chk .
(\xs -> a1 : a2 : a3 : a4 : a5 : a6
gmpTake2Return2
:: Target
- -> [CAddrMode] -- results (3 parts each)
+ -> (CAddrMode,CAddrMode,CAddrMode,CAddrMode,CAddrMode,CAddrMode)
+ -- 2 results (3 parts each)
-> FAST_STRING -- function name
- -> [CAddrMode] -- arguments (3 parts each)
+ -> (CAddrMode,CAddrMode,CAddrMode,CAddrMode,CAddrMode,CAddrMode,CAddrMode)
+ -- liveness + 2 arguments (3 parts each)
-> SUniqSM StixTreeList
-gmpTake2Return2 target res rtn args =
- let [ar1,sr1,dr1, ar2,sr2,dr2] = map (amodeToStix target) res
- [liveness, aa1,sa1,da1, aa2,sa2,da2] = map (amodeToStix target) args
- space = StPrim IntMulOp [mpSpace target 2 1 [sa1, sa2], StInt 2]
+gmpTake2Return2 target_STRICT res@(car1,csr1,cdr1, car2,csr2,cdr2)
+ rtn args@(clive, caa1,csa1,cda1, caa2,csa2,cda2) =
+ let
+ a2stix = amodeToStix target
+ data_hs = dataHS target
+
+ ar1 = a2stix car1
+ sr1 = a2stix csr1
+ dr1 = a2stix cdr1
+ ar2 = a2stix car2
+ sr2 = a2stix csr2
+ dr2 = a2stix cdr2
+ liveness= a2stix clive
+ aa1 = a2stix caa1
+ sa1 = a2stix csa1
+ da1 = a2stix cda1
+ aa2 = a2stix caa2
+ sa2 = a2stix csa2
+ da2 = a2stix cda2
+
+ space = StPrim IntMulOp [mpSpace data_hs 2 1 [sa1, sa2], StInt 2]
oldHp = StIndex PtrKind stgHp (StPrim IntNegOp [space])
safeHp = saveLoc target Hp
save = StAssign PtrKind safeHp oldHp
- (a1,a2,a3) = toStruct target argument1 (aa1,sa1,da1)
- (a4,a5,a6) = toStruct target argument2 (aa2,sa2,da2)
+ (a1,a2,a3) = toStruct data_hs argument1 (aa1,sa1,da1)
+ (a4,a5,a6) = toStruct data_hs argument2 (aa2,sa2,da2)
mpz_op = StCall rtn VoidKind [result3, result4, argument1, argument2]
restore = StAssign PtrKind stgHp safeHp
- (r1,r2,r3) = fromStruct target result3 (ar1,sr1,dr1)
- (r4,r5,r6) = fromStruct target result4 (ar2,sr2,dr2)
+ (r1,r2,r3) = fromStruct data_hs result3 (ar1,sr1,dr1)
+ (r4,r5,r6) = fromStruct data_hs result4 (ar2,sr2,dr2)
in
- heapCheck target liveness space (StInt 0)
- `thenSUs` \ heap_chk ->
+ heapCheck target liveness space (StInt 0) `thenSUs` \ heap_chk ->
returnSUs (heap_chk .
(\xs -> a1 : a2 : a3 : a4 : a5 : a6
\end{code}
-Although gmpCompare doesn't allocate space, it does temporarily use some
-space just beyond the heap pointer. This is safe, because the enclosing
-routine has already guaranteed that this space will be available.
-(See ``primOpHeapRequired.'')
+Although gmpCompare doesn't allocate space, it does temporarily use
+some space just beyond the heap pointer. This is safe, because the
+enclosing routine has already guaranteed that this space will be
+available. (See ``primOpHeapRequired.'')
\begin{code}
gmpCompare
:: Target
-> CAddrMode -- result (boolean)
- -> [CAddrMode] -- arguments (3 parts each)
+ -> (CAddrMode,CAddrMode,CAddrMode,CAddrMode,CAddrMode,CAddrMode,CAddrMode)
+ -- alloc hp + 2 arguments (3 parts each)
-> SUniqSM StixTreeList
-gmpCompare target res args =
- let result = amodeToStix target res
- [hp, aa1,sa1,da1, aa2,sa2,da2] = map (amodeToStix target) args
+gmpCompare target_STRICT res args@(chp, caa1,csa1,cda1, caa2,csa2,cda2) =
+ let
+ a2stix = amodeToStix target
+ data_hs = dataHS target
+
+ result = a2stix res
+ hp = a2stix chp
+ aa1 = a2stix caa1
+ sa1 = a2stix csa1
+ da1 = a2stix cda1
+ aa2 = a2stix caa2
+ sa2 = a2stix csa2
+ da2 = a2stix cda2
+
argument1 = hp
argument2 = StIndex IntKind hp (StInt (toInteger mpIntSize))
- (a1,a2,a3) = toStruct target argument1 (aa1,sa1,da1)
- (a4,a5,a6) = toStruct target argument2 (aa2,sa2,da2)
+ (a1,a2,a3) = toStruct data_hs argument1 (aa1,sa1,da1)
+ (a4,a5,a6) = toStruct data_hs argument2 (aa2,sa2,da2)
mpz_cmp = StCall SLIT("mpz_cmp") IntKind [argument1, argument2]
r1 = StAssign IntKind result mpz_cmp
in
gmpInteger2Int
:: Target
-> CAddrMode -- result
- -> [CAddrMode] -- argument (3 parts)
+ -> (CAddrMode, CAddrMode,CAddrMode,CAddrMode) -- alloc hp + argument (3 parts)
-> SUniqSM StixTreeList
-gmpInteger2Int target res args =
- let result = amodeToStix target res
- [hp, aa,sa,da] = map (amodeToStix target) args
- (a1,a2,a3) = toStruct target hp (aa,sa,da)
+gmpInteger2Int target_STRICT res args@(chp, caa,csa,cda) =
+ let
+ a2stix = amodeToStix target
+ data_hs = dataHS target
+
+ result = a2stix res
+ hp = a2stix chp
+ aa = a2stix caa
+ sa = a2stix csa
+ da = a2stix cda
+
+ (a1,a2,a3) = toStruct data_hs hp (aa,sa,da)
mpz_get_si = StCall SLIT("mpz_get_si") IntKind [hp]
r1 = StAssign IntKind result mpz_get_si
in
gmpInt2Integer
:: Target
- -> [CAddrMode] -- result (3 parts)
- -> [CAddrMode] -- allocated heap, int to convert
+ -> (CAddrMode, CAddrMode, CAddrMode) -- result (3 parts)
+ -> (CAddrMode, CAddrMode) -- allocated heap, Int to convert
-> SUniqSM StixTreeList
-gmpInt2Integer target res args@[_, n] =
- getUniqLabelNCG `thenSUs` \ zlbl ->
- getUniqLabelNCG `thenSUs` \ nlbl ->
- getUniqLabelNCG `thenSUs` \ jlbl ->
- let [ar,sr,dr] = map (amodeToStix target) res
- [hp, i] = map (amodeToStix target) args
+gmpInt2Integer target_STRICT res@(car,csr,cdr) args@(chp, n) =
+ getUniqLabelNCG `thenSUs` \ zlbl ->
+ getUniqLabelNCG `thenSUs` \ nlbl ->
+ getUniqLabelNCG `thenSUs` \ jlbl ->
+ let
+ a2stix = amodeToStix target
+
+ ar = a2stix car
+ sr = a2stix csr
+ dr = a2stix cdr
+ hp = a2stix chp
+ i = a2stix n
+
h1 = StAssign PtrKind (StInd PtrKind hp) arrayOfData_info
size = varHeaderSize target (DataRep 0) + mIN_MP_INT_SIZE
h2 = StAssign IntKind (StInd IntKind (StIndex IntKind hp (StInt 1)))
gmpString2Integer
:: Target
- -> [CAddrMode] -- result (3 parts)
- -> [CAddrMode] -- liveness, string
+ -> (CAddrMode, CAddrMode, CAddrMode) -- result (3 parts)
+ -> (CAddrMode, CAddrMode) -- liveness, string
-> SUniqSM StixTreeList
-gmpString2Integer target res [liveness, str] =
+gmpString2Integer target_STRICT res@(car,csr,cdr) (liveness, str) =
getUniqLabelNCG `thenSUs` \ ulbl ->
- let [ar,sr,dr] = map (amodeToStix target) res
+ let
+ a2stix = amodeToStix target
+ data_hs = dataHS target
+
+ ar = a2stix car
+ sr = a2stix csr
+ dr = a2stix cdr
+
len = case str of
(CString s) -> _LENGTH_ s
(CLit (MachStr s)) -> _LENGTH_ s
save = StAssign PtrKind safeHp oldHp
result = StIndex IntKind stgHpLim (StInt (toInteger (-mpIntSize)))
set_str = StCall SLIT("mpz_init_set_str") IntKind
- [result, amodeToStix target str, StInt 10]
+ [result, a2stix str, StInt 10]
test = StPrim IntEqOp [set_str, StInt 0]
cjmp = StCondJump ulbl test
abort = StCall SLIT("abort") VoidKind []
join = StLabel ulbl
restore = StAssign PtrKind stgHp safeHp
- (a1,a2,a3) = fromStruct target result (ar,sr,dr)
+ (a1,a2,a3) = fromStruct data_hs result (ar,sr,dr)
in
macroCode target HEAP_CHK [liveness, mkIntCLit space, mkIntCLit_0]
`thenSUs` \ heap_chk ->
encodeFloatingKind
:: PrimKind
-> Target
- -> [CAddrMode] -- result
- -> [CAddrMode] -- heap pointer for result, integer argument (3 parts), exponent
+ -> CAddrMode -- result
+ -> (CAddrMode,CAddrMode,CAddrMode,CAddrMode,CAddrMode)
+ -- heap pointer for result, integer argument (3 parts), exponent
-> SUniqSM StixTreeList
-encodeFloatingKind pk target [res] args =
- let result = amodeToStix target res
- [hp, aa,sa,da, expon] = map (amodeToStix target) args
- pk' = if sizeof target FloatKind == sizeof target DoubleKind then DoubleKind
+encodeFloatingKind pk target_STRICT res args@(chp, caa,csa,cda, cexpon) =
+ let
+ a2stix = amodeToStix target
+ size_of = sizeof target
+ data_hs = dataHS target
+
+ result = a2stix res
+ hp = a2stix chp
+ aa = a2stix caa
+ sa = a2stix csa
+ da = a2stix cda
+ expon = a2stix cexpon
+
+ pk' = if size_of FloatKind == size_of DoubleKind
+ then DoubleKind
else pk
- (a1,a2,a3) = toStruct target hp (aa,sa,da)
+ (a1,a2,a3) = toStruct data_hs hp (aa,sa,da)
fn = case pk' of
FloatKind -> SLIT("__encodeFloat")
DoubleKind -> SLIT("__encodeDouble")
decodeFloatingKind
:: PrimKind
-> Target
- -> [CAddrMode] -- exponent result, integer result (3 parts)
- -> [CAddrMode] -- heap pointer for exponent, floating argument
+ -> (CAddrMode, CAddrMode, CAddrMode, CAddrMode)
+ -- exponent result, integer result (3 parts)
+ -> (CAddrMode, CAddrMode)
+ -- heap pointer for exponent, floating argument
-> SUniqSM StixTreeList
-decodeFloatingKind pk target res args =
- let [exponr,ar,sr,dr] = map (amodeToStix target) res
- [hp, arg] = map (amodeToStix target) args
- pk' = if sizeof target FloatKind == sizeof target DoubleKind then DoubleKind
+decodeFloatingKind pk target_STRICT res@(cexponr,car,csr,cdr) args@(chp, carg) =
+ let
+ a2stix = amodeToStix target
+ size_of = sizeof target
+ data_hs = dataHS target
+
+ exponr = a2stix cexponr
+ ar = a2stix car
+ sr = a2stix csr
+ dr = a2stix cdr
+ hp = a2stix chp
+ arg = a2stix carg
+
+ pk' = if size_of FloatKind == size_of DoubleKind
+ then DoubleKind
else pk
setup = StAssign PtrKind mpData_mantissa (StIndex IntKind hp (StInt 1))
fn = case pk' of
DoubleKind -> SLIT("__decodeDouble")
_ -> panic "decodeFloatingKind"
decode = StCall fn VoidKind [mantissa, hp, arg]
- (a1,a2,a3) = fromStruct target mantissa (ar,sr,dr)
+ (a1,a2,a3) = fromStruct data_hs mantissa (ar,sr,dr)
a4 = StAssign IntKind exponr (StInd IntKind hp)
in
returnSUs (\xs -> setup : decode : a1 : a2 : a3 : a4 : xs)
mpData base = StInd PtrKind (StIndex IntKind base (StInt 2))
mpSpace
- :: Target
+ :: StixTree -- dataHs from Target
-> Int -- gmp structures needed
-> Int -- number of results
-> [StixTree] -- sizes to add for estimating result size
-> StixTree -- total space
-mpSpace target gmp res sizes =
+mpSpace data_hs gmp res sizes =
foldr sum (StPrim IntAddOp [fixed, hdrs]) sizes
where
sum x y = StPrim IntAddOp [StPrim IntAbsOp [x], y]
fixed = StInt (toInteger (17 * res + gmp * mpIntSize))
- hdrs = StPrim IntMulOp [dataHS target, StInt (toInteger res)]
+ hdrs = StPrim IntMulOp [data_hs, StInt (toInteger res)]
\end{code}
which includes the space needed for these temporaries before you use them.
\begin{code}
-
mpStruct :: Int -> StixTree
mpStruct n = StIndex IntKind stgHpLim (StInt (toInteger (-(n * mpIntSize))))
toStruct
- :: Target
+ :: StixTree -- dataHS, from Target
-> StixTree
-> (StixTree, StixTree, StixTree)
-> (StixTree, StixTree, StixTree)
-toStruct target str (alloc,size,arr) =
+toStruct data_hs str (alloc,size,arr) =
let
f1 = StAssign IntKind (mpAlloc str) alloc
f2 = StAssign IntKind (mpSize str) size
- f3 = StAssign PtrKind (mpData str) (StIndex PtrKind arr (dataHS target))
+ f3 = StAssign PtrKind (mpData str) (StIndex PtrKind arr data_hs)
in
(f1, f2, f3)
fromStruct
- :: Target
+ :: StixTree -- dataHS, from Target
-> StixTree
-> (StixTree, StixTree, StixTree)
-> (StixTree, StixTree, StixTree)
-fromStruct target str (alloc,size,arr) =
+fromStruct data_hs str (alloc,size,arr) =
let
e1 = StAssign IntKind alloc (mpAlloc str)
e2 = StAssign IntKind size (mpSize str)
e3 = StAssign PtrKind arr (StIndex PtrKind (mpData str)
- (StPrim IntNegOp [dataHS target]))
+ (StPrim IntNegOp [data_hs]))
in
(e1, e2, e3)
-
-
\end{code}
projects / ghc-hetmet.git / blobdiff