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 Constants ( spARelToInt, spBRelToInt )
17 import CostCentre ( noCostCentreAttached )
18 import HeapOffs ( hpRelToInt, subOff )
19 import Literal ( Literal(..) )
20 import PrimOp ( PrimOp(..), isCompareOp, showPrimOp,
21 getPrimOpResultInfo, PrimOpResultInfo(..)
23 import PrimRep ( PrimRep(..), isFloatingRep )
24 import OrdList ( OrdList )
25 import SMRep ( SMRep(..), SMSpecRepKind, SMUpdateKind )
27 import StixMacro ( heapCheck )
28 import StixInteger {- everything -}
29 import UniqSupply ( returnUs, thenUs, UniqSM )
34 The main honcho here is primCode, which handles the guts of COpStmts.
37 arrayOfData_info = sStLitLbl SLIT("ArrayOfData_info") -- out here to avoid CAF (sigh)
38 imMutArrayOfPtrs_info = sStLitLbl SLIT("ImMutArrayOfPtrs_info")
41 :: [CAddrMode] -- results
43 -> [CAddrMode] -- args
44 -> UniqSM StixTreeList
47 First, the dreaded @ccall@. We can't handle @casm@s.
49 Usually, this compiles to an assignment, but when the left-hand side
50 is empty, we just perform the call and ignore the result.
52 ToDo ADR: modify this to handle ForeignObjs.
54 btw Why not let programmer use casm to provide assembly code instead
57 The (MP) integer operations are a true nightmare. Since we don't have
58 a convenient abstract way of allocating temporary variables on the (C)
59 stack, we use the space just below HpLim for the @MP_INT@ structures,
60 and modify our heap check accordingly.
63 -- NB: ordering of clauses somewhere driven by
64 -- the desire to getting sane patt-matching behavior
66 primCode res@[ar1,sr1,dr1, ar2,sr2,dr2]
68 args@[liveness, aa1,sa1,da1, aa2,sa2,da2]
69 = gmpTake2Return2 (ar1,sr1,dr1, ar2,sr2,dr2) SLIT("mpz_divmod") (liveness, aa1,sa1,da1, aa2,sa2,da2)
71 primCode res@[ar1,sr1,dr1, ar2,sr2,dr2]
73 args@[liveness, aa1,sa1,da1, aa2,sa2,da2]
74 = gmpTake2Return2 (ar1,sr1,dr1, ar2,sr2,dr2) SLIT("mpz_targetivmod") (liveness, aa1,sa1,da1, aa2,sa2,da2)
76 primCode res@[ar,sr,dr] IntegerAddOp args@[liveness, aa1,sa1,da1, aa2,sa2,da2]
77 = gmpTake2Return1 (ar,sr,dr) SLIT("mpz_add") (liveness, aa1,sa1,da1, aa2,sa2,da2)
78 primCode res@[ar,sr,dr] IntegerSubOp args@[liveness, aa1,sa1,da1, aa2,sa2,da2]
79 = gmpTake2Return1 (ar,sr,dr) SLIT("mpz_sub") (liveness, aa1,sa1,da1, aa2,sa2,da2)
80 primCode res@[ar,sr,dr] IntegerMulOp args@[liveness, aa1,sa1,da1, aa2,sa2,da2]
81 = gmpTake2Return1 (ar,sr,dr) SLIT("mpz_mul") (liveness, aa1,sa1,da1, aa2,sa2,da2)
83 primCode res@[ar,sr,dr] IntegerNegOp arg@[liveness,aa,sa,da]
84 = gmpTake1Return1 (ar,sr,dr) SLIT("mpz_neg") (liveness,aa,sa,da)
87 Since we are using the heap for intermediate @MP_INT@ structs, integer
88 comparison {\em does} require a heap check in the native code
92 primCode res@[exponr,ar,sr,dr] FloatDecodeOp args@[hp, arg]
93 = decodeFloatingKind FloatRep (exponr,ar,sr,dr) (hp, arg)
95 primCode res@[exponr,ar,sr,dr] DoubleDecodeOp args@[hp, arg]
96 = decodeFloatingKind DoubleRep (exponr,ar,sr,dr) (hp, arg)
98 primCode res@[ar,sr,dr] Int2IntegerOp args@[hp, n]
99 = gmpInt2Integer (ar,sr,dr) (hp, n)
101 primCode res@[ar,sr,dr] Addr2IntegerOp args@[liveness,str]
102 = gmpString2Integer (ar,sr,dr) (liveness,str)
104 primCode [res] IntegerCmpOp args@[hp, aa1,sa1,da1, aa2,sa2,da2]
105 = gmpCompare res (hp, aa1,sa1,da1, aa2,sa2,da2)
107 primCode [res] Integer2IntOp arg@[hp, aa,sa,da]
108 = gmpInteger2Int res (hp, aa,sa,da)
110 primCode [res] Integer2WordOp arg@[hp, aa,sa,da]
111 = gmpInteger2Word res (hp, aa,sa,da)
113 primCode [res] FloatEncodeOp args@[hp, aa,sa,da, expon]
114 = encodeFloatingKind FloatRep res (hp, aa,sa,da, expon)
116 primCode [res] DoubleEncodeOp args@[hp, aa,sa,da, expon]
117 = encodeFloatingKind DoubleRep res (hp, aa,sa,da, expon)
119 primCode [res] Int2AddrOp [arg]
120 = simpleCoercion AddrRep res arg
122 primCode [res] Addr2IntOp [arg]
123 = simpleCoercion IntRep res arg
125 primCode [res] Int2WordOp [arg]
126 = simpleCoercion IntRep{-WordRep?-} res arg
128 primCode [res] Word2IntOp [arg]
129 = simpleCoercion IntRep res arg
132 The @ErrorIO@ primitive is actually a bit weird...assign a new value
133 to the root closure, flush stdout and stderr, and jump to the
137 primCode [] ErrorIOPrimOp [rhs]
139 changeTop = StAssign PtrRep topClosure (amodeToStix rhs)
141 returnUs (\xs -> changeTop : flushStdout : flushStderr : 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") 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 Most other array primitives translate to simple indexing.
219 primCode lhs@[_] IndexArrayOp args
220 = primCode lhs ReadArrayOp args
222 primCode [lhs] ReadArrayOp [obj, ix]
224 lhs' = amodeToStix lhs
225 obj' = amodeToStix obj
227 base = StIndex IntRep obj' mutHS
228 assign = StAssign PtrRep lhs' (StInd PtrRep (StIndex PtrRep base ix'))
230 returnUs (\xs -> assign : xs)
232 primCode [] WriteArrayOp [obj, ix, v]
234 obj' = amodeToStix obj
237 base = StIndex IntRep obj' mutHS
238 assign = StAssign PtrRep (StInd PtrRep (StIndex PtrRep base ix')) v'
240 returnUs (\xs -> assign : xs)
242 primCode lhs@[_] (IndexByteArrayOp pk) args
243 = primCode lhs (ReadByteArrayOp pk) args
245 -- NB: indexing in "pk" units, *not* in bytes (WDP 95/09)
247 primCode [lhs] (ReadByteArrayOp pk) [obj, ix]
249 lhs' = amodeToStix lhs
250 obj' = amodeToStix obj
252 base = StIndex IntRep obj' dataHS
253 assign = StAssign pk lhs' (StInd pk (StIndex pk base ix'))
255 returnUs (\xs -> assign : xs)
257 primCode [lhs] (IndexOffAddrOp pk) [obj, ix]
259 lhs' = amodeToStix lhs
260 obj' = amodeToStix obj
262 assign = StAssign pk lhs' (StInd pk (StIndex pk obj' ix'))
264 returnUs (\xs -> assign : xs)
266 primCode [lhs] (IndexOffForeignObjOp pk) [obj, ix]
268 lhs' = amodeToStix lhs
269 obj' = amodeToStix obj
271 obj'' = StIndex PtrRep obj' foHS
272 assign = StAssign pk lhs' (StInd pk (StIndex pk obj'' ix'))
274 returnUs (\xs -> assign : xs)
276 primCode [] (WriteByteArrayOp pk) [obj, ix, v]
278 obj' = amodeToStix obj
281 base = StIndex IntRep obj' dataHS
282 assign = StAssign pk (StInd pk (StIndex pk base ix')) v'
284 returnUs (\xs -> assign : xs)
287 Stable pointer operations.
292 primCode [lhs] DeRefStablePtrOp [sp]
294 lhs' = amodeToStix lhs
297 call = StCall SLIT("deRefStablePointer") pk [sp', smStablePtrTable]
298 assign = StAssign pk lhs' call
300 returnUs (\xs -> assign : xs)
303 Now the hard one. For comparison, here's the code from StgMacros:
306 #define makeStablePtrZh(stablePtr,liveness,unstablePtr) \
308 EXTDATA(MK_INFO_LBL(StablePointerTable)); \
310 StgStablePtr newSP; \
312 if (SPT_EMPTY(StorageMgrInfo.StablePointerTable)) { /* free stack is empty */ \
313 I_ OldNoPtrs = SPT_NoPTRS(StorageMgrInfo.StablePointerTable); \
315 /* any strictly increasing expression will do here */ \
316 I_ NewNoPtrs = OldNoPtrs * 2 + 100; \
318 I_ NewSize = DYN_VHS + NewNoPtrs + 1 + NewNoPtrs; \
321 HEAP_CHK(NO_LIVENESS, _FHS+NewSize, 0); \
322 CC_ALLOC(CCC, _FHS+NewSize, SPT_K); /* cc prof */ \
324 SPTable = Hp + 1 - (_FHS + NewSize); \
325 SET_DYN_HDR(SPTable,StablePointerTable,CCC,NewSize,NewNoPtrs); \
326 SAFESTGCALL2(void, (void *, P_, P_), enlargeSPTable, SPTable, StorageMgrInfo.StablePointerTable); \
327 StorageMgrInfo.StablePointerTable = SPTable; \
330 newSP = SPT_POP(StorageMgrInfo.StablePointerTable); \
331 SPT_SPTR(StorageMgrInfo.StablePointerTable, newSP) = unstablePtr; \
336 ToDo ADR: finish this. (Boy, this is hard work!)
339 trMumbles are now just StMumbles.
340 StInt 1 is how to write ``1''
341 temporaries are allocated at the end of the heap (see notes in StixInteger)
347 primCode [lhs] MakeStablePtrOp args
349 -- some useful abbreviations (I'm sure these must exist already)
350 add = trPrim . IntAddOp
351 sub = trPrim . IntSubOp
353 dec x = trAssign IntRep [x, sub [x, one]]
354 inc x = trAssign IntRep [x, add [x, one]]
356 -- tedious hardwiring in of closure layout offsets (from SMClosures)
357 dynHS = 2 + fixedHdrSizeInWords + varHdrSizeInWords DynamicRep
358 spt_SIZE c = trIndex PtrRep [c, trInt [fhs + gc_reserved] ]
359 spt_NoPTRS c = trIndex PtrRep [c, trInt [fhs + gc_reserved + 1] ]
360 spt_SPTR c i = trIndex PtrRep [c, add [trInt [dynHS], i]]
361 spt_TOP c = trIndex PtrRep [c, add [trInt [dynHS], spt_NoPTRS c]]
362 spt_FREE c i = trIndex PtrRep [c, add [trInt [dynHS], spt_NoPTRS c]]
364 -- tedious hardwiring in of stack manipulation macros (from SMClosures)
366 trCondJump lbl [trPrim IntEqOp [spt_TOP c, spt_NoPTRS c]]
368 trCondJump lbl [trPrim IntEqOp [spt_TOP c, trInt [0]]]
370 trAssign PtrRep [spt_FREE c (spt_TOP c), f],
374 trAssign PtrRep [x, spt_FREE c (spt_TOP c)]
377 -- now to get down to business
379 [liveness, unstable] = map amodeCode args
381 spt = smStablePtrTable
383 newSPT = -- a temporary (don't know how to allocate it)
384 newSP = -- another temporary
386 allocNewTable = -- some sort fo heap allocation needed
387 copyOldTable = trCall "enlargeSPTable" PtrRep [newSPT, spt]
392 trAssign PtrRep [spt, newSPT]
395 trAssign PtrRep [spt_SPTR spt newSP, unstable],
396 trAssign StablePtrRep [lhs', newSP]
400 getUniqLabelCTS `thenCTS` \ oklbl ->
402 (spt_EMPTY spt oklbl : (enlarge ++ (trLabel [oklbl] : allocate)))
406 primCode res Word2IntegerOp args = panic "primCode:Word2IntegerOp"
408 primCode [lhs] SeqOp [a]
411 The evaluation of seq#'s argument is done by `seqseqseq',
412 here we just set up the call to it (identical to how
413 DerefStablePtr does things.)
415 lhs' = amodeToStix lhs
417 pk = getAmodeRep lhs -- an IntRep
418 call = StCall SLIT("SeqZhCode") pk [a']
419 assign = StAssign pk lhs' call
422 returnUs (\xs -> assign : xs)
424 primCode lhs (CCallOp fn is_asm may_gc arg_tys result_ty) rhs
425 | is_asm = error "ERROR: Native code generator can't handle casm"
428 [] -> returnUs (\xs -> (StCall fn VoidRep args) : xs)
430 let lhs' = amodeToStix lhs
431 pk = if isFloatingRep (getAmodeRep lhs) then DoubleRep else IntRep
432 call = StAssign pk lhs' (StCall fn pk args)
434 returnUs (\xs -> call : xs)
436 args = map amodeCodeForCCall rhs
437 amodeCodeForCCall x =
438 let base = amodeToStix' x
440 case getAmodeRep x of
441 ArrayRep -> StIndex PtrRep base mutHS
442 ByteArrayRep -> StIndex IntRep base dataHS
443 ForeignObjRep -> StIndex PtrRep base foHS
444 {-error "ERROR: native-code generator can't handle ForeignObjs (yet): use -fvia-C!"-}
448 Now the more mundane operations.
453 lhs' = map amodeToStix lhs
454 rhs' = map amodeToStix' rhs
456 returnUs (\ xs -> simplePrim lhs' op rhs' : xs)
464 -> UniqSM StixTreeList
466 simpleCoercion pk lhs rhs
467 = returnUs (\xs -> StAssign pk (amodeToStix lhs) (amodeToStix rhs) : xs)
470 Here we try to rewrite primitives into a form the code generator can
471 understand. Any primitives not handled here must be handled at the
472 level of the specific code generator.
482 Now look for something more conventional.
485 simplePrim [lhs] op rest
486 = StAssign pk lhs (StPrim op rest)
488 pk = if isCompareOp op then
491 case getPrimOpResultInfo op of
493 _ -> simplePrim_error op
495 simplePrim as op bs = simplePrim_error op
498 = 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")
501 %---------------------------------------------------------------------
503 Here we generate the Stix code for CAddrModes.
505 When a character is fetched from a mixed type location, we have to do
506 an extra cast. This is reflected in amodeCode', which is for rhs
507 amodes that might possibly need the extra cast.
510 amodeToStix, amodeToStix' :: CAddrMode -> StixTree
512 amodeToStix'{-'-} am@(CVal rr CharRep)
513 | mixedTypeLocn am = StPrim ChrOp [amodeToStix am]
514 | otherwise = amodeToStix am
516 amodeToStix' am = amodeToStix am
519 amodeToStix am@(CVal rr CharRep)
521 = StInd IntRep (amodeToStix (CAddr rr))
523 amodeToStix (CVal rr pk) = StInd pk (amodeToStix (CAddr rr))
525 amodeToStix (CAddr (SpARel spA off))
526 = StIndex PtrRep stgSpA (StInt (toInteger (spARelToInt spA off)))
528 amodeToStix (CAddr (SpBRel spB off))
529 = StIndex IntRep stgSpB (StInt (toInteger (spBRelToInt spB off)))
531 amodeToStix (CAddr (HpRel hp off))
532 = StIndex IntRep stgHp (StInt (toInteger (-(hpRelToInt (hp `subOff` off)))))
534 amodeToStix (CAddr (NodeRel off))
535 = StIndex IntRep stgNode (StInt (toInteger (hpRelToInt off)))
537 amodeToStix (CReg magic) = StReg (StixMagicId magic)
538 amodeToStix (CTemp uniq pk) = StReg (StixTemp uniq pk)
540 amodeToStix (CLbl lbl _) = StCLbl lbl
541 amodeToStix (CUnVecLbl dir _) = StCLbl dir
543 amodeToStix (CTableEntry base off pk)
544 = StInd pk (StIndex pk (amodeToStix base) (amodeToStix off))
546 -- For CharLike and IntLike, we attempt some trivial constant-folding here.
548 amodeToStix (CCharLike (CLit (MachChar c)))
549 = StLitLbl ((<>) (ptext SLIT("CHARLIKE_closures+")) (int off))
551 off = charLikeSize * ord c
553 amodeToStix (CCharLike x)
554 = StPrim IntAddOp [charLike, off]
556 off = StPrim IntMulOp [amodeToStix x, StInt (toInteger charLikeSize)]
558 amodeToStix (CIntLike (CLit (MachInt i _)))
559 = StPrim IntAddOp [intLikePtr, StInt off]
561 off = toInteger intLikeSize * i
563 amodeToStix (CIntLike x)
564 = StPrim IntAddOp [intLikePtr, off]
566 off = StPrim IntMulOp [amodeToStix x, StInt (toInteger intLikeSize)]
568 -- A CString is just a (CLit . MachStr)
569 amodeToStix (CString s) = StString s
571 amodeToStix (CLit core)
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 "amodeToStix:core literal"
582 -- A CLitLit is just a (CLit . MachLitLit)
583 amodeToStix (CLitLit s _) = StLitLit s
585 -- COffsets are in words, not bytes!
586 amodeToStix (COffset off) = StInt (toInteger (hpRelToInt off))
588 amodeToStix (CMacroExpr _ macro [arg])
590 INFO_PTR -> StInd PtrRep (amodeToStix arg)
591 ENTRY_CODE -> amodeToStix arg
593 EVAL_TAG -> StPrim IntGeOp [tag, StInt 0]
595 tag = StInd IntRep (StIndex IntRep (amodeToStix arg) (StInt (-2)))
596 -- That ``-2'' really bothers me. (JSM) (Replace w/ oTHER_TAG? [WDP])
598 amodeToStix (CCostCentre cc print_as_string)
599 = if noCostCentreAttached cc
600 then StComment SLIT("") -- sigh
601 else panic "amodeToStix:CCostCentre"
604 Sizes of the CharLike and IntLike closures that are arranged as arrays
605 in the data segment. (These are in bytes.)
608 -- The INTLIKE base pointer
610 intLikePtr :: StixTree
612 intLikePtr = StInd PtrRep (sStLitLbl SLIT("INTLIKE_closures"))
618 charLike = sStLitLbl SLIT("CHARLIKE_closures")
620 -- Trees for the ErrorIOPrimOp
622 topClosure, flushStdout, flushStderr, errorIO :: StixTree
624 topClosure = StInd PtrRep (sStLitLbl SLIT("TopClosure"))
625 flushStdout = StCall SLIT("fflush") VoidRep [StLitLit SLIT("stdout")]
626 flushStderr = StCall SLIT("fflush") VoidRep [StLitLit SLIT("stderr")]
627 errorIO = StJump (StInd PtrRep (sStLitLbl SLIT("ErrorIO_innards")))