2 % (c) The AQUA Project, Glasgow University, 1993-1996
6 module StixPrim ( primCode, amodeToStix, amodeToStix' ) where
8 #include "HsVersions.h"
15 import AbsCUtils ( getAmodeRep, mixedTypeLocn )
16 import CallConv ( cCallConv )
17 import Constants ( spARelToInt, spBRelToInt )
18 import CostCentre ( noCostCentreAttached )
19 import HeapOffs ( hpRelToInt, subOff )
20 import Literal ( Literal(..) )
21 import PrimOp ( PrimOp(..), isCompareOp, showPrimOp,
22 getPrimOpResultInfo, PrimOpResultInfo(..)
24 import PrimRep ( PrimRep(..), isFloatingRep )
25 import OrdList ( OrdList )
26 import SMRep ( SMRep(..), SMSpecRepKind, SMUpdateKind )
28 import StixMacro ( heapCheck )
29 import StixInteger {- everything -}
30 import UniqSupply ( returnUs, thenUs, UniqSM )
35 The main honcho here is primCode, which handles the guts of COpStmts.
38 arrayOfData_info = sStLitLbl SLIT("ArrayOfData_info") -- out here to avoid CAF (sigh)
39 imMutArrayOfPtrs_info = sStLitLbl SLIT("ImMutArrayOfPtrs_info")
42 :: [CAddrMode] -- results
44 -> [CAddrMode] -- args
45 -> UniqSM StixTreeList
48 First, the dreaded @ccall@. We can't handle @casm@s.
50 Usually, this compiles to an assignment, but when the left-hand side
51 is empty, we just perform the call and ignore the result.
53 ToDo ADR: modify this to handle ForeignObjs.
55 btw Why not let programmer use casm to provide assembly code instead
58 The (MP) integer operations are a true nightmare. Since we don't have
59 a convenient abstract way of allocating temporary variables on the (C)
60 stack, we use the space just below HpLim for the @MP_INT@ structures,
61 and modify our heap check accordingly.
64 -- NB: ordering of clauses somewhere driven by
65 -- the desire to getting sane patt-matching behavior
67 primCode res@[ar1,sr1,dr1, ar2,sr2,dr2]
69 args@[liveness, aa1,sa1,da1, aa2,sa2,da2]
70 = gmpTake2Return2 (ar1,sr1,dr1, ar2,sr2,dr2) SLIT("mpz_divmod") (liveness, aa1,sa1,da1, aa2,sa2,da2)
72 primCode res@[ar1,sr1,dr1, ar2,sr2,dr2]
74 args@[liveness, aa1,sa1,da1, aa2,sa2,da2]
75 = gmpTake2Return2 (ar1,sr1,dr1, ar2,sr2,dr2) SLIT("mpz_targetivmod") (liveness, aa1,sa1,da1, aa2,sa2,da2)
77 primCode res@[ar,sr,dr] IntegerAddOp args@[liveness, aa1,sa1,da1, aa2,sa2,da2]
78 = gmpTake2Return1 (ar,sr,dr) SLIT("mpz_add") (liveness, aa1,sa1,da1, aa2,sa2,da2)
79 primCode res@[ar,sr,dr] IntegerSubOp args@[liveness, aa1,sa1,da1, aa2,sa2,da2]
80 = gmpTake2Return1 (ar,sr,dr) SLIT("mpz_sub") (liveness, aa1,sa1,da1, aa2,sa2,da2)
81 primCode res@[ar,sr,dr] IntegerMulOp args@[liveness, aa1,sa1,da1, aa2,sa2,da2]
82 = gmpTake2Return1 (ar,sr,dr) SLIT("mpz_mul") (liveness, aa1,sa1,da1, aa2,sa2,da2)
84 primCode res@[ar,sr,dr] IntegerNegOp arg@[liveness,aa,sa,da]
85 = gmpTake1Return1 (ar,sr,dr) SLIT("mpz_neg") (liveness,aa,sa,da)
88 Since we are using the heap for intermediate @MP_INT@ structs, integer
89 comparison {\em does} require a heap check in the native code
93 primCode res@[exponr,ar,sr,dr] FloatDecodeOp args@[hp, arg]
94 = decodeFloatingKind FloatRep (exponr,ar,sr,dr) (hp, arg)
96 primCode res@[exponr,ar,sr,dr] DoubleDecodeOp args@[hp, arg]
97 = decodeFloatingKind DoubleRep (exponr,ar,sr,dr) (hp, arg)
99 primCode res@[ar,sr,dr] Int2IntegerOp args@[hp, n]
100 = gmpInt2Integer (ar,sr,dr) (hp, n)
102 primCode res@[ar,sr,dr] Addr2IntegerOp args@[liveness,str]
103 = gmpString2Integer (ar,sr,dr) (liveness,str)
105 primCode [res] IntegerCmpOp args@[hp, aa1,sa1,da1, aa2,sa2,da2]
106 = gmpCompare res (hp, aa1,sa1,da1, aa2,sa2,da2)
108 primCode [res] Integer2IntOp arg@[hp, aa,sa,da]
109 = gmpInteger2Int res (hp, aa,sa,da)
111 primCode [res] Integer2WordOp arg@[hp, aa,sa,da]
112 = gmpInteger2Word res (hp, aa,sa,da)
114 primCode [res] FloatEncodeOp args@[hp, aa,sa,da, expon]
115 = encodeFloatingKind FloatRep res (hp, aa,sa,da, expon)
117 primCode [res] DoubleEncodeOp args@[hp, aa,sa,da, expon]
118 = encodeFloatingKind DoubleRep res (hp, aa,sa,da, expon)
120 primCode [res] Int2AddrOp [arg]
121 = simpleCoercion AddrRep res arg
123 primCode [res] Addr2IntOp [arg]
124 = simpleCoercion IntRep res arg
126 primCode [res] Int2WordOp [arg]
127 = simpleCoercion IntRep{-WordRep?-} res arg
129 primCode [res] Word2IntOp [arg]
130 = simpleCoercion IntRep res arg
133 The @ErrorIO@ primitive is actually a bit weird...assign a new value
134 to the root closure, and jump to the @ErrorIO_innards@.
137 primCode [] ErrorIOPrimOp [rhs]
139 changeTop = StAssign PtrRep topClosure (amodeToStix rhs)
141 returnUs (\xs -> changeTop : errorIO : xs)
144 @newArray#@ ops allocate heap space.
147 primCode [res] NewArrayOp args
149 [liveness, n, initial] = map amodeToStix args
150 result = amodeToStix res
151 space = StPrim IntAddOp [n, mutHS]
152 loc = StIndex PtrRep stgHp
153 (StPrim IntNegOp [StPrim IntSubOp [space, StInt 1]])
154 assign = StAssign PtrRep result loc
155 initialise = StCall SLIT("newArrZh_init") cCallConv VoidRep [result, n, initial]
157 heapCheck liveness space (StInt 0) `thenUs` \ heap_chk ->
159 returnUs (heap_chk . (\xs -> assign : initialise : xs))
161 primCode [res] (NewByteArrayOp pk) args
163 [liveness, count] = map amodeToStix args
164 result = amodeToStix res
165 n = StPrim IntMulOp [count, StInt (sizeOf pk)]
166 slop = StPrim IntAddOp [n, StInt (sizeOf IntRep - 1)]
167 words = StPrim IntQuotOp [slop, StInt (sizeOf IntRep)]
168 space = StPrim IntAddOp [n, StPrim IntAddOp [words, dataHS]]
169 loc = StIndex PtrRep stgHp
170 (StPrim IntNegOp [StPrim IntSubOp [space, StInt 1]])
171 assign = StAssign PtrRep result loc
172 init1 = StAssign PtrRep (StInd PtrRep loc) arrayOfData_info
173 init2 = StAssign IntRep
176 (StInt (toInteger fixedHdrSizeInWords))))
177 (StPrim IntAddOp [words,
178 StInt (toInteger (varHdrSizeInWords (DataRep 0)))])
180 heapCheck liveness space (StInt 0) `thenUs` \ heap_chk ->
182 returnUs (heap_chk . (\xs -> assign : init1 : init2 : xs))
184 primCode [res] SameMutableArrayOp args
186 compare = StPrim AddrEqOp (map amodeToStix args)
187 assign = StAssign IntRep (amodeToStix res) compare
189 returnUs (\xs -> assign : xs)
191 primCode res@[_] SameMutableByteArrayOp args
192 = primCode res SameMutableArrayOp args
195 Freezing an array of pointers is a double assignment. We fix the
196 header of the ``new'' closure because the lhs is probably a better
197 addressing mode for the indirection (most likely, it's a VanillaReg).
201 primCode [lhs] UnsafeFreezeArrayOp [rhs]
203 lhs' = amodeToStix lhs
204 rhs' = amodeToStix rhs
205 header = StInd PtrRep lhs'
206 assign = StAssign PtrRep lhs' rhs'
207 freeze = StAssign PtrRep header imMutArrayOfPtrs_info
209 returnUs (\xs -> assign : freeze : xs)
211 primCode [lhs] UnsafeFreezeByteArrayOp [rhs]
212 = simpleCoercion PtrRep lhs rhs
215 Returning the size of (mutable) byte arrays is just
216 an indexing operation.
219 primCode [lhs] SizeofByteArrayOp [rhs]
221 lhs' = amodeToStix lhs
222 rhs' = amodeToStix rhs
223 sz = StIndex IntRep rhs' fixedHS
224 assign = StAssign IntRep lhs' (StInd IntRep sz)
226 returnUs (\xs -> assign : xs)
228 primCode [lhs] SizeofMutableByteArrayOp [rhs]
230 lhs' = amodeToStix lhs
231 rhs' = amodeToStix rhs
232 sz = StIndex IntRep rhs' fixedHS
233 assign = StAssign IntRep lhs' (StInd IntRep sz)
235 returnUs (\xs -> assign : xs)
239 Most other array primitives translate to simple indexing.
243 primCode lhs@[_] IndexArrayOp args
244 = primCode lhs ReadArrayOp args
246 primCode [lhs] ReadArrayOp [obj, ix]
248 lhs' = amodeToStix lhs
249 obj' = amodeToStix obj
251 base = StIndex IntRep obj' mutHS
252 assign = StAssign PtrRep lhs' (StInd PtrRep (StIndex PtrRep base ix'))
254 returnUs (\xs -> assign : xs)
256 primCode [] WriteArrayOp [obj, ix, v]
258 obj' = amodeToStix obj
261 base = StIndex IntRep obj' mutHS
262 assign = StAssign PtrRep (StInd PtrRep (StIndex PtrRep base ix')) v'
264 returnUs (\xs -> assign : xs)
266 primCode lhs@[_] (IndexByteArrayOp pk) args
267 = primCode lhs (ReadByteArrayOp pk) args
269 -- NB: indexing in "pk" units, *not* in bytes (WDP 95/09)
271 primCode [lhs] (ReadByteArrayOp pk) [obj, ix]
273 lhs' = amodeToStix lhs
274 obj' = amodeToStix obj
276 base = StIndex IntRep obj' dataHS
277 assign = StAssign pk lhs' (StInd pk (StIndex pk base ix'))
279 returnUs (\xs -> assign : xs)
281 primCode [lhs] (IndexOffAddrOp pk) [obj, ix]
283 lhs' = amodeToStix lhs
284 obj' = amodeToStix obj
286 assign = StAssign pk lhs' (StInd pk (StIndex pk obj' ix'))
288 returnUs (\xs -> assign : xs)
290 primCode [lhs] (IndexOffForeignObjOp pk) [obj, ix]
292 lhs' = amodeToStix lhs
293 obj' = amodeToStix obj
295 obj'' = StIndex PtrRep obj' foHS
296 assign = StAssign pk lhs' (StInd pk (StIndex pk obj'' ix'))
298 returnUs (\xs -> assign : xs)
300 primCode [] (WriteByteArrayOp pk) [obj, ix, v]
302 obj' = amodeToStix obj
305 base = StIndex IntRep obj' dataHS
306 assign = StAssign pk (StInd pk (StIndex pk base ix')) v'
308 returnUs (\xs -> assign : xs)
311 Stable pointer operations.
316 primCode [lhs] DeRefStablePtrOp [sp]
318 lhs' = amodeToStix lhs
321 call = StCall SLIT("deRefStablePointer") cCallConv pk [sp', smStablePtrTable]
322 assign = StAssign pk lhs' call
324 returnUs (\xs -> assign : xs)
327 Now the hard one. For comparison, here's the code from StgMacros:
330 #define makeStablePtrZh(stablePtr,liveness,unstablePtr) \
332 EXTDATA(MK_INFO_LBL(StablePointerTable)); \
334 StgStablePtr newSP; \
336 if (SPT_EMPTY(StorageMgrInfo.StablePointerTable)) { /* free stack is empty */ \
337 I_ OldNoPtrs = SPT_NoPTRS(StorageMgrInfo.StablePointerTable); \
339 /* any strictly increasing expression will do here */ \
340 I_ NewNoPtrs = OldNoPtrs * 2 + 100; \
342 I_ NewSize = DYN_VHS + NewNoPtrs + 1 + NewNoPtrs; \
345 HEAP_CHK(NO_LIVENESS, _FHS+NewSize, 0); \
346 CC_ALLOC(CCC, _FHS+NewSize, SPT_K); /* cc prof */ \
348 SPTable = Hp + 1 - (_FHS + NewSize); \
349 SET_DYN_HDR(SPTable,StablePointerTable,CCC,NewSize,NewNoPtrs); \
350 SAFESTGCALL2(void, (void *, P_, P_), enlargeSPTable, SPTable, StorageMgrInfo.StablePointerTable); \
351 StorageMgrInfo.StablePointerTable = SPTable; \
354 newSP = SPT_POP(StorageMgrInfo.StablePointerTable); \
355 SPT_SPTR(StorageMgrInfo.StablePointerTable, newSP) = unstablePtr; \
360 ToDo ADR: finish this. (Boy, this is hard work!)
363 trMumbles are now just StMumbles.
364 StInt 1 is how to write ``1''
365 temporaries are allocated at the end of the heap (see notes in StixInteger)
371 primCode [lhs] MakeStablePtrOp args
373 -- some useful abbreviations (I'm sure these must exist already)
374 add = trPrim . IntAddOp
375 sub = trPrim . IntSubOp
377 dec x = trAssign IntRep [x, sub [x, one]]
378 inc x = trAssign IntRep [x, add [x, one]]
380 -- tedious hardwiring in of closure layout offsets (from SMClosures)
381 dynHS = 2 + fixedHdrSizeInWords + varHdrSizeInWords DynamicRep
382 spt_SIZE c = trIndex PtrRep [c, trInt [fhs + gc_reserved] ]
383 spt_NoPTRS c = trIndex PtrRep [c, trInt [fhs + gc_reserved + 1] ]
384 spt_SPTR c i = trIndex PtrRep [c, add [trInt [dynHS], i]]
385 spt_TOP c = trIndex PtrRep [c, add [trInt [dynHS], spt_NoPTRS c]]
386 spt_FREE c i = trIndex PtrRep [c, add [trInt [dynHS], spt_NoPTRS c]]
388 -- tedious hardwiring in of stack manipulation macros (from SMClosures)
390 trCondJump lbl [trPrim IntEqOp [spt_TOP c, spt_NoPTRS c]]
392 trCondJump lbl [trPrim IntEqOp [spt_TOP c, trInt [0]]]
394 trAssign PtrRep [spt_FREE c (spt_TOP c), f],
398 trAssign PtrRep [x, spt_FREE c (spt_TOP c)]
401 -- now to get down to business
403 [liveness, unstable] = map amodeCode args
405 spt = smStablePtrTable
407 newSPT = -- a temporary (don't know how to allocate it)
408 newSP = -- another temporary
410 allocNewTable = -- some sort fo heap allocation needed
411 copyOldTable = trCall "enlargeSPTable" PtrRep [newSPT, spt]
416 trAssign PtrRep [spt, newSPT]
419 trAssign PtrRep [spt_SPTR spt newSP, unstable],
420 trAssign StablePtrRep [lhs', newSP]
424 getUniqLabelCTS `thenCTS` \ oklbl ->
426 (spt_EMPTY spt oklbl : (enlarge ++ (trLabel [oklbl] : allocate)))
430 primCode res Word2IntegerOp args = panic "primCode:Word2IntegerOp"
432 primCode [lhs] SeqOp [a]
435 The evaluation of seq#'s argument is done by `seqseqseq',
436 here we just set up the call to it (identical to how
437 DerefStablePtr does things.)
439 lhs' = amodeToStix lhs
441 pk = getAmodeRep lhs -- an IntRep
442 call = StCall SLIT("SeqZhCode") cCallConv pk [a']
443 assign = StAssign pk lhs' call
446 returnUs (\xs -> assign : xs)
448 primCode lhs (CCallOp (Just fn) is_asm may_gc cconv arg_tys result_ty) rhs
449 | is_asm = error "ERROR: Native code generator can't handle casm"
452 [] -> returnUs (\xs -> (StCall fn cconv VoidRep args) : xs)
454 let lhs' = amodeToStix lhs
455 pk = if isFloatingRep (getAmodeRep lhs) then DoubleRep else IntRep
456 call = StAssign pk lhs' (StCall fn cconv pk args)
458 returnUs (\xs -> call : xs)
460 args = map amodeCodeForCCall rhs
461 amodeCodeForCCall x =
462 let base = amodeToStix' x
464 case getAmodeRep x of
465 ArrayRep -> StIndex PtrRep base mutHS
466 ByteArrayRep -> StIndex IntRep base dataHS
467 ForeignObjRep -> StIndex PtrRep base foHS
468 {-error "ERROR: native-code generator can't handle ForeignObjs (yet): use -fvia-C!"-}
472 Now the more mundane operations.
477 lhs' = map amodeToStix lhs
478 rhs' = map amodeToStix' rhs
480 returnUs (\ xs -> simplePrim lhs' op rhs' : xs)
488 -> UniqSM StixTreeList
490 simpleCoercion pk lhs rhs
491 = returnUs (\xs -> StAssign pk (amodeToStix lhs) (amodeToStix rhs) : xs)
494 Here we try to rewrite primitives into a form the code generator can
495 understand. Any primitives not handled here must be handled at the
496 level of the specific code generator.
506 Now look for something more conventional.
509 simplePrim [lhs] op rest
510 = StAssign pk lhs (StPrim op rest)
512 pk = if isCompareOp op then
515 case getPrimOpResultInfo op of
517 _ -> simplePrim_error op
519 simplePrim as op bs = simplePrim_error op
522 = 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")
525 %---------------------------------------------------------------------
527 Here we generate the Stix code for CAddrModes.
529 When a character is fetched from a mixed type location, we have to do
530 an extra cast. This is reflected in amodeCode', which is for rhs
531 amodes that might possibly need the extra cast.
534 amodeToStix, amodeToStix' :: CAddrMode -> StixTree
536 amodeToStix'{-'-} am@(CVal rr CharRep)
537 | mixedTypeLocn am = StPrim ChrOp [amodeToStix am]
538 | otherwise = amodeToStix am
540 amodeToStix' am = amodeToStix am
543 amodeToStix am@(CVal rr CharRep)
545 = StInd IntRep (amodeToStix (CAddr rr))
547 amodeToStix (CVal rr pk) = StInd pk (amodeToStix (CAddr rr))
549 amodeToStix (CAddr (SpARel spA off))
550 = StIndex PtrRep stgSpA (StInt (toInteger (spARelToInt spA off)))
552 amodeToStix (CAddr (SpBRel spB off))
553 = StIndex IntRep stgSpB (StInt (toInteger (spBRelToInt spB off)))
555 amodeToStix (CAddr (HpRel hp off))
556 = StIndex IntRep stgHp (StInt (toInteger (-(hpRelToInt (hp `subOff` off)))))
558 amodeToStix (CAddr (NodeRel off))
559 = StIndex IntRep stgNode (StInt (toInteger (hpRelToInt off)))
561 amodeToStix (CReg magic) = StReg (StixMagicId magic)
562 amodeToStix (CTemp uniq pk) = StReg (StixTemp uniq pk)
564 amodeToStix (CLbl lbl _) = StCLbl lbl
565 amodeToStix (CUnVecLbl dir _) = StCLbl dir
567 amodeToStix (CTableEntry base off pk)
568 = StInd pk (StIndex pk (amodeToStix base) (amodeToStix off))
570 -- For CharLike and IntLike, we attempt some trivial constant-folding here.
572 amodeToStix (CCharLike (CLit (MachChar c)))
573 = StLitLbl ((<>) (ptext SLIT("CHARLIKE_closures+")) (int off))
575 off = charLikeSize * ord c
577 amodeToStix (CCharLike x)
578 = StPrim IntAddOp [charLike, off]
580 off = StPrim IntMulOp [amodeToStix x, StInt (toInteger charLikeSize)]
582 amodeToStix (CIntLike (CLit (MachInt i _)))
583 = StPrim IntAddOp [intLikePtr, StInt off]
585 off = toInteger intLikeSize * toInteger i
587 amodeToStix (CIntLike x)
588 = StPrim IntAddOp [intLikePtr, off]
590 off = StPrim IntMulOp [amodeToStix x, StInt (toInteger intLikeSize)]
592 -- A CString is just a (CLit . MachStr)
593 amodeToStix (CString s) = StString s
595 amodeToStix (CLit core)
597 MachChar c -> StInt (toInteger (ord c))
598 MachStr s -> StString s
599 MachAddr a -> StInt a
600 MachInt i _ -> StInt (toInteger i)
601 MachLitLit s _ -> StLitLit s
602 MachFloat d -> StDouble d
603 MachDouble d -> StDouble d
604 _ -> panic "amodeToStix:core literal"
606 -- A CLitLit is just a (CLit . MachLitLit)
607 amodeToStix (CLitLit s _) = StLitLit s
609 -- COffsets are in words, not bytes!
610 amodeToStix (COffset off) = StInt (toInteger (hpRelToInt off))
612 amodeToStix (CMacroExpr _ macro [arg])
614 INFO_PTR -> StInd PtrRep (amodeToStix arg)
615 ENTRY_CODE -> amodeToStix arg
617 EVAL_TAG -> StPrim IntGeOp [tag, StInt 0]
619 tag = StInd IntRep (StIndex IntRep (amodeToStix arg) (StInt (-2)))
620 -- That ``-2'' really bothers me. (JSM) (Replace w/ oTHER_TAG? [WDP])
622 amodeToStix (CCostCentre cc print_as_string)
623 = if noCostCentreAttached cc
624 then StComment SLIT("") -- sigh
625 else panic "amodeToStix:CCostCentre"
628 Sizes of the CharLike and IntLike closures that are arranged as arrays
629 in the data segment. (These are in bytes.)
632 -- The INTLIKE base pointer
634 intLikePtr :: StixTree
636 intLikePtr = StInd PtrRep (sStLitLbl SLIT("INTLIKE_closures"))
642 charLike = sStLitLbl SLIT("CHARLIKE_closures")
644 -- Trees for the ErrorIOPrimOp
646 topClosure, errorIO :: StixTree
648 topClosure = StInd PtrRep (sStLitLbl SLIT("TopClosure"))
649 errorIO = StJump (StInd PtrRep (sStLitLbl SLIT("ErrorIO_innards")))