2 % (c) The AQUA Project, Glasgow University, 1993-1998
6 module AbsCStixGen ( genCodeAbstractC ) where
8 #include "HsVersions.h"
10 import Ratio ( Rational )
16 import AbsCUtils ( getAmodeRep, mixedTypeLocn,
17 nonemptyAbsC, mkAbsCStmts, mkAbsCStmtList
19 import PprAbsC ( dumpRealC )
20 import SMRep ( fixedItblSize,
22 rET_VEC_SMALL, rET_VEC_BIG
24 import Constants ( mIN_UPD_SIZE )
25 import CLabel ( CLabel, mkReturnInfoLabel, mkReturnPtLabel,
26 mkClosureTblLabel, mkStaticClosureLabel )
27 import ClosureInfo ( infoTableLabelFromCI, entryLabelFromCI,
28 fastLabelFromCI, closureUpdReqd,
29 staticClosureNeedsLink
31 import Const ( Literal(..) )
32 import Maybes ( maybeToBool )
33 import PrimOp ( primOpNeedsWrapper, PrimOp(..) )
34 import PrimRep ( isFloatingRep, PrimRep(..) )
35 import StixInfo ( genCodeInfoTable, genBitmapInfoTable )
36 import StixMacro ( macroCode, checkCode )
37 import StixPrim ( primCode, amodeToStix, amodeToStix' )
38 import Outputable ( pprPanic )
39 import UniqSupply ( returnUs, thenUs, mapUs, getUniqueUs, UniqSM )
40 import Util ( naturalMergeSortLe )
41 import Panic ( panic )
42 import TyCon ( tyConDataCons )
43 import BitSet ( intBS )
44 import Name ( NamedThing(..) )
46 #ifdef REALLY_HASKELL_1_3
47 ord = fromEnum :: Char -> Int
51 For each independent chunk of AbstractC code, we generate a list of
52 @StixTree@s, where each tree corresponds to a single Stix instruction.
53 We leave the chunks separated so that register allocation can be
54 performed locally within the chunk.
57 genCodeAbstractC :: AbstractC -> UniqSM [[StixTree]]
60 = mapUs gentopcode (mkAbsCStmtList absC) `thenUs` \ trees ->
61 returnUs ([StComment SLIT("Native Code")] : trees)
64 a2stix' = amodeToStix'
65 volsaves = volatileSaves
66 volrestores = volatileRestores
68 macro_code = macroCode
69 -- real code follows... ---------
72 Here we handle top-level things, like @CCodeBlock@s and
82 gentopcode (CCodeBlock lbl absC)
83 = gencode absC `thenUs` \ code ->
84 returnUs (StSegment TextSegment : StFunBegin lbl : code [StFunEnd lbl])
86 gentopcode stmt@(CStaticClosure lbl _ _ _)
87 = genCodeStaticClosure stmt `thenUs` \ code ->
88 returnUs (StSegment DataSegment : StLabel lbl : code [])
90 gentopcode stmt@(CRetVector lbl _ _ _)
91 = genCodeVecTbl stmt `thenUs` \ code ->
92 returnUs (StSegment TextSegment : code [StLabel lbl])
94 gentopcode stmt@(CRetDirect uniq absC srt liveness)
95 = gencode absC `thenUs` \ code ->
96 genBitmapInfoTable liveness srt closure_type False `thenUs` \ itbl ->
97 returnUs (StSegment TextSegment :
98 itbl (StLabel lbl_info : StLabel lbl_ret : code []))
100 lbl_info = mkReturnInfoLabel uniq
101 lbl_ret = mkReturnPtLabel uniq
102 closure_type = case liveness of
103 LvSmall _ -> rET_SMALL
106 gentopcode stmt@(CClosureInfoAndCode cl_info slow Nothing _)
109 = genCodeInfoTable stmt `thenUs` \ itbl ->
110 returnUs (StSegment TextSegment : itbl [])
113 = genCodeInfoTable stmt `thenUs` \ itbl ->
114 gencode slow `thenUs` \ slow_code ->
115 returnUs (StSegment TextSegment : itbl (StFunBegin slow_lbl :
116 slow_code [StFunEnd slow_lbl]))
118 slow_is_empty = not (maybeToBool (nonemptyAbsC slow))
119 slow_lbl = entryLabelFromCI cl_info
121 gentopcode stmt@(CClosureInfoAndCode cl_info slow (Just fast) _) =
122 -- ToDo: what if this is empty? ------------------------^^^^
123 genCodeInfoTable stmt `thenUs` \ itbl ->
124 gencode slow `thenUs` \ slow_code ->
125 gencode fast `thenUs` \ fast_code ->
126 returnUs (StSegment TextSegment : itbl (StFunBegin slow_lbl :
127 slow_code (StFunEnd slow_lbl : StFunBegin fast_lbl :
128 fast_code [StFunEnd fast_lbl])))
130 slow_lbl = entryLabelFromCI cl_info
131 fast_lbl = fastLabelFromCI cl_info
133 gentopcode stmt@(CSRT lbl closures)
134 = returnUs [ StSegment TextSegment
136 , StData DataPtrRep (map StCLbl closures)
139 gentopcode stmt@(CBitmap lbl mask)
140 = returnUs [ StSegment TextSegment
142 , StData WordRep (StInt (toInteger (length mask)) :
143 map (StInt . toInteger . intBS) mask)
146 gentopcode stmt@(CClosureTbl tycon)
147 = returnUs [ StSegment TextSegment
148 , StLabel (mkClosureTblLabel tycon)
149 , StData DataPtrRep (map (StCLbl . mkStaticClosureLabel . getName)
150 (tyConDataCons tycon) )
154 = gencode absC `thenUs` \ code ->
155 returnUs (StSegment TextSegment : code [])
163 -> UniqSM StixTreeList
165 genCodeVecTbl (CRetVector lbl amodes srt liveness)
166 = genBitmapInfoTable liveness srt closure_type True `thenUs` \itbl ->
167 returnUs (\xs -> vectbl : itbl xs)
169 vectbl = StData PtrRep (reverse (map a2stix amodes))
170 closure_type = case liveness of
171 LvSmall _ -> rET_VEC_SMALL
172 LvLarge _ -> rET_VEC_BIG
180 -> UniqSM StixTreeList
182 genCodeStaticClosure (CStaticClosure _ cl_info cost_centre amodes)
183 = returnUs (\xs -> table ++ xs)
185 table = StData PtrRep [StCLbl (infoTableLabelFromCI cl_info)] :
186 map (\amode -> StData (getAmodeRep amode) [a2stix amode]) amodes ++
187 [StData PtrRep (padding_wds ++ static_link)]
189 -- always at least one padding word: this is the static link field
190 -- for the garbage collector.
191 padding_wds = if closureUpdReqd cl_info then
192 take (max 0 (mIN_UPD_SIZE - length amodes)) zeros
196 static_link | staticClosureNeedsLink cl_info = [StInt 0]
199 zeros = StInt 0 : zeros
202 -- Watch out for VoidKinds...cf. PprAbsC
204 | getAmodeRep item == VoidRep = StInt 0
205 | otherwise = a2stix item
210 Now the individual AbstractC statements.
216 -> UniqSM StixTreeList
220 @AbsCNop@s just disappear.
224 gencode AbsCNop = returnUs id
228 Split markers are a NOP in this land.
232 gencode CSplitMarker = returnUs id
236 AbstractC instruction sequences are handled individually, and the
237 resulting StixTreeLists are joined together.
241 gencode (AbsCStmts c1 c2)
242 = gencode c1 `thenUs` \ b1 ->
243 gencode c2 `thenUs` \ b2 ->
248 Initialising closure headers in the heap...a fairly complex ordeal if
249 done properly. For now, we just set the info pointer, but we should
250 really take a peek at the flags to determine whether or not there are
251 other things to be done (setting cost centres, age headers, global
256 gencode (CInitHdr cl_info reg_rel _)
259 lbl = infoTableLabelFromCI cl_info
261 returnUs (\xs -> StAssign PtrRep (StInd PtrRep lhs) (StCLbl lbl) : xs)
269 gencode (CCheck macro args assts)
270 = gencode assts `thenUs` \assts_stix ->
271 checkCode macro args assts_stix
275 Assignment, the curse of von Neumann, is the center of the code we
276 produce. In most cases, the type of the assignment is determined
277 by the type of the destination. However, when the destination can
278 have mixed types, the type of the assignment is ``StgWord'' (we use
279 PtrRep for lack of anything better). Think: do we also want a cast
280 of the source? Be careful about floats/doubles.
284 gencode (CAssign lhs rhs)
285 | getAmodeRep lhs == VoidRep = returnUs id
287 = let pk = getAmodeRep lhs
288 pk' = if mixedTypeLocn lhs && not (isFloatingRep pk) then IntRep else pk
292 returnUs (\xs -> StAssign pk' lhs' rhs' : xs)
296 Unconditional jumps, including the special ``enter closure'' operation.
297 Note that the new entry convention requires that we load the InfoPtr (R2)
298 with the address of the info table before jumping to the entry code for Node.
300 For a vectored return, we must subtract the size of the info table to
301 get at the return vector. This depends on the size of the info table,
302 which varies depending on whether we're profiling etc.
307 = returnUs (\xs -> StJump (a2stix dest) : xs)
309 gencode (CFallThrough (CLbl lbl _))
310 = returnUs (\xs -> StFallThrough lbl : xs)
312 gencode (CReturn dest DirectReturn)
313 = returnUs (\xs -> StJump (a2stix dest) : xs)
315 gencode (CReturn table (StaticVectoredReturn n))
316 = returnUs (\xs -> StJump dest : xs)
318 dest = StInd PtrRep (StIndex PtrRep (a2stix table)
319 (StInt (toInteger (-n-fixedItblSize-1))))
321 gencode (CReturn table (DynamicVectoredReturn am))
322 = returnUs (\xs -> StJump dest : xs)
324 dest = StInd PtrRep (StIndex PtrRep (a2stix table) dyn_off)
325 dyn_off = StPrim IntSubOp [StPrim IntNegOp [a2stix am],
326 StInt (toInteger (fixedItblSize+1))]
330 Now the PrimOps, some of which may need caller-saves register wrappers.
334 gencode (COpStmt results op args vols)
335 -- ToDo (ADR?): use that liveness mask
336 | primOpNeedsWrapper op
338 saves = volsaves vols
339 restores = volrestores vols
341 p2stix (nonVoid results) op (nonVoid args)
343 returnUs (\xs -> saves ++ code (restores ++ xs))
345 | otherwise = p2stix (nonVoid results) op (nonVoid args)
347 nonVoid = filter ((/= VoidRep) . getAmodeRep)
351 Now the dreaded conditional jump.
353 Now the if statement. Almost *all* flow of control are of this form.
355 if (am==lit) { absC } else { absCdef }
369 gencode (CSwitch discrim alts deflt)
373 [(tag,alt_code)] -> case maybe_empty_deflt of
374 Nothing -> gencode alt_code
375 Just dc -> mkIfThenElse discrim tag alt_code dc
377 [(tag1@(MachInt i1 _), alt_code1),
378 (tag2@(MachInt i2 _), alt_code2)]
379 | deflt_is_empty && i1 == 0 && i2 == 1
380 -> mkIfThenElse discrim tag1 alt_code1 alt_code2
381 | deflt_is_empty && i1 == 1 && i2 == 0
382 -> mkIfThenElse discrim tag2 alt_code2 alt_code1
384 -- If the @discrim@ is simple, then this unfolding is safe.
385 other | simple_discrim -> mkSimpleSwitches discrim alts deflt
387 -- Otherwise, we need to do a bit of work.
388 other -> getUniqueUs `thenUs` \ u ->
390 (CAssign (CTemp u pk) discrim)
391 (CSwitch (CTemp u pk) alts deflt))
394 maybe_empty_deflt = nonemptyAbsC deflt
395 deflt_is_empty = case maybe_empty_deflt of
399 pk = getAmodeRep discrim
401 simple_discrim = case discrim of
409 Finally, all of the disgusting AbstractC macros.
413 gencode (CMacroStmt macro args) = macro_code macro args
415 gencode (CCallProfCtrMacro macro _)
416 = returnUs (\xs -> StComment macro : xs)
418 gencode (CCallProfCCMacro macro _)
419 = returnUs (\xs -> StComment macro : xs)
422 = pprPanic "AbsCStixGen.gencode" (dumpRealC other)
425 Here, we generate a jump table if there are more than four (integer)
426 alternatives and the jump table occupancy is greater than 50%.
427 Otherwise, we generate a binary comparison tree. (Perhaps this could
432 intTag :: Literal -> Integer
433 intTag (MachChar c) = toInteger (ord c)
434 intTag (MachInt i _) = i
435 intTag _ = panic "intTag"
437 fltTag :: Literal -> Rational
439 fltTag (MachFloat f) = f
440 fltTag (MachDouble d) = d
441 fltTag _ = panic "fltTag"
445 :: CAddrMode -> [(Literal,AbstractC)] -> AbstractC
446 -> UniqSM StixTreeList
448 mkSimpleSwitches am alts absC
449 = getUniqLabelNCG `thenUs` \ udlbl ->
450 getUniqLabelNCG `thenUs` \ ujlbl ->
452 joinedAlts = map (\ (tag,code) -> (tag, mkJoin code ujlbl)) alts
453 sortedAlts = naturalMergeSortLe leAlt joinedAlts
454 -- naturalMergeSortLe, because we often get sorted alts to begin with
456 lowTag = intTag (fst (head sortedAlts))
457 highTag = intTag (fst (last sortedAlts))
459 -- lowest and highest possible values the discriminant could take
460 lowest = if floating then targetMinDouble else targetMinInt
461 highest = if floating then targetMaxDouble else targetMaxInt
464 if not floating && choices > 4 && highTag - lowTag < toInteger (2 * choices) then
465 mkJumpTable am' sortedAlts lowTag highTag udlbl
467 mkBinaryTree am' floating sortedAlts choices lowest highest udlbl
469 `thenUs` \ alt_code ->
470 gencode absC `thenUs` \ dflt_code ->
472 returnUs (\xs -> alt_code (StLabel udlbl : dflt_code (StLabel ujlbl : xs)))
475 floating = isFloatingRep (getAmodeRep am)
476 choices = length alts
478 (x@(MachChar _),_) `leAlt` (y,_) = intTag x <= intTag y
479 (x@(MachInt _ _),_) `leAlt` (y,_) = intTag x <= intTag y
480 (x,_) `leAlt` (y,_) = fltTag x <= fltTag y
484 We use jump tables when doing an integer switch on a relatively dense
485 list of alternatives. We expect to be given a list of alternatives,
486 sorted by tag, and a range of values for which we are to generate a
487 table. Of course, the tags of the alternatives should lie within the
488 indicated range. The alternatives need not cover the range; a default
489 target is provided for the missing alternatives.
491 If a join is necessary after the switch, the alternatives should
492 already finish with a jump to the join point.
497 :: StixTree -- discriminant
498 -> [(Literal, AbstractC)] -- alternatives
499 -> Integer -- low tag
500 -> Integer -- high tag
501 -> CLabel -- default label
502 -> UniqSM StixTreeList
505 mkJumpTable am alts lowTag highTag dflt
506 = getUniqLabelNCG `thenUs` \ utlbl ->
507 mapUs genLabel alts `thenUs` \ branches ->
508 let cjmpLo = StCondJump dflt (StPrim IntLtOp [am, StInt (toInteger lowTag)])
509 cjmpHi = StCondJump dflt (StPrim IntGtOp [am, StInt (toInteger highTag)])
511 offset = StPrim IntSubOp [am, StInt lowTag]
513 jump = StJump (StInd PtrRep (StIndex PtrRep (StCLbl utlbl) offset))
515 table = StData PtrRep (mkTable branches [lowTag..highTag] [])
517 mapUs mkBranch branches `thenUs` \ alts ->
519 returnUs (\xs -> cjmpLo : cjmpHi : jump :
520 StSegment DataSegment : tlbl : table :
521 StSegment TextSegment : foldr1 (.) alts xs)
524 genLabel x = getUniqLabelNCG `thenUs` \ lbl -> returnUs (lbl, x)
526 mkBranch (lbl,(_,alt)) =
527 gencode alt `thenUs` \ alt_code ->
528 returnUs (\xs -> StLabel lbl : alt_code xs)
530 mkTable _ [] tbl = reverse tbl
531 mkTable [] (x:xs) tbl = mkTable [] xs (StCLbl dflt : tbl)
532 mkTable alts@((lbl,(tag,_)):rest) (x:xs) tbl
533 | intTag tag == x = mkTable rest xs (StCLbl lbl : tbl)
534 | otherwise = mkTable alts xs (StCLbl dflt : tbl)
538 We generate binary comparison trees when a jump table is inappropriate.
539 We expect to be given a list of alternatives, sorted by tag, and for
540 convenience, the length of the alternative list. We recursively break
541 the list in half and do a comparison on the first tag of the second half
542 of the list. (Odd lists are broken so that the second half of the list
543 is longer.) We can handle either integer or floating kind alternatives,
544 so long as they are not mixed. (We assume that the type of the discriminant
545 determines the type of the alternatives.)
547 As with the jump table approach, if a join is necessary after the switch, the
548 alternatives should already finish with a jump to the join point.
553 :: StixTree -- discriminant
554 -> Bool -- floating point?
555 -> [(Literal, AbstractC)] -- alternatives
556 -> Int -- number of choices
557 -> Literal -- low tag
558 -> Literal -- high tag
559 -> CLabel -- default code label
560 -> UniqSM StixTreeList
563 mkBinaryTree am floating [(tag,alt)] _ lowTag highTag udlbl
564 | rangeOfOne = gencode alt
566 = let tag' = a2stix (CLit tag)
567 cmpOp = if floating then DoubleNeOp else IntNeOp
568 test = StPrim cmpOp [am, tag']
569 cjmp = StCondJump udlbl test
571 gencode alt `thenUs` \ alt_code ->
572 returnUs (\xs -> cjmp : alt_code xs)
575 rangeOfOne = not floating && intTag lowTag + 1 >= intTag highTag
576 -- When there is only one possible tag left in range, we skip the comparison
578 mkBinaryTree am floating alts choices lowTag highTag udlbl
579 = getUniqLabelNCG `thenUs` \ uhlbl ->
580 let tag' = a2stix (CLit splitTag)
581 cmpOp = if floating then DoubleGeOp else IntGeOp
582 test = StPrim cmpOp [am, tag']
583 cjmp = StCondJump uhlbl test
585 mkBinaryTree am floating alts_lo half lowTag splitTag udlbl
586 `thenUs` \ lo_code ->
587 mkBinaryTree am floating alts_hi (choices - half) splitTag highTag udlbl
588 `thenUs` \ hi_code ->
590 returnUs (\xs -> cjmp : lo_code (StLabel uhlbl : hi_code xs))
593 half = choices `div` 2
594 (alts_lo, alts_hi) = splitAt half alts
595 splitTag = fst (head alts_hi)
602 :: CAddrMode -- discriminant
604 -> AbstractC -- if-part
605 -> AbstractC -- else-part
606 -> UniqSM StixTreeList
609 mkIfThenElse discrim tag alt deflt
610 = getUniqLabelNCG `thenUs` \ ujlbl ->
611 getUniqLabelNCG `thenUs` \ utlbl ->
612 let discrim' = a2stix discrim
613 tag' = a2stix (CLit tag)
614 cmpOp = if (isFloatingRep (getAmodeRep discrim)) then DoubleNeOp else IntNeOp
615 test = StPrim cmpOp [discrim', tag']
616 cjmp = StCondJump utlbl test
620 gencode (mkJoin alt ujlbl) `thenUs` \ alt_code ->
621 gencode deflt `thenUs` \ dflt_code ->
622 returnUs (\xs -> cjmp : alt_code (dest : dflt_code (join : xs)))
624 mkJoin :: AbstractC -> CLabel -> AbstractC
627 | mightFallThrough code = mkAbsCStmts code (CJump (CLbl lbl PtrRep))
631 %---------------------------------------------------------------------------
633 This answers the question: Can the code fall through to the next
634 line(s) of code? This errs towards saying True if it can't choose,
635 because it is used for eliminating needless jumps. In other words, if
636 you might possibly {\em not} jump, then say yes to falling through.
639 mightFallThrough :: AbstractC -> Bool
641 mightFallThrough absC = ft absC True
643 ft AbsCNop if_empty = if_empty
645 ft (CJump _) if_empty = False
646 ft (CReturn _ _) if_empty = False
647 ft (CSwitch _ alts deflt) if_empty
648 = ft deflt if_empty ||
649 or [ft alt if_empty | (_,alt) <- alts]
651 ft (AbsCStmts c1 c2) if_empty = ft c2 (ft c1 if_empty)
652 ft _ if_empty = if_empty
654 {- Old algorithm, which called nonemptyAbsC for every subexpression! =========
655 fallThroughAbsC (AbsCStmts c1 c2)
656 = case nonemptyAbsC c2 of
657 Nothing -> fallThroughAbsC c1
658 Just x -> fallThroughAbsC x
659 fallThroughAbsC (CJump _) = False
660 fallThroughAbsC (CReturn _ _) = False
661 fallThroughAbsC (CSwitch _ choices deflt)
662 = (not (isEmptyAbsC deflt) && fallThroughAbsC deflt)
663 || or (map (fallThroughAbsC . snd) choices)
664 fallThroughAbsC other = True
666 isEmptyAbsC :: AbstractC -> Bool
667 isEmptyAbsC = not . maybeToBool . nonemptyAbsC
668 ================= End of old, quadratic, algorithm -}