ghc/compiler/nativeGen/StixInteger.lhs

   1 %
   2 % (c) The AQUA Project, Glasgow University, 1993-1998
   3 %
   4
   5 \begin{code}
   6 module StixInteger (
   7         gmpCompare,
   8         gmpCompareInt,
   9         gmpInteger2Int,
  10         gmpInteger2Word,
  11         gmpNegate
  12         ) where
  13
  14 #include "HsVersions.h"
  15
  16 import {-# SOURCE #-} StixPrim ( amodeToStix )
  17
  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 )
  24 \end{code}
  25
  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.'')
  30
  31 \begin{code}
  32 stgArrWords__words        :: StixTree -> StixTree
  33 stgArrWords__BYTE_ARR_CTS :: StixTree -> StixTree
  34
  35 stgArrWords__BYTE_ARR_CTS arr
  36    = StIndex WordRep arr arrWordsHS
  37 stgArrWords__words        arr
  38    = case arrWordsHS of
  39         StInt i -> StInd WordRep (StIndex PtrRep arr (StInt (i-1)))
  40
  41 gmpCompare
  42     :: CAddrMode            -- result (boolean)
  43     -> (CAddrMode,CAddrMode,CAddrMode,CAddrMode)
  44                             -- alloc hp + 2 arguments (2 parts each)
  45     -> UniqSM StixTreeList
  46
  47 gmpCompare res args@(csa1,cda1, csa2,cda2)
  48   = let
  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)
  56
  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
  61     in
  62     returnUs (\xs -> a1 : a2 : a3 : a4 : a5 : a6 : r1 : xs)
  63
  64
  65 gmpCompareInt
  66     :: CAddrMode            -- result (boolean)
  67     -> (CAddrMode,CAddrMode,CAddrMode)
  68     -> UniqSM StixTreeList  -- alloc hp + 1 arg (??)
  69
  70 gmpCompareInt res args@(csa1,cda1, cai)
  71   = let
  72         result   = amodeToStix res
  73         sa1      = amodeToStix csa1
  74         aa1      = stgArrWords__words (amodeToStix cda1)
  75         da1      = stgArrWords__BYTE_ARR_CTS (amodeToStix cda1)
  76         ai       = amodeToStix cai
  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
  80     in
  81     returnUs (\xs -> a1 : a2 : a3 : r1 : xs)
  82 \end{code}
  83
  84 \begin{code}
  85 gmpInteger2Int
  86     :: CAddrMode            -- result
  87     -> (CAddrMode,CAddrMode) -- alloc hp + argument (2 parts)
  88     -> UniqSM StixTreeList
  89
  90 gmpInteger2Int res args@(csa,cda)
  91   = let
  92         result  = amodeToStix res
  93         sa      = amodeToStix csa
  94         aa      = stgArrWords__words (amodeToStix cda)
  95         da      = stgArrWords__BYTE_ARR_CTS (amodeToStix cda)
  96
  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
 100     in
 101     returnUs (\xs -> a1 : a2 : a3 : r1 : xs)
 102
 103 gmpInteger2Word
 104     :: CAddrMode            -- result
 105     -> (CAddrMode,CAddrMode) -- alloc hp + argument (2 parts)
 106     -> UniqSM StixTreeList
 107
 108 gmpInteger2Word res args@(csa,cda)
 109   = let
 110         result  = amodeToStix res
 111         sa      = amodeToStix csa
 112         aa      = stgArrWords__words (amodeToStix cda)
 113         da      = stgArrWords__BYTE_ARR_CTS (amodeToStix cda)
 114
 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
 118     in
 119     returnUs (\xs -> a1 : a2 : a3 : r1 : xs)
 120
 121 gmpNegate
 122     :: (CAddrMode,CAddrMode) -- result
 123     -> (CAddrMode,CAddrMode) -- argument (2 parts)
 124     -> UniqSM StixTreeList
 125
 126 gmpNegate (rcs, rcd) args@(cs, cd)
 127   = let
 128         s       = amodeToStix cs
 129         a       = stgArrWords__words (amodeToStix cd)
 130         d       = stgArrWords__BYTE_ARR_CTS (amodeToStix cd)
 131         rs      = amodeToStix rcs
 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
 137     in
 138     returnUs (\xs -> a1 : a2 : a3 : xs)
 139 \end{code}
 140
 141 Support for the Gnu GMP multi-precision package.
 142
 143 \begin{code}
 144 -- size (in words) of __MP_INT
 145 mpIntSize = 3 :: Int
 146
 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))
 151 \end{code}
 152
 153 \begin{code}
 154 toStruct
 155     :: StixTree
 156     -> (StixTree, StixTree, StixTree)
 157     -> (StixTree, StixTree, StixTree)
 158
 159 toStruct str (alloc,size,arr)
 160   = let
 161         f1 = StAssign IntRep (mpAlloc str) alloc
 162         f2 = StAssign IntRep (mpSize str) size
 163         f3 = StAssign PtrRep (mpData str) arr
 164     in
 165     (f1, f2, f3)
 166
 167 scratch1 = StScratchWord 0
 168 scratch2 = StScratchWord mpIntSize
 169 \end{code}
 170