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] FloatEncodeOp args@[hp, aa,sa,da, expon]
113 = encodeFloatingKind FloatRep res (hp, aa,sa,da, expon)
115 primCode [res] DoubleEncodeOp args@[hp, aa,sa,da, expon]
116 = encodeFloatingKind DoubleRep res (hp, aa,sa,da, expon)
118 primCode [res] Int2AddrOp [arg]
119 = simpleCoercion AddrRep res arg
121 primCode [res] Addr2IntOp [arg]
122 = simpleCoercion IntRep res arg
124 primCode [res] Int2WordOp [arg]
125 = simpleCoercion IntRep{-WordRep?-} res arg
127 primCode [res] Word2IntOp [arg]
128 = simpleCoercion IntRep res arg
131 The @ErrorIO@ primitive is actually a bit weird...assign a new value
132 to the root closure, flush stdout and stderr, and jump to the
136 primCode [] ErrorIOPrimOp [rhs]
138 changeTop = StAssign PtrRep topClosure (amodeToStix rhs)
140 returnUs (\xs -> changeTop : flushStdout : flushStderr : errorIO : xs)
143 @newArray#@ ops allocate heap space.
146 primCode [res] NewArrayOp args
148 [liveness, n, initial] = map amodeToStix args
149 result = amodeToStix res
150 space = StPrim IntAddOp [n, mutHS]
151 loc = StIndex PtrRep stgHp
152 (StPrim IntNegOp [StPrim IntSubOp [space, StInt 1]])
153 assign = StAssign PtrRep result loc
154 initialise = StCall SLIT("newArrZh_init") VoidRep [result, n, initial]
156 heapCheck liveness space (StInt 0) `thenUs` \ heap_chk ->
158 returnUs (heap_chk . (\xs -> assign : initialise : xs))
160 primCode [res] (NewByteArrayOp pk) args
162 [liveness, count] = map amodeToStix args
163 result = amodeToStix res
164 n = StPrim IntMulOp [count, StInt (sizeOf pk)]
165 slop = StPrim IntAddOp [n, StInt (sizeOf IntRep - 1)]
166 words = StPrim IntQuotOp [slop, StInt (sizeOf IntRep)]
167 space = StPrim IntAddOp [n, StPrim IntAddOp [words, dataHS]]
168 loc = StIndex PtrRep stgHp
169 (StPrim IntNegOp [StPrim IntSubOp [space, StInt 1]])
170 assign = StAssign PtrRep result loc
171 init1 = StAssign PtrRep (StInd PtrRep loc) arrayOfData_info
172 init2 = StAssign IntRep
175 (StInt (toInteger fixedHdrSizeInWords))))
176 (StPrim IntAddOp [words,
177 StInt (toInteger (varHdrSizeInWords (DataRep 0)))])
179 heapCheck liveness space (StInt 0) `thenUs` \ heap_chk ->
181 returnUs (heap_chk . (\xs -> assign : init1 : init2 : xs))
183 primCode [res] SameMutableArrayOp args
185 compare = StPrim AddrEqOp (map amodeToStix args)
186 assign = StAssign IntRep (amodeToStix res) compare
188 returnUs (\xs -> assign : xs)
190 primCode res@[_] SameMutableByteArrayOp args
191 = primCode res SameMutableArrayOp args
194 Freezing an array of pointers is a double assignment. We fix the
195 header of the ``new'' closure because the lhs is probably a better
196 addressing mode for the indirection (most likely, it's a VanillaReg).
200 primCode [lhs] UnsafeFreezeArrayOp [rhs]
202 lhs' = amodeToStix lhs
203 rhs' = amodeToStix rhs
204 header = StInd PtrRep lhs'
205 assign = StAssign PtrRep lhs' rhs'
206 freeze = StAssign PtrRep header imMutArrayOfPtrs_info
208 returnUs (\xs -> assign : freeze : xs)
210 primCode [lhs] UnsafeFreezeByteArrayOp [rhs]
211 = simpleCoercion PtrRep lhs rhs
214 Most other array primitives translate to simple indexing.
218 primCode lhs@[_] IndexArrayOp args
219 = primCode lhs ReadArrayOp args
221 primCode [lhs] ReadArrayOp [obj, ix]
223 lhs' = amodeToStix lhs
224 obj' = amodeToStix obj
226 base = StIndex IntRep obj' mutHS
227 assign = StAssign PtrRep lhs' (StInd PtrRep (StIndex PtrRep base ix'))
229 returnUs (\xs -> assign : xs)
231 primCode [] WriteArrayOp [obj, ix, v]
233 obj' = amodeToStix obj
236 base = StIndex IntRep obj' mutHS
237 assign = StAssign PtrRep (StInd PtrRep (StIndex PtrRep base ix')) v'
239 returnUs (\xs -> assign : xs)
241 primCode lhs@[_] (IndexByteArrayOp pk) args
242 = primCode lhs (ReadByteArrayOp pk) args
244 -- NB: indexing in "pk" units, *not* in bytes (WDP 95/09)
246 primCode [lhs] (ReadByteArrayOp pk) [obj, ix]
248 lhs' = amodeToStix lhs
249 obj' = amodeToStix obj
251 base = StIndex IntRep obj' dataHS
252 assign = StAssign pk lhs' (StInd pk (StIndex pk base ix'))
254 returnUs (\xs -> assign : xs)
256 primCode [lhs] (IndexOffAddrOp pk) [obj, ix]
258 lhs' = amodeToStix lhs
259 obj' = amodeToStix obj
261 assign = StAssign pk lhs' (StInd pk (StIndex pk obj' ix'))
263 returnUs (\xs -> assign : xs)
265 primCode [lhs] (IndexOffForeignObjOp pk) [obj, ix]
267 lhs' = amodeToStix lhs
268 obj' = amodeToStix obj
270 obj'' = StIndex PtrRep obj' foHS
271 assign = StAssign pk lhs' (StInd pk (StIndex pk obj'' ix'))
273 returnUs (\xs -> assign : xs)
275 primCode [] (WriteByteArrayOp pk) [obj, ix, v]
277 obj' = amodeToStix obj
280 base = StIndex IntRep obj' dataHS
281 assign = StAssign pk (StInd pk (StIndex pk base ix')) v'
283 returnUs (\xs -> assign : xs)
286 Stable pointer operations.
291 primCode [lhs] DeRefStablePtrOp [sp]
293 lhs' = amodeToStix lhs
296 call = StCall SLIT("deRefStablePointer") pk [sp', smStablePtrTable]
297 assign = StAssign pk lhs' call
299 returnUs (\xs -> assign : xs)
302 Now the hard one. For comparison, here's the code from StgMacros:
305 #define makeStablePtrZh(stablePtr,liveness,unstablePtr) \
307 EXTDATA(MK_INFO_LBL(StablePointerTable)); \
309 StgStablePtr newSP; \
311 if (SPT_EMPTY(StorageMgrInfo.StablePointerTable)) { /* free stack is empty */ \
312 I_ OldNoPtrs = SPT_NoPTRS(StorageMgrInfo.StablePointerTable); \
314 /* any strictly increasing expression will do here */ \
315 I_ NewNoPtrs = OldNoPtrs * 2 + 100; \
317 I_ NewSize = DYN_VHS + NewNoPtrs + 1 + NewNoPtrs; \
320 HEAP_CHK(NO_LIVENESS, _FHS+NewSize, 0); \
321 CC_ALLOC(CCC, _FHS+NewSize, SPT_K); /* cc prof */ \
323 SPTable = Hp + 1 - (_FHS + NewSize); \
324 SET_DYN_HDR(SPTable,StablePointerTable,CCC,NewSize,NewNoPtrs); \
325 SAFESTGCALL2(void, (void *, P_, P_), enlargeSPTable, SPTable, StorageMgrInfo.StablePointerTable); \
326 StorageMgrInfo.StablePointerTable = SPTable; \
329 newSP = SPT_POP(StorageMgrInfo.StablePointerTable); \
330 SPT_SPTR(StorageMgrInfo.StablePointerTable, newSP) = unstablePtr; \
335 ToDo ADR: finish this. (Boy, this is hard work!)
338 trMumbles are now just StMumbles.
339 StInt 1 is how to write ``1''
340 temporaries are allocated at the end of the heap (see notes in StixInteger)
346 primCode [lhs] MakeStablePtrOp args
348 -- some useful abbreviations (I'm sure these must exist already)
349 add = trPrim . IntAddOp
350 sub = trPrim . IntSubOp
352 dec x = trAssign IntRep [x, sub [x, one]]
353 inc x = trAssign IntRep [x, add [x, one]]
355 -- tedious hardwiring in of closure layout offsets (from SMClosures)
356 dynHS = 2 + fixedHdrSizeInWords + varHdrSizeInWords DynamicRep
357 spt_SIZE c = trIndex PtrRep [c, trInt [fhs + gc_reserved] ]
358 spt_NoPTRS c = trIndex PtrRep [c, trInt [fhs + gc_reserved + 1] ]
359 spt_SPTR c i = trIndex PtrRep [c, add [trInt [dynHS], i]]
360 spt_TOP c = trIndex PtrRep [c, add [trInt [dynHS], spt_NoPTRS c]]
361 spt_FREE c i = trIndex PtrRep [c, add [trInt [dynHS], spt_NoPTRS c]]
363 -- tedious hardwiring in of stack manipulation macros (from SMClosures)
365 trCondJump lbl [trPrim IntEqOp [spt_TOP c, spt_NoPTRS c]]
367 trCondJump lbl [trPrim IntEqOp [spt_TOP c, trInt [0]]]
369 trAssign PtrRep [spt_FREE c (spt_TOP c), f],
373 trAssign PtrRep [x, spt_FREE c (spt_TOP c)]
376 -- now to get down to business
378 [liveness, unstable] = map amodeCode args
380 spt = smStablePtrTable
382 newSPT = -- a temporary (don't know how to allocate it)
383 newSP = -- another temporary
385 allocNewTable = -- some sort fo heap allocation needed
386 copyOldTable = trCall "enlargeSPTable" PtrRep [newSPT, spt]
391 trAssign PtrRep [spt, newSPT]
394 trAssign PtrRep [spt_SPTR spt newSP, unstable],
395 trAssign StablePtrRep [lhs', newSP]
399 getUniqLabelCTS `thenCTS` \ oklbl ->
401 (spt_EMPTY spt oklbl : (enlarge ++ (trLabel [oklbl] : allocate)))
405 primCode res Word2IntegerOp args = panic "primCode:Word2IntegerOp"
407 primCode lhs (CCallOp fn is_asm may_gc arg_tys result_ty) rhs
408 | is_asm = error "ERROR: Native code generator can't handle casm"
411 [] -> returnUs (\xs -> (StCall fn VoidRep args) : xs)
413 let lhs' = amodeToStix lhs
414 pk = if isFloatingRep (getAmodeRep lhs) then DoubleRep else IntRep
415 call = StAssign pk lhs' (StCall fn pk args)
417 returnUs (\xs -> call : xs)
419 args = map amodeCodeForCCall rhs
420 amodeCodeForCCall x =
421 let base = amodeToStix' x
423 case getAmodeRep x of
424 ArrayRep -> StIndex PtrRep base mutHS
425 ByteArrayRep -> StIndex IntRep base dataHS
426 ForeignObjRep -> StIndex PtrRep base foHS
427 {-error "ERROR: native-code generator can't handle ForeignObjs (yet): use -fvia-C!"-}
431 Now the more mundane operations.
436 lhs' = map amodeToStix lhs
437 rhs' = map amodeToStix' rhs
439 returnUs (\ xs -> simplePrim lhs' op rhs' : xs)
447 -> UniqSM StixTreeList
449 simpleCoercion pk lhs rhs
450 = returnUs (\xs -> StAssign pk (amodeToStix lhs) (amodeToStix rhs) : xs)
453 Here we try to rewrite primitives into a form the code generator can
454 understand. Any primitives not handled here must be handled at the
455 level of the specific code generator.
465 Now look for something more conventional.
468 simplePrim [lhs] op rest
469 = StAssign pk lhs (StPrim op rest)
471 pk = if isCompareOp op then
474 case getPrimOpResultInfo op of
476 _ -> simplePrim_error op
478 simplePrim as op bs = simplePrim_error op
481 = 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")
484 %---------------------------------------------------------------------
486 Here we generate the Stix code for CAddrModes.
488 When a character is fetched from a mixed type location, we have to do
489 an extra cast. This is reflected in amodeCode', which is for rhs
490 amodes that might possibly need the extra cast.
493 amodeToStix, amodeToStix' :: CAddrMode -> StixTree
495 amodeToStix'{-'-} am@(CVal rr CharRep)
496 | mixedTypeLocn am = StPrim ChrOp [amodeToStix am]
497 | otherwise = amodeToStix am
499 amodeToStix' am = amodeToStix am
502 amodeToStix am@(CVal rr CharRep)
504 = StInd IntRep (amodeToStix (CAddr rr))
506 amodeToStix (CVal rr pk) = StInd pk (amodeToStix (CAddr rr))
508 amodeToStix (CAddr (SpARel spA off))
509 = StIndex PtrRep stgSpA (StInt (toInteger (spARelToInt spA off)))
511 amodeToStix (CAddr (SpBRel spB off))
512 = StIndex IntRep stgSpB (StInt (toInteger (spBRelToInt spB off)))
514 amodeToStix (CAddr (HpRel hp off))
515 = StIndex IntRep stgHp (StInt (toInteger (-(hpRelToInt (hp `subOff` off)))))
517 amodeToStix (CAddr (NodeRel off))
518 = StIndex IntRep stgNode (StInt (toInteger (hpRelToInt off)))
520 amodeToStix (CReg magic) = StReg (StixMagicId magic)
521 amodeToStix (CTemp uniq pk) = StReg (StixTemp uniq pk)
523 amodeToStix (CLbl lbl _) = StCLbl lbl
524 amodeToStix (CUnVecLbl dir _) = StCLbl dir
526 amodeToStix (CTableEntry base off pk)
527 = StInd pk (StIndex pk (amodeToStix base) (amodeToStix off))
529 -- For CharLike and IntLike, we attempt some trivial constant-folding here.
531 amodeToStix (CCharLike (CLit (MachChar c)))
532 = StLitLbl ((<>) (ptext SLIT("CHARLIKE_closures+")) (int off))
534 off = charLikeSize * ord c
536 amodeToStix (CCharLike x)
537 = StPrim IntAddOp [charLike, off]
539 off = StPrim IntMulOp [amodeToStix x, StInt (toInteger charLikeSize)]
541 amodeToStix (CIntLike (CLit (MachInt i _)))
542 = StPrim IntAddOp [intLikePtr, StInt off]
544 off = toInteger intLikeSize * i
546 amodeToStix (CIntLike x)
547 = StPrim IntAddOp [intLikePtr, off]
549 off = StPrim IntMulOp [amodeToStix x, StInt (toInteger intLikeSize)]
551 -- A CString is just a (CLit . MachStr)
552 amodeToStix (CString s) = StString s
554 amodeToStix (CLit core)
556 MachChar c -> StInt (toInteger (ord c))
557 MachStr s -> StString s
558 MachAddr a -> StInt a
559 MachInt i _ -> StInt i
560 MachLitLit s _ -> StLitLit s
561 MachFloat d -> StDouble d
562 MachDouble d -> StDouble d
563 _ -> panic "amodeToStix:core literal"
565 -- A CLitLit is just a (CLit . MachLitLit)
566 amodeToStix (CLitLit s _) = StLitLit s
568 -- COffsets are in words, not bytes!
569 amodeToStix (COffset off) = StInt (toInteger (hpRelToInt off))
571 amodeToStix (CMacroExpr _ macro [arg])
573 INFO_PTR -> StInd PtrRep (amodeToStix arg)
574 ENTRY_CODE -> amodeToStix arg
576 EVAL_TAG -> StPrim IntGeOp [tag, StInt 0]
578 tag = StInd IntRep (StIndex IntRep (amodeToStix arg) (StInt (-2)))
579 -- That ``-2'' really bothers me. (JSM) (Replace w/ oTHER_TAG? [WDP])
581 amodeToStix (CCostCentre cc print_as_string)
582 = if noCostCentreAttached cc
583 then StComment SLIT("") -- sigh
584 else panic "amodeToStix:CCostCentre"
587 Sizes of the CharLike and IntLike closures that are arranged as arrays
588 in the data segment. (These are in bytes.)
591 -- The INTLIKE base pointer
593 intLikePtr :: StixTree
595 intLikePtr = StInd PtrRep (sStLitLbl SLIT("INTLIKE_closures"))
601 charLike = sStLitLbl SLIT("CHARLIKE_closures")
603 -- Trees for the ErrorIOPrimOp
605 topClosure, flushStdout, flushStderr, errorIO :: StixTree
607 topClosure = StInd PtrRep (sStLitLbl SLIT("TopClosure"))
608 flushStdout = StCall SLIT("fflush") VoidRep [StLitLit SLIT("stdout")]
609 flushStderr = StCall SLIT("fflush") VoidRep [StLitLit SLIT("stderr")]
610 errorIO = StJump (StInd PtrRep (sStLitLbl SLIT("ErrorIO_innards")))