ghc/compiler/nativeGen/StixInteger.lhs

   1 %
   2 % (c) The AQUA Project, Glasgow University, 1993-1996
   3 %
   4
   5 \begin{code}
   6 module StixInteger (
   7         gmpTake1Return1, gmpTake2Return1, gmpTake2Return2, gmpCompare,
   8         gmpInteger2Int, gmpInteger2Word,
   9         gmpInt2Integer, gmpString2Integer,
  10         encodeFloatingKind, decodeFloatingKind
  11     ) where
  12
  13 #include "HsVersions.h"
  14
  15 import {-# SOURCE #-} StixPrim ( amodeToStix )
  16 import MachMisc
  17 import MachRegs
  18
  19 import AbsCSyn          -- bits and bobs...
  20 import CallConv         ( cCallConv )
  21 import Constants        ( 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, 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") cCallConv VoidRep [result2]
  50 init3 = StCall SLIT("mpz_init") cCallConv VoidRep [result3]
  51 init4 = StCall SLIT("mpz_init") cCallConv 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 cCallConv 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 cCallConv 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 cCallConv 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") cCallConv 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") cCallConv IntRep [hp]
 209         r1 = StAssign IntRep result mpz_get_si
 210     in
 211     returnUs (\xs -> a1 : a2 : a3 : r1 : xs)
 212
 213 gmpInteger2Word
 214     :: CAddrMode            -- result
 215     -> (CAddrMode, CAddrMode,CAddrMode,CAddrMode) -- alloc hp + argument (3 parts)
 216     -> UniqSM StixTreeList
 217
 218 gmpInteger2Word res args@(chp, caa,csa,cda)
 219   = let
 220         result  = amodeToStix res
 221         hp      = amodeToStix chp
 222         aa      = amodeToStix caa
 223         sa      = amodeToStix csa
 224         da      = amodeToStix cda
 225
 226         (a1,a2,a3) = toStruct hp (aa,sa,da)
 227         mpz_get_ui = StCall SLIT("mpz_get_ui") cCallConv IntRep [hp]
 228         r1 = StAssign WordRep result mpz_get_ui
 229     in
 230     returnUs (\xs -> a1 : a2 : a3 : r1 : xs)
 231
 232 arrayOfData_info = sStLitLbl SLIT("ArrayOfData_info")
 233
 234 --------------
 235 gmpInt2Integer
 236     :: (CAddrMode, CAddrMode, CAddrMode) -- result (3 parts)
 237     -> (CAddrMode, CAddrMode)   -- allocated heap, Int to convert
 238     -> UniqSM StixTreeList
 239
 240 gmpInt2Integer res@(car,csr,cdr) args@(chp, n)
 241   = getUniqLabelNCG                     `thenUs` \ zlbl ->
 242     getUniqLabelNCG                     `thenUs` \ nlbl ->
 243     getUniqLabelNCG                     `thenUs` \ jlbl ->
 244     let
 245         ar  = amodeToStix car
 246         sr  = amodeToStix csr
 247         dr  = amodeToStix cdr
 248         hp  = amodeToStix chp
 249         i   = amodeToStix n
 250
 251         h1 = StAssign PtrRep (StInd PtrRep hp) arrayOfData_info
 252         size = varHdrSizeInWords (DataRep 0) + mIN_MP_INT_SIZE
 253         h2 = StAssign IntRep (StInd IntRep (StIndex IntRep hp (StInt 1)))
 254                               (StInt (toInteger size))
 255         cts = StInd IntRep (StIndex IntRep hp dataHS)
 256         test1 = StPrim IntEqOp [i, StInt 0]
 257         test2 = StPrim IntLtOp [i, StInt 0]
 258         cjmp1 = StCondJump zlbl test1
 259         cjmp2 = StCondJump nlbl test2
 260         -- positive
 261         p1 = StAssign IntRep cts i
 262         p2 = StAssign IntRep sr (StInt 1)
 263         p3 = StJump (StCLbl jlbl)
 264         -- negative
 265         n0 = StLabel nlbl
 266         n1 = StAssign IntRep cts (StPrim IntNegOp [i])
 267         n2 = StAssign IntRep sr (StInt (-1))
 268         n3 = StJump (StCLbl jlbl)
 269         -- zero
 270         z0 = StLabel zlbl
 271         z1 = StAssign IntRep sr (StInt 0)
 272         -- everybody
 273         a0 = StLabel jlbl
 274         a1 = StAssign IntRep ar (StInt 1)
 275         a2 = StAssign PtrRep dr hp
 276     in
 277     returnUs (\xs ->
 278         case n of
 279             CLit (MachInt c _) ->
 280                 if c == 0 then     h1 : h2 : z1 : a1 : a2 : xs
 281                 else if c > 0 then h1 : h2 : p1 : p2 : a1 : a2 : xs
 282                 else               h1 : h2 : n1 : n2 : a1 : a2 : xs
 283             _                ->    h1 : h2 : cjmp1 : cjmp2 : p1 : p2 : p3
 284                                       : n0 : n1 : n2 : n3 : z0 : z1
 285                                       : a0 : a1 : a2 : xs)
 286
 287 gmpString2Integer
 288     :: (CAddrMode, CAddrMode, CAddrMode)    -- result (3 parts)
 289     -> (CAddrMode, CAddrMode)               -- liveness, string
 290     -> UniqSM StixTreeList
 291
 292 gmpString2Integer res@(car,csr,cdr) (liveness, str)
 293   = getUniqLabelNCG                                     `thenUs` \ ulbl ->
 294     let
 295         ar = amodeToStix car
 296         sr = amodeToStix csr
 297         dr = amodeToStix cdr
 298
 299         len = case str of
 300             (CString s) -> _LENGTH_ s
 301             (CLit (MachStr s)) -> _LENGTH_ s
 302             _ -> panic "String2Integer"
 303         space = len `quot` 8 + 17 + mpIntSize +
 304             varHdrSizeInWords (DataRep 0) + fixedHdrSizeInWords
 305         oldHp = StIndex PtrRep stgHp (StInt (toInteger (-space)))
 306         safeHp = saveLoc Hp
 307         save = StAssign PtrRep safeHp oldHp
 308         result = StIndex IntRep stgHpLim (StInt (toInteger (-mpIntSize)))
 309         set_str = StCall SLIT("mpz_init_set_str") cCallConv IntRep
 310             [result, amodeToStix str, StInt 10]
 311         test = StPrim IntEqOp [set_str, StInt 0]
 312         cjmp = StCondJump ulbl test
 313         abort = StCall SLIT("abort") cCallConv VoidRep []
 314         join = StLabel ulbl
 315         restore = StAssign PtrRep stgHp safeHp
 316         (a1,a2,a3) = fromStruct result (ar,sr,dr)
 317     in
 318     macroCode HEAP_CHK [liveness, mkIntCLit space, mkIntCLit_0]
 319                                                     `thenUs` \ heap_chk ->
 320
 321     returnUs (heap_chk .
 322         (\xs -> save : cjmp : abort : join : a1 : a2 : a3 : restore : xs))
 323
 324 mkIntCLit_0 = mkIntCLit 0 -- out here to avoid CAF (sigh)
 325
 326 encodeFloatingKind
 327     :: PrimRep
 328     -> CAddrMode        -- result
 329     -> (CAddrMode,CAddrMode,CAddrMode,CAddrMode,CAddrMode)
 330                 -- heap pointer for result, integer argument (3 parts), exponent
 331     -> UniqSM StixTreeList
 332
 333 encodeFloatingKind pk res args@(chp, caa,csa,cda, cexpon)
 334   = let
 335         result  = amodeToStix res
 336         hp      = amodeToStix chp
 337         aa      = amodeToStix caa
 338         sa      = amodeToStix csa
 339         da      = amodeToStix cda
 340         expon   = amodeToStix cexpon
 341
 342         pk' = if sizeOf FloatRep == sizeOf DoubleRep
 343               then DoubleRep
 344               else pk
 345         (a1,a2,a3) = toStruct hp (aa,sa,da)
 346         fn = case pk' of
 347             FloatRep -> SLIT("__encodeFloat")
 348             DoubleRep -> SLIT("__encodeDouble")
 349             _ -> panic "encodeFloatingKind"
 350         encode = StCall fn cCallConv pk' [hp, expon]
 351         r1 = StAssign pk' result encode
 352     in
 353     returnUs (\xs -> a1 : a2 : a3 : r1 : xs)
 354
 355 decodeFloatingKind
 356     :: PrimRep
 357     -> (CAddrMode, CAddrMode, CAddrMode, CAddrMode)
 358                         -- exponent result, integer result (3 parts)
 359     -> (CAddrMode, CAddrMode)
 360                         -- heap pointer for exponent, floating argument
 361     -> UniqSM StixTreeList
 362
 363 decodeFloatingKind pk res@(cexponr,car,csr,cdr) args@(chp, carg)
 364   = let
 365         exponr  = amodeToStix cexponr
 366         ar      = amodeToStix car
 367         sr      = amodeToStix csr
 368         dr      = amodeToStix cdr
 369         hp      = amodeToStix chp
 370         arg     = amodeToStix carg
 371
 372         pk' = if sizeOf FloatRep == sizeOf DoubleRep
 373               then DoubleRep
 374               else pk
 375         setup = StAssign PtrRep mpData_mantissa (StIndex IntRep hp (StInt 1))
 376         fn = case pk' of
 377             FloatRep -> SLIT("__decodeFloat")
 378             DoubleRep -> SLIT("__decodeDouble")
 379             _ -> panic "decodeFloatingKind"
 380         decode = StCall fn cCallConv VoidRep [mantissa, hp, arg]
 381         (a1,a2,a3) = fromStruct mantissa (ar,sr,dr)
 382         a4 = StAssign IntRep exponr (StInd IntRep hp)
 383     in
 384     returnUs (\xs -> setup : decode : a1 : a2 : a3 : a4 : xs)
 385
 386 mantissa = mpStruct 1 -- out here to avoid CAF (sigh)
 387 mpData_mantissa = mpData mantissa
 388 \end{code}
 389
 390 Support for the Gnu GMP multi-precision package.
 391
 392 \begin{code}
 393 -- size (in words) of __MP_INT
 394 mpIntSize = 3 :: Int
 395
 396 mpAlloc, mpSize, mpData :: StixTree -> StixTree
 397 mpAlloc base = StInd IntRep base
 398 mpSize base = StInd IntRep (StIndex IntRep base (StInt 1))
 399 mpData base = StInd PtrRep (StIndex IntRep base (StInt 2))
 400
 401 mpSpace
 402     :: Int              -- gmp structures needed
 403     -> Int              -- number of results
 404     -> [StixTree]       -- sizes to add for estimating result size
 405     -> StixTree         -- total space
 406
 407 mpSpace gmp res sizes
 408   = foldr sum (StPrim IntAddOp [fixed, hdrs]) sizes
 409   where
 410     sum x y = StPrim IntAddOp [StPrim IntAbsOp [x], y]
 411     -- what's the magical 17 for?
 412     fixed = StInt (toInteger (17 * res + gmp * mpIntSize))
 413     hdrs = StPrim IntMulOp [dataHS, StInt (toInteger res)]
 414 \end{code}
 415
 416 We don't have a truly portable way of allocating local temporaries, so
 417 we cheat and use space at the end of the heap.  (Thus, negative
 418 offsets from HpLim are our temporaries.)  Note that you must have
 419 performed a heap check which includes the space needed for these
 420 temporaries before you use them.
 421
 422 \begin{code}
 423 mpStruct :: Int -> StixTree
 424 mpStruct n = StIndex IntRep stgHpLim (StInt (toInteger (-(n * mpIntSize))))
 425
 426 toStruct
 427     :: StixTree
 428     -> (StixTree, StixTree, StixTree)
 429     -> (StixTree, StixTree, StixTree)
 430
 431 toStruct str (alloc,size,arr)
 432   = let
 433         f1 = StAssign IntRep (mpAlloc str) alloc
 434         f2 = StAssign IntRep (mpSize str) size
 435         f3 = StAssign PtrRep (mpData str) (StIndex PtrRep arr dataHS)
 436     in
 437     (f1, f2, f3)
 438
 439 fromStruct
 440     :: StixTree
 441     -> (StixTree, StixTree, StixTree)
 442     -> (StixTree, StixTree, StixTree)
 443
 444 fromStruct str (alloc,size,arr)
 445   = let
 446         e1 = StAssign IntRep alloc (mpAlloc str)
 447         e2 = StAssign IntRep size (mpSize str)
 448         e3 = StAssign PtrRep arr (StIndex PtrRep (mpData str)
 449                                                  (StPrim IntNegOp [dataHS]))
 450     in
 451     (e1, e2, e3)
 452 \end{code}
 453