2 % (c) The AQUA Project, Glasgow University, 1993-1996
6 #include "HsVersions.h"
8 module StixPrim ( primCode, amodeToStix, amodeToStix' ) where
11 import NcgLoop -- paranoia checking only
17 import AbsCUtils ( getAmodeRep, mixedTypeLocn )
18 import CgCompInfo ( 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, smStablePtrTable )
31 import StixInteger {- everything -}
32 import UniqSupply ( returnUs, thenUs, UniqSM(..) )
33 import Unpretty ( uppBeside, uppPStr, uppInt )
37 The main honcho here is primCode, which handles the guts of COpStmts.
40 arrayOfData_info = sStLitLbl SLIT("ArrayOfData_info") -- out here to avoid CAF (sigh)
41 imMutArrayOfPtrs_info = sStLitLbl SLIT("ImMutArrayOfPtrs_info")
44 :: [CAddrMode] -- results
46 -> [CAddrMode] -- args
47 -> UniqSM StixTreeList
50 First, the dreaded @ccall@. We can't handle @casm@s.
52 Usually, this compiles to an assignment, but when the left-hand side
53 is empty, we just perform the call and ignore the result.
55 ToDo ADR: modify this to handle Malloc Ptrs.
57 btw Why not let programmer use casm to provide assembly code instead
60 The (MP) integer operations are a true nightmare. Since we don't have
61 a convenient abstract way of allocating temporary variables on the (C)
62 stack, we use the space just below HpLim for the @MP_INT@ structures,
63 and modify our heap check accordingly.
66 -- NB: ordering of clauses somewhere driven by
67 -- the desire to getting sane patt-matching behavior
69 primCode res@[ar1,sr1,dr1, ar2,sr2,dr2]
71 args@[liveness, aa1,sa1,da1, aa2,sa2,da2]
72 = gmpTake2Return2 (ar1,sr1,dr1, ar2,sr2,dr2) SLIT("mpz_divmod") (liveness, aa1,sa1,da1, aa2,sa2,da2)
74 primCode res@[ar1,sr1,dr1, ar2,sr2,dr2]
76 args@[liveness, aa1,sa1,da1, aa2,sa2,da2]
77 = gmpTake2Return2 (ar1,sr1,dr1, ar2,sr2,dr2) SLIT("mpz_targetivmod") (liveness, aa1,sa1,da1, aa2,sa2,da2)
79 primCode res@[ar,sr,dr] IntegerAddOp args@[liveness, aa1,sa1,da1, aa2,sa2,da2]
80 = gmpTake2Return1 (ar,sr,dr) SLIT("mpz_add") (liveness, aa1,sa1,da1, aa2,sa2,da2)
81 primCode res@[ar,sr,dr] IntegerSubOp args@[liveness, aa1,sa1,da1, aa2,sa2,da2]
82 = gmpTake2Return1 (ar,sr,dr) SLIT("mpz_sub") (liveness, aa1,sa1,da1, aa2,sa2,da2)
83 primCode res@[ar,sr,dr] IntegerMulOp args@[liveness, aa1,sa1,da1, aa2,sa2,da2]
84 = gmpTake2Return1 (ar,sr,dr) SLIT("mpz_mul") (liveness, aa1,sa1,da1, aa2,sa2,da2)
86 primCode res@[ar,sr,dr] IntegerNegOp arg@[liveness,aa,sa,da]
87 = gmpTake1Return1 (ar,sr,dr) SLIT("mpz_neg") (liveness,aa,sa,da)
90 Since we are using the heap for intermediate @MP_INT@ structs, integer
91 comparison {\em does} require a heap check in the native code
95 primCode res@[exponr,ar,sr,dr] FloatDecodeOp args@[hp, arg]
96 = decodeFloatingKind FloatRep (exponr,ar,sr,dr) (hp, arg)
98 primCode res@[exponr,ar,sr,dr] DoubleDecodeOp args@[hp, arg]
99 = decodeFloatingKind DoubleRep (exponr,ar,sr,dr) (hp, arg)
101 primCode res@[ar,sr,dr] Int2IntegerOp args@[hp, n]
102 = gmpInt2Integer (ar,sr,dr) (hp, n)
104 primCode res@[ar,sr,dr] Addr2IntegerOp args@[liveness,str]
105 = gmpString2Integer (ar,sr,dr) (liveness,str)
107 primCode [res] IntegerCmpOp args@[hp, aa1,sa1,da1, aa2,sa2,da2]
108 = gmpCompare res (hp, aa1,sa1,da1, aa2,sa2,da2)
110 primCode [res] Integer2IntOp arg@[hp, aa,sa,da]
111 = gmpInteger2Int 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 [lhs] 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 [] (WriteByteArrayOp pk) [obj, ix, v]
268 obj' = amodeToStix obj
271 base = StIndex IntRep obj' dataHS
272 assign = StAssign pk (StInd pk (StIndex pk base ix')) v'
274 returnUs (\xs -> assign : xs)
277 Stable pointer operations.
282 primCode [lhs] DeRefStablePtrOp [sp]
284 lhs' = amodeToStix lhs
287 call = StCall SLIT("deRefStablePointer") pk [sp', smStablePtrTable]
288 assign = StAssign pk lhs' call
290 returnUs (\xs -> assign : xs)
293 Now the hard one. For comparison, here's the code from StgMacros:
296 #define makeStablePtrZh(stablePtr,liveness,unstablePtr) \
298 EXTDATA(MK_INFO_LBL(StablePointerTable)); \
300 StgStablePtr newSP; \
302 if (SPT_EMPTY(StorageMgrInfo.StablePointerTable)) { /* free stack is empty */ \
303 I_ OldNoPtrs = SPT_NoPTRS(StorageMgrInfo.StablePointerTable); \
305 /* any strictly increasing expression will do here */ \
306 I_ NewNoPtrs = OldNoPtrs * 2 + 100; \
308 I_ NewSize = DYN_VHS + NewNoPtrs + 1 + NewNoPtrs; \
311 HEAP_CHK(NO_LIVENESS, _FHS+NewSize, 0); \
312 CC_ALLOC(CCC, _FHS+NewSize, SPT_K); /* cc prof */ \
314 SPTable = Hp + 1 - (_FHS + NewSize); \
315 SET_DYN_HDR(SPTable,StablePointerTable,CCC,NewSize,NewNoPtrs); \
316 SAFESTGCALL2(void, (void *, P_, P_), enlargeSPTable, SPTable, StorageMgrInfo.StablePointerTable); \
317 StorageMgrInfo.StablePointerTable = SPTable; \
320 newSP = SPT_POP(StorageMgrInfo.StablePointerTable); \
321 SPT_SPTR(StorageMgrInfo.StablePointerTable, newSP) = unstablePtr; \
326 ToDo ADR: finish this. (Boy, this is hard work!)
329 trMumbles are now just StMumbles.
330 StInt 1 is how to write ``1''
331 temporaries are allocated at the end of the heap (see notes in StixInteger)
337 primCode [lhs] MakeStablePtrOp args
339 -- some useful abbreviations (I'm sure these must exist already)
340 add = trPrim . IntAddOp
341 sub = trPrim . IntSubOp
343 dec x = trAssign IntRep [x, sub [x, one]]
344 inc x = trAssign IntRep [x, add [x, one]]
346 -- tedious hardwiring in of closure layout offsets (from SMClosures)
347 dynHS = 2 + fixedHdrSizeInWords + varHdrSizeInWords DynamicRep
348 spt_SIZE c = trIndex PtrRep [c, trInt [fhs + gc_reserved] ]
349 spt_NoPTRS c = trIndex PtrRep [c, trInt [fhs + gc_reserved + 1] ]
350 spt_SPTR c i = trIndex PtrRep [c, add [trInt [dynHS], i]]
351 spt_TOP c = trIndex PtrRep [c, add [trInt [dynHS], spt_NoPTRS c]]
352 spt_FREE c i = trIndex PtrRep [c, add [trInt [dynHS], spt_NoPTRS c]]
354 -- tedious hardwiring in of stack manipulation macros (from SMClosures)
356 trCondJump lbl [trPrim IntEqOp [spt_TOP c, spt_NoPTRS c]]
358 trCondJump lbl [trPrim IntEqOp [spt_TOP c, trInt [0]]]
360 trAssign PtrRep [spt_FREE c (spt_TOP c), f],
364 trAssign PtrRep [x, spt_FREE c (spt_TOP c)]
367 -- now to get down to business
369 [liveness, unstable] = map amodeCode args
371 spt = smStablePtrTable
373 newSPT = -- a temporary (don't know how to allocate it)
374 newSP = -- another temporary
376 allocNewTable = -- some sort fo heap allocation needed
377 copyOldTable = trCall "enlargeSPTable" PtrRep [newSPT, spt]
382 trAssign PtrRep [spt, newSPT]
385 trAssign PtrRep [spt_SPTR spt newSP, unstable],
386 trAssign StablePtrRep [lhs', newSP]
390 getUniqLabelCTS `thenCTS` \ oklbl ->
392 (spt_EMPTY spt oklbl : (enlarge ++ (trLabel [oklbl] : allocate)))
396 primCode res Word2IntegerOp args = panic "primCode:Word2IntegerOp"
398 primCode lhs (CCallOp fn is_asm may_gc arg_tys result_ty) rhs
399 | is_asm = error "ERROR: Native code generator can't handle casm"
402 [] -> returnUs (\xs -> (StCall fn VoidRep args) : xs)
404 let lhs' = amodeToStix lhs
405 pk = if isFloatingRep (getAmodeRep lhs) then DoubleRep else IntRep
406 call = StAssign pk lhs' (StCall fn pk args)
408 returnUs (\xs -> call : xs)
410 args = map amodeCodeForCCall rhs
411 amodeCodeForCCall x =
412 let base = amodeToStix' x
414 case getAmodeRep x of
415 ArrayRep -> StIndex PtrRep base mutHS
416 ByteArrayRep -> StIndex IntRep base dataHS
417 MallocPtrRep -> error "ERROR: native-code generator can't handle Malloc Ptrs (yet): use -fvia-C!"
421 Now the more mundane operations.
426 lhs' = map amodeToStix lhs
427 rhs' = map amodeToStix' rhs
429 returnUs (\ xs -> simplePrim lhs' op rhs' : xs)
437 -> UniqSM StixTreeList
439 simpleCoercion pk lhs rhs
440 = returnUs (\xs -> StAssign pk (amodeToStix lhs) (amodeToStix rhs) : xs)
443 Here we try to rewrite primitives into a form the code generator can
444 understand. Any primitives not handled here must be handled at the
445 level of the specific code generator.
455 Now look for something more conventional.
458 simplePrim [lhs] op rest
459 = StAssign pk lhs (StPrim op rest)
461 pk = if isCompareOp op then
464 case getPrimOpResultInfo op of
466 _ -> simplePrim_error op
468 simplePrim _ op _ = simplePrim_error op
471 = 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")
474 %---------------------------------------------------------------------
476 Here we generate the Stix code for CAddrModes.
478 When a character is fetched from a mixed type location, we have to do
479 an extra cast. This is reflected in amodeCode', which is for rhs
480 amodes that might possibly need the extra cast.
483 amodeToStix, amodeToStix' :: CAddrMode -> StixTree
485 amodeToStix'{-'-} am@(CVal rr CharRep)
486 | mixedTypeLocn am = StPrim ChrOp [amodeToStix am]
487 | otherwise = amodeToStix am
489 amodeToStix' am = amodeToStix am
492 amodeToStix am@(CVal rr CharRep)
494 = StInd IntRep (amodeToStix (CAddr rr))
496 amodeToStix (CVal rr pk) = StInd pk (amodeToStix (CAddr rr))
498 amodeToStix (CAddr (SpARel spA off))
499 = StIndex PtrRep stgSpA (StInt (toInteger (spARelToInt spA off)))
501 amodeToStix (CAddr (SpBRel spB off))
502 = StIndex IntRep stgSpB (StInt (toInteger (spBRelToInt spB off)))
504 amodeToStix (CAddr (HpRel hp off))
505 = StIndex IntRep stgHp (StInt (toInteger (-(hpRelToInt (hp `subOff` off)))))
507 amodeToStix (CAddr (NodeRel off))
508 = StIndex IntRep stgNode (StInt (toInteger (hpRelToInt off)))
510 amodeToStix (CReg magic) = StReg (StixMagicId magic)
511 amodeToStix (CTemp uniq pk) = StReg (StixTemp uniq pk)
513 amodeToStix (CLbl lbl _) = StCLbl lbl
514 amodeToStix (CUnVecLbl dir _) = StCLbl dir
516 amodeToStix (CTableEntry base off pk)
517 = StInd pk (StIndex pk (amodeToStix base) (amodeToStix off))
519 -- For CharLike and IntLike, we attempt some trivial constant-folding here.
521 amodeToStix (CCharLike (CLit (MachChar c)))
522 = StLitLbl (uppBeside (uppPStr SLIT("CHARLIKE_closures+")) (uppInt off))
524 off = charLikeSize * ord c
526 amodeToStix (CCharLike x)
527 = StPrim IntAddOp [charLike, off]
529 off = StPrim IntMulOp [amodeToStix x, StInt (toInteger charLikeSize)]
531 amodeToStix (CIntLike (CLit (MachInt i _)))
532 = StPrim IntAddOp [intLikePtr, StInt off]
534 off = toInteger intLikeSize * i
536 amodeToStix (CIntLike x)
537 = StPrim IntAddOp [intLikePtr, off]
539 off = StPrim IntMulOp [amodeToStix x, StInt (toInteger intLikeSize)]
541 -- A CString is just a (CLit . MachStr)
542 amodeToStix (CString s) = StString s
544 amodeToStix (CLit core)
546 MachChar c -> StInt (toInteger (ord c))
547 MachStr s -> StString s
548 MachAddr a -> StInt a
549 MachInt i _ -> StInt i
550 MachLitLit s _ -> StLitLit s
551 MachFloat d -> StDouble d
552 MachDouble d -> StDouble d
553 _ -> panic "amodeToStix:core literal"
555 -- A CLitLit is just a (CLit . MachLitLit)
556 amodeToStix (CLitLit s _) = StLitLit s
558 -- COffsets are in words, not bytes!
559 amodeToStix (COffset off) = StInt (toInteger (hpRelToInt off))
561 amodeToStix (CMacroExpr _ macro [arg])
563 INFO_PTR -> StInd PtrRep (amodeToStix arg)
564 ENTRY_CODE -> amodeToStix arg
566 EVAL_TAG -> StPrim IntGeOp [tag, StInt 0]
568 tag = StInd IntRep (StIndex IntRep (amodeToStix arg) (StInt (-2)))
569 -- That ``-2'' really bothers me. (JSM) (Replace w/ oTHER_TAG? [WDP])
571 amodeToStix (CCostCentre cc print_as_string)
572 = if noCostCentreAttached cc
573 then StComment SLIT("") -- sigh
574 else panic "amodeToStix:CCostCentre"
577 Sizes of the CharLike and IntLike closures that are arranged as arrays
578 in the data segment. (These are in bytes.)
581 -- The INTLIKE base pointer
583 intLikePtr :: StixTree
585 intLikePtr = StInd PtrRep (sStLitLbl SLIT("INTLIKE_closures"))
591 charLike = sStLitLbl SLIT("CHARLIKE_closures")
593 -- Trees for the ErrorIOPrimOp
595 topClosure, flushStdout, flushStderr, errorIO :: StixTree
597 topClosure = StInd PtrRep (sStLitLbl SLIT("TopClosure"))
598 flushStdout = StCall SLIT("fflush") VoidRep [StLitLit SLIT("stdout")]
599 flushStderr = StCall SLIT("fflush") VoidRep [StLitLit SLIT("stderr")]
600 errorIO = StJump (StInd PtrRep (sStLitLbl SLIT("ErrorIO_innards")))