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