ghc/compiler/nativeGen/StixPrim.lhs

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