2 % (c) The AQUA Project, Glasgow University, 1993-1996
6 #include "HsVersions.h"
8 module StixPrim ( primCode, amodeToStix, amodeToStix' ) where
11 IMPORT_DELOOPER(NcgLoop) -- paranoia checking only
17 import AbsCUtils ( getAmodeRep, mixedTypeLocn )
18 import Constants ( spARelToInt, spBRelToInt )
19 import CostCentre ( noCostCentreAttached )
20 import HeapOffs ( hpRelToInt, subOff )
21 import Literal ( Literal(..) )
22 import PrimOp ( PrimOp(..), isCompareOp, showPrimOp,
23 getPrimOpResultInfo, PrimOpResultInfo(..)
25 import PrimRep ( PrimRep(..), isFloatingRep )
26 import OrdList ( OrdList )
27 import PprStyle ( PprStyle(..) )
28 import SMRep ( SMRep(..), SMSpecRepKind, SMUpdateKind )
30 import StixMacro ( heapCheck )
31 import StixInteger {- everything -}
32 import UniqSupply ( returnUs, thenUs, SYN_IE(UniqSM) )
33 import Unpretty ( uppBeside, uppPStr, uppInt )
36 #ifdef REALLY_HASKELL_1_3
37 ord = fromEnum :: Char -> Int
41 The main honcho here is primCode, which handles the guts of COpStmts.
44 arrayOfData_info = sStLitLbl SLIT("ArrayOfData_info") -- out here to avoid CAF (sigh)
45 imMutArrayOfPtrs_info = sStLitLbl SLIT("ImMutArrayOfPtrs_info")
48 :: [CAddrMode] -- results
50 -> [CAddrMode] -- args
51 -> UniqSM StixTreeList
54 First, the dreaded @ccall@. We can't handle @casm@s.
56 Usually, this compiles to an assignment, but when the left-hand side
57 is empty, we just perform the call and ignore the result.
59 ToDo ADR: modify this to handle ForeignObjs.
61 btw Why not let programmer use casm to provide assembly code instead
64 The (MP) integer operations are a true nightmare. Since we don't have
65 a convenient abstract way of allocating temporary variables on the (C)
66 stack, we use the space just below HpLim for the @MP_INT@ structures,
67 and modify our heap check accordingly.
70 -- NB: ordering of clauses somewhere driven by
71 -- the desire to getting sane patt-matching behavior
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_divmod") (liveness, aa1,sa1,da1, aa2,sa2,da2)
78 primCode res@[ar1,sr1,dr1, ar2,sr2,dr2]
80 args@[liveness, aa1,sa1,da1, aa2,sa2,da2]
81 = gmpTake2Return2 (ar1,sr1,dr1, ar2,sr2,dr2) SLIT("mpz_targetivmod") (liveness, aa1,sa1,da1, aa2,sa2,da2)
83 primCode res@[ar,sr,dr] IntegerAddOp args@[liveness, aa1,sa1,da1, aa2,sa2,da2]
84 = gmpTake2Return1 (ar,sr,dr) SLIT("mpz_add") (liveness, aa1,sa1,da1, aa2,sa2,da2)
85 primCode res@[ar,sr,dr] IntegerSubOp args@[liveness, aa1,sa1,da1, aa2,sa2,da2]
86 = gmpTake2Return1 (ar,sr,dr) SLIT("mpz_sub") (liveness, aa1,sa1,da1, aa2,sa2,da2)
87 primCode res@[ar,sr,dr] IntegerMulOp args@[liveness, aa1,sa1,da1, aa2,sa2,da2]
88 = gmpTake2Return1 (ar,sr,dr) SLIT("mpz_mul") (liveness, aa1,sa1,da1, aa2,sa2,da2)
90 primCode res@[ar,sr,dr] IntegerNegOp arg@[liveness,aa,sa,da]
91 = gmpTake1Return1 (ar,sr,dr) SLIT("mpz_neg") (liveness,aa,sa,da)
94 Since we are using the heap for intermediate @MP_INT@ structs, integer
95 comparison {\em does} require a heap check in the native code
99 primCode res@[exponr,ar,sr,dr] FloatDecodeOp args@[hp, arg]
100 = decodeFloatingKind FloatRep (exponr,ar,sr,dr) (hp, arg)
102 primCode res@[exponr,ar,sr,dr] DoubleDecodeOp args@[hp, arg]
103 = decodeFloatingKind DoubleRep (exponr,ar,sr,dr) (hp, arg)
105 primCode res@[ar,sr,dr] Int2IntegerOp args@[hp, n]
106 = gmpInt2Integer (ar,sr,dr) (hp, n)
108 primCode res@[ar,sr,dr] Addr2IntegerOp args@[liveness,str]
109 = gmpString2Integer (ar,sr,dr) (liveness,str)
111 primCode [res] IntegerCmpOp args@[hp, aa1,sa1,da1, aa2,sa2,da2]
112 = gmpCompare res (hp, aa1,sa1,da1, aa2,sa2,da2)
114 primCode [res] Integer2IntOp arg@[hp, aa,sa,da]
115 = gmpInteger2Int res (hp, aa,sa,da)
117 primCode [res] FloatEncodeOp args@[hp, aa,sa,da, expon]
118 = encodeFloatingKind FloatRep res (hp, aa,sa,da, expon)
120 primCode [res] DoubleEncodeOp args@[hp, aa,sa,da, expon]
121 = encodeFloatingKind DoubleRep res (hp, aa,sa,da, expon)
123 primCode [res] Int2AddrOp [arg]
124 = simpleCoercion AddrRep res arg
126 primCode [res] Addr2IntOp [arg]
127 = simpleCoercion IntRep res arg
129 primCode [res] Int2WordOp [arg]
130 = simpleCoercion IntRep{-WordRep?-} res arg
132 primCode [res] Word2IntOp [arg]
133 = simpleCoercion IntRep res arg
136 The @ErrorIO@ primitive is actually a bit weird...assign a new value
137 to the root closure, flush stdout and stderr, and jump to the
141 primCode [] ErrorIOPrimOp [rhs]
143 changeTop = StAssign PtrRep topClosure (amodeToStix rhs)
145 returnUs (\xs -> changeTop : flushStdout : flushStderr : errorIO : xs)
148 @newArray#@ ops allocate heap space.
151 primCode [res] NewArrayOp args
153 [liveness, n, initial] = map amodeToStix args
154 result = amodeToStix res
155 space = StPrim IntAddOp [n, mutHS]
156 loc = StIndex PtrRep stgHp
157 (StPrim IntNegOp [StPrim IntSubOp [space, StInt 1]])
158 assign = StAssign PtrRep result loc
159 initialise = StCall SLIT("newArrZh_init") VoidRep [result, n, initial]
161 heapCheck liveness space (StInt 0) `thenUs` \ heap_chk ->
163 returnUs (heap_chk . (\xs -> assign : initialise : xs))
165 primCode [res] (NewByteArrayOp pk) args
167 [liveness, count] = map amodeToStix args
168 result = amodeToStix res
169 n = StPrim IntMulOp [count, StInt (sizeOf pk)]
170 slop = StPrim IntAddOp [n, StInt (sizeOf IntRep - 1)]
171 words = StPrim IntQuotOp [slop, StInt (sizeOf IntRep)]
172 space = StPrim IntAddOp [n, StPrim IntAddOp [words, dataHS]]
173 loc = StIndex PtrRep stgHp
174 (StPrim IntNegOp [StPrim IntSubOp [space, StInt 1]])
175 assign = StAssign PtrRep result loc
176 init1 = StAssign PtrRep (StInd PtrRep loc) arrayOfData_info
177 init2 = StAssign IntRep
180 (StInt (toInteger fixedHdrSizeInWords))))
181 (StPrim IntAddOp [words,
182 StInt (toInteger (varHdrSizeInWords (DataRep 0)))])
184 heapCheck liveness space (StInt 0) `thenUs` \ heap_chk ->
186 returnUs (heap_chk . (\xs -> assign : init1 : init2 : xs))
188 primCode [res] SameMutableArrayOp args
190 compare = StPrim AddrEqOp (map amodeToStix args)
191 assign = StAssign IntRep (amodeToStix res) compare
193 returnUs (\xs -> assign : xs)
195 primCode res@[_] SameMutableByteArrayOp args
196 = primCode res SameMutableArrayOp args
199 Freezing an array of pointers is a double assignment. We fix the
200 header of the ``new'' closure because the lhs is probably a better
201 addressing mode for the indirection (most likely, it's a VanillaReg).
205 primCode [lhs] UnsafeFreezeArrayOp [rhs]
207 lhs' = amodeToStix lhs
208 rhs' = amodeToStix rhs
209 header = StInd PtrRep lhs'
210 assign = StAssign PtrRep lhs' rhs'
211 freeze = StAssign PtrRep header imMutArrayOfPtrs_info
213 returnUs (\xs -> assign : freeze : xs)
215 primCode [lhs] UnsafeFreezeByteArrayOp [rhs]
216 = simpleCoercion PtrRep lhs rhs
219 Most other array primitives translate to simple indexing.
223 primCode lhs@[_] IndexArrayOp args
224 = primCode lhs ReadArrayOp args
226 primCode [lhs] ReadArrayOp [obj, ix]
228 lhs' = amodeToStix lhs
229 obj' = amodeToStix obj
231 base = StIndex IntRep obj' mutHS
232 assign = StAssign PtrRep lhs' (StInd PtrRep (StIndex PtrRep base ix'))
234 returnUs (\xs -> assign : xs)
236 primCode [lhs] WriteArrayOp [obj, ix, v]
238 obj' = amodeToStix obj
241 base = StIndex IntRep obj' mutHS
242 assign = StAssign PtrRep (StInd PtrRep (StIndex PtrRep base ix')) v'
244 returnUs (\xs -> assign : xs)
246 primCode lhs@[_] (IndexByteArrayOp pk) args
247 = primCode lhs (ReadByteArrayOp pk) args
249 -- NB: indexing in "pk" units, *not* in bytes (WDP 95/09)
251 primCode [lhs] (ReadByteArrayOp pk) [obj, ix]
253 lhs' = amodeToStix lhs
254 obj' = amodeToStix obj
256 base = StIndex IntRep obj' dataHS
257 assign = StAssign pk lhs' (StInd pk (StIndex pk base ix'))
259 returnUs (\xs -> assign : xs)
261 primCode [lhs] (IndexOffAddrOp pk) [obj, ix]
263 lhs' = amodeToStix lhs
264 obj' = amodeToStix obj
266 assign = StAssign pk lhs' (StInd pk (StIndex pk obj' ix'))
268 returnUs (\xs -> assign : xs)
270 primCode [] (WriteByteArrayOp pk) [obj, ix, v]
272 obj' = amodeToStix obj
275 base = StIndex IntRep obj' dataHS
276 assign = StAssign pk (StInd pk (StIndex pk base ix')) v'
278 returnUs (\xs -> assign : xs)
281 Stable pointer operations.
286 primCode [lhs] DeRefStablePtrOp [sp]
288 lhs' = amodeToStix lhs
291 call = StCall SLIT("deRefStablePointer") pk [sp', smStablePtrTable]
292 assign = StAssign pk lhs' call
294 returnUs (\xs -> assign : xs)
297 Now the hard one. For comparison, here's the code from StgMacros:
300 #define makeStablePtrZh(stablePtr,liveness,unstablePtr) \
302 EXTDATA(MK_INFO_LBL(StablePointerTable)); \
304 StgStablePtr newSP; \
306 if (SPT_EMPTY(StorageMgrInfo.StablePointerTable)) { /* free stack is empty */ \
307 I_ OldNoPtrs = SPT_NoPTRS(StorageMgrInfo.StablePointerTable); \
309 /* any strictly increasing expression will do here */ \
310 I_ NewNoPtrs = OldNoPtrs * 2 + 100; \
312 I_ NewSize = DYN_VHS + NewNoPtrs + 1 + NewNoPtrs; \
315 HEAP_CHK(NO_LIVENESS, _FHS+NewSize, 0); \
316 CC_ALLOC(CCC, _FHS+NewSize, SPT_K); /* cc prof */ \
318 SPTable = Hp + 1 - (_FHS + NewSize); \
319 SET_DYN_HDR(SPTable,StablePointerTable,CCC,NewSize,NewNoPtrs); \
320 SAFESTGCALL2(void, (void *, P_, P_), enlargeSPTable, SPTable, StorageMgrInfo.StablePointerTable); \
321 StorageMgrInfo.StablePointerTable = SPTable; \
324 newSP = SPT_POP(StorageMgrInfo.StablePointerTable); \
325 SPT_SPTR(StorageMgrInfo.StablePointerTable, newSP) = unstablePtr; \
330 ToDo ADR: finish this. (Boy, this is hard work!)
333 trMumbles are now just StMumbles.
334 StInt 1 is how to write ``1''
335 temporaries are allocated at the end of the heap (see notes in StixInteger)
341 primCode [lhs] MakeStablePtrOp args
343 -- some useful abbreviations (I'm sure these must exist already)
344 add = trPrim . IntAddOp
345 sub = trPrim . IntSubOp
347 dec x = trAssign IntRep [x, sub [x, one]]
348 inc x = trAssign IntRep [x, add [x, one]]
350 -- tedious hardwiring in of closure layout offsets (from SMClosures)
351 dynHS = 2 + fixedHdrSizeInWords + varHdrSizeInWords DynamicRep
352 spt_SIZE c = trIndex PtrRep [c, trInt [fhs + gc_reserved] ]
353 spt_NoPTRS c = trIndex PtrRep [c, trInt [fhs + gc_reserved + 1] ]
354 spt_SPTR c i = trIndex PtrRep [c, add [trInt [dynHS], i]]
355 spt_TOP c = trIndex PtrRep [c, add [trInt [dynHS], spt_NoPTRS c]]
356 spt_FREE c i = trIndex PtrRep [c, add [trInt [dynHS], spt_NoPTRS c]]
358 -- tedious hardwiring in of stack manipulation macros (from SMClosures)
360 trCondJump lbl [trPrim IntEqOp [spt_TOP c, spt_NoPTRS c]]
362 trCondJump lbl [trPrim IntEqOp [spt_TOP c, trInt [0]]]
364 trAssign PtrRep [spt_FREE c (spt_TOP c), f],
368 trAssign PtrRep [x, spt_FREE c (spt_TOP c)]
371 -- now to get down to business
373 [liveness, unstable] = map amodeCode args
375 spt = smStablePtrTable
377 newSPT = -- a temporary (don't know how to allocate it)
378 newSP = -- another temporary
380 allocNewTable = -- some sort fo heap allocation needed
381 copyOldTable = trCall "enlargeSPTable" PtrRep [newSPT, spt]
386 trAssign PtrRep [spt, newSPT]
389 trAssign PtrRep [spt_SPTR spt newSP, unstable],
390 trAssign StablePtrRep [lhs', newSP]
394 getUniqLabelCTS `thenCTS` \ oklbl ->
396 (spt_EMPTY spt oklbl : (enlarge ++ (trLabel [oklbl] : allocate)))
400 primCode res Word2IntegerOp args = panic "primCode:Word2IntegerOp"
402 primCode lhs (CCallOp fn is_asm may_gc arg_tys result_ty) rhs
403 | is_asm = error "ERROR: Native code generator can't handle casm"
406 [] -> returnUs (\xs -> (StCall fn VoidRep args) : xs)
408 let lhs' = amodeToStix lhs
409 pk = if isFloatingRep (getAmodeRep lhs) then DoubleRep else IntRep
410 call = StAssign pk lhs' (StCall fn pk args)
412 returnUs (\xs -> call : xs)
414 args = map amodeCodeForCCall rhs
415 amodeCodeForCCall x =
416 let base = amodeToStix' x
418 case getAmodeRep x of
419 ArrayRep -> StIndex PtrRep base mutHS
420 ByteArrayRep -> StIndex IntRep base dataHS
421 ForeignObjRep -> error "ERROR: native-code generator can't handle ForeignObjs (yet): use -fvia-C!"
425 Now the more mundane operations.
430 lhs' = map amodeToStix lhs
431 rhs' = map amodeToStix' rhs
433 returnUs (\ xs -> simplePrim lhs' op rhs' : xs)
441 -> UniqSM StixTreeList
443 simpleCoercion pk lhs rhs
444 = returnUs (\xs -> StAssign pk (amodeToStix lhs) (amodeToStix rhs) : xs)
447 Here we try to rewrite primitives into a form the code generator can
448 understand. Any primitives not handled here must be handled at the
449 level of the specific code generator.
459 Now look for something more conventional.
462 simplePrim [lhs] op rest
463 = StAssign pk lhs (StPrim op rest)
465 pk = if isCompareOp op then
468 case getPrimOpResultInfo op of
470 _ -> simplePrim_error op
472 simplePrim _ op _ = simplePrim_error op
475 = 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")
478 %---------------------------------------------------------------------
480 Here we generate the Stix code for CAddrModes.
482 When a character is fetched from a mixed type location, we have to do
483 an extra cast. This is reflected in amodeCode', which is for rhs
484 amodes that might possibly need the extra cast.
487 amodeToStix, amodeToStix' :: CAddrMode -> StixTree
489 amodeToStix'{-'-} am@(CVal rr CharRep)
490 | mixedTypeLocn am = StPrim ChrOp [amodeToStix am]
491 | otherwise = amodeToStix am
493 amodeToStix' am = amodeToStix am
496 amodeToStix am@(CVal rr CharRep)
498 = StInd IntRep (amodeToStix (CAddr rr))
500 amodeToStix (CVal rr pk) = StInd pk (amodeToStix (CAddr rr))
502 amodeToStix (CAddr (SpARel spA off))
503 = StIndex PtrRep stgSpA (StInt (toInteger (spARelToInt spA off)))
505 amodeToStix (CAddr (SpBRel spB off))
506 = StIndex IntRep stgSpB (StInt (toInteger (spBRelToInt spB off)))
508 amodeToStix (CAddr (HpRel hp off))
509 = StIndex IntRep stgHp (StInt (toInteger (-(hpRelToInt (hp `subOff` off)))))
511 amodeToStix (CAddr (NodeRel off))
512 = StIndex IntRep stgNode (StInt (toInteger (hpRelToInt off)))
514 amodeToStix (CReg magic) = StReg (StixMagicId magic)
515 amodeToStix (CTemp uniq pk) = StReg (StixTemp uniq pk)
517 amodeToStix (CLbl lbl _) = StCLbl lbl
518 amodeToStix (CUnVecLbl dir _) = StCLbl dir
520 amodeToStix (CTableEntry base off pk)
521 = StInd pk (StIndex pk (amodeToStix base) (amodeToStix off))
523 -- For CharLike and IntLike, we attempt some trivial constant-folding here.
525 amodeToStix (CCharLike (CLit (MachChar c)))
526 = StLitLbl (uppBeside (uppPStr SLIT("CHARLIKE_closures+")) (uppInt off))
528 off = charLikeSize * ord c
530 amodeToStix (CCharLike x)
531 = StPrim IntAddOp [charLike, off]
533 off = StPrim IntMulOp [amodeToStix x, StInt (toInteger charLikeSize)]
535 amodeToStix (CIntLike (CLit (MachInt i _)))
536 = StPrim IntAddOp [intLikePtr, StInt off]
538 off = toInteger intLikeSize * i
540 amodeToStix (CIntLike x)
541 = StPrim IntAddOp [intLikePtr, off]
543 off = StPrim IntMulOp [amodeToStix x, StInt (toInteger intLikeSize)]
545 -- A CString is just a (CLit . MachStr)
546 amodeToStix (CString s) = StString s
548 amodeToStix (CLit core)
550 MachChar c -> StInt (toInteger (ord c))
551 MachStr s -> StString s
552 MachAddr a -> StInt a
553 MachInt i _ -> StInt i
554 MachLitLit s _ -> StLitLit s
555 MachFloat d -> StDouble d
556 MachDouble d -> StDouble d
557 _ -> panic "amodeToStix:core literal"
559 -- A CLitLit is just a (CLit . MachLitLit)
560 amodeToStix (CLitLit s _) = StLitLit s
562 -- COffsets are in words, not bytes!
563 amodeToStix (COffset off) = StInt (toInteger (hpRelToInt off))
565 amodeToStix (CMacroExpr _ macro [arg])
567 INFO_PTR -> StInd PtrRep (amodeToStix arg)
568 ENTRY_CODE -> amodeToStix arg
570 EVAL_TAG -> StPrim IntGeOp [tag, StInt 0]
572 tag = StInd IntRep (StIndex IntRep (amodeToStix arg) (StInt (-2)))
573 -- That ``-2'' really bothers me. (JSM) (Replace w/ oTHER_TAG? [WDP])
575 amodeToStix (CCostCentre cc print_as_string)
576 = if noCostCentreAttached cc
577 then StComment SLIT("") -- sigh
578 else panic "amodeToStix:CCostCentre"
581 Sizes of the CharLike and IntLike closures that are arranged as arrays
582 in the data segment. (These are in bytes.)
585 -- The INTLIKE base pointer
587 intLikePtr :: StixTree
589 intLikePtr = StInd PtrRep (sStLitLbl SLIT("INTLIKE_closures"))
595 charLike = sStLitLbl SLIT("CHARLIKE_closures")
597 -- Trees for the ErrorIOPrimOp
599 topClosure, flushStdout, flushStderr, errorIO :: StixTree
601 topClosure = StInd PtrRep (sStLitLbl SLIT("TopClosure"))
602 flushStdout = StCall SLIT("fflush") VoidRep [StLitLit SLIT("stdout")]
603 flushStderr = StCall SLIT("fflush") VoidRep [StLitLit SLIT("stderr")]
604 errorIO = StJump (StInd PtrRep (sStLitLbl SLIT("ErrorIO_innards")))