[project @ 2000-03-23 17:45:17 by simonpj]

[ghc-hetmet.git] / ghc / compiler / nativeGen / StixInteger.lhs

diff --git a/ghc/compiler/nativeGen/StixInteger.lhs b/ghc/compiler/nativeGen/StixInteger.lhs
index 044548c..8748879 100644 (file)
--- a/ghc/compiler/nativeGen/StixInteger.lhs
+++ b/ghc/compiler/nativeGen/StixInteger.lhs
@@ -5,9 +5,10 @@
 \begin{code}
 module StixInteger ( 
        gmpCompare, 
+        gmpCompareInt,
        gmpInteger2Int, 
        gmpInteger2Word,
-       gmpNegate 
+       gmpNegate
        ) where
 
 #include "HsVersions.h"
@@ -17,13 +18,12 @@ import MachMisc
 import MachRegs
 
 import AbsCSyn         hiding (spRel) -- bits and bobs..
-import Const           ( Literal(..) )
+import Literal         ( Literal(..) )
 import CallConv                ( cCallConv )
-import OrdList         ( OrdList )
 import PrimOp          ( PrimOp(..) )
 import PrimRep         ( PrimRep(..) )
 import SMRep           ( arrWordsHdrSize )
-import Stix            ( sStLitLbl, StixTree(..), StixTreeList )
+import Stix            ( sStLitLbl, StixTree(..), StixTreeList, arrWordsHS )
 import UniqSupply      ( returnUs, thenUs, UniqSM )
 \end{code}
 
@@ -33,23 +33,30 @@ enclosing routine has already guaranteed that this space will be
 available.  (See ``primOpHeapRequired.'')
 
 \begin{code}
+stgArrWords__words        :: StixTree -> StixTree
+stgArrWords__BYTE_ARR_CTS :: StixTree -> StixTree
+
+stgArrWords__BYTE_ARR_CTS arr 
+   = StIndex WordRep arr arrWordsHS
+stgArrWords__words        arr 
+   = case arrWordsHS of 
+        StInt i -> StInd WordRep (StIndex PtrRep arr (StInt (i-1)))
+
 gmpCompare
     :: CAddrMode           -- result (boolean)
-    -> (CAddrMode,CAddrMode,CAddrMode,CAddrMode,CAddrMode,CAddrMode)
-                           -- alloc hp + 2 arguments (3 parts each)
+    -> (CAddrMode,CAddrMode,CAddrMode,CAddrMode)
+                           -- alloc hp + 2 arguments (2 parts each)
     -> UniqSM StixTreeList
 
-gmpCompare res args@(caa1,csa1,cda1, caa2,csa2,cda2)
+gmpCompare res args@(csa1,cda1, csa2,cda2)
   = let
        result  = amodeToStix res
-       scratch1 = scratch_space
-       scratch2 = StIndex IntRep scratch_space (StInt (toInteger mpIntSize))
-       aa1     = amodeToStix caa1
        sa1     = amodeToStix csa1
-       da1     = amodeToStix cda1
-       aa2     = amodeToStix caa2
        sa2     = amodeToStix csa2
-       da2     = amodeToStix cda2
+       aa1     = stgArrWords__words (amodeToStix cda1)
+       aa2     = stgArrWords__words (amodeToStix cda2)
+       da1     = stgArrWords__BYTE_ARR_CTS (amodeToStix cda1)
+       da2     = stgArrWords__BYTE_ARR_CTS (amodeToStix cda2)
 
        (a1,a2,a3) = toStruct scratch1 (aa1,sa1,da1)
        (a4,a5,a6) = toStruct scratch2 (aa2,sa2,da2)
@@ -57,58 +64,77 @@ gmpCompare res args@(caa1,csa1,cda1, caa2,csa2,cda2)
        r1 = StAssign IntRep result mpz_cmp
     in
     returnUs (\xs -> a1 : a2 : a3 : a4 : a5 : a6 : r1 : xs)
+
+
+gmpCompareInt
+    :: CAddrMode           -- result (boolean)
+    -> (CAddrMode,CAddrMode,CAddrMode)
+    -> UniqSM StixTreeList  -- alloc hp + 1 arg (??)
+
+gmpCompareInt res args@(csa1,cda1, cai)
+  = let
+       result   = amodeToStix res
+       sa1      = amodeToStix csa1
+       aa1      = stgArrWords__words (amodeToStix cda1)
+       da1      = stgArrWords__BYTE_ARR_CTS (amodeToStix cda1)
+        ai       = amodeToStix cai
+       (a1,a2,a3) = toStruct scratch1 (aa1,sa1,da1)
+       mpz_cmp_si = StCall SLIT("mpz_cmp_si") cCallConv IntRep [scratch1, ai]
+       r1 = StAssign IntRep result mpz_cmp_si
+    in
+    returnUs (\xs -> a1 : a2 : a3 : r1 : xs)
 \end{code}
 
 \begin{code}
 gmpInteger2Int
     :: CAddrMode           -- result
