2 % (c) The AQUA Project, Glasgow University, 1993-1996
6 module StixPrim ( primCode, amodeToStix, amodeToStix' ) where
8 #include "HsVersions.h"
14 import AbsCUtils ( getAmodeRep, mixedTypeLocn )
15 import Constants ( spARelToInt, spBRelToInt )
16 import CostCentre ( noCostCentreAttached )
17 import HeapOffs ( hpRelToInt, subOff )
18 import Literal ( Literal(..) )
19 import PrimOp ( PrimOp(..), isCompareOp, showPrimOp,
20 getPrimOpResultInfo, PrimOpResultInfo(..)
22 import PrimRep ( PrimRep(..), isFloatingRep )
23 import OrdList ( OrdList )
24 import SMRep ( SMRep(..), SMSpecRepKind, SMUpdateKind )
26 import StixMacro ( heapCheck )
27 import StixInteger {- everything -}
28 import UniqSupply ( returnUs, thenUs, UniqSM )
31 #ifdef REALLY_HASKELL_1_3
32 ord = fromEnum :: Char -> Int
36 The main honcho here is primCode, which handles the guts of COpStmts.
39 arrayOfData_info = sStLitLbl SLIT("ArrayOfData_info") -- out here to avoid CAF (sigh)
40 imMutArrayOfPtrs_info = sStLitLbl SLIT("ImMutArrayOfPtrs_info")
43 :: [CAddrMode] -- results
45 -> [CAddrMode] -- args
46 -> UniqSM StixTreeList
49 First, the dreaded @ccall@. We can't handle @casm@s.
51 Usually, this compiles to an assignment, but when the left-hand side
52 is empty, we just perform the call and ignore the result.
54 ToDo ADR: modify this to handle ForeignObjs.
56 btw Why not let programmer use casm to provide assembly code instead
59 The (MP) integer operations are a true nightmare. Since we don't have
60 a convenient abstract way of allocating temporary variables on the (C)
61 stack, we use the space just below HpLim for the @MP_INT@ structures,
62 and modify our heap check accordingly.
65 -- NB: ordering of clauses somewhere driven by
66 -- the desire to getting sane patt-matching behavior
68 primCode res@[ar1,sr1,dr1, ar2,sr2,dr2]
70 args@[liveness, aa1,sa1,da1, aa2,sa2,da2]
71 = gmpTake2Return2 (ar1,sr1,dr1, ar2,sr2,dr2) SLIT("mpz_divmod") (liveness, aa1,sa1,da1, aa2,sa2,da2)
73 primCode res@[ar1,sr1,dr1, ar2,sr2,dr2]
75 args@[liveness, aa1,sa1,da1, aa2,sa2,da2]
76 = gmpTake2Return2 (ar1,sr1,dr1, ar2,sr2,dr2) SLIT("mpz_targetivmod") (liveness, aa1,sa1,da1, aa2,sa2,da2)
78 primCode res@[ar,sr,dr] IntegerAddOp args@[liveness, aa1,sa1,da1, aa2,sa2,da2]
79 = gmpTake2Return1 (ar,sr,dr) SLIT("mpz_add") (liveness, aa1,sa1,da1, aa2,sa2,da2)
80 primCode res@[ar,sr,dr] IntegerSubOp args@[liveness, aa1,sa1,da1, aa2,sa2,da2]
81 = gmpTake2Return1 (ar,sr,dr) SLIT("mpz_sub") (liveness, aa1,sa1,da1, aa2,sa2,da2)
82 primCode res@[ar,sr,dr] IntegerMulOp args@[liveness, aa1,sa1,da1, aa2,sa2,da2]
83 = gmpTake2Return1 (ar,sr,dr) SLIT("mpz_mul") (liveness, aa1,sa1,da1, aa2,sa2,da2)
85 primCode res@[ar,sr,dr] IntegerNegOp arg@[liveness,aa,sa,da]
86 = gmpTake1Return1 (ar,sr,dr) SLIT("mpz_neg") (liveness,aa,sa,da)
89 Since we are using the heap for intermediate @MP_INT@ structs, integer
90 comparison {\em does} require a heap check in the native code
94 primCode res@[exponr,ar,sr,dr] FloatDecodeOp args@[hp, arg]
95 = decodeFloatingKind FloatRep (exponr,ar,sr,dr) (hp, arg)
97 primCode res@[exponr,ar,sr,dr] DoubleDecodeOp args@[hp, arg]
98 = decodeFloatingKind DoubleRep (exponr,ar,sr,dr) (hp, arg)
100 primCode res@[ar,sr,dr] Int2IntegerOp args@[hp, n]
101 = gmpInt2Integer (ar,sr,dr) (hp, n)
103 primCode res@[ar,sr,dr] Addr2IntegerOp args@[liveness,str]
104 = gmpString2Integer (ar,sr,dr) (liveness,str)
106 primCode [res] IntegerCmpOp args@[hp, aa1,sa1,da1, aa2,sa2,da2]
107 = gmpCompare res (hp, aa1,sa1,da1, aa2,sa2,da2)
109 primCode [res] Integer2IntOp arg@[hp, aa,sa,da]
110 = gmpInteger2Int res (hp, aa,sa,da)
112 primCode [res] Integer2WordOp arg@[hp, aa,sa,da]
113 = gmpInteger2Word res (hp, aa,sa,da)
115 primCode [res] FloatEncodeOp args@[hp, aa,sa,da, expon]
116 = encodeFloatingKind FloatRep res (hp, aa,sa,da, expon)
118 primCode [res] DoubleEncodeOp args@[hp, aa,sa,da, expon]
119 = encodeFloatingKind DoubleRep res (hp, aa,sa,da, expon)
121 primCode [res] Int2AddrOp [arg]
122 = simpleCoercion AddrRep res arg
124 primCode [res] Addr2IntOp [arg]
125 = simpleCoercion IntRep res arg
127 primCode [res] Int2WordOp [arg]
128 = simpleCoercion IntRep{-WordRep?-} res arg
130 primCode [res] Word2IntOp [arg]
131 = simpleCoercion IntRep res arg
134 The @ErrorIO@ primitive is actually a bit weird...assign a new value
135 to the root closure, flush stdout and stderr, and jump to the
139 primCode [] ErrorIOPrimOp [rhs]
141 changeTop = StAssign PtrRep topClosure (amodeToStix rhs)
143 returnUs (\xs -> changeTop : flushStdout : flushStderr : errorIO : xs)
146 @newArray#@ ops allocate heap space.
149 primCode [res] NewArrayOp args
151 [liveness, n, initial] = map amodeToStix args
152 result = amodeToStix res
153 space = StPrim IntAddOp [n, mutHS]
154 loc = StIndex PtrRep stgHp
155 (StPrim IntNegOp [StPrim IntSubOp [space, StInt 1]])
156 assign = StAssign PtrRep result loc
157 initialise = StCall SLIT("newArrZh_init") VoidRep [result, n, initial]
159 heapCheck liveness space (StInt 0) `thenUs` \ heap_chk ->
161 returnUs (heap_chk . (\xs -> assign : initialise : xs))
163 primCode [res] (NewByteArrayOp pk) args
165 [liveness, count] = map amodeToStix args
166 result = amodeToStix res
167 n = StPrim IntMulOp [count, StInt (sizeOf pk)]
168 slop = StPrim IntAddOp [n, StInt (sizeOf IntRep - 1)]
169 words = StPrim IntQuotOp [slop, StInt (sizeOf IntRep)]
170 space = StPrim IntAddOp [n, StPrim IntAddOp [words, dataHS]]
171 loc = StIndex PtrRep stgHp
172 (StPrim IntNegOp [StPrim IntSubOp [space, StInt 1]])
173 assign = StAssign PtrRep result loc
174 init1 = StAssign PtrRep (StInd PtrRep loc) arrayOfData_info
175 init2 = StAssign IntRep
178 (StInt (toInteger fixedHdrSizeInWords))))
179 (StPrim IntAddOp [words,
180 StInt (toInteger (varHdrSizeInWords (DataRep 0)))])
182 heapCheck liveness space (StInt 0) `thenUs` \ heap_chk ->
184 returnUs (heap_chk . (\xs -> assign : init1 : init2 : xs))
186 primCode [res] SameMutableArrayOp args
188 compare = StPrim AddrEqOp (map amodeToStix args)
189 assign = StAssign IntRep (amodeToStix res) compare
191 returnUs (\xs -> assign : xs)
193 primCode res@[_] SameMutableByteArrayOp args
194 = primCode res SameMutableArrayOp args
197 Freezing an array of pointers is a double assignment. We fix the
198 header of the ``new'' closure because the lhs is probably a better
199 addressing mode for the indirection (most likely, it's a VanillaReg).
203 primCode [lhs] UnsafeFreezeArrayOp [rhs]
205 lhs' = amodeToStix lhs
206 rhs' = amodeToStix rhs
207 header = StInd PtrRep lhs'
208 assign = StAssign PtrRep lhs' rhs'
209 freeze = StAssign PtrRep header imMutArrayOfPtrs_info
211 returnUs (\xs -> assign : freeze : xs)
213 primCode [lhs] UnsafeFreezeByteArrayOp [rhs]
214 = simpleCoercion PtrRep lhs rhs
217 Most other array primitives translate to simple indexing.
221 primCode lhs@[_] IndexArrayOp args
222 = primCode lhs ReadArrayOp args
224 primCode [lhs] ReadArrayOp [obj, ix]
226 lhs' = amodeToStix lhs
227 obj' = amodeToStix obj
229 base = StIndex IntRep obj' mutHS
230 assign = StAssign PtrRep lhs' (StInd PtrRep (StIndex PtrRep base ix'))
232 returnUs (\xs -> assign : xs)
234 primCode [] WriteArrayOp [obj, ix, v]
236 obj' = amodeToStix obj
239 base = StIndex IntRep obj' mutHS
240 assign = StAssign PtrRep (StInd PtrRep (StIndex PtrRep base ix')) v'
242 returnUs (\xs -> assign : xs)
244 primCode lhs@[_] (IndexByteArrayOp pk) args
245 = primCode lhs (ReadByteArrayOp pk) args
247 -- NB: indexing in "pk" units, *not* in bytes (WDP 95/09)
249 primCode [lhs] (ReadByteArrayOp pk) [obj, ix]
251 lhs' = amodeToStix lhs
252 obj' = amodeToStix obj
254 base = StIndex IntRep obj' dataHS
255 assign = StAssign pk lhs' (StInd pk (StIndex pk base ix'))
257 returnUs (\xs -> assign : xs)
259 primCode [lhs] (IndexOffAddrOp pk) [obj, ix]
261 lhs' = amodeToStix lhs
262 obj' = amodeToStix obj
264 assign = StAssign pk lhs' (StInd pk (StIndex pk obj' ix'))
266 returnUs (\xs -> assign : xs)
268 primCode [lhs] (IndexOffForeignObjOp pk) [obj, ix]
270 lhs' = amodeToStix lhs
271 obj' = amodeToStix obj
273 obj'' = StIndex PtrRep obj' foHS
274 assign = StAssign pk lhs' (StInd pk (StIndex pk obj'' ix'))
276 returnUs (\xs -> assign : xs)
278 primCode [] (WriteByteArrayOp pk) [obj, ix, v]
280 obj' = amodeToStix obj
283 base = StIndex IntRep obj' dataHS
284 assign = StAssign pk (StInd pk (StIndex pk base ix')) v'
286 returnUs (\xs -> assign : xs)
289 Stable pointer operations.
294 primCode [lhs] DeRefStablePtrOp [sp]
296 lhs' = amodeToStix lhs
299 call = StCall SLIT("deRefStablePointer") pk [sp', smStablePtrTable]
300 assign = StAssign pk lhs' call
302 returnUs (\xs -> assign : xs)
305 Now the hard one. For comparison, here's the code from StgMacros:
308 #define makeStablePtrZh(stablePtr,liveness,unstablePtr) \
310 EXTDATA(MK_INFO_LBL(StablePointerTable)); \
312 StgStablePtr newSP; \
314 if (SPT_EMPTY(StorageMgrInfo.StablePointerTable)) { /* free stack is empty */ \
315 I_ OldNoPtrs = SPT_NoPTRS(StorageMgrInfo.StablePointerTable); \
317 /* any strictly increasing expression will do here */ \
318 I_ NewNoPtrs = OldNoPtrs * 2 + 100; \
320 I_ NewSize = DYN_VHS + NewNoPtrs + 1 + NewNoPtrs; \
323 HEAP_CHK(NO_LIVENESS, _FHS+NewSize, 0); \
324 CC_ALLOC(CCC, _FHS+NewSize, SPT_K); /* cc prof */ \
326 SPTable = Hp + 1 - (_FHS + NewSize); \
327 SET_DYN_HDR(SPTable,StablePointerTable,CCC,NewSize,NewNoPtrs); \
328 SAFESTGCALL2(void, (void *, P_, P_), enlargeSPTable, SPTable, StorageMgrInfo.StablePointerTable); \
329 StorageMgrInfo.StablePointerTable = SPTable; \
332 newSP = SPT_POP(StorageMgrInfo.StablePointerTable); \
333 SPT_SPTR(StorageMgrInfo.StablePointerTable, newSP) = unstablePtr; \
338 ToDo ADR: finish this. (Boy, this is hard work!)
341 trMumbles are now just StMumbles.
342 StInt 1 is how to write ``1''
343 temporaries are allocated at the end of the heap (see notes in StixInteger)
349 primCode [lhs] MakeStablePtrOp args
351 -- some useful abbreviations (I'm sure these must exist already)
352 add = trPrim . IntAddOp
353 sub = trPrim . IntSubOp
355 dec x = trAssign IntRep [x, sub [x, one]]
356 inc x = trAssign IntRep [x, add [x, one]]
358 -- tedious hardwiring in of closure layout offsets (from SMClosures)
359 dynHS = 2 + fixedHdrSizeInWords + varHdrSizeInWords DynamicRep
360 spt_SIZE c = trIndex PtrRep [c, trInt [fhs + gc_reserved] ]
361 spt_NoPTRS c = trIndex PtrRep [c, trInt [fhs + gc_reserved + 1] ]
362 spt_SPTR c i = trIndex PtrRep [c, add [trInt [dynHS], i]]
363 spt_TOP c = trIndex PtrRep [c, add [trInt [dynHS], spt_NoPTRS c]]
364 spt_FREE c i = trIndex PtrRep [c, add [trInt [dynHS], spt_NoPTRS c]]
366 -- tedious hardwiring in of stack manipulation macros (from SMClosures)
368 trCondJump lbl [trPrim IntEqOp [spt_TOP c, spt_NoPTRS c]]
370 trCondJump lbl [trPrim IntEqOp [spt_TOP c, trInt [0]]]
372 trAssign PtrRep [spt_FREE c (spt_TOP c), f],
376 trAssign PtrRep [x, spt_FREE c (spt_TOP c)]
379 -- now to get down to business
381 [liveness, unstable] = map amodeCode args
383 spt = smStablePtrTable
385 newSPT = -- a temporary (don't know how to allocate it)
386 newSP = -- another temporary
388 allocNewTable = -- some sort fo heap allocation needed
389 copyOldTable = trCall "enlargeSPTable" PtrRep [newSPT, spt]
394 trAssign PtrRep [spt, newSPT]
397 trAssign PtrRep [spt_SPTR spt newSP, unstable],
398 trAssign StablePtrRep [lhs', newSP]
402 getUniqLabelCTS `thenCTS` \ oklbl ->
404 (spt_EMPTY spt oklbl : (enlarge ++ (trLabel [oklbl] : allocate)))
408 primCode res Word2IntegerOp args = panic "primCode:Word2IntegerOp"
410 primCode lhs (CCallOp fn is_asm may_gc arg_tys result_ty) rhs
411 | is_asm = error "ERROR: Native code generator can't handle casm"
414 [] -> returnUs (\xs -> (StCall fn VoidRep args) : xs)
416 let lhs' = amodeToStix lhs
417 pk = if isFloatingRep (getAmodeRep lhs) then DoubleRep else IntRep
418 call = StAssign pk lhs' (StCall fn pk args)
420 returnUs (\xs -> call : xs)
422 args = map amodeCodeForCCall rhs
423 amodeCodeForCCall x =
424 let base = amodeToStix' x
426 case getAmodeRep x of
427 ArrayRep -> StIndex PtrRep base mutHS
428 ByteArrayRep -> StIndex IntRep base dataHS
429 ForeignObjRep -> StIndex PtrRep base foHS
430 {-error "ERROR: native-code generator can't handle ForeignObjs (yet): use -fvia-C!"-}
434 Now the more mundane operations.
439 lhs' = map amodeToStix lhs
440 rhs' = map amodeToStix' rhs
442 returnUs (\ xs -> simplePrim lhs' op rhs' : xs)
450 -> UniqSM StixTreeList
452 simpleCoercion pk lhs rhs
453 = returnUs (\xs -> StAssign pk (amodeToStix lhs) (amodeToStix rhs) : xs)
456 Here we try to rewrite primitives into a form the code generator can
457 understand. Any primitives not handled here must be handled at the
458 level of the specific code generator.
468 Now look for something more conventional.
471 simplePrim [lhs] op rest
472 = StAssign pk lhs (StPrim op rest)
474 pk = if isCompareOp op then
477 case getPrimOpResultInfo op of
479 _ -> simplePrim_error op
481 simplePrim as op bs = simplePrim_error op
484 = error ("ERROR: primitive operation `"++showPrimOp 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 %---------------------------------------------------------------------
489 Here we generate the Stix code for CAddrModes.
491 When a character is fetched from a mixed type location, we have to do
492 an extra cast. This is reflected in amodeCode', which is for rhs
493 amodes that might possibly need the extra cast.
496 amodeToStix, amodeToStix' :: CAddrMode -> StixTree
498 amodeToStix'{-'-} am@(CVal rr CharRep)
499 | mixedTypeLocn am = StPrim ChrOp [amodeToStix am]
500 | otherwise = amodeToStix am
502 amodeToStix' am = amodeToStix am
505 amodeToStix am@(CVal rr CharRep)
507 = StInd IntRep (amodeToStix (CAddr rr))
509 amodeToStix (CVal rr pk) = StInd pk (amodeToStix (CAddr rr))
511 amodeToStix (CAddr (SpARel spA off))
512 = StIndex PtrRep stgSpA (StInt (toInteger (spARelToInt spA off)))
514 amodeToStix (CAddr (SpBRel spB off))
515 = StIndex IntRep stgSpB (StInt (toInteger (spBRelToInt spB off)))
517 amodeToStix (CAddr (HpRel hp off))
518 = StIndex IntRep stgHp (StInt (toInteger (-(hpRelToInt (hp `subOff` off)))))
520 amodeToStix (CAddr (NodeRel off))
521 = StIndex IntRep stgNode (StInt (toInteger (hpRelToInt off)))
523 amodeToStix (CReg magic) = StReg (StixMagicId magic)
524 amodeToStix (CTemp uniq pk) = StReg (StixTemp uniq pk)
526 amodeToStix (CLbl lbl _) = StCLbl lbl
527 amodeToStix (CUnVecLbl dir _) = StCLbl dir
529 amodeToStix (CTableEntry base off pk)
530 = StInd pk (StIndex pk (amodeToStix base) (amodeToStix off))
532 -- For CharLike and IntLike, we attempt some trivial constant-folding here.
534 amodeToStix (CCharLike (CLit (MachChar c)))
535 = StLitLbl ((<>) (ptext SLIT("CHARLIKE_closures+")) (int off))
537 off = charLikeSize * ord c
539 amodeToStix (CCharLike x)
540 = StPrim IntAddOp [charLike, off]
542 off = StPrim IntMulOp [amodeToStix x, StInt (toInteger charLikeSize)]
544 amodeToStix (CIntLike (CLit (MachInt i _)))
545 = StPrim IntAddOp [intLikePtr, StInt off]
547 off = toInteger intLikeSize * i
549 amodeToStix (CIntLike x)
550 = StPrim IntAddOp [intLikePtr, off]
552 off = StPrim IntMulOp [amodeToStix x, StInt (toInteger intLikeSize)]
554 -- A CString is just a (CLit . MachStr)
555 amodeToStix (CString s) = StString s
557 amodeToStix (CLit core)
559 MachChar c -> StInt (toInteger (ord c))
560 MachStr s -> StString s
561 MachAddr a -> StInt a
562 MachInt i _ -> StInt i
563 MachLitLit s _ -> StLitLit s
564 MachFloat d -> StDouble d
565 MachDouble d -> StDouble d
566 _ -> panic "amodeToStix:core literal"
568 -- A CLitLit is just a (CLit . MachLitLit)
569 amodeToStix (CLitLit s _) = StLitLit s
571 -- COffsets are in words, not bytes!
572 amodeToStix (COffset off) = StInt (toInteger (hpRelToInt off))
574 amodeToStix (CMacroExpr _ macro [arg])
576 INFO_PTR -> StInd PtrRep (amodeToStix arg)
577 ENTRY_CODE -> amodeToStix arg
579 EVAL_TAG -> StPrim IntGeOp [tag, StInt 0]
581 tag = StInd IntRep (StIndex IntRep (amodeToStix arg) (StInt (-2)))
582 -- That ``-2'' really bothers me. (JSM) (Replace w/ oTHER_TAG? [WDP])
584 amodeToStix (CCostCentre cc print_as_string)
585 = if noCostCentreAttached cc
586 then StComment SLIT("") -- sigh
587 else panic "amodeToStix:CCostCentre"
590 Sizes of the CharLike and IntLike closures that are arranged as arrays
591 in the data segment. (These are in bytes.)
594 -- The INTLIKE base pointer
596 intLikePtr :: StixTree
598 intLikePtr = StInd PtrRep (sStLitLbl SLIT("INTLIKE_closures"))
604 charLike = sStLitLbl SLIT("CHARLIKE_closures")
606 -- Trees for the ErrorIOPrimOp
608 topClosure, flushStdout, flushStderr, errorIO :: StixTree
610 topClosure = StInd PtrRep (sStLitLbl SLIT("TopClosure"))
611 flushStdout = StCall SLIT("fflush") VoidRep [StLitLit SLIT("stdout")]
612 flushStderr = StCall SLIT("fflush") VoidRep [StLitLit SLIT("stderr")]
613 errorIO = StJump (StInd PtrRep (sStLitLbl SLIT("ErrorIO_innards")))