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 (Left fn) is_asm may_gc cconv arg_tys result_ty) rhs
 449   | is_asm = error "ERROR: Native code generator can't handle casm"
 450   | may_gc = error "ERROR: Native code generator can't handle _ccall_GC_\n"
 451   | otherwise
 452   = case lhs of
 453       [] -> returnUs (\xs -> (StCall fn cconv VoidRep args) : xs)
 454       [lhs] ->
 455           let lhs' = amodeToStix lhs
 456               pk = if isFloatingRep (getAmodeRep lhs) then DoubleRep else IntRep
 457               call = StAssign pk lhs' (StCall fn cconv pk args)
 458           in
 459               returnUs (\xs -> call : xs)
 460   where
 461     args = map amodeCodeForCCall rhs
 462     amodeCodeForCCall x =
 463         let base = amodeToStix' x
 464         in
 465             case getAmodeRep x of
 466               ArrayRep      -> StIndex PtrRep base mutHS
 467               ByteArrayRep  -> StIndex IntRep base dataHS
 468               ForeignObjRep -> StIndex PtrRep base foHS
 469                  {-error "ERROR: native-code generator can't handle ForeignObjs (yet): use -fvia-C!"-}
 470               _ -> base
 471 \end{code}
 472
 473 Now the more mundane operations.
 474
 475 \begin{code}
 476 primCode lhs op rhs
 477   = let
 478         lhs' = map amodeToStix  lhs
 479         rhs' = map amodeToStix' rhs
 480     in
 481     returnUs (\ xs -> simplePrim lhs' op rhs' : xs)
 482 \end{code}
 483
 484 \begin{code}
 485 simpleCoercion
 486       :: PrimRep
 487       -> CAddrMode
 488       -> CAddrMode
 489       -> UniqSM StixTreeList
 490
 491 simpleCoercion pk lhs rhs
 492   = returnUs (\xs -> StAssign pk (amodeToStix lhs) (amodeToStix rhs) : xs)
 493 \end{code}
 494
 495 Here we try to rewrite primitives into a form the code generator can
 496 understand.  Any primitives not handled here must be handled at the
 497 level of the specific code generator.
 498
 499 \begin{code}
 500 simplePrim
 501     :: [StixTree]
 502     -> PrimOp
 503     -> [StixTree]
 504     -> StixTree
 505 \end{code}
 506
 507 Now look for something more conventional.
 508
 509 \begin{code}
 510 simplePrim [lhs] op rest
 511   = StAssign pk lhs (StPrim op rest)
 512   where
 513     pk = if isCompareOp op then
 514             IntRep
 515          else
 516             case getPrimOpResultInfo op of
 517                ReturnsPrim pk -> pk
 518                _ -> simplePrim_error op
 519
 520 simplePrim as op bs = simplePrim_error op
 521
 522 simplePrim_error op
 523     = 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")
 524 \end{code}
 525
 526 %---------------------------------------------------------------------
 527
 528 Here we generate the Stix code for CAddrModes.
 529
 530 When a character is fetched from a mixed type location, we have to do
 531 an extra cast.  This is reflected in amodeCode', which is for rhs
 532 amodes that might possibly need the extra cast.
 533
 534 \begin{code}
 535 amodeToStix, amodeToStix' :: CAddrMode -> StixTree
 536
 537 amodeToStix'{-'-} am@(CVal rr CharRep)
 538     | mixedTypeLocn am = StPrim ChrOp [amodeToStix am]
 539     | otherwise = amodeToStix am
 540
 541 amodeToStix' am = amodeToStix am
 542
 543 -----------
 544 amodeToStix am@(CVal rr CharRep)
 545   | mixedTypeLocn am
 546   = StInd IntRep (amodeToStix (CAddr rr))
 547
 548 amodeToStix (CVal rr pk) = StInd pk (amodeToStix (CAddr rr))
 549
 550 amodeToStix (CAddr (SpARel spA off))
 551   = StIndex PtrRep stgSpA (StInt (toInteger (spARelToInt spA off)))
 552
 553 amodeToStix (CAddr (SpBRel spB off))
 554   = StIndex IntRep stgSpB (StInt (toInteger (spBRelToInt spB off)))
 555
 556 amodeToStix (CAddr (HpRel hp off))
 557   = StIndex IntRep stgHp (StInt (toInteger (-(hpRelToInt (hp `subOff` off)))))
 558
 559 amodeToStix (CAddr (NodeRel off))
 560   = StIndex IntRep stgNode (StInt (toInteger (hpRelToInt off)))
 561
 562 amodeToStix (CReg magic)    = StReg (StixMagicId magic)
 563 amodeToStix (CTemp uniq pk) = StReg (StixTemp uniq pk)
 564
 565 amodeToStix (CLbl      lbl _) = StCLbl lbl
 566 amodeToStix (CUnVecLbl dir _) = StCLbl dir
 567
 568 amodeToStix (CTableEntry base off pk)
 569   = StInd pk (StIndex pk (amodeToStix base) (amodeToStix off))
 570
 571  -- For CharLike and IntLike, we attempt some trivial constant-folding here.
 572
 573 amodeToStix (CCharLike (CLit (MachChar c)))
 574   = StLitLbl ((<>) (ptext SLIT("CHARLIKE_closures+")) (int off))
 575   where
 576     off = charLikeSize * ord c
 577
 578 amodeToStix (CCharLike x)
 579   = StPrim IntAddOp [charLike, off]
 580   where
 581     off = StPrim IntMulOp [amodeToStix x, StInt (toInteger charLikeSize)]
 582
 583 amodeToStix (CIntLike (CLit (MachInt i _)))
 584   = StPrim IntAddOp [intLikePtr, StInt off]
 585   where
 586     off = toInteger intLikeSize * toInteger i
 587
 588 amodeToStix (CIntLike x)
 589   = StPrim IntAddOp [intLikePtr, off]
 590   where
 591     off = StPrim IntMulOp [amodeToStix x, StInt (toInteger intLikeSize)]
 592
 593  -- A CString is just a (CLit . MachStr)
 594 amodeToStix (CString s) = StString s
 595
 596 amodeToStix (CLit core)
 597   = case core of
 598       MachChar c     -> StInt (toInteger (ord c))
 599       MachStr s      -> StString s
 600       MachAddr a     -> StInt a
 601       MachInt i _    -> StInt (toInteger i)
 602       MachLitLit s _ -> StLitLit s
 603       MachFloat d    -> StDouble d
 604       MachDouble d   -> StDouble d
 605       _ -> panic "amodeToStix:core literal"
 606
 607  -- A CLitLit is just a (CLit . MachLitLit)
 608 amodeToStix (CLitLit s _) = StLitLit s
 609
 610  -- COffsets are in words, not bytes!
 611 amodeToStix (COffset off) = StInt (toInteger (hpRelToInt off))
 612
 613 amodeToStix (CMacroExpr _ macro [arg])
 614   = case macro of
 615       INFO_PTR   -> StInd PtrRep (amodeToStix arg)
 616       ENTRY_CODE -> amodeToStix arg
 617       INFO_TAG   -> tag
 618       EVAL_TAG   -> StPrim IntGeOp [tag, StInt 0]
 619    where
 620      tag = StInd IntRep (StIndex IntRep (amodeToStix arg) (StInt (-2)))
 621      -- That ``-2'' really bothers me. (JSM) (Replace w/ oTHER_TAG? [WDP])
 622
 623 amodeToStix (CCostCentre cc print_as_string)
 624   = if noCostCentreAttached cc
 625     then StComment SLIT("") -- sigh
 626     else panic "amodeToStix:CCostCentre"
 627 \end{code}
 628
 629 Sizes of the CharLike and IntLike closures that are arranged as arrays
 630 in the data segment.  (These are in bytes.)
 631
 632 \begin{code}
 633 -- The INTLIKE base pointer
 634
 635 intLikePtr :: StixTree
 636
 637 intLikePtr = StInd PtrRep (sStLitLbl SLIT("INTLIKE_closures"))
 638
 639 -- The CHARLIKE base
 640
 641 charLike :: StixTree
 642
 643 charLike = sStLitLbl SLIT("CHARLIKE_closures")
 644
 645 -- Trees for the ErrorIOPrimOp
 646
 647 topClosure, errorIO :: StixTree
 648
 649 topClosure = StInd PtrRep (sStLitLbl SLIT("TopClosure"))
 650 errorIO = StJump (StInd PtrRep (sStLitLbl SLIT("ErrorIO_innards")))
 651 \end{code}