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