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