2 % (c) The AQUA Project, Glasgow University, 1993-1995
6 #include "HsVersions.h"
9 genPrimCode, amodeCode, amodeCode',
11 Target, CAddrMode, StixTree, PrimOp, UniqSupply
14 IMPORT_Trace -- ToDo: rm debugging
17 import PrelInfo ( PrimOp(..), PrimOpResultInfo(..), TyCon,
18 getPrimOpResultInfo, isCompareOp, showPrimOp
19 IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
20 IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
22 import CgCompInfo ( spARelToInt, spBRelToInt )
25 import PrimRep ( isFloatingRep )
27 import SMRep ( SMRep(..), SMSpecRepKind(..), SMUpdateKind(..) )
29 import StixMacro ( smStablePtrTable )
30 import StixInteger {- everything -}
37 The main honcho here is genPrimCode, 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")
45 -> [CAddrMode] -- results
47 -> [CAddrMode] -- args
48 -> UniqSM StixTreeList
52 First, the dreaded @ccall@. We can't handle @casm@s.
54 Usually, this compiles to an assignment, but when the left-hand side is
55 empty, we just perform the call and ignore the result.
57 ToDo ADR: modify this to handle Malloc Ptrs.
59 btw Why not let programmer use casm to provide assembly code instead
63 -- hacking with Uncle Will:
64 #define target_STRICT target@(Target _ _ _ _ _ _ _ _)
66 genPrimCode target_STRICT res op args
69 a2stix = amodeToStix target
70 a2stix' = amodeToStix' target
72 data_hs = dataHS target
73 heap_chkr = heapCheck target
74 size_of = sizeof target
75 fixed_hs = fixedHeaderSize target
76 var_hs = varHeaderSize target
78 --- real code will follow... -------------
81 The (MP) integer operations are a true nightmare. Since we don't have a
82 convenient abstract way of allocating temporary variables on the (C) stack,
83 we use the space just below HpLim for the @MP_INT@ structures, and modify our
84 heap check accordingly.
87 -- NB: ordering of clauses somewhere driven by
88 -- the desire to getting sane patt-matching behavior
90 genprim res@[ar1,sr1,dr1, ar2,sr2,dr2]
92 args@[liveness, aa1,sa1,da1, aa2,sa2,da2] =
93 gmpTake2Return2 target (ar1,sr1,dr1, ar2,sr2,dr2) SLIT("mpz_divmod") (liveness, aa1,sa1,da1, aa2,sa2,da2)
95 genprim res@[ar1,sr1,dr1, ar2,sr2,dr2]
97 args@[liveness, aa1,sa1,da1, aa2,sa2,da2] =
98 gmpTake2Return2 target (ar1,sr1,dr1, ar2,sr2,dr2) SLIT("mpz_targetivmod") (liveness, aa1,sa1,da1, aa2,sa2,da2)
100 genprim res@[ar,sr,dr] IntegerAddOp args@[liveness, aa1,sa1,da1, aa2,sa2,da2] =
101 gmpTake2Return1 target (ar,sr,dr) SLIT("mpz_add") (liveness, aa1,sa1,da1, aa2,sa2,da2)
102 genprim res@[ar,sr,dr] IntegerSubOp args@[liveness, aa1,sa1,da1, aa2,sa2,da2] =
103 gmpTake2Return1 target (ar,sr,dr) SLIT("mpz_sub") (liveness, aa1,sa1,da1, aa2,sa2,da2)
104 genprim res@[ar,sr,dr] IntegerMulOp args@[liveness, aa1,sa1,da1, aa2,sa2,da2] =
105 gmpTake2Return1 target (ar,sr,dr) SLIT("mpz_mul") (liveness, aa1,sa1,da1, aa2,sa2,da2)
107 genprim res@[ar,sr,dr] IntegerNegOp arg@[liveness,aa,sa,da] =
108 gmpTake1Return1 target (ar,sr,dr) SLIT("mpz_neg") (liveness,aa,sa,da)
111 Since we are using the heap for intermediate @MP_INT@ structs, integer comparison
112 {\em does} require a heap check in the native code implementation.
115 genprim res@[exponr,ar,sr,dr] FloatDecodeOp args@[hp, arg] =
116 decodeFloatingKind FloatRep target (exponr,ar,sr,dr) (hp, arg)
118 genprim res@[exponr,ar,sr,dr] DoubleDecodeOp args@[hp, arg] =
119 decodeFloatingKind DoubleRep target (exponr,ar,sr,dr) (hp, arg)
121 genprim res@[ar,sr,dr] Int2IntegerOp args@[hp, n]
122 = gmpInt2Integer target (ar,sr,dr) (hp, n)
124 genprim res@[ar,sr,dr] Addr2IntegerOp args@[liveness,str]
125 = gmpString2Integer target (ar,sr,dr) (liveness,str)
127 genprim [res] IntegerCmpOp args@[hp, aa1,sa1,da1, aa2,sa2,da2]
128 = gmpCompare target res (hp, aa1,sa1,da1, aa2,sa2,da2)
130 genprim [res] Integer2IntOp arg@[hp, aa,sa,da]
131 = gmpInteger2Int target res (hp, aa,sa,da)
133 genprim [res] FloatEncodeOp args@[hp, aa,sa,da, expon] =
134 encodeFloatingKind FloatRep target res (hp, aa,sa,da, expon)
136 genprim [res] DoubleEncodeOp args@[hp, aa,sa,da, expon] =
137 encodeFloatingKind DoubleRep target res (hp, aa,sa,da, expon)
139 genprim [res] Int2AddrOp [arg] =
140 simpleCoercion AddrRep res arg
142 genprim [res] Addr2IntOp [arg] =
143 simpleCoercion IntRep res arg
145 genprim [res] Int2WordOp [arg] =
146 simpleCoercion IntRep{-WordRep?-} res arg
148 genprim [res] Word2IntOp [arg] =
149 simpleCoercion IntRep res arg
153 The @ErrorIO@ primitive is actually a bit weird...assign a new value to the root
154 closure, flush stdout and stderr, and jump to the @ErrorIO_innards@.
158 genprim [] ErrorIOPrimOp [rhs] =
159 let changeTop = StAssign PtrRep topClosure (a2stix rhs)
161 returnUs (\xs -> changeTop : flushStdout : flushStderr : errorIO : xs)
165 @newArray#@ ops allocate heap space.
168 genprim [res] NewArrayOp args =
169 let [liveness, n, initial] = map a2stix args
171 space = StPrim IntAddOp [n, mut_hs]
172 loc = StIndex PtrRep stgHp
173 (StPrim IntNegOp [StPrim IntSubOp [space, StInt 1]])
174 assign = StAssign PtrRep result loc
175 initialise = StCall SLIT("newArrZh_init") VoidRep [result, n, initial]
177 heap_chkr liveness space (StInt 0) `thenUs` \ heap_chk ->
179 returnUs (heap_chk . (\xs -> assign : initialise : xs))
181 genprim [res] (NewByteArrayOp pk) args =
182 let [liveness, count] = map a2stix args
184 n = StPrim IntMulOp [count, StInt (toInteger (size_of pk))]
185 slop = StPrim IntAddOp [n, StInt (toInteger (size_of IntRep - 1))]
186 words = StPrim IntQuotOp [slop, StInt (toInteger (size_of IntRep))]
187 space = StPrim IntAddOp [n, StPrim IntAddOp [words, data_hs]]
188 loc = StIndex PtrRep stgHp
189 (StPrim IntNegOp [StPrim IntSubOp [space, StInt 1]])
190 assign = StAssign PtrRep result loc
191 init1 = StAssign PtrRep (StInd PtrRep loc) arrayOfData_info
192 init2 = StAssign IntRep
195 (StInt (toInteger fixed_hs))))
196 (StPrim IntAddOp [words,
197 StInt (toInteger (var_hs (DataRep 0)))])
199 heap_chkr liveness space (StInt 0) `thenUs` \ heap_chk ->
201 returnUs (heap_chk . (\xs -> assign : init1 : init2 : xs))
203 genprim [res] SameMutableArrayOp args =
204 let compare = StPrim AddrEqOp (map a2stix args)
205 assign = StAssign IntRep (a2stix res) compare
207 returnUs (\xs -> assign : xs)
209 genprim res@[_] SameMutableByteArrayOp args =
210 genprim res SameMutableArrayOp args
214 Freezing an array of pointers is a double assignment. We fix the header of
215 the ``new'' closure because the lhs is probably a better addressing mode for
216 the indirection (most likely, it's a VanillaReg).
220 genprim [lhs] UnsafeFreezeArrayOp [rhs] =
221 let lhs' = a2stix lhs
223 header = StInd PtrRep lhs'
224 assign = StAssign PtrRep lhs' rhs'
225 freeze = StAssign PtrRep header imMutArrayOfPtrs_info
227 returnUs (\xs -> assign : freeze : xs)
229 genprim [lhs] UnsafeFreezeByteArrayOp [rhs] =
230 simpleCoercion PtrRep lhs rhs
234 Most other array primitives translate to simple indexing.
238 genprim lhs@[_] IndexArrayOp args =
239 genprim lhs ReadArrayOp args
241 genprim [lhs] ReadArrayOp [obj, ix] =
242 let lhs' = a2stix lhs
245 base = StIndex IntRep obj' mut_hs
246 assign = StAssign PtrRep lhs' (StInd PtrRep (StIndex PtrRep base ix'))
248 returnUs (\xs -> assign : xs)
250 genprim [lhs] WriteArrayOp [obj, ix, v] =
251 let obj' = a2stix obj
254 base = StIndex IntRep obj' mut_hs
255 assign = StAssign PtrRep (StInd PtrRep (StIndex PtrRep base ix')) v'
257 returnUs (\xs -> assign : xs)
259 genprim lhs@[_] (IndexByteArrayOp pk) args =
260 genprim lhs (ReadByteArrayOp pk) args
262 -- NB: indexing in "pk" units, *not* in bytes (WDP 95/09)
264 genprim [lhs] (ReadByteArrayOp pk) [obj, ix] =
265 let lhs' = a2stix lhs
268 base = StIndex IntRep obj' data_hs
269 assign = StAssign pk lhs' (StInd pk (StIndex pk base ix'))
271 returnUs (\xs -> assign : xs)
273 genprim [lhs] (IndexOffAddrOp pk) [obj, ix] =
274 let lhs' = a2stix lhs
277 assign = StAssign pk lhs' (StInd pk (StIndex pk obj' ix'))
279 returnUs (\xs -> assign : xs)
281 genprim [] (WriteByteArrayOp pk) [obj, ix, v] =
282 let obj' = a2stix obj
285 base = StIndex IntRep obj' data_hs
286 assign = StAssign pk (StInd pk (StIndex pk base ix')) v'
288 returnUs (\xs -> assign : xs)
291 Stable pointer operations.
297 genprim [lhs] DeRefStablePtrOp [sp] =
298 let lhs' = a2stix lhs
301 call = StCall SLIT("deRefStablePointer") pk [sp', smStablePtrTable]
302 assign = StAssign pk lhs' call
304 returnUs (\xs -> assign : xs)
308 Now the hard one. For comparison, here's the code from StgMacros:
311 #define makeStablePtrZh(stablePtr,liveness,unstablePtr) \
313 EXTDATA(MK_INFO_LBL(StablePointerTable)); \
315 StgStablePtr newSP; \
317 if (SPT_EMPTY(StorageMgrInfo.StablePointerTable)) { /* free stack is empty */ \
318 I_ OldNoPtrs = SPT_NoPTRS(StorageMgrInfo.StablePointerTable); \
320 /* any strictly increasing expression will do here */ \
321 I_ NewNoPtrs = OldNoPtrs * 2 + 100; \
323 I_ NewSize = DYN_VHS + NewNoPtrs + 1 + NewNoPtrs; \
326 HEAP_CHK(NO_LIVENESS, _FHS+NewSize, 0); \
327 CC_ALLOC(CCC, _FHS+NewSize, SPT_K); /* cc prof */ \
329 SPTable = Hp + 1 - (_FHS + NewSize); \
330 SET_DYN_HDR(SPTable,StablePointerTable,CCC,NewSize,NewNoPtrs); \
331 SAFESTGCALL2(void, (void *, P_, P_), enlargeSPTable, SPTable, StorageMgrInfo.StablePointerTable); \
332 StorageMgrInfo.StablePointerTable = SPTable; \
335 newSP = SPT_POP(StorageMgrInfo.StablePointerTable); \
336 SPT_SPTR(StorageMgrInfo.StablePointerTable, newSP) = unstablePtr; \
341 ToDo ADR: finish this. (Boy, this is hard work!)
344 trMumbles are now just StMumbles.
345 StInt 1 is how to write ``1''
346 temporaries are allocated at the end of the heap (see notes in StixInteger)
352 genprim [lhs] MakeStablePtrOp args =
354 -- some useful abbreviations (I'm sure these must exist already)
355 add = trPrim . IntAddOp
356 sub = trPrim . IntSubOp
358 dec x = trAssign IntRep [x, sub [x, one]]
359 inc x = trAssign IntRep [x, add [x, one]]
361 -- tedious hardwiring in of closure layout offsets (from SMClosures)
362 dynHS = 2 + fixedHeaderSize md sty + varHeaderSize md sty DynamicRep
363 spt_SIZE c = trIndex PtrRep [c, trInt [fhs + gc_reserved] ]
364 spt_NoPTRS c = trIndex PtrRep [c, trInt [fhs + gc_reserved + 1] ]
365 spt_SPTR c i = trIndex PtrRep [c, add [trInt [dynHS], i]]
366 spt_TOP c = trIndex PtrRep [c, add [trInt [dynHS], spt_NoPTRS c]]
367 spt_FREE c i = trIndex PtrRep [c, add [trInt [dynHS], spt_NoPTRS c]]
369 -- tedious hardwiring in of stack manipulation macros (from SMClosures)
371 trCondJump lbl [trPrim IntEqOp [spt_TOP c, spt_NoPTRS c]]
373 trCondJump lbl [trPrim IntEqOp [spt_TOP c, trInt [0]]]
375 trAssign PtrRep [spt_FREE c (spt_TOP c), f],
379 trAssign PtrRep [x, spt_FREE c (spt_TOP c)]
382 -- now to get down to business
383 lhs' = amodeCode sty md lhs
384 [liveness, unstable] = map (amodeCode sty md) args
386 spt = smStablePtrTable
388 newSPT = -- a temporary (don't know how to allocate it)
389 newSP = -- another temporary
391 allocNewTable = -- some sort fo heap allocation needed
392 copyOldTable = trCall "enlargeSPTable" PtrRep [newSPT, spt]
397 trAssign PtrRep [spt, newSPT]
400 trAssign PtrRep [spt_SPTR spt newSP, unstable],
401 trAssign StablePtrRep [lhs', newSP]
405 getUniqLabelCTS `thenCTS` \ oklbl ->
407 (spt_EMPTY spt oklbl : (enlarge ++ (trLabel [oklbl] : allocate)))
411 genprim res Word2IntegerOp args = panic "genPrimCode:Word2IntegerOp"
413 genprim lhs (CCallOp fn is_asm may_gc arg_tys result_ty) rhs
414 | is_asm = error "ERROR: Native code generator can't handle casm"
417 [] -> returnUs (\xs -> (StCall fn VoidRep args) : xs)
419 let lhs' = a2stix lhs
420 pk = if isFloatingRep (getAmodeRep lhs) then DoubleRep else IntRep
421 call = StAssign pk lhs' (StCall fn pk args)
423 returnUs (\xs -> call : xs)
425 args = map amodeCodeForCCall rhs
426 amodeCodeForCCall x =
429 case getAmodeRep x of
430 ArrayRep -> StIndex PtrRep base mut_hs
431 ByteArrayRep -> StIndex IntRep base data_hs
432 MallocPtrRep -> error "ERROR: native-code generator can't handle Malloc Ptrs (yet): use -fvia-C!"
436 Now the more mundane operations.
440 let lhs' = map a2stix lhs
441 rhs' = map a2stix' rhs
443 returnUs (\ xs -> simplePrim lhs' op rhs' : xs)
451 -> UniqSM StixTreeList
453 simpleCoercion pk lhs rhs =
454 returnUs (\xs -> StAssign pk (a2stix lhs) (a2stix rhs) : xs)
458 Here we try to rewrite primitives into a form the code generator
459 can understand. Any primitives not handled here must be handled
460 at the level of the specific code generator.
473 Now look for something more conventional.
477 simplePrim [lhs] op rest = StAssign pk lhs (StPrim op rest)
478 where pk = if isCompareOp op then IntRep
479 else case getPrimOpResultInfo op of
481 _ -> simplePrim_error op
483 simplePrim _ op _ = simplePrim_error op
486 = 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")
489 %---------------------------------------------------------------------
491 Here we generate the Stix code for CAddrModes.
493 When a character is fetched from a mixed type location, we have to
494 do an extra cast. This is reflected in amodeCode', which is for rhs
495 amodes that might possibly need the extra cast.
499 amodeCode, amodeCode'
504 amodeCode'{-'-} target_STRICT am@(CVal rr CharRep)
505 | mixedTypeLocn am = StPrim ChrOp [amodeToStix target am]
506 | otherwise = amodeToStix target am
508 amodeCode' target am = amodeToStix target am
510 amodeCode target_STRICT am
513 -- grab "target" things:
514 hp_rel = hpRel target
515 char_like = charLikeClosureSize target
516 int_like = intLikeClosureSize target
517 a2stix = amodeToStix target
519 -- real code: ----------------------------------
520 acode am@(CVal rr CharRep) | mixedTypeLocn am =
521 StInd IntRep (acode (CAddr rr))
523 acode (CVal rr pk) = StInd pk (acode (CAddr rr))
525 acode (CAddr (SpARel spA off)) =
526 StIndex PtrRep stgSpA (StInt (toInteger (spARelToInt spA off)))
528 acode (CAddr (SpBRel spB off)) =
529 StIndex IntRep stgSpB (StInt (toInteger (spBRelToInt spB off)))
531 acode (CAddr (HpRel hp off)) =
532 StIndex IntRep stgHp (StInt (toInteger (-(hp_rel (hp `subOff` off)))))
534 acode (CAddr (NodeRel off)) =
535 StIndex IntRep stgNode (StInt (toInteger (hp_rel off)))
537 acode (CReg magic) = StReg (StixMagicId magic)
538 acode (CTemp uniq pk) = StReg (StixTemp uniq pk)
540 acode (CLbl lbl _) = StCLbl lbl
542 acode (CUnVecLbl dir _) = StCLbl dir
544 acode (CTableEntry base off pk) =
545 StInd pk (StIndex pk (acode base) (acode off))
547 -- For CharLike and IntLike, we attempt some trivial constant-folding here.
549 acode (CCharLike (CLit (MachChar c))) =
550 StLitLbl (uppBeside (uppPStr SLIT("CHARLIKE_closures+")) (uppInt off))
551 where off = char_like * ord c
553 acode (CCharLike x) =
554 StPrim IntAddOp [charLike, off]
555 where off = StPrim IntMulOp [acode x,
556 StInt (toInteger (char_like))]
558 acode (CIntLike (CLit (MachInt i _))) =
559 StPrim IntAddOp [intLikePtr, StInt off]
560 where off = toInteger int_like * i
563 StPrim IntAddOp [intLikePtr, off]
564 where off = StPrim IntMulOp [acode x,
565 StInt (toInteger int_like)]
567 -- A CString is just a (CLit . MachStr)
568 acode (CString s) = StString s
570 acode (CLit core) = case core of
571 (MachChar c) -> StInt (toInteger (ord c))
572 (MachStr s) -> StString s
573 (MachAddr a) -> StInt a
574 (MachInt i _) -> StInt i
575 (MachLitLit s _) -> StLitLit s
576 (MachFloat d) -> StDouble d
577 (MachDouble d) -> StDouble d
578 _ -> panic "amodeCode:core literal"
580 -- A CLitLit is just a (CLit . MachLitLit)
581 acode (CLitLit s _) = StLitLit s
583 -- COffsets are in words, not bytes!
584 acode (COffset off) = StInt (toInteger (hp_rel off))
586 acode (CMacroExpr _ macro [arg]) =
588 INFO_PTR -> StInd PtrRep (a2stix arg)
589 ENTRY_CODE -> a2stix arg
591 EVAL_TAG -> StPrim IntGeOp [tag, StInt 0]
593 tag = StInd IntRep (StIndex IntRep (a2stix arg) (StInt (-2)))
594 -- That ``-2'' really bothers me. (JSM)
596 acode (CCostCentre cc print_as_string)
597 = if noCostCentreAttached cc
598 then StComment SLIT("") -- sigh
599 else panic "amodeCode:CCostCentre"
602 Sizes of the CharLike and IntLike closures that are arranged as arrays in the
603 data segment. (These are in bytes.)
607 -- The INTLIKE base pointer
609 intLikePtr :: StixTree
611 intLikePtr = StInd PtrRep (sStLitLbl SLIT("INTLIKE_closures"))
617 charLike = sStLitLbl SLIT("CHARLIKE_closures")
619 -- Trees for the ErrorIOPrimOp
621 topClosure, flushStdout, flushStderr, errorIO :: StixTree
623 topClosure = StInd PtrRep (sStLitLbl SLIT("TopClosure"))
624 flushStdout = StCall SLIT("fflush") VoidRep [StLitLit SLIT("stdout")]
625 flushStderr = StCall SLIT("fflush") VoidRep [StLitLit SLIT("stderr")]
626 errorIO = StJump (StInd PtrRep (sStLitLbl SLIT("ErrorIO_innards")))