ghc/compiler/nativeGen/StixInteger.lhs

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