2 % (c) The AQUA Project, Glasgow University, 1993-1996
6 #include "HsVersions.h"
8 module AbsCStixGen ( genCodeAbstractC ) where
11 IMPORT_1_3(Ratio(Rational))
17 #if __GLASGOW_HASKELL__ >= 202
18 import MachRegs hiding (Addr)
23 import AbsCUtils ( getAmodeRep, mixedTypeLocn,
24 nonemptyAbsC, mkAbsCStmts, mkAbsCStmtList
26 import Constants ( mIN_UPD_SIZE )
27 import CLabel ( CLabel )
28 import ClosureInfo ( infoTableLabelFromCI, entryLabelFromCI,
29 fastLabelFromCI, closureUpdReqd
31 import HeapOffs ( hpRelToInt )
32 import Literal ( Literal(..) )
33 import Maybes ( maybeToBool )
34 import OrdList ( OrdList )
35 import PrimOp ( primOpNeedsWrapper, PrimOp(..) )
36 import PrimRep ( isFloatingRep, PrimRep(..) )
37 import StixInfo ( genCodeInfoTable )
38 import StixMacro ( macroCode )
39 import StixPrim ( primCode, amodeToStix, amodeToStix' )
40 import UniqSupply ( returnUs, thenUs, mapUs, getUnique, SYN_IE(UniqSM) )
41 import Util ( naturalMergeSortLe, panic )
43 #ifdef REALLY_HASKELL_1_3
44 ord = fromEnum :: Char -> Int
48 For each independent chunk of AbstractC code, we generate a list of
49 @StixTree@s, where each tree corresponds to a single Stix instruction.
50 We leave the chunks separated so that register allocation can be
51 performed locally within the chunk.
54 genCodeAbstractC :: AbstractC -> UniqSM [[StixTree]]
57 = mapUs gentopcode (mkAbsCStmtList absC) `thenUs` \ trees ->
58 returnUs ([StComment SLIT("Native Code")] : trees)
61 a2stix' = amodeToStix'
62 volsaves = volatileSaves
63 volrestores = volatileRestores
65 macro_code = macroCode
67 -- real code follows... ---------
70 Here we handle top-level things, like @CCodeBlock@s and
80 gentopcode (CCodeBlock label absC)
81 = gencode absC `thenUs` \ code ->
82 returnUs (StSegment TextSegment : StFunBegin label : code [StFunEnd label])
84 gentopcode stmt@(CStaticClosure label _ _ _)
85 = genCodeStaticClosure stmt `thenUs` \ code ->
86 returnUs (StSegment DataSegment : StLabel label : code [])
88 gentopcode stmt@(CRetUnVector _ _) = returnUs []
90 gentopcode stmt@(CFlatRetVector label _)
91 = genCodeVecTbl stmt `thenUs` \ code ->
92 returnUs (StSegment TextSegment : code [StLabel label])
94 gentopcode stmt@(CClosureInfoAndCode cl_info slow Nothing _ _ _)
97 = genCodeInfoTable stmt `thenUs` \ itbl ->
98 returnUs (StSegment TextSegment : itbl [])
101 = genCodeInfoTable stmt `thenUs` \ itbl ->
102 gencode slow `thenUs` \ slow_code ->
103 returnUs (StSegment TextSegment : itbl (StFunBegin slow_lbl :
104 slow_code [StFunEnd slow_lbl]))
106 slow_is_empty = not (maybeToBool (nonemptyAbsC slow))
107 slow_lbl = entryLabelFromCI cl_info
109 gentopcode stmt@(CClosureInfoAndCode cl_info slow (Just fast) _ _ _) =
110 -- ToDo: what if this is empty? ------------------------^^^^
111 genCodeInfoTable stmt `thenUs` \ itbl ->
112 gencode slow `thenUs` \ slow_code ->
113 gencode fast `thenUs` \ fast_code ->
114 returnUs (StSegment TextSegment : itbl (StFunBegin slow_lbl :
115 slow_code (StFunEnd slow_lbl : StFunBegin fast_lbl :
116 fast_code [StFunEnd fast_lbl])))
118 slow_lbl = entryLabelFromCI cl_info
119 fast_lbl = fastLabelFromCI cl_info
122 = gencode absC `thenUs` \ code ->
123 returnUs (StSegment TextSegment : code [])
127 Vector tables are trivial!
133 -> UniqSM StixTreeList
135 genCodeVecTbl (CFlatRetVector label amodes)
136 = returnUs (\xs -> vectbl : xs)
138 vectbl = StData PtrRep (reverse (map a2stix amodes))
142 Static closures are not so hard either.
148 -> UniqSM StixTreeList
150 genCodeStaticClosure (CStaticClosure _ cl_info cost_centre amodes)
151 = returnUs (\xs -> table : xs)
153 table = StData PtrRep (StCLbl info_lbl : body)
154 info_lbl = infoTableLabelFromCI cl_info
156 body = if closureUpdReqd cl_info then
157 take (max mIN_UPD_SIZE (length amodes')) (amodes' ++ zeros)
161 zeros = StInt 0 : zeros
163 amodes' = map amodeZeroVoid amodes
165 -- Watch out for VoidKinds...cf. PprAbsC
167 | getAmodeRep item == VoidRep = StInt 0
168 | otherwise = a2stix item
172 Now the individual AbstractC statements.
178 -> UniqSM StixTreeList
182 @AbsCNop@s just disappear.
186 gencode AbsCNop = returnUs id
190 Split markers are a NOP in this land.
194 gencode CSplitMarker = returnUs id
198 AbstractC instruction sequences are handled individually, and the
199 resulting StixTreeLists are joined together.
203 gencode (AbsCStmts c1 c2)
204 = gencode c1 `thenUs` \ b1 ->
205 gencode c2 `thenUs` \ b2 ->
210 Initialising closure headers in the heap...a fairly complex ordeal if
211 done properly. For now, we just set the info pointer, but we should
212 really take a peek at the flags to determine whether or not there are
213 other things to be done (setting cost centres, age headers, global
218 gencode (CInitHdr cl_info reg_rel _ _)
220 lhs = a2stix (CVal reg_rel PtrRep)
221 lbl = infoTableLabelFromCI cl_info
223 returnUs (\xs -> StAssign PtrRep lhs (StCLbl lbl) : xs)
227 Assignment, the curse of von Neumann, is the center of the code we
228 produce. In most cases, the type of the assignment is determined
229 by the type of the destination. However, when the destination can
230 have mixed types, the type of the assignment is ``StgWord'' (we use
231 PtrRep for lack of anything better). Think: do we also want a cast
232 of the source? Be careful about floats/doubles.
236 gencode (CAssign lhs rhs)
237 | getAmodeRep lhs == VoidRep = returnUs id
239 = let pk = getAmodeRep lhs
240 pk' = if mixedTypeLocn lhs && not (isFloatingRep pk) then IntRep else pk
244 returnUs (\xs -> StAssign pk' lhs' rhs' : xs)
248 Unconditional jumps, including the special ``enter closure'' operation.
249 Note that the new entry convention requires that we load the InfoPtr (R2)
250 with the address of the info table before jumping to the entry code for Node.
255 = returnUs (\xs -> StJump (a2stix dest) : xs)
257 gencode (CFallThrough (CLbl lbl _))
258 = returnUs (\xs -> StFallThrough lbl : xs)
260 gencode (CReturn dest DirectReturn)
261 = returnUs (\xs -> StJump (a2stix dest) : xs)
263 gencode (CReturn table (StaticVectoredReturn n))
264 = returnUs (\xs -> StJump dest : xs)
266 dest = StInd PtrRep (StIndex PtrRep (a2stix table)
267 (StInt (toInteger (-n-1))))
269 gencode (CReturn table (DynamicVectoredReturn am))
270 = returnUs (\xs -> StJump dest : xs)
272 dest = StInd PtrRep (StIndex PtrRep (a2stix table) dyn_off)
273 dyn_off = StPrim IntSubOp [StPrim IntNegOp [a2stix am], StInt 1]
277 Now the PrimOps, some of which may need caller-saves register wrappers.
281 gencode (COpStmt results op args liveness_mask vols)
282 -- ToDo (ADR?): use that liveness mask
283 | primOpNeedsWrapper op
285 saves = volsaves vols
286 restores = volrestores vols
288 p2stix (nonVoid results) op (nonVoid args)
290 returnUs (\xs -> saves ++ code (restores ++ xs))
292 | otherwise = p2stix (nonVoid results) op (nonVoid args)
294 nonVoid = filter ((/= VoidRep) . getAmodeRep)
298 Now the dreaded conditional jump.
300 Now the if statement. Almost *all* flow of control are of this form.
302 if (am==lit) { absC } else { absCdef }
316 gencode (CSwitch discrim alts deflt)
320 [(tag,alt_code)] -> case maybe_empty_deflt of
321 Nothing -> gencode alt_code
322 Just dc -> mkIfThenElse discrim tag alt_code dc
324 [(tag1@(MachInt i1 _), alt_code1),
325 (tag2@(MachInt i2 _), alt_code2)]
326 | deflt_is_empty && i1 == 0 && i2 == 1
327 -> mkIfThenElse discrim tag1 alt_code1 alt_code2
328 | deflt_is_empty && i1 == 1 && i2 == 0
329 -> mkIfThenElse discrim tag2 alt_code2 alt_code1
331 -- If the @discrim@ is simple, then this unfolding is safe.
332 other | simple_discrim -> mkSimpleSwitches discrim alts deflt
334 -- Otherwise, we need to do a bit of work.
335 other -> getUnique `thenUs` \ u ->
337 (CAssign (CTemp u pk) discrim)
338 (CSwitch (CTemp u pk) alts deflt))
341 maybe_empty_deflt = nonemptyAbsC deflt
342 deflt_is_empty = case maybe_empty_deflt of
346 pk = getAmodeRep discrim
348 simple_discrim = case discrim of
356 Finally, all of the disgusting AbstractC macros.
360 gencode (CMacroStmt macro args) = macro_code macro args
362 gencode (CCallProfCtrMacro macro _)
363 = returnUs (\xs -> StComment macro : xs)
365 gencode (CCallProfCCMacro macro _)
366 = returnUs (\xs -> StComment macro : xs)
370 Here, we generate a jump table if there are more than four (integer) alternatives and
371 the jump table occupancy is greater than 50%. Otherwise, we generate a binary
372 comparison tree. (Perhaps this could be tuned.)
376 intTag :: Literal -> Integer
377 intTag (MachChar c) = toInteger (ord c)
378 intTag (MachInt i _) = i
379 intTag _ = panic "intTag"
381 fltTag :: Literal -> Rational
383 fltTag (MachFloat f) = f
384 fltTag (MachDouble d) = d
385 fltTag _ = panic "fltTag"
389 :: CAddrMode -> [(Literal,AbstractC)] -> AbstractC
390 -> UniqSM StixTreeList
392 mkSimpleSwitches am alts absC
393 = getUniqLabelNCG `thenUs` \ udlbl ->
394 getUniqLabelNCG `thenUs` \ ujlbl ->
396 joinedAlts = map (\ (tag,code) -> (tag, mkJoin code ujlbl)) alts
397 sortedAlts = naturalMergeSortLe leAlt joinedAlts
398 -- naturalMergeSortLe, because we often get sorted alts to begin with
400 lowTag = intTag (fst (head sortedAlts))
401 highTag = intTag (fst (last sortedAlts))
403 -- lowest and highest possible values the discriminant could take
404 lowest = if floating then targetMinDouble else targetMinInt
405 highest = if floating then targetMaxDouble else targetMaxInt
408 if not floating && choices > 4 && highTag - lowTag < toInteger (2 * choices) then
409 mkJumpTable am' sortedAlts lowTag highTag udlbl
411 mkBinaryTree am' floating sortedAlts choices lowest highest udlbl
413 `thenUs` \ alt_code ->
414 gencode absC `thenUs` \ dflt_code ->
416 returnUs (\xs -> alt_code (StLabel udlbl : dflt_code (StLabel ujlbl : xs)))
419 floating = isFloatingRep (getAmodeRep am)
420 choices = length alts
422 (x@(MachChar _),_) `leAlt` (y,_) = intTag x <= intTag y
423 (x@(MachInt _ _),_) `leAlt` (y,_) = intTag x <= intTag y
424 (x,_) `leAlt` (y,_) = fltTag x <= fltTag y
428 We use jump tables when doing an integer switch on a relatively dense
429 list of alternatives. We expect to be given a list of alternatives,
430 sorted by tag, and a range of values for which we are to generate a
431 table. Of course, the tags of the alternatives should lie within the
432 indicated range. The alternatives need not cover the range; a default
433 target is provided for the missing alternatives.
435 If a join is necessary after the switch, the alternatives should
436 already finish with a jump to the join point.
441 :: StixTree -- discriminant
442 -> [(Literal, AbstractC)] -- alternatives
443 -> Integer -- low tag
444 -> Integer -- high tag
445 -> CLabel -- default label
446 -> UniqSM StixTreeList
449 mkJumpTable am alts lowTag highTag dflt
450 = getUniqLabelNCG `thenUs` \ utlbl ->
451 mapUs genLabel alts `thenUs` \ branches ->
452 let cjmpLo = StCondJump dflt (StPrim IntLtOp [am, StInt lowTag])
453 cjmpHi = StCondJump dflt (StPrim IntGtOp [am, StInt highTag])
455 offset = StPrim IntSubOp [am, StInt lowTag]
456 jump = StJump (StInd PtrRep (StIndex PtrRep (StCLbl utlbl) offset))
459 table = StData PtrRep (mkTable branches [lowTag..highTag] [])
461 mapUs mkBranch branches `thenUs` \ alts ->
463 returnUs (\xs -> cjmpLo : cjmpHi : jump :
464 StSegment DataSegment : tlbl : table :
465 StSegment TextSegment : foldr1 (.) alts xs)
468 genLabel x = getUniqLabelNCG `thenUs` \ lbl -> returnUs (lbl, x)
470 mkBranch (lbl,(_,alt)) =
471 gencode alt `thenUs` \ alt_code ->
472 returnUs (\xs -> StLabel lbl : alt_code xs)
474 mkTable _ [] tbl = reverse tbl
475 mkTable [] (x:xs) tbl = mkTable [] xs (StCLbl dflt : tbl)
476 mkTable alts@((lbl,(tag,_)):rest) (x:xs) tbl
477 | intTag tag == x = mkTable rest xs (StCLbl lbl : tbl)
478 | otherwise = mkTable alts xs (StCLbl dflt : tbl)
482 We generate binary comparison trees when a jump table is inappropriate.
483 We expect to be given a list of alternatives, sorted by tag, and for
484 convenience, the length of the alternative list. We recursively break
485 the list in half and do a comparison on the first tag of the second half
486 of the list. (Odd lists are broken so that the second half of the list
487 is longer.) We can handle either integer or floating kind alternatives,
488 so long as they are not mixed. (We assume that the type of the discriminant
489 determines the type of the alternatives.)
491 As with the jump table approach, if a join is necessary after the switch, the
492 alternatives should already finish with a jump to the join point.
497 :: StixTree -- discriminant
498 -> Bool -- floating point?
499 -> [(Literal, AbstractC)] -- alternatives
500 -> Int -- number of choices
501 -> Literal -- low tag
502 -> Literal -- high tag
503 -> CLabel -- default code label
504 -> UniqSM StixTreeList
507 mkBinaryTree am floating [(tag,alt)] _ lowTag highTag udlbl
508 | rangeOfOne = gencode alt
510 = let tag' = a2stix (CLit tag)
511 cmpOp = if floating then DoubleNeOp else IntNeOp
512 test = StPrim cmpOp [am, tag']
513 cjmp = StCondJump udlbl test
515 gencode alt `thenUs` \ alt_code ->
516 returnUs (\xs -> cjmp : alt_code xs)
519 rangeOfOne = not floating && intTag lowTag + 1 >= intTag highTag
520 -- When there is only one possible tag left in range, we skip the comparison
522 mkBinaryTree am floating alts choices lowTag highTag udlbl
523 = getUniqLabelNCG `thenUs` \ uhlbl ->
524 let tag' = a2stix (CLit splitTag)
525 cmpOp = if floating then DoubleGeOp else IntGeOp
526 test = StPrim cmpOp [am, tag']
527 cjmp = StCondJump uhlbl test
529 mkBinaryTree am floating alts_lo half lowTag splitTag udlbl
530 `thenUs` \ lo_code ->
531 mkBinaryTree am floating alts_hi (choices - half) splitTag highTag udlbl
532 `thenUs` \ hi_code ->
534 returnUs (\xs -> cjmp : lo_code (StLabel uhlbl : hi_code xs))
537 half = choices `div` 2
538 (alts_lo, alts_hi) = splitAt half alts
539 splitTag = fst (head alts_hi)
546 :: CAddrMode -- discriminant
548 -> AbstractC -- if-part
549 -> AbstractC -- else-part
550 -> UniqSM StixTreeList
553 mkIfThenElse discrim tag alt deflt
554 = getUniqLabelNCG `thenUs` \ ujlbl ->
555 getUniqLabelNCG `thenUs` \ utlbl ->
556 let discrim' = a2stix discrim
557 tag' = a2stix (CLit tag)
558 cmpOp = if (isFloatingRep (getAmodeRep discrim)) then DoubleNeOp else IntNeOp
559 test = StPrim cmpOp [discrim', tag']
560 cjmp = StCondJump utlbl test
564 gencode (mkJoin alt ujlbl) `thenUs` \ alt_code ->
565 gencode deflt `thenUs` \ dflt_code ->
566 returnUs (\xs -> cjmp : alt_code (dest : dflt_code (join : xs)))
568 mkJoin :: AbstractC -> CLabel -> AbstractC
571 | mightFallThrough code = mkAbsCStmts code (CJump (CLbl lbl PtrRep))
575 %---------------------------------------------------------------------------
577 This answers the question: Can the code fall through to the next
578 line(s) of code? This errs towards saying True if it can't choose,
579 because it is used for eliminating needless jumps. In other words, if
580 you might possibly {\em not} jump, then say yes to falling through.
583 mightFallThrough :: AbstractC -> Bool
585 mightFallThrough absC = ft absC True
587 ft AbsCNop if_empty = if_empty
589 ft (CJump _) if_empty = False
590 ft (CReturn _ _) if_empty = False
591 ft (CSwitch _ alts deflt) if_empty
592 = ft deflt if_empty ||
593 or [ft alt if_empty | (_,alt) <- alts]
595 ft (AbsCStmts c1 c2) if_empty = ft c2 (ft c1 if_empty)
596 ft _ if_empty = if_empty
598 {- Old algorithm, which called nonemptyAbsC for every subexpression! =========
599 fallThroughAbsC (AbsCStmts c1 c2)
600 = case nonemptyAbsC c2 of
601 Nothing -> fallThroughAbsC c1
602 Just x -> fallThroughAbsC x
603 fallThroughAbsC (CJump _) = False
604 fallThroughAbsC (CReturn _ _) = False
605 fallThroughAbsC (CSwitch _ choices deflt)
606 = (not (isEmptyAbsC deflt) && fallThroughAbsC deflt)
607 || or (map (fallThroughAbsC . snd) choices)
608 fallThroughAbsC other = True
610 isEmptyAbsC :: AbstractC -> Bool
611 isEmptyAbsC = not . maybeToBool . nonemptyAbsC
612 ================= End of old, quadratic, algorithm -}