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