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