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