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