ghc/compiler/nativeGen/StixInteger.lhs

   1 %
   2 % (c) The AQUA Project, Glasgow University, 1993-1996
   3 %
   4
   5 \begin{code}
   6 module StixInteger (
   7         gmpTake1Return1, gmpTake2Return1, gmpTake2Return2, gmpCompare,
   8         gmpInteger2Int, gmpInt2Integer, gmpString2Integer,
   9         encodeFloatingKind, decodeFloatingKind
  10     ) where
  11
  12 #include "HsVersions.h"
  13
  14 import {-# SOURCE #-} StixPrim ( amodeToStix )
  15 import MachMisc
  16 import MachRegs
  17
  18 import AbsCSyn          -- bits and bobs...
  19 import Constants        ( mIN_MP_INT_SIZE )
  20 import Literal          ( Literal(..) )
  21 import OrdList          ( OrdList )
  22 import PrimOp           ( PrimOp(..) )
  23 import PrimRep          ( PrimRep(..) )
  24 import SMRep            ( SMRep(..), SMSpecRepKind, SMUpdateKind )
  25 import Stix             ( getUniqLabelNCG, sStLitLbl, stgHp, stgHpLim,
  26                           StixTree(..), StixTreeList,
  27                           CodeSegment, StixReg
  28                         )
  29 import StixMacro        ( macroCode, heapCheck )
  30 import UniqSupply       ( returnUs, thenUs, UniqSM )
  31 import Util             ( panic )
  32 \end{code}
  33
  34 \begin{code}
  35 gmpTake1Return1
  36     :: (CAddrMode,CAddrMode,CAddrMode)  -- result (3 parts)
  37     -> FAST_STRING                      -- function name
  38     -> (CAddrMode, CAddrMode,CAddrMode,CAddrMode)
  39                                         -- argument (4 parts)
  40     -> UniqSM StixTreeList
  41
  42 argument1 = mpStruct 1 -- out here to avoid CAF (sigh)
  43 argument2 = mpStruct 2
  44 result2 = mpStruct 2
  45 result3 = mpStruct 3
  46 result4 = mpStruct 4
  47 init2 = StCall SLIT("mpz_init") VoidRep [result2]
  48 init3 = StCall SLIT("mpz_init") VoidRep [result3]
  49 init4 = StCall SLIT("mpz_init") VoidRep [result4]
  50
  51 gmpTake1Return1 res@(car,csr,cdr) rtn arg@(clive,caa,csa,cda)
  52   = let
  53         ar      = amodeToStix car
  54         sr      = amodeToStix csr
  55         dr      = amodeToStix cdr
  56         liveness= amodeToStix clive
  57         aa      = amodeToStix caa
  58         sa      = amodeToStix csa
  59         da      = amodeToStix cda
  60
  61         space = mpSpace 2 1 [sa]
  62         oldHp = StIndex PtrRep stgHp (StPrim IntNegOp [space])
  63         safeHp = saveLoc Hp
  64         save = StAssign PtrRep safeHp oldHp
  65         (a1,a2,a3) = toStruct argument1 (aa,sa,da)
  66         mpz_op = StCall rtn VoidRep [result2, argument1]
  67         restore = StAssign PtrRep stgHp safeHp
  68         (r1,r2,r3) = fromStruct result2 (ar,sr,dr)
  69     in
  70     heapCheck liveness space (StInt 0) `thenUs` \ heap_chk ->
  71
  72     returnUs (heap_chk .
  73         (\xs -> a1 : a2 : a3 : save : init2 : mpz_op : r1 : r2 : r3 : restore : xs))
  74
  75 gmpTake2Return1
  76     :: (CAddrMode,CAddrMode,CAddrMode)  -- result (3 parts)
  77     -> FAST_STRING                      -- function name
  78     -> (CAddrMode,CAddrMode,CAddrMode,CAddrMode,CAddrMode,CAddrMode,CAddrMode)
  79                                         -- liveness + 2 arguments (3 parts each)
  80     -> UniqSM StixTreeList
  81
  82 gmpTake2Return1 res@(car,csr,cdr) rtn args@(clive, caa1,csa1,cda1, caa2,csa2,cda2)
  83   = let
  84         ar      = amodeToStix car
  85         sr      = amodeToStix csr
  86         dr      = amodeToStix cdr
  87         liveness= amodeToStix clive
  88         aa1     = amodeToStix caa1
  89         sa1     = amodeToStix csa1
  90         da1     = amodeToStix cda1
  91         aa2     = amodeToStix caa2
  92         sa2     = amodeToStix csa2
  93         da2     = amodeToStix cda2
  94
  95         space = mpSpace 3 1 [sa1, sa2]
  96         oldHp = StIndex PtrRep stgHp (StPrim IntNegOp [space])
  97         safeHp = saveLoc Hp
  98         save = StAssign PtrRep safeHp oldHp
  99         (a1,a2,a3) = toStruct argument1 (aa1,sa1,da1)
 100         (a4,a5,a6) = toStruct argument2 (aa2,sa2,da2)
 101         mpz_op = StCall rtn VoidRep [result3, argument1, argument2]
 102         restore = StAssign PtrRep stgHp safeHp
 103         (r1,r2,r3) = fromStruct result3 (ar,sr,dr)
 104     in
 105     heapCheck liveness space (StInt 0) `thenUs` \ heap_chk ->
 106
 107     returnUs (heap_chk .
 108         (\xs -> a1 : a2 : a3 : a4 : a5 : a6
 109                     : save : init3 : mpz_op : r1 : r2 : r3 : restore : xs))
 110
 111 gmpTake2Return2
 112     :: (CAddrMode,CAddrMode,CAddrMode,CAddrMode,CAddrMode,CAddrMode)
 113                             -- 2 results (3 parts each)
 114     -> FAST_STRING          -- function name
 115     -> (CAddrMode,CAddrMode,CAddrMode,CAddrMode,CAddrMode,CAddrMode,CAddrMode)
 116                             -- liveness + 2 arguments (3 parts each)
 117     -> UniqSM StixTreeList
 118
 119 gmpTake2Return2 res@(car1,csr1,cdr1, car2,csr2,cdr2)
 120                 rtn args@(clive, caa1,csa1,cda1, caa2,csa2,cda2)
 121   = let
 122         ar1     = amodeToStix car1
 123         sr1     = amodeToStix csr1
 124         dr1     = amodeToStix cdr1
 125         ar2     = amodeToStix car2
 126         sr2     = amodeToStix csr2
 127         dr2     = amodeToStix cdr2
 128         liveness= amodeToStix clive
 129         aa1     = amodeToStix caa1
 130         sa1     = amodeToStix csa1
 131         da1     = amodeToStix cda1
 132         aa2     = amodeToStix caa2
 133         sa2     = amodeToStix csa2
 134         da2     = amodeToStix cda2
 135
 136         space = StPrim IntMulOp [mpSpace 2 1 [sa1, sa2], StInt 2]
 137         oldHp = StIndex PtrRep stgHp (StPrim IntNegOp [space])
 138         safeHp = saveLoc Hp
 139         save = StAssign PtrRep safeHp oldHp
 140         (a1,a2,a3) = toStruct argument1 (aa1,sa1,da1)
 141         (a4,a5,a6) = toStruct argument2 (aa2,sa2,da2)
 142         mpz_op = StCall rtn VoidRep [result3, result4, argument1, argument2]
 143         restore = StAssign PtrRep stgHp safeHp
 144         (r1,r2,r3) = fromStruct result3 (ar1,sr1,dr1)
 145         (r4,r5,r6) = fromStruct result4 (ar2,sr2,dr2)
 146
 147     in
 148     heapCheck liveness space (StInt 0) `thenUs` \ heap_chk ->
 149
 150     returnUs (heap_chk .
 151         (\xs -> a1 : a2 : a3 : a4 : a5 : a6
 152                     : save : init3 : init4 : mpz_op
 153                     : r1 : r2 : r3 : r4 : r5 : r6 : restore : xs))
 154 \end{code}
 155
 156 Although gmpCompare doesn't allocate space, it does temporarily use
 157 some space just beyond the heap pointer.  This is safe, because the
 158 enclosing routine has already guaranteed that this space will be
 159 available.  (See ``primOpHeapRequired.'')
 160
 161 \begin{code}
 162 gmpCompare
 163     :: CAddrMode            -- result (boolean)
 164     -> (CAddrMode,CAddrMode,CAddrMode,CAddrMode,CAddrMode,CAddrMode,CAddrMode)
 165                             -- alloc hp + 2 arguments (3 parts each)
 166     -> UniqSM StixTreeList
 167
 168 gmpCompare res args@(chp, caa1,csa1,cda1, caa2,csa2,cda2)
 169   = let
 170         result  = amodeToStix res
 171         hp      = amodeToStix chp
 172         aa1     = amodeToStix caa1
 173         sa1     = amodeToStix csa1
 174         da1     = amodeToStix cda1
 175         aa2     = amodeToStix caa2
 176         sa2     = amodeToStix csa2
 177         da2     = amodeToStix cda2
 178
 179         argument1 = hp
 180         argument2 = StIndex IntRep hp (StInt (toInteger mpIntSize))
 181         (a1,a2,a3) = toStruct argument1 (aa1,sa1,da1)
 182         (a4,a5,a6) = toStruct argument2 (aa2,sa2,da2)
 183         mpz_cmp = StCall SLIT("mpz_cmp") IntRep [argument1, argument2]
 184         r1 = StAssign IntRep result mpz_cmp
 185     in
 186     returnUs (\xs -> a1 : a2 : a3 : a4 : a5 : a6 : r1 : xs)
 187 \end{code}
 188
 189 See the comment above regarding the heap check (or lack thereof).
 190
 191 \begin{code}
 192 gmpInteger2Int
 193     :: CAddrMode            -- result
 194     -> (CAddrMode, CAddrMode,CAddrMode,CAddrMode) -- alloc hp + argument (3 parts)
 195     -> UniqSM StixTreeList
 196
 197 gmpInteger2Int res args@(chp, caa,csa,cda)
 198   = let
 199         result  = amodeToStix res
 200         hp      = amodeToStix chp
 201         aa      = amodeToStix caa
 202         sa      = amodeToStix csa
 203         da      = amodeToStix cda
 204
 205         (a1,a2,a3) = toStruct hp (aa,sa,da)
 206         mpz_get_si = StCall SLIT("mpz_get_si") IntRep [hp]
 207         r1 = StAssign IntRep result mpz_get_si
 208     in
 209     returnUs (\xs -> a1 : a2 : a3 : r1 : xs)
 210
 211 arrayOfData_info = sStLitLbl SLIT("ArrayOfData_info")
 212
 213 --------------
 214 gmpInt2Integer
 215     :: (CAddrMode, CAddrMode, CAddrMode) -- result (3 parts)
 216     -> (CAddrMode, CAddrMode)   -- allocated heap, Int to convert
 217     -> UniqSM StixTreeList
 218
 219 gmpInt2Integer res@(car,csr,cdr) args@(chp, n)
 220   = getUniqLabelNCG                     `thenUs` \ zlbl ->
 221     getUniqLabelNCG                     `thenUs` \ nlbl ->
 222     getUniqLabelNCG                     `thenUs` \ jlbl ->
 223     let
 224         ar  = amodeToStix car
 225         sr  = amodeToStix csr
 226         dr  = amodeToStix cdr
 227         hp  = amodeToStix chp
 228         i   = amodeToStix n
 229
 230         h1 = StAssign PtrRep (StInd PtrRep hp) arrayOfData_info
 231         size = varHdrSizeInWords (DataRep 0) + mIN_MP_INT_SIZE
 232         h2 = StAssign IntRep (StInd IntRep (StIndex IntRep hp (StInt 1)))
 233                               (StInt (toInteger size))
 234         cts = StInd IntRep (StIndex IntRep hp dataHS)
 235         test1 = StPrim IntEqOp [i, StInt 0]
 236         test2 = StPrim IntLtOp [i, StInt 0]
 237         cjmp1 = StCondJump zlbl test1
 238         cjmp2 = StCondJump nlbl test2
 239         -- positive
 240         p1 = StAssign IntRep cts i
 241         p2 = StAssign IntRep sr (StInt 1)
 242         p3 = StJump (StCLbl jlbl)
 243         -- negative
 244         n0 = StLabel nlbl
 245         n1 = StAssign IntRep cts (StPrim IntNegOp [i])
 246         n2 = StAssign IntRep sr (StInt (-1))
 247         n3 = StJump (StCLbl jlbl)
 248         -- zero
 249         z0 = StLabel zlbl
 250         z1 = StAssign IntRep sr (StInt 0)
 251         -- everybody
 252         a0 = StLabel jlbl
 253         a1 = StAssign IntRep ar (StInt 1)
 254         a2 = StAssign PtrRep dr hp
 255     in
 256     returnUs (\xs ->
 257         case n of
 258             CLit (MachInt c _) ->
 259                 if c == 0 then     h1 : h2 : z1 : a1 : a2 : xs
 260                 else if c > 0 then h1 : h2 : p1 : p2 : a1 : a2 : xs
 261                 else               h1 : h2 : n1 : n2 : a1 : a2 : xs
 262             _                ->    h1 : h2 : cjmp1 : cjmp2 : p1 : p2 : p3
 263                                       : n0 : n1 : n2 : n3 : z0 : z1
 264                                       : a0 : a1 : a2 : xs)
 265
 266 gmpString2Integer
 267     :: (CAddrMode, CAddrMode, CAddrMode)    -- result (3 parts)
 268     -> (CAddrMode, CAddrMode)               -- liveness, string
 269     -> UniqSM StixTreeList
 270
 271 gmpString2Integer res@(car,csr,cdr) (liveness, str)
 272   = getUniqLabelNCG                                     `thenUs` \ ulbl ->
 273     let
 274         ar = amodeToStix car
 275         sr = amodeToStix csr
 276         dr = amodeToStix cdr
 277
 278         len = case str of
 279             (CString s) -> _LENGTH_ s
 280             (CLit (MachStr s)) -> _LENGTH_ s
 281             _ -> panic "String2Integer"
 282         space = len `quot` 8 + 17 + mpIntSize +
 283             varHdrSizeInWords (DataRep 0) + fixedHdrSizeInWords
 284         oldHp = StIndex PtrRep stgHp (StInt (toInteger (-space)))
 285         safeHp = saveLoc Hp
 286         save = StAssign PtrRep safeHp oldHp
 287         result = StIndex IntRep stgHpLim (StInt (toInteger (-mpIntSize)))
 288         set_str = StCall SLIT("mpz_init_set_str") IntRep
 289             [result, amodeToStix str, StInt 10]
 290         test = StPrim IntEqOp [set_str, StInt 0]
 291         cjmp = StCondJump ulbl test
 292         abort = StCall SLIT("abort") VoidRep []
 293         join = StLabel ulbl
 294         restore = StAssign PtrRep stgHp safeHp
 295         (a1,a2,a3) = fromStruct result (ar,sr,dr)
 296     in
 297     macroCode HEAP_CHK [liveness, mkIntCLit space, mkIntCLit_0]
 298                                                     `thenUs` \ heap_chk ->
 299
 300     returnUs (heap_chk .
 301         (\xs -> save : cjmp : abort : join : a1 : a2 : a3 : restore : xs))
 302
 303 mkIntCLit_0 = mkIntCLit 0 -- out here to avoid CAF (sigh)
 304
 305 encodeFloatingKind
 306     :: PrimRep
 307     -> CAddrMode        -- result
 308     -> (CAddrMode,CAddrMode,CAddrMode,CAddrMode,CAddrMode)
 309                 -- heap pointer for result, integer argument (3 parts), exponent
 310     -> UniqSM StixTreeList
 311
 312 encodeFloatingKind pk res args@(chp, caa,csa,cda, cexpon)
 313   = let
 314         result  = amodeToStix res
 315         hp      = amodeToStix chp
 316         aa      = amodeToStix caa
 317         sa      = amodeToStix csa
 318         da      = amodeToStix cda
 319         expon   = amodeToStix cexpon
 320
 321         pk' = if sizeOf FloatRep == sizeOf DoubleRep
 322               then DoubleRep
 323               else pk
 324         (a1,a2,a3) = toStruct hp (aa,sa,da)
 325         fn = case pk' of
 326             FloatRep -> SLIT("__encodeFloat")
 327             DoubleRep -> SLIT("__encodeDouble")
 328             _ -> panic "encodeFloatingKind"
 329         encode = StCall fn pk' [hp, expon]
 330         r1 = StAssign pk' result encode
 331     in
 332     returnUs (\xs -> a1 : a2 : a3 : r1 : xs)
 333
 334 decodeFloatingKind
 335     :: PrimRep
 336     -> (CAddrMode, CAddrMode, CAddrMode, CAddrMode)
 337                         -- exponent result, integer result (3 parts)
 338     -> (CAddrMode, CAddrMode)
 339                         -- heap pointer for exponent, floating argument
 340     -> UniqSM StixTreeList
 341
 342 decodeFloatingKind pk res@(cexponr,car,csr,cdr) args@(chp, carg)
 343   = let
 344         exponr  = amodeToStix cexponr
 345         ar      = amodeToStix car
 346         sr      = amodeToStix csr
 347         dr      = amodeToStix cdr
 348         hp      = amodeToStix chp
 349         arg     = amodeToStix carg
 350
 351         pk' = if sizeOf FloatRep == sizeOf DoubleRep
 352               then DoubleRep
 353               else pk
 354         setup = StAssign PtrRep mpData_mantissa (StIndex IntRep hp (StInt 1))
 355         fn = case pk' of
 356             FloatRep -> SLIT("__decodeFloat")
 357             DoubleRep -> SLIT("__decodeDouble")
 358             _ -> panic "decodeFloatingKind"
 359         decode = StCall fn VoidRep [mantissa, hp, arg]
 360         (a1,a2,a3) = fromStruct mantissa (ar,sr,dr)
 361         a4 = StAssign IntRep exponr (StInd IntRep hp)
 362     in
 363     returnUs (\xs -> setup : decode : a1 : a2 : a3 : a4 : xs)
 364
 365 mantissa = mpStruct 1 -- out here to avoid CAF (sigh)
 366 mpData_mantissa = mpData mantissa
 367 \end{code}
 368
 369 Support for the Gnu GMP multi-precision package.
 370
 371 \begin{code}
 372 mpIntSize = 3 :: Int
 373
 374 mpAlloc, mpSize, mpData :: StixTree -> StixTree
 375 mpAlloc base = StInd IntRep base
 376 mpSize base = StInd IntRep (StIndex IntRep base (StInt 1))
 377 mpData base = StInd PtrRep (StIndex IntRep base (StInt 2))
 378
 379 mpSpace
 380     :: Int              -- gmp structures needed
 381     -> Int              -- number of results
 382     -> [StixTree]       -- sizes to add for estimating result size
 383     -> StixTree         -- total space
 384
 385 mpSpace gmp res sizes
 386   = foldr sum (StPrim IntAddOp [fixed, hdrs]) sizes
 387   where
 388     sum x y = StPrim IntAddOp [StPrim IntAbsOp [x], y]
 389     fixed = StInt (toInteger (17 * res + gmp * mpIntSize))
 390     hdrs = StPrim IntMulOp [dataHS, StInt (toInteger res)]
 391 \end{code}
 392
 393 We don't have a truly portable way of allocating local temporaries, so
 394 we cheat and use space at the end of the heap.  (Thus, negative
 395 offsets from HpLim are our temporaries.)  Note that you must have
 396 performed a heap check which includes the space needed for these
 397 temporaries before you use them.
 398
 399 \begin{code}
 400 mpStruct :: Int -> StixTree
 401 mpStruct n = StIndex IntRep stgHpLim (StInt (toInteger (-(n * mpIntSize))))
 402
 403 toStruct
 404     :: StixTree
 405     -> (StixTree, StixTree, StixTree)
 406     -> (StixTree, StixTree, StixTree)
 407
 408 toStruct str (alloc,size,arr)
 409   = let
 410         f1 = StAssign IntRep (mpAlloc str) alloc
 411         f2 = StAssign IntRep (mpSize str) size
 412         f3 = StAssign PtrRep (mpData str) (StIndex PtrRep arr dataHS)
 413     in
 414     (f1, f2, f3)
 415
 416 fromStruct
 417     :: StixTree
 418     -> (StixTree, StixTree, StixTree)
 419     -> (StixTree, StixTree, StixTree)
 420
 421 fromStruct str (alloc,size,arr)
 422   = let
 423         e1 = StAssign IntRep alloc (mpAlloc str)
 424         e2 = StAssign IntRep size (mpSize str)
 425         e3 = StAssign PtrRep arr (StIndex PtrRep (mpData str)
 426                                                  (StPrim IntNegOp [dataHS]))
 427     in
 428     (e1, e2, e3)
 429 \end{code}
 430