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 #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 201
  12 IMPORT_DELOOPER(NcgLoop)                -- paranoia checking only
  13 #endif
  14
  15 import MachMisc
  16 #if __GLASGOW_HASKELL__ >= 202
  17 import MachRegs hiding (Addr)
  18 #else
  19 import MachRegs
  20 #endif
  21
  22 import AbsCSyn
  23 import AbsCUtils        ( getAmodeRep, mixedTypeLocn )
  24 import Constants        ( spARelToInt, spBRelToInt )
  25 import CostCentre       ( noCostCentreAttached )
  26 import HeapOffs         ( hpRelToInt, subOff )
  27 import Literal          ( Literal(..) )
  28 import PrimOp           ( PrimOp(..), isCompareOp, showPrimOp,
  29                           getPrimOpResultInfo, PrimOpResultInfo(..)
  30                         )
  31 import PrimRep          ( PrimRep(..), isFloatingRep )
  32 import OrdList          ( OrdList )
  33 import Outputable       ( PprStyle(..) )
  34 import SMRep            ( SMRep(..), SMSpecRepKind, SMUpdateKind )
  35 import Stix
  36 import StixMacro        ( heapCheck )
  37 import StixInteger      {- everything -}
  38 import UniqSupply       ( returnUs, thenUs, SYN_IE(UniqSM) )
  39 import Pretty           ( (<>), ptext, int )
  40 import Util             ( panic )
  41
  42 #ifdef REALLY_HASKELL_1_3
  43 ord = fromEnum :: Char -> Int
  44 #endif
  45 \end{code}
  46
  47 The main honcho here is primCode, which handles the guts of COpStmts.
  48
  49 \begin{code}
  50 arrayOfData_info      = sStLitLbl SLIT("ArrayOfData_info") -- out here to avoid CAF (sigh)
  51 imMutArrayOfPtrs_info = sStLitLbl SLIT("ImMutArrayOfPtrs_info")
  52
  53 primCode
  54     :: [CAddrMode]      -- results
  55     -> PrimOp           -- op
  56     -> [CAddrMode]      -- args
  57     -> UniqSM StixTreeList
  58 \end{code}
  59
  60 First, the dreaded @ccall@.  We can't handle @casm@s.
  61
  62 Usually, this compiles to an assignment, but when the left-hand side
  63 is empty, we just perform the call and ignore the result.
  64
  65 ToDo ADR: modify this to handle ForeignObjs.
  66
  67 btw Why not let programmer use casm to provide assembly code instead
  68 of C code?  ADR
  69
  70 The (MP) integer operations are a true nightmare.  Since we don't have
  71 a convenient abstract way of allocating temporary variables on the (C)
  72 stack, we use the space just below HpLim for the @MP_INT@ structures,
  73 and modify our heap check accordingly.
  74
  75 \begin{code}
  76 -- NB: ordering of clauses somewhere driven by
  77 -- the desire to getting sane patt-matching behavior
  78
  79 primCode res@[ar1,sr1,dr1, ar2,sr2,dr2]
  80          IntegerQuotRemOp
  81          args@[liveness, aa1,sa1,da1, aa2,sa2,da2]
  82   = gmpTake2Return2 (ar1,sr1,dr1, ar2,sr2,dr2) SLIT("mpz_divmod") (liveness, aa1,sa1,da1, aa2,sa2,da2)
  83
  84 primCode res@[ar1,sr1,dr1, ar2,sr2,dr2]
  85          IntegerDivModOp
  86          args@[liveness, aa1,sa1,da1, aa2,sa2,da2]
  87   = gmpTake2Return2 (ar1,sr1,dr1, ar2,sr2,dr2) SLIT("mpz_targetivmod") (liveness, aa1,sa1,da1, aa2,sa2,da2)
  88
  89 primCode res@[ar,sr,dr] IntegerAddOp args@[liveness, aa1,sa1,da1, aa2,sa2,da2]
  90   = gmpTake2Return1 (ar,sr,dr) SLIT("mpz_add") (liveness, aa1,sa1,da1, aa2,sa2,da2)
  91 primCode res@[ar,sr,dr] IntegerSubOp args@[liveness, aa1,sa1,da1, aa2,sa2,da2]
  92   = gmpTake2Return1 (ar,sr,dr) SLIT("mpz_sub") (liveness, aa1,sa1,da1, aa2,sa2,da2)
  93 primCode res@[ar,sr,dr] IntegerMulOp args@[liveness, aa1,sa1,da1, aa2,sa2,da2]
  94   = gmpTake2Return1 (ar,sr,dr) SLIT("mpz_mul") (liveness, aa1,sa1,da1, aa2,sa2,da2)
  95
  96 primCode res@[ar,sr,dr] IntegerNegOp arg@[liveness,aa,sa,da]
  97   = gmpTake1Return1 (ar,sr,dr) SLIT("mpz_neg") (liveness,aa,sa,da)
  98 \end{code}
  99
 100 Since we are using the heap for intermediate @MP_INT@ structs, integer
 101 comparison {\em does} require a heap check in the native code
 102 implementation.
 103
 104 \begin{code}
 105 primCode res@[exponr,ar,sr,dr] FloatDecodeOp args@[hp, arg]
 106   = decodeFloatingKind FloatRep (exponr,ar,sr,dr) (hp, arg)
 107
 108 primCode res@[exponr,ar,sr,dr] DoubleDecodeOp args@[hp, arg]
 109   = decodeFloatingKind DoubleRep (exponr,ar,sr,dr) (hp, arg)
 110
 111 primCode res@[ar,sr,dr] Int2IntegerOp args@[hp, n]
 112   = gmpInt2Integer (ar,sr,dr) (hp, n)
 113
 114 primCode res@[ar,sr,dr] Addr2IntegerOp args@[liveness,str]
 115   = gmpString2Integer (ar,sr,dr) (liveness,str)
 116
 117 primCode [res] IntegerCmpOp args@[hp, aa1,sa1,da1, aa2,sa2,da2]
 118   = gmpCompare res (hp, aa1,sa1,da1, aa2,sa2,da2)
 119
 120 primCode [res] Integer2IntOp arg@[hp, aa,sa,da]
 121   = gmpInteger2Int res (hp, aa,sa,da)
 122
 123 primCode [res] FloatEncodeOp args@[hp, aa,sa,da, expon]
 124   = encodeFloatingKind FloatRep res (hp, aa,sa,da, expon)
 125
 126 primCode [res] DoubleEncodeOp args@[hp, aa,sa,da, expon]
 127   = encodeFloatingKind DoubleRep res (hp, aa,sa,da, expon)
 128
 129 primCode [res] Int2AddrOp [arg]
 130   = simpleCoercion AddrRep res arg
 131
 132 primCode [res] Addr2IntOp [arg]
 133   = simpleCoercion IntRep res arg
 134
 135 primCode [res] Int2WordOp [arg]
 136   = simpleCoercion IntRep{-WordRep?-} res arg
 137
 138 primCode [res] Word2IntOp [arg]
 139   = simpleCoercion IntRep res arg
 140 \end{code}
 141
 142 The @ErrorIO@ primitive is actually a bit weird...assign a new value
 143 to the root closure, flush stdout and stderr, and jump to the
 144 @ErrorIO_innards@.
 145
 146 \begin{code}
 147 primCode [] ErrorIOPrimOp [rhs]
 148   = let
 149         changeTop = StAssign PtrRep topClosure (amodeToStix rhs)
 150     in
 151     returnUs (\xs -> changeTop : flushStdout : flushStderr : errorIO : xs)
 152 \end{code}
 153
 154 @newArray#@ ops allocate heap space.
 155
 156 \begin{code}
 157 primCode [res] NewArrayOp args
 158   = let
 159         [liveness, n, initial] = map amodeToStix args
 160         result = amodeToStix res
 161         space = StPrim IntAddOp [n, mutHS]
 162         loc = StIndex PtrRep stgHp
 163               (StPrim IntNegOp [StPrim IntSubOp [space, StInt 1]])
 164         assign = StAssign PtrRep result loc
 165         initialise = StCall SLIT("newArrZh_init") VoidRep [result, n, initial]
 166     in
 167     heapCheck liveness space (StInt 0)  `thenUs` \ heap_chk ->
 168
 169     returnUs (heap_chk . (\xs -> assign : initialise : xs))
 170
 171 primCode [res] (NewByteArrayOp pk) args
 172   = let
 173         [liveness, count] = map amodeToStix args
 174         result = amodeToStix res
 175         n = StPrim IntMulOp [count, StInt (sizeOf pk)]
 176         slop = StPrim IntAddOp [n, StInt (sizeOf IntRep - 1)]
 177         words = StPrim IntQuotOp [slop, StInt (sizeOf IntRep)]
 178         space = StPrim IntAddOp [n, StPrim IntAddOp [words, dataHS]]
 179         loc = StIndex PtrRep stgHp
 180               (StPrim IntNegOp [StPrim IntSubOp [space, StInt 1]])
 181         assign = StAssign PtrRep result loc
 182         init1 = StAssign PtrRep (StInd PtrRep loc) arrayOfData_info
 183         init2 = StAssign IntRep
 184                          (StInd IntRep
 185                                 (StIndex IntRep loc
 186                                          (StInt (toInteger fixedHdrSizeInWords))))
 187                          (StPrim IntAddOp [words,
 188                                           StInt (toInteger (varHdrSizeInWords (DataRep 0)))])
 189     in
 190     heapCheck liveness space (StInt 0)  `thenUs` \ heap_chk ->
 191
 192     returnUs (heap_chk . (\xs -> assign : init1 : init2 : xs))
 193
 194 primCode [res] SameMutableArrayOp args
 195   = let
 196         compare = StPrim AddrEqOp (map amodeToStix args)
 197         assign = StAssign IntRep (amodeToStix res) compare
 198     in
 199     returnUs (\xs -> assign : xs)
 200
 201 primCode res@[_] SameMutableByteArrayOp args
 202   = primCode res SameMutableArrayOp args
 203 \end{code}
 204
 205 Freezing an array of pointers is a double assignment.  We fix the
 206 header of the ``new'' closure because the lhs is probably a better
 207 addressing mode for the indirection (most likely, it's a VanillaReg).
 208
 209 \begin{code}
 210
 211 primCode [lhs] UnsafeFreezeArrayOp [rhs]
 212   = let
 213         lhs' = amodeToStix lhs
 214         rhs' = amodeToStix rhs
 215         header = StInd PtrRep lhs'
 216         assign = StAssign PtrRep lhs' rhs'
 217         freeze = StAssign PtrRep header imMutArrayOfPtrs_info
 218     in
 219     returnUs (\xs -> assign : freeze : xs)
 220
 221 primCode [lhs] UnsafeFreezeByteArrayOp [rhs]
 222   = simpleCoercion PtrRep lhs rhs
 223 \end{code}
 224
 225 Most other array primitives translate to simple indexing.
 226
 227 \begin{code}
 228
 229 primCode lhs@[_] IndexArrayOp args
 230   = primCode lhs ReadArrayOp args
 231
 232 primCode [lhs] ReadArrayOp [obj, ix]
 233   = let
 234         lhs' = amodeToStix lhs
 235         obj' = amodeToStix obj
 236         ix' = amodeToStix ix
 237         base = StIndex IntRep obj' mutHS
 238         assign = StAssign PtrRep lhs' (StInd PtrRep (StIndex PtrRep base ix'))
 239     in
 240     returnUs (\xs -> assign : xs)
 241
 242 primCode [] WriteArrayOp [obj, ix, v]
 243   = let
 244         obj' = amodeToStix obj
 245         ix' = amodeToStix ix
 246         v' = amodeToStix v
 247         base = StIndex IntRep obj' mutHS
 248         assign = StAssign PtrRep (StInd PtrRep (StIndex PtrRep base ix')) v'
 249     in
 250     returnUs (\xs -> assign : xs)
 251
 252 primCode lhs@[_] (IndexByteArrayOp pk) args
 253   = primCode lhs (ReadByteArrayOp pk) args
 254
 255 -- NB: indexing in "pk" units, *not* in bytes (WDP 95/09)
 256
 257 primCode [lhs] (ReadByteArrayOp pk) [obj, ix]
 258   = let
 259         lhs' = amodeToStix lhs
 260         obj' = amodeToStix obj
 261         ix' = amodeToStix ix
 262         base = StIndex IntRep obj' dataHS
 263         assign = StAssign pk lhs' (StInd pk (StIndex pk base ix'))
 264     in
 265     returnUs (\xs -> assign : xs)
 266
 267 primCode [lhs] (IndexOffAddrOp pk) [obj, ix]
 268   = let
 269         lhs' = amodeToStix lhs
 270         obj' = amodeToStix obj
 271         ix' = amodeToStix ix
 272         assign = StAssign pk lhs' (StInd pk (StIndex pk obj' ix'))
 273     in
 274     returnUs (\xs -> assign : xs)
 275
 276 primCode [] (WriteByteArrayOp pk) [obj, ix, v]
 277   = let
 278         obj' = amodeToStix obj
 279         ix' = amodeToStix ix
 280         v' = amodeToStix v
 281         base = StIndex IntRep obj' dataHS
 282         assign = StAssign pk (StInd pk (StIndex pk base ix')) v'
 283     in
 284     returnUs (\xs -> assign : xs)
 285 \end{code}
 286
 287 Stable pointer operations.
 288
 289 First the easy one.
 290 \begin{code}
 291
 292 primCode [lhs] DeRefStablePtrOp [sp]
 293   = let
 294         lhs' = amodeToStix lhs
 295         pk = getAmodeRep lhs
 296         sp' = amodeToStix sp
 297         call = StCall SLIT("deRefStablePointer") pk [sp', smStablePtrTable]
 298         assign = StAssign pk lhs' call
 299     in
 300     returnUs (\xs -> assign : xs)
 301 \end{code}
 302
 303 Now the hard one.  For comparison, here's the code from StgMacros:
 304
 305 \begin{verbatim}
 306 #define makeStablePtrZh(stablePtr,liveness,unstablePtr)              \
 307 do {                                                                 \
 308   EXTDATA(MK_INFO_LBL(StablePointerTable));                          \
 309   EXTDATA(UnusedSP);                                                 \
 310   StgStablePtr newSP;                                                \
 311                                                                      \
 312   if (SPT_EMPTY(StorageMgrInfo.StablePointerTable)) { /* free stack is empty */ \
 313     I_ OldNoPtrs = SPT_NoPTRS(StorageMgrInfo.StablePointerTable);    \
 314                                                                      \
 315     /* any strictly increasing expression will do here */            \
 316     I_ NewNoPtrs = OldNoPtrs * 2 + 100;                              \
 317                                                                      \
 318     I_ NewSize = DYN_VHS + NewNoPtrs + 1 + NewNoPtrs;                \
 319     P_ SPTable;                                                      \
 320                                                                      \
 321     HEAP_CHK(NO_LIVENESS, _FHS+NewSize, 0);                          \
 322     CC_ALLOC(CCC, _FHS+NewSize, SPT_K); /* cc prof */                \
 323                                                                      \
 324     SPTable = Hp + 1 - (_FHS + NewSize);                             \
 325     SET_DYN_HDR(SPTable,StablePointerTable,CCC,NewSize,NewNoPtrs);   \
 326     SAFESTGCALL2(void, (void *, P_, P_), enlargeSPTable, SPTable, StorageMgrInfo.StablePointerTable);      \
 327     StorageMgrInfo.StablePointerTable = SPTable;                     \
 328   }                                                                  \
 329                                                                      \
 330   newSP = SPT_POP(StorageMgrInfo.StablePointerTable);                \
 331   SPT_SPTR(StorageMgrInfo.StablePointerTable, newSP) = unstablePtr; \
 332   stablePtr = newSP;                                                 \
 333 } while (0)
 334 \end{verbatim}
 335
 336 ToDo ADR: finish this.  (Boy, this is hard work!)
 337
 338 Notes for ADR:
 339     trMumbles are now just StMumbles.
 340     StInt 1 is how to write ``1''
 341     temporaries are allocated at the end of the heap (see notes in StixInteger)
 342     Good luck!
 343
 344     --JSM
 345
 346 \begin{pseudocode}
 347 primCode [lhs] MakeStablePtrOp args
 348   = let
 349         -- some useful abbreviations (I'm sure these must exist already)
 350         add = trPrim . IntAddOp
 351         sub = trPrim . IntSubOp
 352         one = trInt [1]
 353         dec x = trAssign IntRep [x, sub [x, one]]
 354         inc x = trAssign IntRep [x, add [x, one]]
 355
 356         -- tedious hardwiring in of closure layout offsets (from SMClosures)
 357         dynHS = 2 + fixedHdrSizeInWords + varHdrSizeInWords DynamicRep
 358         spt_SIZE c   = trIndex PtrRep [c, trInt [fhs + gc_reserved] ]
 359         spt_NoPTRS c = trIndex PtrRep [c, trInt [fhs + gc_reserved + 1] ]
 360         spt_SPTR c i = trIndex PtrRep [c, add [trInt [dynHS], i]]
 361         spt_TOP c    = trIndex PtrRep [c, add [trInt [dynHS], spt_NoPTRS c]]
 362         spt_FREE c i = trIndex PtrRep [c, add [trInt [dynHS], spt_NoPTRS c]]
 363
 364         -- tedious hardwiring in of stack manipulation macros (from SMClosures)
 365         spt_FULL c lbl =
 366                 trCondJump lbl [trPrim IntEqOp [spt_TOP c, spt_NoPTRS c]]
 367         spt_EMPTY c lbl =
 368                 trCondJump lbl [trPrim IntEqOp [spt_TOP c, trInt [0]]]
 369         spt_PUSH c f = [
 370                 trAssign PtrRep [spt_FREE c (spt_TOP c), f],
 371                 inc (spt_TOP c),
 372         spt_POP c x  = [
 373                 dec (spt_TOP c),
 374                 trAssign PtrRep [x, spt_FREE c (spt_TOP c)]
 375         ]
 376
 377         -- now to get down to business
 378         lhs' = amodeCode lhs
 379         [liveness, unstable] = map amodeCode args
 380
 381         spt = smStablePtrTable
 382
 383         newSPT = -- a temporary (don't know how to allocate it)
 384         newSP = -- another temporary
 385
 386         allocNewTable = -- some sort fo heap allocation needed
 387         copyOldTable = trCall "enlargeSPTable" PtrRep [newSPT, spt]
 388
 389         enlarge =
 390                 allocNewTable ++ [
 391                 copyOldTable,
 392                 trAssign PtrRep [spt, newSPT]
 393         allocate = [
 394                 spt_POP spt newSP,
 395                 trAssign PtrRep [spt_SPTR spt newSP, unstable],
 396                 trAssign StablePtrRep [lhs', newSP]
 397         ]
 398
 399     in
 400     getUniqLabelCTS                                `thenCTS` \ oklbl ->
 401     returnCodes sty md
 402         (spt_EMPTY spt oklbl : (enlarge ++ (trLabel [oklbl] : allocate)))
 403 \end{pseudocode}
 404
 405 \begin{code}
 406 primCode res Word2IntegerOp args = panic "primCode:Word2IntegerOp"
 407
 408 primCode lhs (CCallOp fn is_asm may_gc arg_tys result_ty) rhs
 409   | is_asm = error "ERROR: Native code generator can't handle casm"
 410   | otherwise
 411   = case lhs of
 412       [] -> returnUs (\xs -> (StCall fn VoidRep args) : xs)
 413       [lhs] ->
 414           let lhs' = amodeToStix lhs
 415               pk = if isFloatingRep (getAmodeRep lhs) then DoubleRep else IntRep
 416               call = StAssign pk lhs' (StCall fn pk args)
 417           in
 418               returnUs (\xs -> call : xs)
 419   where
 420     args = map amodeCodeForCCall rhs
 421     amodeCodeForCCall x =
 422         let base = amodeToStix' x
 423         in
 424             case getAmodeRep x of
 425               ArrayRep -> StIndex PtrRep base mutHS
 426               ByteArrayRep -> StIndex IntRep base dataHS
 427               ForeignObjRep -> 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 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")
 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}