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 [lhs] (IndexOffForeignObjOp pk) [obj, ix]
 277   = let
 278         lhs' = amodeToStix lhs
 279         obj' = amodeToStix obj
 280         ix' = amodeToStix ix
 281         obj'' = StIndex PtrRep obj' foHS
 282         assign = StAssign pk lhs' (StInd pk (StIndex pk obj'' ix'))
 283     in
 284     returnUs (\xs -> assign : xs)
 285
 286 primCode [] (WriteByteArrayOp pk) [obj, ix, v]
 287   = let
 288         obj' = amodeToStix obj
 289         ix' = amodeToStix ix
 290         v' = amodeToStix v
 291         base = StIndex IntRep obj' dataHS
 292         assign = StAssign pk (StInd pk (StIndex pk base ix')) v'
 293     in
 294     returnUs (\xs -> assign : xs)
 295 \end{code}
 296
 297 Stable pointer operations.
 298
 299 First the easy one.
 300 \begin{code}
 301
 302 primCode [lhs] DeRefStablePtrOp [sp]
 303   = let
 304         lhs' = amodeToStix lhs
 305         pk = getAmodeRep lhs
 306         sp' = amodeToStix sp
 307         call = StCall SLIT("deRefStablePointer") pk [sp', smStablePtrTable]
 308         assign = StAssign pk lhs' call
 309     in
 310     returnUs (\xs -> assign : xs)
 311 \end{code}
 312
 313 Now the hard one.  For comparison, here's the code from StgMacros:
 314
 315 \begin{verbatim}
 316 #define makeStablePtrZh(stablePtr,liveness,unstablePtr)              \
 317 do {                                                                 \
 318   EXTDATA(MK_INFO_LBL(StablePointerTable));                          \
 319   EXTDATA(UnusedSP);                                                 \
 320   StgStablePtr newSP;                                                \
 321                                                                      \
 322   if (SPT_EMPTY(StorageMgrInfo.StablePointerTable)) { /* free stack is empty */ \
 323     I_ OldNoPtrs = SPT_NoPTRS(StorageMgrInfo.StablePointerTable);    \
 324                                                                      \
 325     /* any strictly increasing expression will do here */            \
 326     I_ NewNoPtrs = OldNoPtrs * 2 + 100;                              \
 327                                                                      \
 328     I_ NewSize = DYN_VHS + NewNoPtrs + 1 + NewNoPtrs;                \
 329     P_ SPTable;                                                      \
 330                                                                      \
 331     HEAP_CHK(NO_LIVENESS, _FHS+NewSize, 0);                          \
 332     CC_ALLOC(CCC, _FHS+NewSize, SPT_K); /* cc prof */                \
 333                                                                      \
 334     SPTable = Hp + 1 - (_FHS + NewSize);                             \
 335     SET_DYN_HDR(SPTable,StablePointerTable,CCC,NewSize,NewNoPtrs);   \
 336     SAFESTGCALL2(void, (void *, P_, P_), enlargeSPTable, SPTable, StorageMgrInfo.StablePointerTable);      \
 337     StorageMgrInfo.StablePointerTable = SPTable;                     \
 338   }                                                                  \
 339                                                                      \
 340   newSP = SPT_POP(StorageMgrInfo.StablePointerTable);                \
 341   SPT_SPTR(StorageMgrInfo.StablePointerTable, newSP) = unstablePtr; \
 342   stablePtr = newSP;                                                 \
 343 } while (0)
 344 \end{verbatim}
 345
 346 ToDo ADR: finish this.  (Boy, this is hard work!)
 347
 348 Notes for ADR:
 349     trMumbles are now just StMumbles.
 350     StInt 1 is how to write ``1''
 351     temporaries are allocated at the end of the heap (see notes in StixInteger)
 352     Good luck!
 353
 354     --JSM
 355
 356 \begin{pseudocode}
 357 primCode [lhs] MakeStablePtrOp args
 358   = let
 359         -- some useful abbreviations (I'm sure these must exist already)
 360         add = trPrim . IntAddOp
 361         sub = trPrim . IntSubOp
 362         one = trInt [1]
 363         dec x = trAssign IntRep [x, sub [x, one]]
 364         inc x = trAssign IntRep [x, add [x, one]]
 365
 366         -- tedious hardwiring in of closure layout offsets (from SMClosures)
 367         dynHS = 2 + fixedHdrSizeInWords + varHdrSizeInWords DynamicRep
 368         spt_SIZE c   = trIndex PtrRep [c, trInt [fhs + gc_reserved] ]
 369         spt_NoPTRS c = trIndex PtrRep [c, trInt [fhs + gc_reserved + 1] ]
 370         spt_SPTR c i = trIndex PtrRep [c, add [trInt [dynHS], i]]
 371         spt_TOP c    = trIndex PtrRep [c, add [trInt [dynHS], spt_NoPTRS c]]
 372         spt_FREE c i = trIndex PtrRep [c, add [trInt [dynHS], spt_NoPTRS c]]
 373
 374         -- tedious hardwiring in of stack manipulation macros (from SMClosures)
 375         spt_FULL c lbl =
 376                 trCondJump lbl [trPrim IntEqOp [spt_TOP c, spt_NoPTRS c]]
 377         spt_EMPTY c lbl =
 378                 trCondJump lbl [trPrim IntEqOp [spt_TOP c, trInt [0]]]
 379         spt_PUSH c f = [
 380                 trAssign PtrRep [spt_FREE c (spt_TOP c), f],
 381                 inc (spt_TOP c),
 382         spt_POP c x  = [
 383                 dec (spt_TOP c),
 384                 trAssign PtrRep [x, spt_FREE c (spt_TOP c)]
 385         ]
 386
 387         -- now to get down to business
 388         lhs' = amodeCode lhs
 389         [liveness, unstable] = map amodeCode args
 390
 391         spt = smStablePtrTable
 392
 393         newSPT = -- a temporary (don't know how to allocate it)
 394         newSP = -- another temporary
 395
 396         allocNewTable = -- some sort fo heap allocation needed
 397         copyOldTable = trCall "enlargeSPTable" PtrRep [newSPT, spt]
 398
 399         enlarge =
 400                 allocNewTable ++ [
 401                 copyOldTable,
 402                 trAssign PtrRep [spt, newSPT]
 403         allocate = [
 404                 spt_POP spt newSP,
 405                 trAssign PtrRep [spt_SPTR spt newSP, unstable],
 406                 trAssign StablePtrRep [lhs', newSP]
 407         ]
 408
 409     in
 410     getUniqLabelCTS                                `thenCTS` \ oklbl ->
 411     returnCodes sty md
 412         (spt_EMPTY spt oklbl : (enlarge ++ (trLabel [oklbl] : allocate)))
 413 \end{pseudocode}
 414
 415 \begin{code}
 416 primCode res Word2IntegerOp args = panic "primCode:Word2IntegerOp"
 417
 418 primCode lhs (CCallOp fn is_asm may_gc arg_tys result_ty) rhs
 419   | is_asm = error "ERROR: Native code generator can't handle casm"
 420   | otherwise
 421   = case lhs of
 422       [] -> returnUs (\xs -> (StCall fn VoidRep args) : xs)
 423       [lhs] ->
 424           let lhs' = amodeToStix lhs
 425               pk = if isFloatingRep (getAmodeRep lhs) then DoubleRep else IntRep
 426               call = StAssign pk lhs' (StCall fn pk args)
 427           in
 428               returnUs (\xs -> call : xs)
 429   where
 430     args = map amodeCodeForCCall rhs
 431     amodeCodeForCCall x =
 432         let base = amodeToStix' x
 433         in
 434             case getAmodeRep x of
 435               ArrayRep      -> StIndex PtrRep base mutHS
 436               ByteArrayRep  -> StIndex IntRep base dataHS
 437               ForeignObjRep -> StIndex PtrRep base foHS
 438                  {-error "ERROR: native-code generator can't handle ForeignObjs (yet): use -fvia-C!"-}
 439               _ -> base
 440 \end{code}
 441
 442 Now the more mundane operations.
 443
 444 \begin{code}
 445 primCode lhs op rhs
 446   = let
 447         lhs' = map amodeToStix  lhs
 448         rhs' = map amodeToStix' rhs
 449     in
 450     returnUs (\ xs -> simplePrim lhs' op rhs' : xs)
 451 \end{code}
 452
 453 \begin{code}
 454 simpleCoercion
 455       :: PrimRep
 456       -> CAddrMode
 457       -> CAddrMode
 458       -> UniqSM StixTreeList
 459
 460 simpleCoercion pk lhs rhs
 461   = returnUs (\xs -> StAssign pk (amodeToStix lhs) (amodeToStix rhs) : xs)
 462 \end{code}
 463
 464 Here we try to rewrite primitives into a form the code generator can
 465 understand.  Any primitives not handled here must be handled at the
 466 level of the specific code generator.
 467
 468 \begin{code}
 469 simplePrim
 470     :: [StixTree]
 471     -> PrimOp
 472     -> [StixTree]
 473     -> StixTree
 474 \end{code}
 475
 476 Now look for something more conventional.
 477
 478 \begin{code}
 479 simplePrim [lhs] op rest
 480   = StAssign pk lhs (StPrim op rest)
 481   where
 482     pk = if isCompareOp op then
 483             IntRep
 484          else
 485             case getPrimOpResultInfo op of
 486                ReturnsPrim pk -> pk
 487                _ -> simplePrim_error op
 488
 489 simplePrim as op bs = simplePrim_error op
 490
 491 simplePrim_error op
 492     = 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")
 493 \end{code}
 494
 495 %---------------------------------------------------------------------
 496
 497 Here we generate the Stix code for CAddrModes.
 498
 499 When a character is fetched from a mixed type location, we have to do
 500 an extra cast.  This is reflected in amodeCode', which is for rhs
 501 amodes that might possibly need the extra cast.
 502
 503 \begin{code}
 504 amodeToStix, amodeToStix' :: CAddrMode -> StixTree
 505
 506 amodeToStix'{-'-} am@(CVal rr CharRep)
 507     | mixedTypeLocn am = StPrim ChrOp [amodeToStix am]
 508     | otherwise = amodeToStix am
 509
 510 amodeToStix' am = amodeToStix am
 511
 512 -----------
 513 amodeToStix am@(CVal rr CharRep)
 514   | mixedTypeLocn am
 515   = StInd IntRep (amodeToStix (CAddr rr))
 516
 517 amodeToStix (CVal rr pk) = StInd pk (amodeToStix (CAddr rr))
 518
 519 amodeToStix (CAddr (SpARel spA off))
 520   = StIndex PtrRep stgSpA (StInt (toInteger (spARelToInt spA off)))
 521
 522 amodeToStix (CAddr (SpBRel spB off))
 523   = StIndex IntRep stgSpB (StInt (toInteger (spBRelToInt spB off)))
 524
 525 amodeToStix (CAddr (HpRel hp off))
 526   = StIndex IntRep stgHp (StInt (toInteger (-(hpRelToInt (hp `subOff` off)))))
 527
 528 amodeToStix (CAddr (NodeRel off))
 529   = StIndex IntRep stgNode (StInt (toInteger (hpRelToInt off)))
 530
 531 amodeToStix (CReg magic)    = StReg (StixMagicId magic)
 532 amodeToStix (CTemp uniq pk) = StReg (StixTemp uniq pk)
 533
 534 amodeToStix (CLbl      lbl _) = StCLbl lbl
 535 amodeToStix (CUnVecLbl dir _) = StCLbl dir
 536
 537 amodeToStix (CTableEntry base off pk)
 538   = StInd pk (StIndex pk (amodeToStix base) (amodeToStix off))
 539
 540  -- For CharLike and IntLike, we attempt some trivial constant-folding here.
 541
 542 amodeToStix (CCharLike (CLit (MachChar c)))
 543   = StLitLbl ((<>) (ptext SLIT("CHARLIKE_closures+")) (int off))
 544   where
 545     off = charLikeSize * ord c
 546
 547 amodeToStix (CCharLike x)
 548   = StPrim IntAddOp [charLike, off]
 549   where
 550     off = StPrim IntMulOp [amodeToStix x, StInt (toInteger charLikeSize)]
 551
 552 amodeToStix (CIntLike (CLit (MachInt i _)))
 553   = StPrim IntAddOp [intLikePtr, StInt off]
 554   where
 555     off = toInteger intLikeSize * i
 556
 557 amodeToStix (CIntLike x)
 558   = StPrim IntAddOp [intLikePtr, off]
 559   where
 560     off = StPrim IntMulOp [amodeToStix x, StInt (toInteger intLikeSize)]
 561
 562  -- A CString is just a (CLit . MachStr)
 563 amodeToStix (CString s) = StString s
 564
 565 amodeToStix (CLit core)
 566   = case core of
 567       MachChar c     -> StInt (toInteger (ord c))
 568       MachStr s      -> StString s
 569       MachAddr a     -> StInt a
 570       MachInt i _    -> StInt i
 571       MachLitLit s _ -> StLitLit s
 572       MachFloat d    -> StDouble d
 573       MachDouble d   -> StDouble d
 574       _ -> panic "amodeToStix:core literal"
 575
 576  -- A CLitLit is just a (CLit . MachLitLit)
 577 amodeToStix (CLitLit s _) = StLitLit s
 578
 579  -- COffsets are in words, not bytes!
 580 amodeToStix (COffset off) = StInt (toInteger (hpRelToInt off))
 581
 582 amodeToStix (CMacroExpr _ macro [arg])
 583   = case macro of
 584       INFO_PTR   -> StInd PtrRep (amodeToStix arg)
 585       ENTRY_CODE -> amodeToStix arg
 586       INFO_TAG   -> tag
 587       EVAL_TAG   -> StPrim IntGeOp [tag, StInt 0]
 588    where
 589      tag = StInd IntRep (StIndex IntRep (amodeToStix arg) (StInt (-2)))
 590      -- That ``-2'' really bothers me. (JSM) (Replace w/ oTHER_TAG? [WDP])
 591
 592 amodeToStix (CCostCentre cc print_as_string)
 593   = if noCostCentreAttached cc
 594     then StComment SLIT("") -- sigh
 595     else panic "amodeToStix:CCostCentre"
 596 \end{code}
 597
 598 Sizes of the CharLike and IntLike closures that are arranged as arrays
 599 in the data segment.  (These are in bytes.)
 600
 601 \begin{code}
 602 -- The INTLIKE base pointer
 603
 604 intLikePtr :: StixTree
 605
 606 intLikePtr = StInd PtrRep (sStLitLbl SLIT("INTLIKE_closures"))
 607
 608 -- The CHARLIKE base
 609
 610 charLike :: StixTree
 611
 612 charLike = sStLitLbl SLIT("CHARLIKE_closures")
 613
 614 -- Trees for the ErrorIOPrimOp
 615
 616 topClosure, flushStdout, flushStderr, errorIO :: StixTree
 617
 618 topClosure = StInd PtrRep (sStLitLbl SLIT("TopClosure"))
 619 flushStdout = StCall SLIT("fflush") VoidRep [StLitLit SLIT("stdout")]
 620 flushStderr = StCall SLIT("fflush") VoidRep [StLitLit SLIT("stderr")]
 621 errorIO = StJump (StInd PtrRep (sStLitLbl SLIT("ErrorIO_innards")))
 622 \end{code}