-    -> (CAddrMode,CAddrMode,CAddrMode) -- alloc hp + argument (3 parts)
+    -> (CAddrMode,CAddrMode) -- alloc hp + argument (2 parts)
     -> UniqSM StixTreeList
 
-gmpInteger2Int res args@(caa,csa,cda)
+gmpInteger2Int res args@(csa,cda)
   = let
        result  = amodeToStix res
-       aa      = amodeToStix caa
        sa      = amodeToStix csa
-       da      = amodeToStix cda
+       aa      = stgArrWords__words (amodeToStix cda)
+       da      = stgArrWords__BYTE_ARR_CTS (amodeToStix cda)
 
-       (a1,a2,a3) = toStruct scratch_space (aa,sa,da)
-       mpz_get_si = StCall SLIT("mpz_get_si") cCallConv IntRep [scratch_space]
+       (a1,a2,a3) = toStruct scratch1 (aa,sa,da)
+       mpz_get_si = StCall SLIT("mpz_get_si") cCallConv IntRep [scratch1]
        r1 = StAssign IntRep result mpz_get_si
     in
     returnUs (\xs -> a1 : a2 : a3 : r1 : xs)
 
 gmpInteger2Word
     :: CAddrMode           -- result
-    -> (CAddrMode,CAddrMode,CAddrMode) -- alloc hp + argument (3 parts)
+    -> (CAddrMode,CAddrMode) -- alloc hp + argument (2 parts)
     -> UniqSM StixTreeList
 
-gmpInteger2Word res args@(caa,csa,cda)
+gmpInteger2Word res args@(csa,cda)
   = let
        result  = amodeToStix res
-       aa      = amodeToStix caa
        sa      = amodeToStix csa
-       da      = amodeToStix cda
+       aa      = stgArrWords__words (amodeToStix cda)
+       da      = stgArrWords__BYTE_ARR_CTS (amodeToStix cda)
 
-       (a1,a2,a3) = toStruct scratch_space (aa,sa,da)
-       mpz_get_ui = StCall SLIT("mpz_get_ui") cCallConv IntRep [scratch_space]
+       (a1,a2,a3) = toStruct scratch1 (aa,sa,da)
+       mpz_get_ui = StCall SLIT("mpz_get_ui") cCallConv IntRep [scratch1]
        r1 = StAssign WordRep result mpz_get_ui
     in
     returnUs (\xs -> a1 : a2 : a3 : r1 : xs)
 
 gmpNegate
-    :: (CAddrMode,CAddrMode,CAddrMode) -- result
-    -> (CAddrMode,CAddrMode,CAddrMode) -- argument (3 parts)
+    :: (CAddrMode,CAddrMode) -- result
+    -> (CAddrMode,CAddrMode) -- argument (2 parts)
     -> UniqSM StixTreeList
 
-gmpNegate (rca, rcs, rcd) args@(ca, cs, cd)
+gmpNegate (rcs, rcd) args@(cs, cd)
   = let
-       a       = amodeToStix ca
        s       = amodeToStix cs
-       d       = amodeToStix cd
-       ra      = amodeToStix rca
+       a       = stgArrWords__words (amodeToStix cd)
+       d       = stgArrWords__BYTE_ARR_CTS (amodeToStix cd)
        rs      = amodeToStix rcs
-       rd      = amodeToStix rcd
+       ra      = stgArrWords__words (amodeToStix rcd)
+       rd      = stgArrWords__BYTE_ARR_CTS (amodeToStix rcd)
        a1      = StAssign IntRep ra a
        a2      = StAssign IntRep rs (StPrim IntNegOp [s])
        a3      = StAssign PtrRep rd d
@@ -138,11 +164,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 (StInt (toInteger arrWordsHdrSize)))
+       f3 = StAssign PtrRep (mpData str) arr
     in
     (f1, f2, f3)
 
-scratch_space = sStLitLbl SLIT("stg_scratch_space")
+scratch1 = StScratchWord 0
+scratch2 = StScratchWord mpIntSize
 \end{code}