X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=ghc%2Fcompiler%2FnativeGen%2FStixInteger.lhs;h=ef901f0808d8899392d0ba72de119766c563474b;hp=1051d26153c60efc972aa3632ebebf633f98d35d;hb=5eb1c77c795f92ed0f4c8023847e9d4be1a4fd0d;hpb=e7d21ee4f8ac907665a7e170c71d59e13a01da09 diff --git a/ghc/compiler/nativeGen/StixInteger.lhs b/ghc/compiler/nativeGen/StixInteger.lhs index 1051d26..ef901f0 100644 --- a/ghc/compiler/nativeGen/StixInteger.lhs +++ b/ghc/compiler/nativeGen/StixInteger.lhs @@ -1,305 +1,368 @@ % -% (c) The AQUA Project, Glasgow University, 1993-1995 +% (c) The AQUA Project, Glasgow University, 1993-1996 % \begin{code} #include "HsVersions.h" -module StixInteger ( - gmpTake1Return1, gmpTake2Return1, gmpTake2Return2, - gmpCompare, gmpInteger2Int, gmpInt2Integer, gmpString2Integer, - encodeFloatingKind, decodeFloatingKind +module StixInteger ( + gmpTake1Return1, gmpTake2Return1, gmpTake2Return2, gmpCompare, + gmpInteger2Int, gmpInt2Integer, gmpString2Integer, + encodeFloatingKind, decodeFloatingKind ) where -IMPORT_Trace -- ToDo: rm debugging - -import AbsCSyn -import CgCompInfo ( mIN_MP_INT_SIZE ) -import MachDesc -import Pretty -import AbsPrel ( PrimOp(..) - IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp) - IF_ATTACK_PRAGMAS(COMMA pprPrimOp) - ) -import SMRep ( SMRep(..), SMSpecRepKind, SMUpdateKind(..) ) -import Stix -import SplitUniq -import Unique -import Util - +IMP_Ubiq(){-uitous-} +IMPORT_DELOOPER(NcgLoop) ( amodeToStix ) + +import MachMisc +import MachRegs + +import AbsCSyn -- bits and bobs... +import CgCompInfo ( mIN_MP_INT_SIZE ) +import Literal ( Literal(..) ) +import OrdList ( OrdList ) +import PrimOp ( PrimOp(..) ) +import PrimRep ( PrimRep(..) ) +import SMRep ( SMRep(..), SMSpecRepKind, SMUpdateKind ) +import Stix ( getUniqLabelNCG, sStLitLbl, stgHp, stgHpLim, + StixTree(..), SYN_IE(StixTreeList), + CodeSegment, StixReg + ) +import StixMacro ( macroCode, heapCheck ) +import UniqSupply ( returnUs, thenUs, SYN_IE(UniqSM) ) +import Util ( panic ) \end{code} \begin{code} - -gmpTake1Return1 - :: Target - -> [CAddrMode] -- result (3 parts) - -> FAST_STRING -- function name - -> [CAddrMode] -- argument (3 parts) - -> SUniqSM StixTreeList +gmpTake1Return1 + :: (CAddrMode,CAddrMode,CAddrMode) -- result (3 parts) + -> FAST_STRING -- function name + -> (CAddrMode, CAddrMode,CAddrMode,CAddrMode) + -- argument (4 parts) + -> UniqSM StixTreeList argument1 = mpStruct 1 -- out here to avoid CAF (sigh) argument2 = mpStruct 2 result2 = mpStruct 2 result3 = mpStruct 3 result4 = mpStruct 4 -init2 = StCall SLIT("mpz_init") VoidKind [result2] -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] - 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) - mpz_op = StCall rtn VoidKind [result2, argument1] - restore = StAssign PtrKind stgHp safeHp - (r1,r2,r3) = fromStruct target result2 (ar,sr,dr) +init2 = StCall SLIT("mpz_init") VoidRep [result2] +init3 = StCall SLIT("mpz_init") VoidRep [result3] +init4 = StCall SLIT("mpz_init") VoidRep [result4] + +gmpTake1Return1 res@(car,csr,cdr) rtn arg@(clive,caa,csa,cda) + = let + ar = amodeToStix car + sr = amodeToStix csr + dr = amodeToStix cdr + liveness= amodeToStix clive + aa = amodeToStix caa + sa = amodeToStix csa + da = amodeToStix cda + + space = mpSpace 2 1 [sa] + oldHp = StIndex PtrRep stgHp (StPrim IntNegOp [space]) + safeHp = saveLoc Hp + save = StAssign PtrRep safeHp oldHp + (a1,a2,a3) = toStruct argument1 (aa,sa,da) + mpz_op = StCall rtn VoidRep [result2, argument1] + restore = StAssign PtrRep stgHp safeHp + (r1,r2,r3) = fromStruct result2 (ar,sr,dr) in - 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) - -> 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] - 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) - mpz_op = StCall rtn VoidKind [result3, argument1, argument2] - restore = StAssign PtrKind stgHp safeHp - (r1,r2,r3) = fromStruct target result3 (ar,sr,dr) + heapCheck liveness space (StInt 0) `thenUs` \ heap_chk -> + + returnUs (heap_chk . + (\xs -> a1 : a2 : a3 : save : init2 : mpz_op : r1 : r2 : r3 : restore : xs)) + +gmpTake2Return1 + :: (CAddrMode,CAddrMode,CAddrMode) -- result (3 parts) + -> FAST_STRING -- function name + -> (CAddrMode,CAddrMode,CAddrMode,CAddrMode,CAddrMode,CAddrMode,CAddrMode) + -- liveness + 2 arguments (3 parts each) + -> UniqSM StixTreeList + +gmpTake2Return1 res@(car,csr,cdr) rtn args@(clive, caa1,csa1,cda1, caa2,csa2,cda2) + = let + ar = amodeToStix car + sr = amodeToStix csr + dr = amodeToStix cdr + liveness= amodeToStix clive + aa1 = amodeToStix caa1 + sa1 = amodeToStix csa1 + da1 = amodeToStix cda1 + aa2 = amodeToStix caa2 + sa2 = amodeToStix csa2 + da2 = amodeToStix cda2 + + space = mpSpace 3 1 [sa1, sa2] + oldHp = StIndex PtrRep stgHp (StPrim IntNegOp [space]) + safeHp = saveLoc Hp + save = StAssign PtrRep safeHp oldHp + (a1,a2,a3) = toStruct argument1 (aa1,sa1,da1) + (a4,a5,a6) = toStruct argument2 (aa2,sa2,da2) + mpz_op = StCall rtn VoidRep [result3, argument1, argument2] + restore = StAssign PtrRep stgHp safeHp + (r1,r2,r3) = fromStruct result3 (ar,sr,dr) in - heapCheck target liveness space (StInt 0) - `thenSUs` \ heap_chk -> + heapCheck liveness space (StInt 0) `thenUs` \ heap_chk -> - returnSUs (heap_chk . - (\xs -> a1 : a2 : a3 : a4 : a5 : a6 - : save : init3 : mpz_op : r1 : r2 : r3 : restore : xs)) + returnUs (heap_chk . + (\xs -> a1 : a2 : a3 : a4 : a5 : a6 + : save : init3 : mpz_op : r1 : r2 : r3 : restore : xs)) 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) - -> 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] - 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) - 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) + -> (CAddrMode,CAddrMode,CAddrMode,CAddrMode,CAddrMode,CAddrMode,CAddrMode) + -- liveness + 2 arguments (3 parts each) + -> UniqSM StixTreeList + +gmpTake2Return2 res@(car1,csr1,cdr1, car2,csr2,cdr2) + rtn args@(clive, caa1,csa1,cda1, caa2,csa2,cda2) + = let + ar1 = amodeToStix car1 + sr1 = amodeToStix csr1 + dr1 = amodeToStix cdr1 + ar2 = amodeToStix car2 + sr2 = amodeToStix csr2 + dr2 = amodeToStix cdr2 + liveness= amodeToStix clive + aa1 = amodeToStix caa1 + sa1 = amodeToStix csa1 + da1 = amodeToStix cda1 + aa2 = amodeToStix caa2 + sa2 = amodeToStix csa2 + da2 = amodeToStix cda2 + + space = StPrim IntMulOp [mpSpace 2 1 [sa1, sa2], StInt 2] + oldHp = StIndex PtrRep stgHp (StPrim IntNegOp [space]) + safeHp = saveLoc Hp + save = StAssign PtrRep safeHp oldHp + (a1,a2,a3) = toStruct argument1 (aa1,sa1,da1) + (a4,a5,a6) = toStruct argument2 (aa2,sa2,da2) + mpz_op = StCall rtn VoidRep [result3, result4, argument1, argument2] + restore = StAssign PtrRep stgHp safeHp + (r1,r2,r3) = fromStruct result3 (ar1,sr1,dr1) + (r4,r5,r6) = fromStruct result4 (ar2,sr2,dr2) in - heapCheck target liveness space (StInt 0) - `thenSUs` \ heap_chk -> - - returnSUs (heap_chk . - (\xs -> a1 : a2 : a3 : a4 : a5 : a6 - : save : init3 : init4 : mpz_op - : r1 : r2 : r3 : r4 : r5 : r6 : restore : xs)) + heapCheck liveness space (StInt 0) `thenUs` \ heap_chk -> + returnUs (heap_chk . + (\xs -> a1 : a2 : a3 : a4 : a5 : a6 + : save : init3 : init4 : mpz_op + : r1 : r2 : r3 : r4 : r5 : r6 : restore : xs)) \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 + :: CAddrMode -- result (boolean) + -> (CAddrMode,CAddrMode,CAddrMode,CAddrMode,CAddrMode,CAddrMode,CAddrMode) + -- alloc hp + 2 arguments (3 parts each) + -> UniqSM StixTreeList + +gmpCompare res args@(chp, caa1,csa1,cda1, caa2,csa2,cda2) + = let + result = amodeToStix res + hp = amodeToStix chp + aa1 = amodeToStix caa1 + sa1 = amodeToStix csa1 + da1 = amodeToStix cda1 + aa2 = amodeToStix caa2 + sa2 = amodeToStix csa2 + da2 = amodeToStix cda2 -gmpCompare - :: Target - -> CAddrMode -- result (boolean) - -> [CAddrMode] -- 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 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) - mpz_cmp = StCall SLIT("mpz_cmp") IntKind [argument1, argument2] - r1 = StAssign IntKind result mpz_cmp + argument2 = StIndex IntRep hp (StInt (toInteger mpIntSize)) + (a1,a2,a3) = toStruct argument1 (aa1,sa1,da1) + (a4,a5,a6) = toStruct argument2 (aa2,sa2,da2) + mpz_cmp = StCall SLIT("mpz_cmp") IntRep [argument1, argument2] + r1 = StAssign IntRep result mpz_cmp in - returnSUs (\xs -> a1 : a2 : a3 : a4 : a5 : a6 : r1 : xs) - + returnUs (\xs -> a1 : a2 : a3 : a4 : a5 : a6 : r1 : xs) \end{code} See the comment above regarding the heap check (or lack thereof). \begin{code} - -gmpInteger2Int - :: Target - -> CAddrMode -- result - -> [CAddrMode] -- 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) - mpz_get_si = StCall SLIT("mpz_get_si") IntKind [hp] - r1 = StAssign IntKind result mpz_get_si +gmpInteger2Int + :: CAddrMode -- result + -> (CAddrMode, CAddrMode,CAddrMode,CAddrMode) -- alloc hp + argument (3 parts) + -> UniqSM StixTreeList + +gmpInteger2Int res args@(chp, caa,csa,cda) + = let + result = amodeToStix res + hp = amodeToStix chp + aa = amodeToStix caa + sa = amodeToStix csa + da = amodeToStix cda + + (a1,a2,a3) = toStruct hp (aa,sa,da) + mpz_get_si = StCall SLIT("mpz_get_si") IntRep [hp] + r1 = StAssign IntRep result mpz_get_si in - returnSUs (\xs -> a1 : a2 : a3 : r1 : xs) + returnUs (\xs -> a1 : a2 : a3 : r1 : xs) arrayOfData_info = sStLitLbl SLIT("ArrayOfData_info") -gmpInt2Integer - :: Target - -> [CAddrMode] -- result (3 parts) - -> [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 - 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))) - (StInt (toInteger size)) - cts = StInd IntKind (StIndex IntKind hp (dataHS target)) - test1 = StPrim IntEqOp [i, StInt 0] - test2 = StPrim IntLtOp [i, StInt 0] - cjmp1 = StCondJump zlbl test1 - cjmp2 = StCondJump nlbl test2 +-------------- +gmpInt2Integer + :: (CAddrMode, CAddrMode, CAddrMode) -- result (3 parts) + -> (CAddrMode, CAddrMode) -- allocated heap, Int to convert + -> UniqSM StixTreeList + +gmpInt2Integer res@(car,csr,cdr) args@(chp, n) + = getUniqLabelNCG `thenUs` \ zlbl -> + getUniqLabelNCG `thenUs` \ nlbl -> + getUniqLabelNCG `thenUs` \ jlbl -> + let + ar = amodeToStix car + sr = amodeToStix csr + dr = amodeToStix cdr + hp = amodeToStix chp + i = amodeToStix n + + h1 = StAssign PtrRep (StInd PtrRep hp) arrayOfData_info + size = varHdrSizeInWords (DataRep 0) + mIN_MP_INT_SIZE + h2 = StAssign IntRep (StInd IntRep (StIndex IntRep hp (StInt 1))) + (StInt (toInteger size)) + cts = StInd IntRep (StIndex IntRep hp dataHS) + test1 = StPrim IntEqOp [i, StInt 0] + test2 = StPrim IntLtOp [i, StInt 0] + cjmp1 = StCondJump zlbl test1 + cjmp2 = StCondJump nlbl test2 -- positive - p1 = StAssign IntKind cts i - p2 = StAssign IntKind sr (StInt 1) - p3 = StJump (StCLbl jlbl) + p1 = StAssign IntRep cts i + p2 = StAssign IntRep sr (StInt 1) + p3 = StJump (StCLbl jlbl) -- negative - n0 = StLabel nlbl - n1 = StAssign IntKind cts (StPrim IntNegOp [i]) - n2 = StAssign IntKind sr (StInt (-1)) - n3 = StJump (StCLbl jlbl) + n0 = StLabel nlbl + n1 = StAssign IntRep cts (StPrim IntNegOp [i]) + n2 = StAssign IntRep sr (StInt (-1)) + n3 = StJump (StCLbl jlbl) -- zero - z0 = StLabel zlbl - z1 = StAssign IntKind sr (StInt 0) - -- everybody - a0 = StLabel jlbl - a1 = StAssign IntKind ar (StInt 1) - a2 = StAssign PtrKind dr hp + z0 = StLabel zlbl + z1 = StAssign IntRep sr (StInt 0) + -- everybody + a0 = StLabel jlbl + a1 = StAssign IntRep ar (StInt 1) + a2 = StAssign PtrRep dr hp in - returnSUs (\xs -> - case n of - CLit (MachInt c _) -> - if c == 0 then h1 : h2 : z1 : a1 : a2 : xs - else if c > 0 then h1 : h2 : p1 : p2 : a1 : a2 : xs - else h1 : h2 : n1 : n2 : a1 : a2 : xs - _ -> h1 : h2 : cjmp1 : cjmp2 : p1 : p2 : p3 - : n0 : n1 : n2 : n3 : z0 : z1 - : a0 : a1 : a2 : xs) - -gmpString2Integer - :: Target - -> [CAddrMode] -- result (3 parts) - -> [CAddrMode] -- liveness, string - -> SUniqSM StixTreeList - -gmpString2Integer target res [liveness, str] = - getUniqLabelNCG `thenSUs` \ ulbl -> - let [ar,sr,dr] = map (amodeToStix target) res + returnUs (\xs -> + case n of + CLit (MachInt c _) -> + if c == 0 then h1 : h2 : z1 : a1 : a2 : xs + else if c > 0 then h1 : h2 : p1 : p2 : a1 : a2 : xs + else h1 : h2 : n1 : n2 : a1 : a2 : xs + _ -> h1 : h2 : cjmp1 : cjmp2 : p1 : p2 : p3 + : n0 : n1 : n2 : n3 : z0 : z1 + : a0 : a1 : a2 : xs) + +gmpString2Integer + :: (CAddrMode, CAddrMode, CAddrMode) -- result (3 parts) + -> (CAddrMode, CAddrMode) -- liveness, string + -> UniqSM StixTreeList + +gmpString2Integer res@(car,csr,cdr) (liveness, str) + = getUniqLabelNCG `thenUs` \ ulbl -> + let + ar = amodeToStix car + sr = amodeToStix csr + dr = amodeToStix cdr + len = case str of (CString s) -> _LENGTH_ s (CLit (MachStr s)) -> _LENGTH_ s _ -> panic "String2Integer" space = len `quot` 8 + 17 + mpIntSize + - varHeaderSize target (DataRep 0) + fixedHeaderSize target - oldHp = StIndex PtrKind stgHp (StInt (toInteger (-space))) - safeHp = saveLoc target Hp - 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] + varHdrSizeInWords (DataRep 0) + fixedHdrSizeInWords + oldHp = StIndex PtrRep stgHp (StInt (toInteger (-space))) + safeHp = saveLoc Hp + save = StAssign PtrRep safeHp oldHp + result = StIndex IntRep stgHpLim (StInt (toInteger (-mpIntSize))) + set_str = StCall SLIT("mpz_init_set_str") IntRep + [result, amodeToStix str, StInt 10] test = StPrim IntEqOp [set_str, StInt 0] cjmp = StCondJump ulbl test - abort = StCall SLIT("abort") VoidKind [] + abort = StCall SLIT("abort") VoidRep [] join = StLabel ulbl - restore = StAssign PtrKind stgHp safeHp - (a1,a2,a3) = fromStruct target result (ar,sr,dr) + restore = StAssign PtrRep stgHp safeHp + (a1,a2,a3) = fromStruct result (ar,sr,dr) in - macroCode target HEAP_CHK [liveness, mkIntCLit space, mkIntCLit_0] - `thenSUs` \ heap_chk -> + macroCode HEAP_CHK [liveness, mkIntCLit space, mkIntCLit_0] + `thenUs` \ heap_chk -> - returnSUs (heap_chk . - (\xs -> save : cjmp : abort : join : a1 : a2 : a3 : restore : xs)) + returnUs (heap_chk . + (\xs -> save : cjmp : abort : join : a1 : a2 : a3 : restore : xs)) mkIntCLit_0 = mkIntCLit 0 -- out here to avoid CAF (sigh) -encodeFloatingKind - :: PrimKind - -> Target - -> [CAddrMode] -- result - -> [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 - else pk - (a1,a2,a3) = toStruct target hp (aa,sa,da) +encodeFloatingKind + :: PrimRep + -> CAddrMode -- result + -> (CAddrMode,CAddrMode,CAddrMode,CAddrMode,CAddrMode) + -- heap pointer for result, integer argument (3 parts), exponent + -> UniqSM StixTreeList + +encodeFloatingKind pk res args@(chp, caa,csa,cda, cexpon) + = let + result = amodeToStix res + hp = amodeToStix chp + aa = amodeToStix caa + sa = amodeToStix csa + da = amodeToStix cda + expon = amodeToStix cexpon + + pk' = if sizeOf FloatRep == sizeOf DoubleRep + then DoubleRep + else pk + (a1,a2,a3) = toStruct hp (aa,sa,da) fn = case pk' of - FloatKind -> SLIT("__encodeFloat") - DoubleKind -> SLIT("__encodeDouble") + FloatRep -> SLIT("__encodeFloat") + DoubleRep -> SLIT("__encodeDouble") _ -> panic "encodeFloatingKind" encode = StCall fn pk' [hp, expon] r1 = StAssign pk' result encode in - returnSUs (\xs -> a1 : a2 : a3 : r1 : xs) - -decodeFloatingKind - :: PrimKind - -> Target - -> [CAddrMode] -- exponent result, integer result (3 parts) - -> [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 - else pk - setup = StAssign PtrKind mpData_mantissa (StIndex IntKind hp (StInt 1)) + returnUs (\xs -> a1 : a2 : a3 : r1 : xs) + +decodeFloatingKind + :: PrimRep + -> (CAddrMode, CAddrMode, CAddrMode, CAddrMode) + -- exponent result, integer result (3 parts) + -> (CAddrMode, CAddrMode) + -- heap pointer for exponent, floating argument + -> UniqSM StixTreeList + +decodeFloatingKind pk res@(cexponr,car,csr,cdr) args@(chp, carg) + = let + exponr = amodeToStix cexponr + ar = amodeToStix car + sr = amodeToStix csr + dr = amodeToStix cdr + hp = amodeToStix chp + arg = amodeToStix carg + + pk' = if sizeOf FloatRep == sizeOf DoubleRep + then DoubleRep + else pk + setup = StAssign PtrRep mpData_mantissa (StIndex IntRep hp (StInt 1)) fn = case pk' of - FloatKind -> SLIT("__decodeFloat") - DoubleKind -> SLIT("__decodeDouble") + FloatRep -> SLIT("__decodeFloat") + DoubleRep -> SLIT("__decodeDouble") _ -> panic "decodeFloatingKind" - decode = StCall fn VoidKind [mantissa, hp, arg] - (a1,a2,a3) = fromStruct target mantissa (ar,sr,dr) - a4 = StAssign IntKind exponr (StInd IntKind hp) + decode = StCall fn VoidRep [mantissa, hp, arg] + (a1,a2,a3) = fromStruct mantissa (ar,sr,dr) + a4 = StAssign IntRep exponr (StInd IntRep hp) in - returnSUs (\xs -> setup : decode : a1 : a2 : a3 : a4 : xs) + returnUs (\xs -> setup : decode : a1 : a2 : a3 : a4 : xs) mantissa = mpStruct 1 -- out here to avoid CAF (sigh) mpData_mantissa = mpData mantissa @@ -308,69 +371,62 @@ mpData_mantissa = mpData mantissa Support for the Gnu GMP multi-precision package. \begin{code} - mpIntSize = 3 :: Int mpAlloc, mpSize, mpData :: StixTree -> StixTree -mpAlloc base = StInd IntKind base -mpSize base = StInd IntKind (StIndex IntKind base (StInt 1)) -mpData base = StInd PtrKind (StIndex IntKind base (StInt 2)) +mpAlloc base = StInd IntRep base +mpSize base = StInd IntRep (StIndex IntRep base (StInt 1)) +mpData base = StInd PtrRep (StIndex IntRep base (StInt 2)) -mpSpace - :: Target - -> Int -- gmp structures needed +mpSpace + :: Int -- gmp structures needed -> Int -- number of results -> [StixTree] -- sizes to add for estimating result size -> StixTree -- total space -mpSpace target gmp res sizes = - foldr sum (StPrim IntAddOp [fixed, hdrs]) sizes +mpSpace 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 [dataHS, StInt (toInteger res)] \end{code} -We don't have a truly portable way of allocating local temporaries, so we -cheat and use space at the end of the heap. (Thus, negative offsets from -HpLim are our temporaries.) Note that you must have performed a heap check -which includes the space needed for these temporaries before you use them. +We don't have a truly portable way of allocating local temporaries, so +we cheat and use space at the end of the heap. (Thus, negative +offsets from HpLim are our temporaries.) Note that you must have +performed a heap check 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 - -> (StixTree, StixTree, StixTree) - -> (StixTree, StixTree, StixTree) - -toStruct target 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)) +mpStruct n = StIndex IntRep stgHpLim (StInt (toInteger (-(n * mpIntSize)))) + +toStruct + :: StixTree + -> (StixTree, StixTree, StixTree) + -> (StixTree, StixTree, StixTree) + +toStruct str (alloc,size,arr) + = let + f1 = StAssign IntRep (mpAlloc str) alloc + f2 = StAssign IntRep (mpSize str) size + f3 = StAssign PtrRep (mpData str) (StIndex PtrRep arr dataHS) in - (f1, f2, f3) - -fromStruct - :: Target - -> StixTree - -> (StixTree, StixTree, StixTree) - -> (StixTree, StixTree, StixTree) - -fromStruct target 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])) + (f1, f2, f3) + +fromStruct + :: StixTree + -> (StixTree, StixTree, StixTree) + -> (StixTree, StixTree, StixTree) + +fromStruct str (alloc,size,arr) + = let + e1 = StAssign IntRep alloc (mpAlloc str) + e2 = StAssign IntRep size (mpSize str) + e3 = StAssign PtrRep arr (StIndex PtrRep (mpData str) + (StPrim IntNegOp [dataHS])) in - (e1, e2, e3) - - + (e1, e2, e3) \end{code}