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
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, mkClosureLabel,
27 moduleRegdLabel, labelDynamic )
28 import ClosureInfo ( infoTableLabelFromCI, entryLabelFromCI,
29 fastLabelFromCI, closureUpdReqd,
30 staticClosureNeedsLink
32 import Literal ( Literal(..), word2IntLit )
33 import Maybes ( maybeToBool )
34 import PrimOp ( primOpNeedsWrapper, PrimOp(..) )
35 import PrimRep ( isFloatingRep, PrimRep(..) )
36 import StixInfo ( genCodeInfoTable, genBitmapInfoTable )
37 import StixMacro ( macroCode, checkCode )
38 import StixPrim ( primCode, amodeToStix, amodeToStix' )
39 import Outputable ( pprPanic, ppr )
40 import UniqSupply ( returnUs, thenUs, mapUs, getUniqueUs, UniqSM )
41 import Util ( naturalMergeSortLe )
42 import Panic ( panic )
43 import TyCon ( tyConDataCons )
44 import DataCon ( dataConWrapId )
45 import BitSet ( intBS )
46 import Name ( NamedThing(..) )
48 import CmdLineOpts ( opt_Static )
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]
63 a2stix' = amodeToStix'
64 volsaves = volatileSaves
65 volrestores = volatileRestores
67 macro_code = macroCode
68 -- real code follows... ---------
71 Here we handle top-level things, like @CCodeBlock@s and
81 gentopcode (CCodeBlock lbl absC)
82 = gencode absC `thenUs` \ code ->
83 returnUs (StSegment TextSegment : StFunBegin lbl : code [StFunEnd lbl])
85 gentopcode stmt@(CStaticClosure lbl _ _ _)
86 = genCodeStaticClosure stmt `thenUs` \ code ->
89 then StSegment DataSegment
90 : StLabel lbl : code []
91 else StSegment DataSegment
92 : StData PtrRep [StInt 0] -- DLLised world, need extra zero word
93 : StLabel lbl : code []
96 gentopcode stmt@(CRetVector lbl _ _ _)
97 = genCodeVecTbl stmt `thenUs` \ code ->
98 returnUs (StSegment TextSegment : code [StLabel lbl])
100 gentopcode stmt@(CRetDirect uniq absC srt liveness)
101 = gencode absC `thenUs` \ code ->
102 genBitmapInfoTable liveness srt closure_type False `thenUs` \ itbl ->
103 returnUs (StSegment TextSegment :
104 itbl (StLabel lbl_info : StLabel lbl_ret : code []))
106 lbl_info = mkReturnInfoLabel uniq
107 lbl_ret = mkReturnPtLabel uniq
108 closure_type = case liveness of
109 LvSmall _ -> rET_SMALL
112 gentopcode stmt@(CClosureInfoAndCode cl_info slow Nothing _)
115 = genCodeInfoTable stmt `thenUs` \ itbl ->
116 returnUs (StSegment TextSegment : itbl [])
119 = genCodeInfoTable stmt `thenUs` \ itbl ->
120 gencode slow `thenUs` \ slow_code ->
121 returnUs (StSegment TextSegment : itbl (StFunBegin slow_lbl :
122 slow_code [StFunEnd slow_lbl]))
124 slow_is_empty = not (maybeToBool (nonemptyAbsC slow))
125 slow_lbl = entryLabelFromCI cl_info
127 gentopcode stmt@(CClosureInfoAndCode cl_info slow (Just fast) _) =
128 -- ToDo: what if this is empty? ------------------------^^^^
129 genCodeInfoTable stmt `thenUs` \ itbl ->
130 gencode slow `thenUs` \ slow_code ->
131 gencode fast `thenUs` \ fast_code ->
132 returnUs (StSegment TextSegment : itbl (StFunBegin slow_lbl :
133 slow_code (StFunEnd slow_lbl : StFunBegin fast_lbl :
134 fast_code [StFunEnd fast_lbl])))
136 slow_lbl = entryLabelFromCI cl_info
137 fast_lbl = fastLabelFromCI cl_info
139 gentopcode stmt@(CSRT lbl closures)
140 = returnUs [ StSegment TextSegment
142 , StData DataPtrRep (map mk_StCLbl_for_SRT closures)
145 mk_StCLbl_for_SRT :: CLabel -> StixTree
146 mk_StCLbl_for_SRT label
148 = StIndex CharRep (StCLbl label) (StInt 1)
152 gentopcode stmt@(CBitmap lbl mask)
153 = returnUs [ StSegment TextSegment
155 , StData WordRep (StInt (toInteger (length mask)) :
156 map (StInt . toInteger . intBS) mask)
159 gentopcode stmt@(CClosureTbl tycon)
160 = returnUs [ StSegment TextSegment
161 , StLabel (mkClosureTblLabel tycon)
162 , StData DataPtrRep (map (StCLbl . mkClosureLabel . getName . dataConWrapId)
163 (tyConDataCons tycon) )
166 gentopcode stmt@(CModuleInitBlock lbl absC)
167 = gencode absC `thenUs` \ code ->
168 getUniqLabelNCG `thenUs` \ tmp_lbl ->
169 getUniqLabelNCG `thenUs` \ flag_lbl ->
170 returnUs ( StSegment DataSegment
172 : StData IntRep [StInt 0]
173 : StSegment TextSegment
175 : StCondJump tmp_lbl (StPrim IntNeOp
176 [StInd IntRep (StCLbl flag_lbl),
178 : StAssign IntRep (StInd IntRep (StCLbl flag_lbl)) (StInt 1)
181 , StAssign PtrRep stgSp
182 (StIndex PtrRep stgSp (StInt (-1)))
183 , StJump (StInd WordRep stgSp)
187 = gencode absC `thenUs` \ code ->
188 returnUs (StSegment TextSegment : code [])
195 -> UniqSM StixTreeList
197 genCodeVecTbl (CRetVector lbl amodes srt liveness)
198 = genBitmapInfoTable liveness srt closure_type True `thenUs` \itbl ->
199 returnUs (\xs -> vectbl : itbl xs)
201 vectbl = StData PtrRep (reverse (map a2stix amodes))
202 closure_type = case liveness of
203 LvSmall _ -> rET_VEC_SMALL
204 LvLarge _ -> rET_VEC_BIG
212 -> UniqSM StixTreeList
214 genCodeStaticClosure (CStaticClosure _ cl_info cost_centre amodes)
215 = returnUs (\xs -> table ++ xs)
217 table = StData PtrRep [StCLbl (infoTableLabelFromCI cl_info)] :
218 map (\amode -> StData (getAmodeRep amode) [a2stix amode]) amodes ++
219 [StData PtrRep (padding_wds ++ static_link)]
221 -- always at least one padding word: this is the static link field
222 -- for the garbage collector.
223 padding_wds = if closureUpdReqd cl_info then
224 take (max 0 (mIN_UPD_SIZE - length amodes)) zeros
228 static_link | staticClosureNeedsLink cl_info = [StInt 0]
231 zeros = StInt 0 : zeros
234 -- Watch out for VoidKinds...cf. PprAbsC
236 | getAmodeRep item == VoidRep = StInt 0
237 | otherwise = a2stix item
242 Now the individual AbstractC statements.
248 -> UniqSM StixTreeList
252 @AbsCNop@s just disappear.
256 gencode AbsCNop = returnUs id
260 Split markers are a NOP in this land.
264 gencode CSplitMarker = returnUs id
268 AbstractC instruction sequences are handled individually, and the
269 resulting StixTreeLists are joined together.
273 gencode (AbsCStmts c1 c2)
274 = gencode c1 `thenUs` \ b1 ->
275 gencode c2 `thenUs` \ b2 ->
280 Initialising closure headers in the heap...a fairly complex ordeal if
281 done properly. For now, we just set the info pointer, but we should
282 really take a peek at the flags to determine whether or not there are
283 other things to be done (setting cost centres, age headers, global
288 gencode (CInitHdr cl_info reg_rel _)
291 lbl = infoTableLabelFromCI cl_info
293 returnUs (\xs -> StAssign PtrRep (StInd PtrRep lhs) (StCLbl lbl) : xs)
301 gencode (CCheck macro args assts)
302 = gencode assts `thenUs` \assts_stix ->
303 checkCode macro args assts_stix
307 Assignment, the curse of von Neumann, is the center of the code we
308 produce. In most cases, the type of the assignment is determined
309 by the type of the destination. However, when the destination can
310 have mixed types, the type of the assignment is ``StgWord'' (we use
311 PtrRep for lack of anything better). Think: do we also want a cast
312 of the source? Be careful about floats/doubles.
316 gencode (CAssign lhs rhs)
317 | getAmodeRep lhs == VoidRep = returnUs id
319 = let pk = getAmodeRep lhs
320 pk' = if mixedTypeLocn lhs && not (isFloatingRep pk) then IntRep else pk
324 returnUs (\xs -> StAssign pk' lhs' rhs' : xs)
328 Unconditional jumps, including the special ``enter closure'' operation.
329 Note that the new entry convention requires that we load the InfoPtr (R2)
330 with the address of the info table before jumping to the entry code for Node.
332 For a vectored return, we must subtract the size of the info table to
333 get at the return vector. This depends on the size of the info table,
334 which varies depending on whether we're profiling etc.
339 = returnUs (\xs -> StJump (a2stix dest) : xs)
341 gencode (CFallThrough (CLbl lbl _))
342 = returnUs (\xs -> StFallThrough lbl : xs)
344 gencode (CReturn dest DirectReturn)
345 = returnUs (\xs -> StJump (a2stix dest) : xs)
347 gencode (CReturn table (StaticVectoredReturn n))
348 = returnUs (\xs -> StJump dest : xs)
350 dest = StInd PtrRep (StIndex PtrRep (a2stix table)
351 (StInt (toInteger (-n-fixedItblSize-1))))
353 gencode (CReturn table (DynamicVectoredReturn am))
354 = returnUs (\xs -> StJump dest : xs)
356 dest = StInd PtrRep (StIndex PtrRep (a2stix table) dyn_off)
357 dyn_off = StPrim IntSubOp [StPrim IntNegOp [a2stix am],
358 StInt (toInteger (fixedItblSize+1))]
362 Now the PrimOps, some of which may need caller-saves register wrappers.
366 gencode (COpStmt results op args vols)
367 -- ToDo (ADR?): use that liveness mask
368 | primOpNeedsWrapper op
370 saves = volsaves vols
371 restores = volrestores vols
373 p2stix (nonVoid results) op (nonVoid args)
375 returnUs (\xs -> saves ++ code (restores ++ xs))
377 | otherwise = p2stix (nonVoid results) op (nonVoid args)
379 nonVoid = filter ((/= VoidRep) . getAmodeRep)
383 Now the dreaded conditional jump.
385 Now the if statement. Almost *all* flow of control are of this form.
387 if (am==lit) { absC } else { absCdef }
401 gencode (CSwitch discrim alts deflt)
405 [(tag,alt_code)] -> case maybe_empty_deflt of
406 Nothing -> gencode alt_code
407 Just dc -> mkIfThenElse discrim tag alt_code dc
409 [(tag1@(MachInt i1), alt_code1),
410 (tag2@(MachInt i2), alt_code2)]
411 | deflt_is_empty && i1 == 0 && i2 == 1
412 -> mkIfThenElse discrim tag1 alt_code1 alt_code2
413 | deflt_is_empty && i1 == 1 && i2 == 0
414 -> mkIfThenElse discrim tag2 alt_code2 alt_code1
416 -- If the @discrim@ is simple, then this unfolding is safe.
417 other | simple_discrim -> mkSimpleSwitches discrim alts deflt
419 -- Otherwise, we need to do a bit of work.
420 other -> getUniqueUs `thenUs` \ u ->
422 (CAssign (CTemp u pk) discrim)
423 (CSwitch (CTemp u pk) alts deflt))
426 maybe_empty_deflt = nonemptyAbsC deflt
427 deflt_is_empty = case maybe_empty_deflt of
431 pk = getAmodeRep discrim
433 simple_discrim = case discrim of
441 Finally, all of the disgusting AbstractC macros.
445 gencode (CMacroStmt macro args) = macro_code macro args
447 gencode (CCallProfCtrMacro macro _)
448 = returnUs (\xs -> StComment macro : xs)
450 gencode (CCallProfCCMacro macro _)
451 = returnUs (\xs -> StComment macro : xs)
454 = pprPanic "AbsCStixGen.gencode" (dumpRealC other)
457 Here, we generate a jump table if there are more than four (integer)
458 alternatives and the jump table occupancy is greater than 50%.
459 Otherwise, we generate a binary comparison tree. (Perhaps this could
464 intTag :: Literal -> Integer
465 intTag (MachChar c) = toInteger (ord c)
466 intTag (MachInt i) = i
467 intTag (MachWord w) = intTag (word2IntLit (MachWord w))
468 intTag _ = panic "intTag"
470 fltTag :: Literal -> Rational
472 fltTag (MachFloat f) = f
473 fltTag (MachDouble d) = d
474 fltTag x = pprPanic "fltTag" (ppr x)
478 :: CAddrMode -> [(Literal,AbstractC)] -> AbstractC
479 -> UniqSM StixTreeList
481 mkSimpleSwitches am alts absC
482 = getUniqLabelNCG `thenUs` \ udlbl ->
483 getUniqLabelNCG `thenUs` \ ujlbl ->
485 joinedAlts = map (\ (tag,code) -> (tag, mkJoin code ujlbl)) alts
486 sortedAlts = naturalMergeSortLe leAlt joinedAlts
487 -- naturalMergeSortLe, because we often get sorted alts to begin with
489 lowTag = intTag (fst (head sortedAlts))
490 highTag = intTag (fst (last sortedAlts))
492 -- lowest and highest possible values the discriminant could take
493 lowest = if floating then targetMinDouble else targetMinInt
494 highest = if floating then targetMaxDouble else targetMaxInt
497 if not floating && choices > 4 && highTag - lowTag < toInteger (2 * choices) then
498 mkJumpTable am' sortedAlts lowTag highTag udlbl
500 mkBinaryTree am' floating sortedAlts choices lowest highest udlbl
502 `thenUs` \ alt_code ->
503 gencode absC `thenUs` \ dflt_code ->
505 returnUs (\xs -> alt_code (StLabel udlbl : dflt_code (StLabel ujlbl : xs)))
508 floating = isFloatingRep (getAmodeRep am)
509 choices = length alts
511 (x@(MachChar _),_) `leAlt` (y,_) = intTag x <= intTag y
512 (x@(MachInt _), _) `leAlt` (y,_) = intTag x <= intTag y
513 (x@(MachWord _), _) `leAlt` (y,_) = intTag x <= intTag y
514 (x,_) `leAlt` (y,_) = fltTag x <= fltTag y
518 We use jump tables when doing an integer switch on a relatively dense
519 list of alternatives. We expect to be given a list of alternatives,
520 sorted by tag, and a range of values for which we are to generate a
521 table. Of course, the tags of the alternatives should lie within the
522 indicated range. The alternatives need not cover the range; a default
523 target is provided for the missing alternatives.
525 If a join is necessary after the switch, the alternatives should
526 already finish with a jump to the join point.
531 :: StixTree -- discriminant
532 -> [(Literal, AbstractC)] -- alternatives
533 -> Integer -- low tag
534 -> Integer -- high tag
535 -> CLabel -- default label
536 -> UniqSM StixTreeList
539 mkJumpTable am alts lowTag highTag dflt
540 = getUniqLabelNCG `thenUs` \ utlbl ->
541 mapUs genLabel alts `thenUs` \ branches ->
542 let cjmpLo = StCondJump dflt (StPrim IntLtOp [am, StInt (toInteger lowTag)])
543 cjmpHi = StCondJump dflt (StPrim IntGtOp [am, StInt (toInteger highTag)])
545 offset = StPrim IntSubOp [am, StInt lowTag]
547 jump = StJump (StInd PtrRep (StIndex PtrRep (StCLbl utlbl) offset))
549 table = StData PtrRep (mkTable branches [lowTag..highTag] [])
551 mapUs mkBranch branches `thenUs` \ alts ->
553 returnUs (\xs -> cjmpLo : cjmpHi : jump :
554 StSegment DataSegment : tlbl : table :
555 StSegment TextSegment : foldr1 (.) alts xs)
558 genLabel x = getUniqLabelNCG `thenUs` \ lbl -> returnUs (lbl, x)
560 mkBranch (lbl,(_,alt)) =
561 gencode alt `thenUs` \ alt_code ->
562 returnUs (\xs -> StLabel lbl : alt_code xs)
564 mkTable _ [] tbl = reverse tbl
565 mkTable [] (x:xs) tbl = mkTable [] xs (StCLbl dflt : tbl)
566 mkTable alts@((lbl,(tag,_)):rest) (x:xs) tbl
567 | intTag tag == x = mkTable rest xs (StCLbl lbl : tbl)
568 | otherwise = mkTable alts xs (StCLbl dflt : tbl)
572 We generate binary comparison trees when a jump table is inappropriate.
573 We expect to be given a list of alternatives, sorted by tag, and for
574 convenience, the length of the alternative list. We recursively break
575 the list in half and do a comparison on the first tag of the second half
576 of the list. (Odd lists are broken so that the second half of the list
577 is longer.) We can handle either integer or floating kind alternatives,
578 so long as they are not mixed. (We assume that the type of the discriminant
579 determines the type of the alternatives.)
581 As with the jump table approach, if a join is necessary after the switch, the
582 alternatives should already finish with a jump to the join point.
587 :: StixTree -- discriminant
588 -> Bool -- floating point?
589 -> [(Literal, AbstractC)] -- alternatives
590 -> Int -- number of choices
591 -> Literal -- low tag
592 -> Literal -- high tag
593 -> CLabel -- default code label
594 -> UniqSM StixTreeList
597 mkBinaryTree am floating [(tag,alt)] _ lowTag highTag udlbl
598 | rangeOfOne = gencode alt
600 = let tag' = a2stix (CLit tag)
601 cmpOp = if floating then DoubleNeOp else IntNeOp
602 test = StPrim cmpOp [am, tag']
603 cjmp = StCondJump udlbl test
605 gencode alt `thenUs` \ alt_code ->
606 returnUs (\xs -> cjmp : alt_code xs)
609 rangeOfOne = not floating && intTag lowTag + 1 >= intTag highTag
610 -- When there is only one possible tag left in range, we skip the comparison
612 mkBinaryTree am floating alts choices lowTag highTag udlbl
613 = getUniqLabelNCG `thenUs` \ uhlbl ->
614 let tag' = a2stix (CLit splitTag)
615 cmpOp = if floating then DoubleGeOp else IntGeOp
616 test = StPrim cmpOp [am, tag']
617 cjmp = StCondJump uhlbl test
619 mkBinaryTree am floating alts_lo half lowTag splitTag udlbl
620 `thenUs` \ lo_code ->
621 mkBinaryTree am floating alts_hi (choices - half) splitTag highTag udlbl
622 `thenUs` \ hi_code ->
624 returnUs (\xs -> cjmp : lo_code (StLabel uhlbl : hi_code xs))
627 half = choices `div` 2
628 (alts_lo, alts_hi) = splitAt half alts
629 splitTag = fst (head alts_hi)
636 :: CAddrMode -- discriminant
638 -> AbstractC -- if-part
639 -> AbstractC -- else-part
640 -> UniqSM StixTreeList
643 mkIfThenElse discrim tag alt deflt
644 = getUniqLabelNCG `thenUs` \ ujlbl ->
645 getUniqLabelNCG `thenUs` \ utlbl ->
646 let discrim' = a2stix discrim
647 tag' = a2stix (CLit tag)
648 cmpOp = if (isFloatingRep (getAmodeRep discrim)) then DoubleNeOp else IntNeOp
649 test = StPrim cmpOp [discrim', tag']
650 cjmp = StCondJump utlbl test
654 gencode (mkJoin alt ujlbl) `thenUs` \ alt_code ->
655 gencode deflt `thenUs` \ dflt_code ->
656 returnUs (\xs -> cjmp : alt_code (dest : dflt_code (join : xs)))
658 mkJoin :: AbstractC -> CLabel -> AbstractC
661 | mightFallThrough code = mkAbsCStmts code (CJump (CLbl lbl PtrRep))
665 %---------------------------------------------------------------------------
667 This answers the question: Can the code fall through to the next
668 line(s) of code? This errs towards saying True if it can't choose,
669 because it is used for eliminating needless jumps. In other words, if
670 you might possibly {\em not} jump, then say yes to falling through.
673 mightFallThrough :: AbstractC -> Bool
675 mightFallThrough absC = ft absC True
677 ft AbsCNop if_empty = if_empty
679 ft (CJump _) if_empty = False
680 ft (CReturn _ _) if_empty = False
681 ft (CSwitch _ alts deflt) if_empty
682 = ft deflt if_empty ||
683 or [ft alt if_empty | (_,alt) <- alts]
685 ft (AbsCStmts c1 c2) if_empty = ft c2 (ft c1 if_empty)
686 ft _ if_empty = if_empty
688 {- Old algorithm, which called nonemptyAbsC for every subexpression! =========
689 fallThroughAbsC (AbsCStmts c1 c2)
690 = case nonemptyAbsC c2 of
691 Nothing -> fallThroughAbsC c1
692 Just x -> fallThroughAbsC x
693 fallThroughAbsC (CJump _) = False
694 fallThroughAbsC (CReturn _ _) = False
695 fallThroughAbsC (CSwitch _ choices deflt)
696 = (not (isEmptyAbsC deflt) && fallThroughAbsC deflt)
697 || or (map (fallThroughAbsC . snd) choices)
698 fallThroughAbsC other = True
700 isEmptyAbsC :: AbstractC -> Bool
701 isEmptyAbsC = not . maybeToBool . nonemptyAbsC
702 ================= End of old, quadratic, algorithm -}