ghc/compiler/nativeGen/StixInteger.lhs

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