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