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