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