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
14 #if __GLASGOW_HASKELL__ >= 202
15 import MachRegs hiding (Addr)
21 import AbsCUtils ( getAmodeRep, mixedTypeLocn )
22 import Constants ( spARelToInt, spBRelToInt )
23 import CostCentre ( noCostCentreAttached )
24 import HeapOffs ( hpRelToInt, subOff )
25 import Literal ( Literal(..) )
26 import PrimOp ( PrimOp(..), isCompareOp, showPrimOp,
27 getPrimOpResultInfo, PrimOpResultInfo(..)
29 import PrimRep ( PrimRep(..), isFloatingRep )
30 import OrdList ( OrdList )
31 import PprStyle ( PprStyle(..) )
32 import SMRep ( SMRep(..), SMSpecRepKind, SMUpdateKind )
34 import StixMacro ( heapCheck )
35 import StixInteger {- everything -}
36 import UniqSupply ( returnUs, thenUs, SYN_IE(UniqSM) )
37 import Pretty ( (<>), ptext, int )
40 #ifdef REALLY_HASKELL_1_3
41 ord = fromEnum :: Char -> Int
45 The main honcho here is primCode, which handles the guts of COpStmts.
48 arrayOfData_info = sStLitLbl SLIT("ArrayOfData_info") -- out here to avoid CAF (sigh)
49 imMutArrayOfPtrs_info = sStLitLbl SLIT("ImMutArrayOfPtrs_info")
52 :: [CAddrMode] -- results
54 -> [CAddrMode] -- args
55 -> UniqSM StixTreeList
58 First, the dreaded @ccall@. We can't handle @casm@s.
60 Usually, this compiles to an assignment, but when the left-hand side
61 is empty, we just perform the call and ignore the result.
63 ToDo ADR: modify this to handle ForeignObjs.
65 btw Why not let programmer use casm to provide assembly code instead
68 The (MP) integer operations are a true nightmare. Since we don't have
69 a convenient abstract way of allocating temporary variables on the (C)
70 stack, we use the space just below HpLim for the @MP_INT@ structures,
71 and modify our heap check accordingly.
74 -- NB: ordering of clauses somewhere driven by
75 -- the desire to getting sane patt-matching behavior
77 primCode res@[ar1,sr1,dr1, ar2,sr2,dr2]
79 args@[liveness, aa1,sa1,da1, aa2,sa2,da2]
80 = gmpTake2Return2 (ar1,sr1,dr1, ar2,sr2,dr2) SLIT("mpz_divmod") (liveness, aa1,sa1,da1, aa2,sa2,da2)
82 primCode res@[ar1,sr1,dr1, ar2,sr2,dr2]
84 args@[liveness, aa1,sa1,da1, aa2,sa2,da2]
85 = gmpTake2Return2 (ar1,sr1,dr1, ar2,sr2,dr2) SLIT("mpz_targetivmod") (liveness, aa1,sa1,da1, aa2,sa2,da2)
87 primCode res@[ar,sr,dr] IntegerAddOp args@[liveness, aa1,sa1,da1, aa2,sa2,da2]
88 = gmpTake2Return1 (ar,sr,dr) SLIT("mpz_add") (liveness, aa1,sa1,da1, aa2,sa2,da2)
89 primCode res@[ar,sr,dr] IntegerSubOp args@[liveness, aa1,sa1,da1, aa2,sa2,da2]
90 = gmpTake2Return1 (ar,sr,dr) SLIT("mpz_sub") (liveness, aa1,sa1,da1, aa2,sa2,da2)
91 primCode res@[ar,sr,dr] IntegerMulOp args@[liveness, aa1,sa1,da1, aa2,sa2,da2]
92 = gmpTake2Return1 (ar,sr,dr) SLIT("mpz_mul") (liveness, aa1,sa1,da1, aa2,sa2,da2)
94 primCode res@[ar,sr,dr] IntegerNegOp arg@[liveness,aa,sa,da]
95 = gmpTake1Return1 (ar,sr,dr) SLIT("mpz_neg") (liveness,aa,sa,da)
98 Since we are using the heap for intermediate @MP_INT@ structs, integer
99 comparison {\em does} require a heap check in the native code
103 primCode res@[exponr,ar,sr,dr] FloatDecodeOp args@[hp, arg]
104 = decodeFloatingKind FloatRep (exponr,ar,sr,dr) (hp, arg)
106 primCode res@[exponr,ar,sr,dr] DoubleDecodeOp args@[hp, arg]
107 = decodeFloatingKind DoubleRep (exponr,ar,sr,dr) (hp, arg)
109 primCode res@[ar,sr,dr] Int2IntegerOp args@[hp, n]
110 = gmpInt2Integer (ar,sr,dr) (hp, n)
112 primCode res@[ar,sr,dr] Addr2IntegerOp args@[liveness,str]
113 = gmpString2Integer (ar,sr,dr) (liveness,str)
115 primCode [res] IntegerCmpOp args@[hp, aa1,sa1,da1, aa2,sa2,da2]
116 = gmpCompare res (hp, aa1,sa1,da1, aa2,sa2,da2)
118 primCode [res] Integer2IntOp arg@[hp, aa,sa,da]
119 = gmpInteger2Int res (hp, aa,sa,da)
121 primCode [res] FloatEncodeOp args@[hp, aa,sa,da, expon]
122 = encodeFloatingKind FloatRep res (hp, aa,sa,da, expon)
124 primCode [res] DoubleEncodeOp args@[hp, aa,sa,da, expon]
125 = encodeFloatingKind DoubleRep res (hp, aa,sa,da, expon)
127 primCode [res] Int2AddrOp [arg]
128 = simpleCoercion AddrRep res arg
130 primCode [res] Addr2IntOp [arg]
131 = simpleCoercion IntRep res arg
133 primCode [res] Int2WordOp [arg]
134 = simpleCoercion IntRep{-WordRep?-} res arg
136 primCode [res] Word2IntOp [arg]
137 = simpleCoercion IntRep res arg
140 The @ErrorIO@ primitive is actually a bit weird...assign a new value
141 to the root closure, flush stdout and stderr, and jump to the
145 primCode [] ErrorIOPrimOp [rhs]
147 changeTop = StAssign PtrRep topClosure (amodeToStix rhs)
149 returnUs (\xs -> changeTop : flushStdout : flushStderr : errorIO : xs)
152 @newArray#@ ops allocate heap space.
155 primCode [res] NewArrayOp args
157 [liveness, n, initial] = map amodeToStix args
158 result = amodeToStix res
159 space = StPrim IntAddOp [n, mutHS]
160 loc = StIndex PtrRep stgHp
161 (StPrim IntNegOp [StPrim IntSubOp [space, StInt 1]])
162 assign = StAssign PtrRep result loc
163 initialise = StCall SLIT("newArrZh_init") VoidRep [result, n, initial]
165 heapCheck liveness space (StInt 0) `thenUs` \ heap_chk ->
167 returnUs (heap_chk . (\xs -> assign : initialise : xs))
169 primCode [res] (NewByteArrayOp pk) args
171 [liveness, count] = map amodeToStix args
172 result = amodeToStix res
173 n = StPrim IntMulOp [count, StInt (sizeOf pk)]
174 slop = StPrim IntAddOp [n, StInt (sizeOf IntRep - 1)]
175 words = StPrim IntQuotOp [slop, StInt (sizeOf IntRep)]
176 space = StPrim IntAddOp [n, StPrim IntAddOp [words, dataHS]]
177 loc = StIndex PtrRep stgHp
178 (StPrim IntNegOp [StPrim IntSubOp [space, StInt 1]])
179 assign = StAssign PtrRep result loc
180 init1 = StAssign PtrRep (StInd PtrRep loc) arrayOfData_info
181 init2 = StAssign IntRep
184 (StInt (toInteger fixedHdrSizeInWords))))
185 (StPrim IntAddOp [words,
186 StInt (toInteger (varHdrSizeInWords (DataRep 0)))])
188 heapCheck liveness space (StInt 0) `thenUs` \ heap_chk ->
190 returnUs (heap_chk . (\xs -> assign : init1 : init2 : xs))
192 primCode [res] SameMutableArrayOp args
194 compare = StPrim AddrEqOp (map amodeToStix args)
195 assign = StAssign IntRep (amodeToStix res) compare
197 returnUs (\xs -> assign : xs)
199 primCode res@[_] SameMutableByteArrayOp args
200 = primCode res SameMutableArrayOp args
203 Freezing an array of pointers is a double assignment. We fix the
204 header of the ``new'' closure because the lhs is probably a better
205 addressing mode for the indirection (most likely, it's a VanillaReg).
209 primCode [lhs] UnsafeFreezeArrayOp [rhs]
211 lhs' = amodeToStix lhs
212 rhs' = amodeToStix rhs
213 header = StInd PtrRep lhs'
214 assign = StAssign PtrRep lhs' rhs'
215 freeze = StAssign PtrRep header imMutArrayOfPtrs_info
217 returnUs (\xs -> assign : freeze : xs)
219 primCode [lhs] UnsafeFreezeByteArrayOp [rhs]
220 = simpleCoercion PtrRep lhs rhs
223 Most other array primitives translate to simple indexing.
227 primCode lhs@[_] IndexArrayOp args
228 = primCode lhs ReadArrayOp args
230 primCode [lhs] ReadArrayOp [obj, ix]
232 lhs' = amodeToStix lhs
233 obj' = amodeToStix obj
235 base = StIndex IntRep obj' mutHS
236 assign = StAssign PtrRep lhs' (StInd PtrRep (StIndex PtrRep base ix'))
238 returnUs (\xs -> assign : xs)
240 primCode [] WriteArrayOp [obj, ix, v]
242 obj' = amodeToStix obj
245 base = StIndex IntRep obj' mutHS
246 assign = StAssign PtrRep (StInd PtrRep (StIndex PtrRep base ix')) v'
248 returnUs (\xs -> assign : xs)
250 primCode lhs@[_] (IndexByteArrayOp pk) args
251 = primCode lhs (ReadByteArrayOp pk) args
253 -- NB: indexing in "pk" units, *not* in bytes (WDP 95/09)
255 primCode [lhs] (ReadByteArrayOp pk) [obj, ix]
257 lhs' = amodeToStix lhs
258 obj' = amodeToStix obj
260 base = StIndex IntRep obj' dataHS
261 assign = StAssign pk lhs' (StInd pk (StIndex pk base ix'))
263 returnUs (\xs -> assign : xs)
265 primCode [lhs] (IndexOffAddrOp pk) [obj, ix]
267 lhs' = amodeToStix lhs
268 obj' = amodeToStix obj
270 assign = StAssign pk lhs' (StInd pk (StIndex pk obj' ix'))
272 returnUs (\xs -> assign : xs)
274 primCode [] (WriteByteArrayOp pk) [obj, ix, v]
276 obj' = amodeToStix obj
279 base = StIndex IntRep obj' dataHS
280 assign = StAssign pk (StInd pk (StIndex pk base ix')) v'
282 returnUs (\xs -> assign : xs)
285 Stable pointer operations.
290 primCode [lhs] DeRefStablePtrOp [sp]
292 lhs' = amodeToStix lhs
295 call = StCall SLIT("deRefStablePointer") pk [sp', smStablePtrTable]
296 assign = StAssign pk lhs' call
298 returnUs (\xs -> assign : xs)
301 Now the hard one. For comparison, here's the code from StgMacros:
304 #define makeStablePtrZh(stablePtr,liveness,unstablePtr) \
306 EXTDATA(MK_INFO_LBL(StablePointerTable)); \
308 StgStablePtr newSP; \
310 if (SPT_EMPTY(StorageMgrInfo.StablePointerTable)) { /* free stack is empty */ \
311 I_ OldNoPtrs = SPT_NoPTRS(StorageMgrInfo.StablePointerTable); \
313 /* any strictly increasing expression will do here */ \
314 I_ NewNoPtrs = OldNoPtrs * 2 + 100; \
316 I_ NewSize = DYN_VHS + NewNoPtrs + 1 + NewNoPtrs; \
319 HEAP_CHK(NO_LIVENESS, _FHS+NewSize, 0); \
320 CC_ALLOC(CCC, _FHS+NewSize, SPT_K); /* cc prof */ \
322 SPTable = Hp + 1 - (_FHS + NewSize); \
323 SET_DYN_HDR(SPTable,StablePointerTable,CCC,NewSize,NewNoPtrs); \
324 SAFESTGCALL2(void, (void *, P_, P_), enlargeSPTable, SPTable, StorageMgrInfo.StablePointerTable); \
325 StorageMgrInfo.StablePointerTable = SPTable; \
328 newSP = SPT_POP(StorageMgrInfo.StablePointerTable); \
329 SPT_SPTR(StorageMgrInfo.StablePointerTable, newSP) = unstablePtr; \
334 ToDo ADR: finish this. (Boy, this is hard work!)
337 trMumbles are now just StMumbles.
338 StInt 1 is how to write ``1''
339 temporaries are allocated at the end of the heap (see notes in StixInteger)
345 primCode [lhs] MakeStablePtrOp args
347 -- some useful abbreviations (I'm sure these must exist already)
348 add = trPrim . IntAddOp
349 sub = trPrim . IntSubOp
351 dec x = trAssign IntRep [x, sub [x, one]]
352 inc x = trAssign IntRep [x, add [x, one]]
354 -- tedious hardwiring in of closure layout offsets (from SMClosures)
355 dynHS = 2 + fixedHdrSizeInWords + varHdrSizeInWords DynamicRep
356 spt_SIZE c = trIndex PtrRep [c, trInt [fhs + gc_reserved] ]
357 spt_NoPTRS c = trIndex PtrRep [c, trInt [fhs + gc_reserved + 1] ]
358 spt_SPTR c i = trIndex PtrRep [c, add [trInt [dynHS], i]]
359 spt_TOP c = trIndex PtrRep [c, add [trInt [dynHS], spt_NoPTRS c]]
360 spt_FREE c i = trIndex PtrRep [c, add [trInt [dynHS], spt_NoPTRS c]]
362 -- tedious hardwiring in of stack manipulation macros (from SMClosures)
364 trCondJump lbl [trPrim IntEqOp [spt_TOP c, spt_NoPTRS c]]
366 trCondJump lbl [trPrim IntEqOp [spt_TOP c, trInt [0]]]
368 trAssign PtrRep [spt_FREE c (spt_TOP c), f],
372 trAssign PtrRep [x, spt_FREE c (spt_TOP c)]
375 -- now to get down to business
377 [liveness, unstable] = map amodeCode args
379 spt = smStablePtrTable
381 newSPT = -- a temporary (don't know how to allocate it)
382 newSP = -- another temporary
384 allocNewTable = -- some sort fo heap allocation needed
385 copyOldTable = trCall "enlargeSPTable" PtrRep [newSPT, spt]
390 trAssign PtrRep [spt, newSPT]
393 trAssign PtrRep [spt_SPTR spt newSP, unstable],
394 trAssign StablePtrRep [lhs', newSP]
398 getUniqLabelCTS `thenCTS` \ oklbl ->
400 (spt_EMPTY spt oklbl : (enlarge ++ (trLabel [oklbl] : allocate)))
404 primCode res Word2IntegerOp args = panic "primCode:Word2IntegerOp"
406 primCode lhs (CCallOp fn is_asm may_gc arg_tys result_ty) rhs
407 | is_asm = error "ERROR: Native code generator can't handle casm"
410 [] -> returnUs (\xs -> (StCall fn VoidRep args) : xs)
412 let lhs' = amodeToStix lhs
413 pk = if isFloatingRep (getAmodeRep lhs) then DoubleRep else IntRep
414 call = StAssign pk lhs' (StCall fn pk args)
416 returnUs (\xs -> call : xs)
418 args = map amodeCodeForCCall rhs
419 amodeCodeForCCall x =
420 let base = amodeToStix' x
422 case getAmodeRep x of
423 ArrayRep -> StIndex PtrRep base mutHS
424 ByteArrayRep -> StIndex IntRep base dataHS
425 ForeignObjRep -> error "ERROR: native-code generator can't handle ForeignObjs (yet): use -fvia-C!"
429 Now the more mundane operations.
434 lhs' = map amodeToStix lhs
435 rhs' = map amodeToStix' rhs
437 returnUs (\ xs -> simplePrim lhs' op rhs' : xs)
445 -> UniqSM StixTreeList
447 simpleCoercion pk lhs rhs
448 = returnUs (\xs -> StAssign pk (amodeToStix lhs) (amodeToStix rhs) : xs)
451 Here we try to rewrite primitives into a form the code generator can
452 understand. Any primitives not handled here must be handled at the
453 level of the specific code generator.
463 Now look for something more conventional.
466 simplePrim [lhs] op rest
467 = StAssign pk lhs (StPrim op rest)
469 pk = if isCompareOp op then
472 case getPrimOpResultInfo op of
474 _ -> simplePrim_error op
476 simplePrim as op bs = simplePrim_error op
479 = 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")
482 %---------------------------------------------------------------------
484 Here we generate the Stix code for CAddrModes.
486 When a character is fetched from a mixed type location, we have to do
487 an extra cast. This is reflected in amodeCode', which is for rhs
488 amodes that might possibly need the extra cast.
491 amodeToStix, amodeToStix' :: CAddrMode -> StixTree
493 amodeToStix'{-'-} am@(CVal rr CharRep)
494 | mixedTypeLocn am = StPrim ChrOp [amodeToStix am]
495 | otherwise = amodeToStix am
497 amodeToStix' am = amodeToStix am
500 amodeToStix am@(CVal rr CharRep)
502 = StInd IntRep (amodeToStix (CAddr rr))
504 amodeToStix (CVal rr pk) = StInd pk (amodeToStix (CAddr rr))
506 amodeToStix (CAddr (SpARel spA off))
507 = StIndex PtrRep stgSpA (StInt (toInteger (spARelToInt spA off)))
509 amodeToStix (CAddr (SpBRel spB off))
510 = StIndex IntRep stgSpB (StInt (toInteger (spBRelToInt spB off)))
512 amodeToStix (CAddr (HpRel hp off))
513 = StIndex IntRep stgHp (StInt (toInteger (-(hpRelToInt (hp `subOff` off)))))
515 amodeToStix (CAddr (NodeRel off))
516 = StIndex IntRep stgNode (StInt (toInteger (hpRelToInt off)))
518 amodeToStix (CReg magic) = StReg (StixMagicId magic)
519 amodeToStix (CTemp uniq pk) = StReg (StixTemp uniq pk)
521 amodeToStix (CLbl lbl _) = StCLbl lbl
522 amodeToStix (CUnVecLbl dir _) = StCLbl dir
524 amodeToStix (CTableEntry base off pk)
525 = StInd pk (StIndex pk (amodeToStix base) (amodeToStix off))
527 -- For CharLike and IntLike, we attempt some trivial constant-folding here.
529 amodeToStix (CCharLike (CLit (MachChar c)))
530 = StLitLbl ((<>) (ptext SLIT("CHARLIKE_closures+")) (int off))
532 off = charLikeSize * ord c
534 amodeToStix (CCharLike x)
535 = StPrim IntAddOp [charLike, off]
537 off = StPrim IntMulOp [amodeToStix x, StInt (toInteger charLikeSize)]
539 amodeToStix (CIntLike (CLit (MachInt i _)))
540 = StPrim IntAddOp [intLikePtr, StInt off]
542 off = toInteger intLikeSize * i
544 amodeToStix (CIntLike x)
545 = StPrim IntAddOp [intLikePtr, off]
547 off = StPrim IntMulOp [amodeToStix x, StInt (toInteger intLikeSize)]
549 -- A CString is just a (CLit . MachStr)
550 amodeToStix (CString s) = StString s
552 amodeToStix (CLit core)
554 MachChar c -> StInt (toInteger (ord c))
555 MachStr s -> StString s
556 MachAddr a -> StInt a
557 MachInt i _ -> StInt i
558 MachLitLit s _ -> StLitLit s
559 MachFloat d -> StDouble d
560 MachDouble d -> StDouble d
561 _ -> panic "amodeToStix:core literal"
563 -- A CLitLit is just a (CLit . MachLitLit)
564 amodeToStix (CLitLit s _) = StLitLit s
566 -- COffsets are in words, not bytes!
567 amodeToStix (COffset off) = StInt (toInteger (hpRelToInt off))
569 amodeToStix (CMacroExpr _ macro [arg])
571 INFO_PTR -> StInd PtrRep (amodeToStix arg)
572 ENTRY_CODE -> amodeToStix arg
574 EVAL_TAG -> StPrim IntGeOp [tag, StInt 0]
576 tag = StInd IntRep (StIndex IntRep (amodeToStix arg) (StInt (-2)))
577 -- That ``-2'' really bothers me. (JSM) (Replace w/ oTHER_TAG? [WDP])
579 amodeToStix (CCostCentre cc print_as_string)
580 = if noCostCentreAttached cc
581 then StComment SLIT("") -- sigh
582 else panic "amodeToStix:CCostCentre"
585 Sizes of the CharLike and IntLike closures that are arranged as arrays
586 in the data segment. (These are in bytes.)
589 -- The INTLIKE base pointer
591 intLikePtr :: StixTree
593 intLikePtr = StInd PtrRep (sStLitLbl SLIT("INTLIKE_closures"))
599 charLike = sStLitLbl SLIT("CHARLIKE_closures")
601 -- Trees for the ErrorIOPrimOp
603 topClosure, flushStdout, flushStderr, errorIO :: StixTree
605 topClosure = StInd PtrRep (sStLitLbl SLIT("TopClosure"))
606 flushStdout = StCall SLIT("fflush") VoidRep [StLitLit SLIT("stdout")]
607 flushStderr = StCall SLIT("fflush") VoidRep [StLitLit SLIT("stderr")]
608 errorIO = StJump (StInd PtrRep (sStLitLbl SLIT("ErrorIO_innards")))