2 % (c) The AQUA Project, Glasgow University, 1993-1996
6 #include "HsVersions.h"
8 module StixPrim ( primCode, amodeToStix, amodeToStix' ) where
11 #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 201
12 IMPORT_DELOOPER(NcgLoop) -- paranoia checking only
16 #if __GLASGOW_HASKELL__ >= 202
17 import MachRegs hiding (Addr)
23 import AbsCUtils ( getAmodeRep, mixedTypeLocn )
24 import Constants ( spARelToInt, spBRelToInt )
25 import CostCentre ( noCostCentreAttached )
26 import HeapOffs ( hpRelToInt, subOff )
27 import Literal ( Literal(..) )
28 import PrimOp ( PrimOp(..), isCompareOp, showPrimOp,
29 getPrimOpResultInfo, PrimOpResultInfo(..)
31 import PrimRep ( PrimRep(..), isFloatingRep )
32 import OrdList ( OrdList )
33 import Outputable ( PprStyle(..) )
34 import SMRep ( SMRep(..), SMSpecRepKind, SMUpdateKind )
36 import StixMacro ( heapCheck )
37 import StixInteger {- everything -}
38 import UniqSupply ( returnUs, thenUs, SYN_IE(UniqSM) )
39 import Pretty ( (<>), ptext, int )
42 #ifdef REALLY_HASKELL_1_3
43 ord = fromEnum :: Char -> Int
47 The main honcho here is primCode, which handles the guts of COpStmts.
50 arrayOfData_info = sStLitLbl SLIT("ArrayOfData_info") -- out here to avoid CAF (sigh)
51 imMutArrayOfPtrs_info = sStLitLbl SLIT("ImMutArrayOfPtrs_info")
54 :: [CAddrMode] -- results
56 -> [CAddrMode] -- args
57 -> UniqSM StixTreeList
60 First, the dreaded @ccall@. We can't handle @casm@s.
62 Usually, this compiles to an assignment, but when the left-hand side
63 is empty, we just perform the call and ignore the result.
65 ToDo ADR: modify this to handle ForeignObjs.
67 btw Why not let programmer use casm to provide assembly code instead
70 The (MP) integer operations are a true nightmare. Since we don't have
71 a convenient abstract way of allocating temporary variables on the (C)
72 stack, we use the space just below HpLim for the @MP_INT@ structures,
73 and modify our heap check accordingly.
76 -- NB: ordering of clauses somewhere driven by
77 -- the desire to getting sane patt-matching behavior
79 primCode res@[ar1,sr1,dr1, ar2,sr2,dr2]
81 args@[liveness, aa1,sa1,da1, aa2,sa2,da2]
82 = gmpTake2Return2 (ar1,sr1,dr1, ar2,sr2,dr2) SLIT("mpz_divmod") (liveness, aa1,sa1,da1, aa2,sa2,da2)
84 primCode res@[ar1,sr1,dr1, ar2,sr2,dr2]
86 args@[liveness, aa1,sa1,da1, aa2,sa2,da2]
87 = gmpTake2Return2 (ar1,sr1,dr1, ar2,sr2,dr2) SLIT("mpz_targetivmod") (liveness, aa1,sa1,da1, aa2,sa2,da2)
89 primCode res@[ar,sr,dr] IntegerAddOp args@[liveness, aa1,sa1,da1, aa2,sa2,da2]
90 = gmpTake2Return1 (ar,sr,dr) SLIT("mpz_add") (liveness, aa1,sa1,da1, aa2,sa2,da2)
91 primCode res@[ar,sr,dr] IntegerSubOp args@[liveness, aa1,sa1,da1, aa2,sa2,da2]
92 = gmpTake2Return1 (ar,sr,dr) SLIT("mpz_sub") (liveness, aa1,sa1,da1, aa2,sa2,da2)
93 primCode res@[ar,sr,dr] IntegerMulOp args@[liveness, aa1,sa1,da1, aa2,sa2,da2]
94 = gmpTake2Return1 (ar,sr,dr) SLIT("mpz_mul") (liveness, aa1,sa1,da1, aa2,sa2,da2)
96 primCode res@[ar,sr,dr] IntegerNegOp arg@[liveness,aa,sa,da]
97 = gmpTake1Return1 (ar,sr,dr) SLIT("mpz_neg") (liveness,aa,sa,da)
100 Since we are using the heap for intermediate @MP_INT@ structs, integer
101 comparison {\em does} require a heap check in the native code
105 primCode res@[exponr,ar,sr,dr] FloatDecodeOp args@[hp, arg]
106 = decodeFloatingKind FloatRep (exponr,ar,sr,dr) (hp, arg)
108 primCode res@[exponr,ar,sr,dr] DoubleDecodeOp args@[hp, arg]
109 = decodeFloatingKind DoubleRep (exponr,ar,sr,dr) (hp, arg)
111 primCode res@[ar,sr,dr] Int2IntegerOp args@[hp, n]
112 = gmpInt2Integer (ar,sr,dr) (hp, n)
114 primCode res@[ar,sr,dr] Addr2IntegerOp args@[liveness,str]
115 = gmpString2Integer (ar,sr,dr) (liveness,str)
117 primCode [res] IntegerCmpOp args@[hp, aa1,sa1,da1, aa2,sa2,da2]
118 = gmpCompare res (hp, aa1,sa1,da1, aa2,sa2,da2)
120 primCode [res] Integer2IntOp arg@[hp, aa,sa,da]
121 = gmpInteger2Int res (hp, aa,sa,da)
123 primCode [res] FloatEncodeOp args@[hp, aa,sa,da, expon]
124 = encodeFloatingKind FloatRep res (hp, aa,sa,da, expon)
126 primCode [res] DoubleEncodeOp args@[hp, aa,sa,da, expon]
127 = encodeFloatingKind DoubleRep res (hp, aa,sa,da, expon)
129 primCode [res] Int2AddrOp [arg]
130 = simpleCoercion AddrRep res arg
132 primCode [res] Addr2IntOp [arg]
133 = simpleCoercion IntRep res arg
135 primCode [res] Int2WordOp [arg]
136 = simpleCoercion IntRep{-WordRep?-} res arg
138 primCode [res] Word2IntOp [arg]
139 = simpleCoercion IntRep res arg
142 The @ErrorIO@ primitive is actually a bit weird...assign a new value
143 to the root closure, flush stdout and stderr, and jump to the
147 primCode [] ErrorIOPrimOp [rhs]
149 changeTop = StAssign PtrRep topClosure (amodeToStix rhs)
151 returnUs (\xs -> changeTop : flushStdout : flushStderr : errorIO : xs)
154 @newArray#@ ops allocate heap space.
157 primCode [res] NewArrayOp args
159 [liveness, n, initial] = map amodeToStix args
160 result = amodeToStix res
161 space = StPrim IntAddOp [n, mutHS]
162 loc = StIndex PtrRep stgHp
163 (StPrim IntNegOp [StPrim IntSubOp [space, StInt 1]])
164 assign = StAssign PtrRep result loc
165 initialise = StCall SLIT("newArrZh_init") VoidRep [result, n, initial]
167 heapCheck liveness space (StInt 0) `thenUs` \ heap_chk ->
169 returnUs (heap_chk . (\xs -> assign : initialise : xs))
171 primCode [res] (NewByteArrayOp pk) args
173 [liveness, count] = map amodeToStix args
174 result = amodeToStix res
175 n = StPrim IntMulOp [count, StInt (sizeOf pk)]
176 slop = StPrim IntAddOp [n, StInt (sizeOf IntRep - 1)]
177 words = StPrim IntQuotOp [slop, StInt (sizeOf IntRep)]
178 space = StPrim IntAddOp [n, StPrim IntAddOp [words, dataHS]]
179 loc = StIndex PtrRep stgHp
180 (StPrim IntNegOp [StPrim IntSubOp [space, StInt 1]])
181 assign = StAssign PtrRep result loc
182 init1 = StAssign PtrRep (StInd PtrRep loc) arrayOfData_info
183 init2 = StAssign IntRep
186 (StInt (toInteger fixedHdrSizeInWords))))
187 (StPrim IntAddOp [words,
188 StInt (toInteger (varHdrSizeInWords (DataRep 0)))])
190 heapCheck liveness space (StInt 0) `thenUs` \ heap_chk ->
192 returnUs (heap_chk . (\xs -> assign : init1 : init2 : xs))
194 primCode [res] SameMutableArrayOp args
196 compare = StPrim AddrEqOp (map amodeToStix args)
197 assign = StAssign IntRep (amodeToStix res) compare
199 returnUs (\xs -> assign : xs)
201 primCode res@[_] SameMutableByteArrayOp args
202 = primCode res SameMutableArrayOp args
205 Freezing an array of pointers is a double assignment. We fix the
206 header of the ``new'' closure because the lhs is probably a better
207 addressing mode for the indirection (most likely, it's a VanillaReg).
211 primCode [lhs] UnsafeFreezeArrayOp [rhs]
213 lhs' = amodeToStix lhs
214 rhs' = amodeToStix rhs
215 header = StInd PtrRep lhs'
216 assign = StAssign PtrRep lhs' rhs'
217 freeze = StAssign PtrRep header imMutArrayOfPtrs_info
219 returnUs (\xs -> assign : freeze : xs)
221 primCode [lhs] UnsafeFreezeByteArrayOp [rhs]
222 = simpleCoercion PtrRep lhs rhs
225 Most other array primitives translate to simple indexing.
229 primCode lhs@[_] IndexArrayOp args
230 = primCode lhs ReadArrayOp args
232 primCode [lhs] ReadArrayOp [obj, ix]
234 lhs' = amodeToStix lhs
235 obj' = amodeToStix obj
237 base = StIndex IntRep obj' mutHS
238 assign = StAssign PtrRep lhs' (StInd PtrRep (StIndex PtrRep base ix'))
240 returnUs (\xs -> assign : xs)
242 primCode [] WriteArrayOp [obj, ix, v]
244 obj' = amodeToStix obj
247 base = StIndex IntRep obj' mutHS
248 assign = StAssign PtrRep (StInd PtrRep (StIndex PtrRep base ix')) v'
250 returnUs (\xs -> assign : xs)
252 primCode lhs@[_] (IndexByteArrayOp pk) args
253 = primCode lhs (ReadByteArrayOp pk) args
255 -- NB: indexing in "pk" units, *not* in bytes (WDP 95/09)
257 primCode [lhs] (ReadByteArrayOp pk) [obj, ix]
259 lhs' = amodeToStix lhs
260 obj' = amodeToStix obj
262 base = StIndex IntRep obj' dataHS
263 assign = StAssign pk lhs' (StInd pk (StIndex pk base ix'))
265 returnUs (\xs -> assign : xs)
267 primCode [lhs] (IndexOffAddrOp pk) [obj, ix]
269 lhs' = amodeToStix lhs
270 obj' = amodeToStix obj
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 (CCallOp fn is_asm may_gc arg_tys result_ty) rhs
409 | is_asm = error "ERROR: Native code generator can't handle casm"
412 [] -> returnUs (\xs -> (StCall fn VoidRep args) : xs)
414 let lhs' = amodeToStix lhs
415 pk = if isFloatingRep (getAmodeRep lhs) then DoubleRep else IntRep
416 call = StAssign pk lhs' (StCall fn pk args)
418 returnUs (\xs -> call : xs)
420 args = map amodeCodeForCCall rhs
421 amodeCodeForCCall x =
422 let base = amodeToStix' x
424 case getAmodeRep x of
425 ArrayRep -> StIndex PtrRep base mutHS
426 ByteArrayRep -> StIndex IntRep base dataHS
427 ForeignObjRep -> 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 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")
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")))