X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FnativeGen%2FStixInteger.lhs;h=6b9ad9c113952ec642ff41c369bad1964eaad8a4;hb=438596897ebbe25a07e1c82085cfbc5bdb00f09e;hp=a019c521406241deb760c055959d85d5e2d693c8;hpb=26741ec416bae2c502ef00a2ba0e79050a32cb67;p=ghc-hetmet.git diff --git a/ghc/compiler/nativeGen/StixInteger.lhs b/ghc/compiler/nativeGen/StixInteger.lhs index a019c52..6b9ad9c 100644 --- a/ghc/compiler/nativeGen/StixInteger.lhs +++ b/ghc/compiler/nativeGen/StixInteger.lhs @@ -1,158 +1,30 @@ % -% (c) The AQUA Project, Glasgow University, 1993-1996 +% (c) The AQUA Project, Glasgow University, 1993-1998 % \begin{code} -#include "HsVersions.h" - -module StixInteger ( - gmpTake1Return1, gmpTake2Return1, gmpTake2Return2, gmpCompare, - gmpInteger2Int, gmpInt2Integer, gmpString2Integer, - encodeFloatingKind, decodeFloatingKind - ) where +module StixInteger ( + gmpCompare, + gmpInteger2Int, + gmpInteger2Word, + gmpNegate + ) where -IMP_Ubiq(){-uitous-} -IMPORT_DELOOPER(NcgLoop) ( amodeToStix ) +#include "HsVersions.h" +import {-# SOURCE #-} StixPrim ( amodeToStix ) import MachMisc import MachRegs -import AbsCSyn -- bits and bobs... -import CgCompInfo ( mIN_MP_INT_SIZE ) -import Literal ( Literal(..) ) +import AbsCSyn hiding (spRel) -- bits and bobs.. +import Const ( Literal(..) ) +import CallConv ( cCallConv ) import OrdList ( OrdList ) import PrimOp ( PrimOp(..) ) import PrimRep ( PrimRep(..) ) -import SMRep ( SMRep(..), SMSpecRepKind, SMUpdateKind ) -import Stix ( getUniqLabelNCG, sStLitLbl, stgHp, stgHpLim, - StixTree(..), StixTreeList(..), - CodeSegment, StixReg - ) -import StixMacro ( macroCode, heapCheck ) -import UniqSupply ( returnUs, thenUs, SYN_IE(UniqSM) ) -import Util ( panic ) -\end{code} - -\begin{code} -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") 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 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 liveness space (StInt 0) `thenUs` \ heap_chk -> - - returnUs (heap_chk . - (\xs -> a1 : a2 : a3 : a4 : a5 : a6 - : save : init3 : mpz_op : r1 : r2 : r3 : restore : xs)) - -gmpTake2Return2 - :: (CAddrMode,CAddrMode,CAddrMode,CAddrMode,CAddrMode,CAddrMode) - -- 2 results (3 parts each) - -> FAST_STRING -- function name - -> (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 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)) +import SMRep ( arrHdrSize ) +import Stix ( sStLitLbl, StixTree(..), StixTreeList ) +import UniqSupply ( returnUs, thenUs, UniqSM ) \end{code} Although gmpCompare doesn't allocate space, it does temporarily use @@ -163,14 +35,15 @@ available. (See ``primOpHeapRequired.'') \begin{code} gmpCompare :: CAddrMode -- result (boolean) - -> (CAddrMode,CAddrMode,CAddrMode,CAddrMode,CAddrMode,CAddrMode,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) +gmpCompare res args@(caa1,csa1,cda1, caa2,csa2,cda2) = let result = amodeToStix res - hp = amodeToStix chp + scratch1 = scratch_space + scratch2 = StIndex IntRep scratch_space (StInt (toInteger mpIntSize)) aa1 = amodeToStix caa1 sa1 = amodeToStix csa1 da1 = amodeToStix cda1 @@ -178,230 +51,84 @@ gmpCompare res args@(chp, caa1,csa1,cda1, caa2,csa2,cda2) sa2 = amodeToStix csa2 da2 = amodeToStix cda2 - argument1 = hp - 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] + (a1,a2,a3) = toStruct scratch1 (aa1,sa1,da1) + (a4,a5,a6) = toStruct scratch2 (aa2,sa2,da2) + mpz_cmp = StCall SLIT("mpz_cmp") cCallConv IntRep [scratch1, scratch2] r1 = StAssign IntRep result mpz_cmp in 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 :: CAddrMode -- result - -> (CAddrMode, CAddrMode,CAddrMode,CAddrMode) -- alloc hp + argument (3 parts) + -> (CAddrMode,CAddrMode,CAddrMode) -- alloc hp + argument (3 parts) -> UniqSM StixTreeList -gmpInteger2Int res args@(chp, caa,csa,cda) +gmpInteger2Int res args@(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] + (a1,a2,a3) = toStruct scratch_space (aa,sa,da) + mpz_get_si = StCall SLIT("mpz_get_si") cCallConv IntRep [scratch_space] r1 = StAssign IntRep result mpz_get_si in returnUs (\xs -> a1 : a2 : a3 : r1 : xs) -arrayOfData_info = sStLitLbl SLIT("ArrayOfData_info") - --------------- -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 IntRep cts i - p2 = StAssign IntRep sr (StInt 1) - p3 = StJump (StCLbl jlbl) - -- negative - 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 IntRep sr (StInt 0) - -- everybody - a0 = StLabel jlbl - a1 = StAssign IntRep ar (StInt 1) - a2 = StAssign PtrRep dr hp - in - 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 + - 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") VoidRep [] - join = StLabel ulbl - restore = StAssign PtrRep stgHp safeHp - (a1,a2,a3) = fromStruct result (ar,sr,dr) - in - macroCode HEAP_CHK [liveness, mkIntCLit space, mkIntCLit_0] - `thenUs` \ heap_chk -> - - returnUs (heap_chk . - (\xs -> save : cjmp : abort : join : a1 : a2 : a3 : restore : xs)) - -mkIntCLit_0 = mkIntCLit 0 -- out here to avoid CAF (sigh) - -encodeFloatingKind - :: PrimRep - -> CAddrMode -- result - -> (CAddrMode,CAddrMode,CAddrMode,CAddrMode,CAddrMode) - -- heap pointer for result, integer argument (3 parts), exponent +gmpInteger2Word + :: CAddrMode -- result + -> (CAddrMode,CAddrMode,CAddrMode) -- alloc hp + argument (3 parts) -> UniqSM StixTreeList -encodeFloatingKind pk res args@(chp, caa,csa,cda, cexpon) +gmpInteger2Word res args@(caa,csa,cda) = let - result = amodeToStix res - hp = amodeToStix chp + result = amodeToStix res 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 - FloatRep -> SLIT("__encodeFloat") - DoubleRep -> SLIT("__encodeDouble") - _ -> panic "encodeFloatingKind" - encode = StCall fn pk' [hp, expon] - r1 = StAssign pk' result encode + (a1,a2,a3) = toStruct scratch_space (aa,sa,da) + mpz_get_ui = StCall SLIT("mpz_get_ui") cCallConv IntRep [scratch_space] + r1 = StAssign WordRep result mpz_get_ui in 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 +gmpNegate + :: (CAddrMode,CAddrMode,CAddrMode) -- result + -> (CAddrMode,CAddrMode,CAddrMode) -- argument (3 parts) -> UniqSM StixTreeList -decodeFloatingKind pk res@(cexponr,car,csr,cdr) args@(chp, carg) +gmpNegate (rca, rcs, rcd) args@(ca, cs, cd) = 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 - FloatRep -> SLIT("__decodeFloat") - DoubleRep -> SLIT("__decodeDouble") - _ -> panic "decodeFloatingKind" - decode = StCall fn VoidRep [mantissa, hp, arg] - (a1,a2,a3) = fromStruct mantissa (ar,sr,dr) - a4 = StAssign IntRep exponr (StInd IntRep hp) + a = amodeToStix ca + s = amodeToStix cs + d = amodeToStix cd + ra = amodeToStix rca + rs = amodeToStix rcs + rd = amodeToStix rcd + a1 = StAssign IntRep ra a + a2 = StAssign IntRep rs (StPrim IntNegOp [s]) + a3 = StAssign PtrRep rd d in - returnUs (\xs -> setup : decode : a1 : a2 : a3 : a4 : xs) - -mantissa = mpStruct 1 -- out here to avoid CAF (sigh) -mpData_mantissa = mpData mantissa + returnUs (\xs -> a1 : a2 : a3 : xs) \end{code} Support for the Gnu GMP multi-precision package. \begin{code} +-- size (in words) of __MP_INT mpIntSize = 3 :: Int mpAlloc, mpSize, mpData :: StixTree -> StixTree mpAlloc base = StInd IntRep base mpSize base = StInd IntRep (StIndex IntRep base (StInt 1)) mpData base = StInd PtrRep (StIndex IntRep base (StInt 2)) - -mpSpace - :: Int -- gmp structures needed - -> Int -- number of results - -> [StixTree] -- sizes to add for estimating result size - -> StixTree -- total space - -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, 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. - \begin{code} -mpStruct :: Int -> StixTree -mpStruct n = StIndex IntRep stgHpLim (StInt (toInteger (-(n * mpIntSize)))) - toStruct :: StixTree -> (StixTree, StixTree, StixTree) @@ -411,22 +138,11 @@ 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) + f3 = StAssign PtrRep (mpData str) + (StIndex PtrRep arr (StInt (toInteger arrHdrSize))) in (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) +scratch_space = sStLitLbl SLIT("stg_scratch_space") \end{code}