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