ghc/compiler/nativeGen/StixPrim.lhs

   1 %
   2 % (c) The AQUA Project, Glasgow University, 1993-1996
   3 %
   4
   5 \begin{code}
   6 module StixPrim ( primCode, amodeToStix, amodeToStix' ) where
   7
   8 #include "HsVersions.h"
   9
  10 import Char            ( ord )
  11 import MachMisc
  12 import MachRegs
  13
  14 import AbsCSyn
  15 import AbsCUtils        ( getAmodeRep, mixedTypeLocn )
  16 import CallConv         ( cCallConv )
  17 import Constants        ( spARelToInt, spBRelToInt )
  18 import CostCentre       ( noCostCentreAttached )
  19 import HeapOffs         ( hpRelToInt, subOff )
  20 import Literal          ( Literal(..) )
  21 import PrimOp           ( PrimOp(..), isCompareOp, showPrimOp,
  22                           getPrimOpResultInfo, PrimOpResultInfo(..)
  23                         )
  24 import PrimRep          ( PrimRep(..), isFloatingRep )
  25 import OrdList          ( OrdList )
  26 import SMRep            ( SMRep(..), SMSpecRepKind, SMUpdateKind )
  27 import Stix
  28 import StixMacro        ( heapCheck )
  29 import StixInteger      {- everything -}
  30 import UniqSupply       ( returnUs, thenUs, UniqSM )
  31 import Outputable
  32
  33 \end{code}
  34
  35 The main honcho here is primCode, which handles the guts of COpStmts.
  36
  37 \begin{code}
  38 arrayOfData_info      = sStLitLbl SLIT("ArrayOfData_info") -- out here to avoid CAF (sigh)
  39 imMutArrayOfPtrs_info = sStLitLbl SLIT("ImMutArrayOfPtrs_info")
  40
  41 primCode
  42     :: [CAddrMode]      -- results
  43     -> PrimOp           -- op
  44     -> [CAddrMode]      -- args
  45     -> UniqSM StixTreeList
  46 \end{code}
  47
  48 First, the dreaded @ccall@.  We can't handle @casm@s.
  49
  50 Usually, this compiles to an assignment, but when the left-hand side
  51 is empty, we just perform the call and ignore the result.
  52
  53 ToDo ADR: modify this to handle ForeignObjs.
  54
  55 btw Why not let programmer use casm to provide assembly code instead
  56 of C code?  ADR
  57
  58 The (MP) integer operations are a true nightmare.  Since we don't have
  59 a convenient abstract way of allocating temporary variables on the (C)
  60 stack, we use the space just below HpLim for the @MP_INT@ structures,
  61 and modify our heap check accordingly.
  62
  63 \begin{code}
  64 -- NB: ordering of clauses somewhere driven by
  65 -- the desire to getting sane patt-matching behavior
  66
  67 primCode res@[ar1,sr1,dr1, ar2,sr2,dr2]
  68          IntegerQuotRemOp
  69          args@[liveness, aa1,sa1,da1, aa2,sa2,da2]
  70   = gmpTake2Return2 (ar1,sr1,dr1, ar2,sr2,dr2) SLIT("mpz_divmod") (liveness, aa1,sa1,da1, aa2,sa2,da2)
  71
  72 primCode res@[ar1,sr1,dr1, ar2,sr2,dr2]
  73          IntegerDivModOp
  74          args@[liveness, aa1,sa1,da1, aa2,sa2,da2]
  75   = gmpTake2Return2 (ar1,sr1,dr1, ar2,sr2,dr2) SLIT("mpz_targetivmod") (liveness, aa1,sa1,da1, aa2,sa2,da2)
  76
  77 primCode res@[ar,sr,dr] IntegerAddOp args@[liveness, aa1,sa1,da1, aa2,sa2,da2]
  78   = gmpTake2Return1 (ar,sr,dr) SLIT("mpz_add") (liveness, aa1,sa1,da1, aa2,sa2,da2)
  79 primCode res@[ar,sr,dr] IntegerSubOp args@[liveness, aa1,sa1,da1, aa2,sa2,da2]
  80   = gmpTake2Return1 (ar,sr,dr) SLIT("mpz_sub") (liveness, aa1,sa1,da1, aa2,sa2,da2)
  81 primCode res@[ar,sr,dr] IntegerMulOp args@[liveness, aa1,sa1,da1, aa2,sa2,da2]
  82   = gmpTake2Return1 (ar,sr,dr) SLIT("mpz_mul") (liveness, aa1,sa1,da1, aa2,sa2,da2)
  83
  84 primCode res@[ar,sr,dr] IntegerNegOp arg@[liveness,aa,sa,da]
  85   = gmpTake1Return1 (ar,sr,dr) SLIT("mpz_neg") (liveness,aa,sa,da)
  86 \end{code}
  87
  88 Since we are using the heap for intermediate @MP_INT@ structs, integer
  89 comparison {\em does} require a heap check in the native code
  90 implementation.
  91
  92 \begin{code}
  93 primCode res@[exponr,ar,sr,dr] FloatDecodeOp args@[hp, arg]
  94   = decodeFloatingKind FloatRep (exponr,ar,sr,dr) (hp, arg)
  95
  96 primCode res@[exponr,ar,sr,dr] DoubleDecodeOp args@[hp, arg]
  97   = decodeFloatingKind DoubleRep (exponr,ar,sr,dr) (hp, arg)
  98
  99 primCode res@[ar,sr,dr] Int2IntegerOp args@[hp, n]
 100   = gmpInt2Integer (ar,sr,dr) (hp, n)
 101
 102 primCode res@[ar,sr,dr] Addr2IntegerOp args@[liveness,str]
 103   = gmpString2Integer (ar,sr,dr) (liveness,str)
 104
 105 primCode [res] IntegerCmpOp args@[hp, aa1,sa1,da1, aa2,sa2,da2]
 106   = gmpCompare res (hp, aa1,sa1,da1, aa2,sa2,da2)
 107
 108 primCode [res] Integer2IntOp arg@[hp, aa,sa,da]
 109   = gmpInteger2Int res (hp, aa,sa,da)
 110
 111 primCode [res] Integer2WordOp arg@[hp, aa,sa,da]
 112   = gmpInteger2Word res (hp, aa,sa,da)
 113
 114 primCode [res] FloatEncodeOp args@[hp, aa,sa,da, expon]
 115   = encodeFloatingKind FloatRep res (hp, aa,sa,da, expon)
 116
 117 primCode [res] DoubleEncodeOp args@[hp, aa,sa,da, expon]
 118   = encodeFloatingKind DoubleRep res (hp, aa,sa,da, expon)
 119
 120 primCode [res] Int2AddrOp [arg]
 121   = simpleCoercion AddrRep res arg
 122
 123 primCode [res] Addr2IntOp [arg]
 124   = simpleCoercion IntRep res arg
 125
 126 primCode [res] Int2WordOp [arg]
 127   = simpleCoercion IntRep{-WordRep?-} res arg
 128
 129 primCode [res] Word2IntOp [arg]
 130   = simpleCoercion IntRep res arg
 131 \end{code}
 132
 133 The @ErrorIO@ primitive is actually a bit weird...assign a new value
 134 to the root closure, and jump to the @ErrorIO_innards@.
 135
 136 \begin{code}
 137 primCode [] ErrorIOPrimOp [rhs]
 138   = let
 139         changeTop = StAssign PtrRep topClosure (amodeToStix rhs)
 140     in
 141     returnUs (\xs -> changeTop : errorIO : xs)
 142 \end{code}
 143
 144 @newArray#@ ops allocate heap space.
 145
 146 \begin{code}
 147 primCode [res] NewArrayOp args
 148   = let
 149         [liveness, n, initial] = map amodeToStix args
 150         result = amodeToStix res
 151         space = StPrim IntAddOp [n, mutHS]
 152         loc = StIndex PtrRep stgHp
 153               (StPrim IntNegOp [StPrim IntSubOp [space, StInt 1]])
 154         assign = StAssign PtrRep result loc
 155         initialise = StCall SLIT("newArrZh_init") cCallConv VoidRep [result, n, initial]
 156     in
 157     heapCheck liveness space (StInt 0)  `thenUs` \ heap_chk ->
 158
 159     returnUs (heap_chk . (\xs -> assign : initialise : xs))
 160
 161 primCode [res] (NewByteArrayOp pk) args
 162   = let
 163         [liveness, count] = map amodeToStix args
 164         result = amodeToStix res
 165         n = StPrim IntMulOp [count, StInt (sizeOf pk)]
 166         slop = StPrim IntAddOp [n, StInt (sizeOf IntRep - 1)]
 167         words = StPrim IntQuotOp [slop, StInt (sizeOf IntRep)]
 168         space = StPrim IntAddOp [n, StPrim IntAddOp [words, dataHS]]
 169         loc = StIndex PtrRep stgHp
 170               (StPrim IntNegOp [StPrim IntSubOp [space, StInt 1]])
 171         assign = StAssign PtrRep result loc
 172         init1 = StAssign PtrRep (StInd PtrRep loc) arrayOfData_info
 173         init2 = StAssign IntRep
 174                          (StInd IntRep
 175                                 (StIndex IntRep loc
 176                                          (StInt (toInteger fixedHdrSizeInWords))))
 177                          (StPrim IntAddOp [words,
 178                                           StInt (toInteger (varHdrSizeInWords (DataRep 0)))])
 179     in
 180     heapCheck liveness space (StInt 0)  `thenUs` \ heap_chk ->
 181
 182     returnUs (heap_chk . (\xs -> assign : init1 : init2 : xs))
 183
 184 primCode [res] SameMutableArrayOp args
 185   = let
 186         compare = StPrim AddrEqOp (map amodeToStix args)
 187         assign = StAssign IntRep (amodeToStix res) compare
 188     in
 189     returnUs (\xs -> assign : xs)
 190
 191 primCode res@[_] SameMutableByteArrayOp args
 192   = primCode res SameMutableArrayOp args
 193 \end{code}
 194
 195 Freezing an array of pointers is a double assignment.  We fix the
 196 header of the ``new'' closure because the lhs is probably a better
 197 addressing mode for the indirection (most likely, it's a VanillaReg).
 198
 199 \begin{code}
 200
 201 primCode [lhs] UnsafeFreezeArrayOp [rhs]
 202   = let
 203         lhs' = amodeToStix lhs
 204         rhs' = amodeToStix rhs
 205         header = StInd PtrRep lhs'
 206         assign = StAssign PtrRep lhs' rhs'
 207         freeze = StAssign PtrRep header imMutArrayOfPtrs_info
 208     in
 209     returnUs (\xs -> assign : freeze : xs)
 210
 211 primCode [lhs] UnsafeFreezeByteArrayOp [rhs]
 212   = simpleCoercion PtrRep lhs rhs
 213 \end{code}
 214
 215 Returning the size of (mutable) byte arrays is just
 216 an indexing operation.
 217
 218 \begin{code}
 219 primCode [lhs] SizeofByteArrayOp [rhs]
 220   = let
 221         lhs' = amodeToStix lhs
 222         rhs' = amodeToStix rhs
 223         sz   = StIndex IntRep rhs' fixedHS
 224         assign = StAssign IntRep lhs' (StInd IntRep sz)
 225     in
 226     returnUs (\xs -> assign : xs)
 227
 228 primCode [lhs] SizeofMutableByteArrayOp [rhs]
 229   = let
 230         lhs' = amodeToStix lhs
 231         rhs' = amodeToStix rhs
 232         sz   = StIndex IntRep rhs' fixedHS
 233         assign = StAssign IntRep lhs' (StInd IntRep sz)
 234     in
 235     returnUs (\xs -> assign : xs)
 236
 237 \end{code}
 238
 239 Most other array primitives translate to simple indexing.
 240
 241 \begin{code}
 242
 243 primCode lhs@[_] IndexArrayOp args
 244   = primCode lhs ReadArrayOp args
 245
 246 primCode [lhs] ReadArrayOp [obj, ix]
 247   = let
 248         lhs' = amodeToStix lhs
 249         obj' = amodeToStix obj
 250         ix' = amodeToStix ix
 251         base = StIndex IntRep obj' mutHS
 252         assign = StAssign PtrRep lhs' (StInd PtrRep (StIndex PtrRep base ix'))
 253     in
 254     returnUs (\xs -> assign : xs)
 255
 256 primCode [] WriteArrayOp [obj, ix, v]
 257   = let
 258         obj' = amodeToStix obj
 259         ix' = amodeToStix ix
 260         v' = amodeToStix v
 261         base = StIndex IntRep obj' mutHS
 262         assign = StAssign PtrRep (StInd PtrRep (StIndex PtrRep base ix')) v'
 263     in
 264     returnUs (\xs -> assign : xs)
 265
 266 primCode lhs@[_] (IndexByteArrayOp pk) args
 267   = primCode lhs (ReadByteArrayOp pk) args
 268
 269 -- NB: indexing in "pk" units, *not* in bytes (WDP 95/09)
 270
 271 primCode [lhs] (ReadByteArrayOp pk) [obj, ix]
 272   = let
 273         lhs' = amodeToStix lhs
 274         obj' = amodeToStix obj
 275         ix' = amodeToStix ix
 276         base = StIndex IntRep obj' dataHS
 277         assign = StAssign pk lhs' (StInd pk (StIndex pk base ix'))
 278     in
 279     returnUs (\xs -> assign : xs)
 280
 281 primCode [lhs] (IndexOffAddrOp pk) [obj, ix]
 282   = let
 283         lhs' = amodeToStix lhs
 284         obj' = amodeToStix obj
 285         ix' = amodeToStix ix
 286         assign = StAssign pk lhs' (StInd pk (StIndex pk obj' ix'))
 287     in
 288     returnUs (\xs -> assign : xs)
 289
 290 primCode [lhs] (IndexOffForeignObjOp pk) [obj, ix]
 291   = let
 292         lhs' = amodeToStix lhs
 293         obj' = amodeToStix obj
 294         ix' = amodeToStix ix
 295         obj'' = StIndex PtrRep obj' foHS
 296         assign = StAssign pk lhs' (StInd pk (StIndex pk obj'' ix'))
 297     in
 298     returnUs (\xs -> assign : xs)
 299
 300 primCode [] (WriteByteArrayOp pk) [obj, ix, v]
 301   = let
 302         obj' = amodeToStix obj
 303         ix' = amodeToStix ix
 304         v' = amodeToStix v
 305         base = StIndex IntRep obj' dataHS
 306         assign = StAssign pk (StInd pk (StIndex pk base ix')) v'
 307     in
 308     returnUs (\xs -> assign : xs)
 309 \end{code}
 310
 311 Stable pointer operations.
 312
 313 First the easy one.
 314 \begin{code}
 315
 316 primCode [lhs] DeRefStablePtrOp [sp]
 317   = let
 318         lhs' = amodeToStix lhs
 319         pk = getAmodeRep lhs
 320         sp' = amodeToStix sp
 321         call = StCall SLIT("deRefStablePointer") cCallConv pk [sp', smStablePtrTable]
 322         assign = StAssign pk lhs' call
 323     in
 324     returnUs (\xs -> assign : xs)
 325 \end{code}
 326
 327 Now the hard one.  For comparison, here's the code from StgMacros:
 328
 329 \begin{verbatim}
 330 #define makeStablePtrZh(stablePtr,liveness,unstablePtr)              \
 331 do {                                                                 \
 332   EXTDATA(MK_INFO_LBL(StablePointerTable));                          \
 333   EXTDATA(UnusedSP);                                                 \
 334   StgStablePtr newSP;                                                \
 335                                                                      \
 336   if (SPT_EMPTY(StorageMgrInfo.StablePointerTable)) { /* free stack is empty */ \
 337     I_ OldNoPtrs = SPT_NoPTRS(StorageMgrInfo.StablePointerTable);    \
 338                                                                      \
 339     /* any strictly increasing expression will do here */            \
 340     I_ NewNoPtrs = OldNoPtrs * 2 + 100;                              \
 341                                                                      \
 342     I_ NewSize = DYN_VHS + NewNoPtrs + 1 + NewNoPtrs;                \
 343     P_ SPTable;                                                      \
 344                                                                      \
 345     HEAP_CHK(NO_LIVENESS, _FHS+NewSize, 0);                          \
 346     CC_ALLOC(CCC, _FHS+NewSize, SPT_K); /* cc prof */                \
 347                                                                      \
 348     SPTable = Hp + 1 - (_FHS + NewSize);                             \
 349     SET_DYN_HDR(SPTable,StablePointerTable,CCC,NewSize,NewNoPtrs);   \
 350     SAFESTGCALL2(void, (void *, P_, P_), enlargeSPTable, SPTable, StorageMgrInfo.StablePointerTable);      \
 351     StorageMgrInfo.StablePointerTable = SPTable;                     \
 352   }                                                                  \
 353                                                                      \
 354   newSP = SPT_POP(StorageMgrInfo.StablePointerTable);                \
 355   SPT_SPTR(StorageMgrInfo.StablePointerTable, newSP) = unstablePtr; \
 356   stablePtr = newSP;                                                 \
 357 } while (0)
 358 \end{verbatim}
 359
 360 ToDo ADR: finish this.  (Boy, this is hard work!)
 361
 362 Notes for ADR:
 363     trMumbles are now just StMumbles.
 364     StInt 1 is how to write ``1''
 365     temporaries are allocated at the end of the heap (see notes in StixInteger)
 366     Good luck!
 367
 368     --JSM
 369
 370 \begin{pseudocode}
 371 primCode [lhs] MakeStablePtrOp args
 372   = let
 373         -- some useful abbreviations (I'm sure these must exist already)
 374         add = trPrim . IntAddOp
 375         sub = trPrim . IntSubOp
 376         one = trInt [1]
 377         dec x = trAssign IntRep [x, sub [x, one]]
 378         inc x = trAssign IntRep [x, add [x, one]]
 379
 380         -- tedious hardwiring in of closure layout offsets (from SMClosures)
 381         dynHS = 2 + fixedHdrSizeInWords + varHdrSizeInWords DynamicRep
 382         spt_SIZE c   = trIndex PtrRep [c, trInt [fhs + gc_reserved] ]
 383         spt_NoPTRS c = trIndex PtrRep [c, trInt [fhs + gc_reserved + 1] ]
 384         spt_SPTR c i = trIndex PtrRep [c, add [trInt [dynHS], i]]
 385         spt_TOP c    = trIndex PtrRep [c, add [trInt [dynHS], spt_NoPTRS c]]
 386         spt_FREE c i = trIndex PtrRep [c, add [trInt [dynHS], spt_NoPTRS c]]
 387
 388         -- tedious hardwiring in of stack manipulation macros (from SMClosures)
 389         spt_FULL c lbl =
 390                 trCondJump lbl [trPrim IntEqOp [spt_TOP c, spt_NoPTRS c]]
 391         spt_EMPTY c lbl =
 392                 trCondJump lbl [trPrim IntEqOp [spt_TOP c, trInt [0]]]
 393         spt_PUSH c f = [
 394                 trAssign PtrRep [spt_FREE c (spt_TOP c), f],
 395                 inc (spt_TOP c),
 396         spt_POP c x  = [
 397                 dec (spt_TOP c),
 398                 trAssign PtrRep [x, spt_FREE c (spt_TOP c)]
 399         ]
 400
 401         -- now to get down to business
 402         lhs' = amodeCode lhs
 403         [liveness, unstable] = map amodeCode args
 404
 405         spt = smStablePtrTable
 406
 407         newSPT = -- a temporary (don't know how to allocate it)
 408         newSP = -- another temporary
 409
 410         allocNewTable = -- some sort fo heap allocation needed
 411         copyOldTable = trCall "enlargeSPTable" PtrRep [newSPT, spt]
 412
 413         enlarge =
 414                 allocNewTable ++ [
 415                 copyOldTable,
 416                 trAssign PtrRep [spt, newSPT]
 417         allocate = [
 418                 spt_POP spt newSP,
 419                 trAssign PtrRep [spt_SPTR spt newSP, unstable],
 420                 trAssign StablePtrRep [lhs', newSP]
 421         ]
 422
 423     in
 424     getUniqLabelCTS                                `thenCTS` \ oklbl ->
 425     returnCodes sty md
 426         (spt_EMPTY spt oklbl : (enlarge ++ (trLabel [oklbl] : allocate)))
 427 \end{pseudocode}
 428
 429 \begin{code}
 430 primCode res Word2IntegerOp args = panic "primCode:Word2IntegerOp"
 431
 432 primCode [lhs] SeqOp [a]
 433   = let
 434      {-
 435       The evaluation of seq#'s argument is done by `seqseqseq',
 436       here we just set up the call to it (identical to how
 437       DerefStablePtr does things.)
 438      -}
 439      lhs'   = amodeToStix lhs
 440      a'     = amodeToStix a
 441      pk     = getAmodeRep lhs  -- an IntRep
 442      call   = StCall SLIT("SeqZhCode") cCallConv pk [a']
 443      assign = StAssign pk lhs' call
 444     in
 445 --    trace "SeqOp" $
 446     returnUs (\xs -> assign : xs)
 447
 448 primCode lhs (CCallOp (Just fn) is_asm may_gc cconv arg_tys result_ty) rhs
 449   | is_asm = error "ERROR: Native code generator can't handle casm"
 450   | otherwise
 451   = case lhs of
 452       [] -> returnUs (\xs -> (StCall fn cconv VoidRep args) : xs)
 453       [lhs] ->
 454           let lhs' = amodeToStix lhs
 455               pk = if isFloatingRep (getAmodeRep lhs) then DoubleRep else IntRep
 456               call = StAssign pk lhs' (StCall fn cconv pk args)
 457           in
 458               returnUs (\xs -> call : xs)
 459   where
 460     args = map amodeCodeForCCall rhs
 461     amodeCodeForCCall x =
 462         let base = amodeToStix' x
 463         in
 464             case getAmodeRep x of
 465               ArrayRep      -> StIndex PtrRep base mutHS
 466               ByteArrayRep  -> StIndex IntRep base dataHS
 467               ForeignObjRep -> StIndex PtrRep base foHS
 468                  {-error "ERROR: native-code generator can't handle ForeignObjs (yet): use -fvia-C!"-}
 469               _ -> base
 470 \end{code}
 471
 472 Now the more mundane operations.
 473
 474 \begin{code}
 475 primCode lhs op rhs
 476   = let
 477         lhs' = map amodeToStix  lhs
 478         rhs' = map amodeToStix' rhs
 479     in
 480     returnUs (\ xs -> simplePrim lhs' op rhs' : xs)
 481 \end{code}
 482
 483 \begin{code}
 484 simpleCoercion
 485       :: PrimRep
 486       -> CAddrMode
 487       -> CAddrMode
 488       -> UniqSM StixTreeList
 489
 490 simpleCoercion pk lhs rhs
 491   = returnUs (\xs -> StAssign pk (amodeToStix lhs) (amodeToStix rhs) : xs)
 492 \end{code}
 493
 494 Here we try to rewrite primitives into a form the code generator can
 495 understand.  Any primitives not handled here must be handled at the
 496 level of the specific code generator.
 497
 498 \begin{code}
 499 simplePrim
 500     :: [StixTree]
 501     -> PrimOp
 502     -> [StixTree]
 503     -> StixTree
 504 \end{code}
 505
 506 Now look for something more conventional.
 507
 508 \begin{code}
 509 simplePrim [lhs] op rest
 510   = StAssign pk lhs (StPrim op rest)
 511   where
 512     pk = if isCompareOp op then
 513             IntRep
 514          else
 515             case getPrimOpResultInfo op of
 516                ReturnsPrim pk -> pk
 517                _ -> simplePrim_error op
 518
 519 simplePrim as op bs = simplePrim_error op
 520
 521 simplePrim_error op
 522     = error ("ERROR: primitive operation `"++showPrimOp op++"'cannot be handled\nby the native-code generator.  Workaround: use -fvia-C.\n(Perhaps you should report it as a GHC bug, also.)\n")
 523 \end{code}
 524
 525 %---------------------------------------------------------------------
 526
 527 Here we generate the Stix code for CAddrModes.
 528
 529 When a character is fetched from a mixed type location, we have to do
 530 an extra cast.  This is reflected in amodeCode', which is for rhs
 531 amodes that might possibly need the extra cast.
 532
 533 \begin{code}
 534 amodeToStix, amodeToStix' :: CAddrMode -> StixTree
 535
 536 amodeToStix'{-'-} am@(CVal rr CharRep)
 537     | mixedTypeLocn am = StPrim ChrOp [amodeToStix am]
 538     | otherwise = amodeToStix am
 539
 540 amodeToStix' am = amodeToStix am
 541
 542 -----------
 543 amodeToStix am@(CVal rr CharRep)
 544   | mixedTypeLocn am
 545   = StInd IntRep (amodeToStix (CAddr rr))
 546
 547 amodeToStix (CVal rr pk) = StInd pk (amodeToStix (CAddr rr))
 548
 549 amodeToStix (CAddr (SpARel spA off))
 550   = StIndex PtrRep stgSpA (StInt (toInteger (spARelToInt spA off)))
 551
 552 amodeToStix (CAddr (SpBRel spB off))
 553   = StIndex IntRep stgSpB (StInt (toInteger (spBRelToInt spB off)))
 554
 555 amodeToStix (CAddr (HpRel hp off))
 556   = StIndex IntRep stgHp (StInt (toInteger (-(hpRelToInt (hp `subOff` off)))))
 557
 558 amodeToStix (CAddr (NodeRel off))
 559   = StIndex IntRep stgNode (StInt (toInteger (hpRelToInt off)))
 560
 561 amodeToStix (CReg magic)    = StReg (StixMagicId magic)
 562 amodeToStix (CTemp uniq pk) = StReg (StixTemp uniq pk)
 563
 564 amodeToStix (CLbl      lbl _) = StCLbl lbl
 565 amodeToStix (CUnVecLbl dir _) = StCLbl dir
 566
 567 amodeToStix (CTableEntry base off pk)
 568   = StInd pk (StIndex pk (amodeToStix base) (amodeToStix off))
 569
 570  -- For CharLike and IntLike, we attempt some trivial constant-folding here.
 571
 572 amodeToStix (CCharLike (CLit (MachChar c)))
 573   = StLitLbl ((<>) (ptext SLIT("CHARLIKE_closures+")) (int off))
 574   where
 575     off = charLikeSize * ord c
 576
 577 amodeToStix (CCharLike x)
 578   = StPrim IntAddOp [charLike, off]
 579   where
 580     off = StPrim IntMulOp [amodeToStix x, StInt (toInteger charLikeSize)]
 581
 582 amodeToStix (CIntLike (CLit (MachInt i _)))
 583   = StPrim IntAddOp [intLikePtr, StInt off]
 584   where
 585     off = toInteger intLikeSize * toInteger i
 586
 587 amodeToStix (CIntLike x)
 588   = StPrim IntAddOp [intLikePtr, off]
 589   where
 590     off = StPrim IntMulOp [amodeToStix x, StInt (toInteger intLikeSize)]
 591
 592  -- A CString is just a (CLit . MachStr)
 593 amodeToStix (CString s) = StString s
 594
 595 amodeToStix (CLit core)
 596   = case core of
 597       MachChar c     -> StInt (toInteger (ord c))
 598       MachStr s      -> StString s
 599       MachAddr a     -> StInt a
 600       MachInt i _    -> StInt (toInteger i)
 601       MachLitLit s _ -> StLitLit s
 602       MachFloat d    -> StDouble d
 603       MachDouble d   -> StDouble d
 604       _ -> panic "amodeToStix:core literal"
 605
 606  -- A CLitLit is just a (CLit . MachLitLit)
 607 amodeToStix (CLitLit s _) = StLitLit s
 608
 609  -- COffsets are in words, not bytes!
 610 amodeToStix (COffset off) = StInt (toInteger (hpRelToInt off))
 611
 612 amodeToStix (CMacroExpr _ macro [arg])
 613   = case macro of
 614       INFO_PTR   -> StInd PtrRep (amodeToStix arg)
 615       ENTRY_CODE -> amodeToStix arg
 616       INFO_TAG   -> tag
 617       EVAL_TAG   -> StPrim IntGeOp [tag, StInt 0]
 618    where
 619      tag = StInd IntRep (StIndex IntRep (amodeToStix arg) (StInt (-2)))
 620      -- That ``-2'' really bothers me. (JSM) (Replace w/ oTHER_TAG? [WDP])
 621
 622 amodeToStix (CCostCentre cc print_as_string)
 623   = if noCostCentreAttached cc
 624     then StComment SLIT("") -- sigh
 625     else panic "amodeToStix:CCostCentre"
 626 \end{code}
 627
 628 Sizes of the CharLike and IntLike closures that are arranged as arrays
 629 in the data segment.  (These are in bytes.)
 630
 631 \begin{code}
 632 -- The INTLIKE base pointer
 633
 634 intLikePtr :: StixTree
 635
 636 intLikePtr = StInd PtrRep (sStLitLbl SLIT("INTLIKE_closures"))
 637
 638 -- The CHARLIKE base
 639
 640 charLike :: StixTree
 641
 642 charLike = sStLitLbl SLIT("CHARLIKE_closures")
 643
 644 -- Trees for the ErrorIOPrimOp
 645
 646 topClosure, errorIO :: StixTree
 647
 648 topClosure = StInd PtrRep (sStLitLbl SLIT("TopClosure"))
 649 errorIO = StJump (StInd PtrRep (sStLitLbl SLIT("ErrorIO_innards")))
 650 \end{code}