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