ghc/compiler/nativeGen/StixInteger.lhs

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