ghc/compiler/nativeGen/StixPrim.lhs

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