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, mkClosureLabel,
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(..) )
50 For each independent chunk of AbstractC code, we generate a list of
51 @StixTree@s, where each tree corresponds to a single Stix instruction.
52 We leave the chunks separated so that register allocation can be
53 performed locally within the chunk.
56 genCodeAbstractC :: AbstractC -> UniqSM [[StixTree]]
59 = mapUs gentopcode (mkAbsCStmtList absC) `thenUs` \ trees ->
60 returnUs ([StComment SLIT("Native Code")] : trees)
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 ->
87 returnUs (StSegment DataSegment : StLabel lbl : code [])
89 gentopcode stmt@(CRetVector lbl _ _ _)
90 = genCodeVecTbl stmt `thenUs` \ code ->
91 returnUs (StSegment TextSegment : code [StLabel lbl])
93 gentopcode stmt@(CRetDirect uniq absC srt liveness)
94 = gencode absC `thenUs` \ code ->
95 genBitmapInfoTable liveness srt closure_type False `thenUs` \ itbl ->
96 returnUs (StSegment TextSegment :
97 itbl (StLabel lbl_info : StLabel lbl_ret : code []))
99 lbl_info = mkReturnInfoLabel uniq
100 lbl_ret = mkReturnPtLabel uniq
101 closure_type = case liveness of
102 LvSmall _ -> rET_SMALL
105 gentopcode stmt@(CClosureInfoAndCode cl_info slow Nothing _)
108 = genCodeInfoTable stmt `thenUs` \ itbl ->
109 returnUs (StSegment TextSegment : itbl [])
112 = genCodeInfoTable stmt `thenUs` \ itbl ->
113 gencode slow `thenUs` \ slow_code ->
114 returnUs (StSegment TextSegment : itbl (StFunBegin slow_lbl :
115 slow_code [StFunEnd slow_lbl]))
117 slow_is_empty = not (maybeToBool (nonemptyAbsC slow))
118 slow_lbl = entryLabelFromCI cl_info
120 gentopcode stmt@(CClosureInfoAndCode cl_info slow (Just fast) _) =
121 -- ToDo: what if this is empty? ------------------------^^^^
122 genCodeInfoTable stmt `thenUs` \ itbl ->
123 gencode slow `thenUs` \ slow_code ->
124 gencode fast `thenUs` \ fast_code ->
125 returnUs (StSegment TextSegment : itbl (StFunBegin slow_lbl :
126 slow_code (StFunEnd slow_lbl : StFunBegin fast_lbl :
127 fast_code [StFunEnd fast_lbl])))
129 slow_lbl = entryLabelFromCI cl_info
130 fast_lbl = fastLabelFromCI cl_info
132 gentopcode stmt@(CSRT lbl closures)
133 = returnUs [ StSegment TextSegment
135 , StData DataPtrRep (map StCLbl closures)
138 gentopcode stmt@(CBitmap lbl mask)
139 = returnUs [ StSegment TextSegment
141 , StData WordRep (StInt (toInteger (length mask)) :
142 map (StInt . toInteger . intBS) mask)
145 gentopcode stmt@(CClosureTbl tycon)
146 = returnUs [ StSegment TextSegment
147 , StLabel (mkClosureTblLabel tycon)
148 , StData DataPtrRep (map (StCLbl . mkClosureLabel . getName . dataConWrapId)
149 (tyConDataCons tycon) )
152 gentopcode stmt@(CModuleInitBlock lbl absC)
153 = gencode absC `thenUs` \ code ->
154 getUniqLabelNCG `thenUs` \ tmp_lbl ->
155 returnUs ( StSegment DataSegment
156 : StLabel moduleRegdLabel
157 : StData IntRep [StInt 0]
158 : StSegment TextSegment
160 : StCondJump tmp_lbl (StPrim IntNeOp
161 [StInd IntRep (StCLbl moduleRegdLabel),
163 : StAssign IntRep (StInd IntRep (StCLbl moduleRegdLabel)) (StInt 1)
166 , StAssign PtrRep stgSp (StPrim IntSubOp [stgSp, StInt 4])
167 , StJump (StInd WordRep stgSp)
171 = gencode absC `thenUs` \ code ->
172 returnUs (StSegment TextSegment : code [])
179 -> UniqSM StixTreeList
181 genCodeVecTbl (CRetVector lbl amodes srt liveness)
182 = genBitmapInfoTable liveness srt closure_type True `thenUs` \itbl ->
183 returnUs (\xs -> vectbl : itbl xs)
185 vectbl = StData PtrRep (reverse (map a2stix amodes))
186 closure_type = case liveness of
187 LvSmall _ -> rET_VEC_SMALL
188 LvLarge _ -> rET_VEC_BIG
196 -> UniqSM StixTreeList
198 genCodeStaticClosure (CStaticClosure _ cl_info cost_centre amodes)
199 = returnUs (\xs -> table ++ xs)
201 table = StData PtrRep [StCLbl (infoTableLabelFromCI cl_info)] :
202 map (\amode -> StData (getAmodeRep amode) [a2stix amode]) amodes ++
203 [StData PtrRep (padding_wds ++ static_link)]
205 -- always at least one padding word: this is the static link field
206 -- for the garbage collector.
207 padding_wds = if closureUpdReqd cl_info then
208 take (max 0 (mIN_UPD_SIZE - length amodes)) zeros
212 static_link | staticClosureNeedsLink cl_info = [StInt 0]
215 zeros = StInt 0 : zeros
218 -- Watch out for VoidKinds...cf. PprAbsC
220 | getAmodeRep item == VoidRep = StInt 0
221 | otherwise = a2stix item
226 Now the individual AbstractC statements.
232 -> UniqSM StixTreeList
236 @AbsCNop@s just disappear.
240 gencode AbsCNop = returnUs id
244 Split markers are a NOP in this land.
248 gencode CSplitMarker = returnUs id
252 AbstractC instruction sequences are handled individually, and the
253 resulting StixTreeLists are joined together.
257 gencode (AbsCStmts c1 c2)
258 = gencode c1 `thenUs` \ b1 ->
259 gencode c2 `thenUs` \ b2 ->
264 Initialising closure headers in the heap...a fairly complex ordeal if
265 done properly. For now, we just set the info pointer, but we should
266 really take a peek at the flags to determine whether or not there are
267 other things to be done (setting cost centres, age headers, global
272 gencode (CInitHdr cl_info reg_rel _)
275 lbl = infoTableLabelFromCI cl_info
277 returnUs (\xs -> StAssign PtrRep (StInd PtrRep lhs) (StCLbl lbl) : xs)
285 gencode (CCheck macro args assts)
286 = gencode assts `thenUs` \assts_stix ->
287 checkCode macro args assts_stix
291 Assignment, the curse of von Neumann, is the center of the code we
292 produce. In most cases, the type of the assignment is determined
293 by the type of the destination. However, when the destination can
294 have mixed types, the type of the assignment is ``StgWord'' (we use
295 PtrRep for lack of anything better). Think: do we also want a cast
296 of the source? Be careful about floats/doubles.
300 gencode (CAssign lhs rhs)
301 | getAmodeRep lhs == VoidRep = returnUs id
303 = let pk = getAmodeRep lhs
304 pk' = if mixedTypeLocn lhs && not (isFloatingRep pk) then IntRep else pk
308 returnUs (\xs -> StAssign pk' lhs' rhs' : xs)
312 Unconditional jumps, including the special ``enter closure'' operation.
313 Note that the new entry convention requires that we load the InfoPtr (R2)
314 with the address of the info table before jumping to the entry code for Node.
316 For a vectored return, we must subtract the size of the info table to
317 get at the return vector. This depends on the size of the info table,
318 which varies depending on whether we're profiling etc.
323 = returnUs (\xs -> StJump (a2stix dest) : xs)
325 gencode (CFallThrough (CLbl lbl _))
326 = returnUs (\xs -> StFallThrough lbl : xs)
328 gencode (CReturn dest DirectReturn)
329 = returnUs (\xs -> StJump (a2stix dest) : xs)
331 gencode (CReturn table (StaticVectoredReturn n))
332 = returnUs (\xs -> StJump dest : xs)
334 dest = StInd PtrRep (StIndex PtrRep (a2stix table)
335 (StInt (toInteger (-n-fixedItblSize-1))))
337 gencode (CReturn table (DynamicVectoredReturn am))
338 = returnUs (\xs -> StJump dest : xs)
340 dest = StInd PtrRep (StIndex PtrRep (a2stix table) dyn_off)
341 dyn_off = StPrim IntSubOp [StPrim IntNegOp [a2stix am],
342 StInt (toInteger (fixedItblSize+1))]
346 Now the PrimOps, some of which may need caller-saves register wrappers.
350 gencode (COpStmt results op args vols)
351 -- ToDo (ADR?): use that liveness mask
352 | primOpNeedsWrapper op
354 saves = volsaves vols
355 restores = volrestores vols
357 p2stix (nonVoid results) op (nonVoid args)
359 returnUs (\xs -> saves ++ code (restores ++ xs))
361 | otherwise = p2stix (nonVoid results) op (nonVoid args)
363 nonVoid = filter ((/= VoidRep) . getAmodeRep)
367 Now the dreaded conditional jump.
369 Now the if statement. Almost *all* flow of control are of this form.
371 if (am==lit) { absC } else { absCdef }
385 gencode (CSwitch discrim alts deflt)
389 [(tag,alt_code)] -> case maybe_empty_deflt of
390 Nothing -> gencode alt_code
391 Just dc -> mkIfThenElse discrim tag alt_code dc
393 [(tag1@(MachInt i1), alt_code1),
394 (tag2@(MachInt i2), alt_code2)]
395 | deflt_is_empty && i1 == 0 && i2 == 1
396 -> mkIfThenElse discrim tag1 alt_code1 alt_code2
397 | deflt_is_empty && i1 == 1 && i2 == 0
398 -> mkIfThenElse discrim tag2 alt_code2 alt_code1
400 -- If the @discrim@ is simple, then this unfolding is safe.
401 other | simple_discrim -> mkSimpleSwitches discrim alts deflt
403 -- Otherwise, we need to do a bit of work.
404 other -> getUniqueUs `thenUs` \ u ->
406 (CAssign (CTemp u pk) discrim)
407 (CSwitch (CTemp u pk) alts deflt))
410 maybe_empty_deflt = nonemptyAbsC deflt
411 deflt_is_empty = case maybe_empty_deflt of
415 pk = getAmodeRep discrim
417 simple_discrim = case discrim of
425 Finally, all of the disgusting AbstractC macros.
429 gencode (CMacroStmt macro args) = macro_code macro args
431 gencode (CCallProfCtrMacro macro _)
432 = returnUs (\xs -> StComment macro : xs)
434 gencode (CCallProfCCMacro macro _)
435 = returnUs (\xs -> StComment macro : xs)
438 = pprPanic "AbsCStixGen.gencode" (dumpRealC other)
441 Here, we generate a jump table if there are more than four (integer)
442 alternatives and the jump table occupancy is greater than 50%.
443 Otherwise, we generate a binary comparison tree. (Perhaps this could
448 intTag :: Literal -> Integer
449 intTag (MachChar c) = toInteger (ord c)
450 intTag (MachInt i) = i
451 intTag (MachWord w) = intTag (word2IntLit (MachWord w))
452 intTag _ = panic "intTag"
454 fltTag :: Literal -> Rational
456 fltTag (MachFloat f) = f
457 fltTag (MachDouble d) = d
458 fltTag x = pprPanic "fltTag" (ppr x)
462 :: CAddrMode -> [(Literal,AbstractC)] -> AbstractC
463 -> UniqSM StixTreeList
465 mkSimpleSwitches am alts absC
466 = getUniqLabelNCG `thenUs` \ udlbl ->
467 getUniqLabelNCG `thenUs` \ ujlbl ->
469 joinedAlts = map (\ (tag,code) -> (tag, mkJoin code ujlbl)) alts
470 sortedAlts = naturalMergeSortLe leAlt joinedAlts
471 -- naturalMergeSortLe, because we often get sorted alts to begin with
473 lowTag = intTag (fst (head sortedAlts))
474 highTag = intTag (fst (last sortedAlts))
476 -- lowest and highest possible values the discriminant could take
477 lowest = if floating then targetMinDouble else targetMinInt
478 highest = if floating then targetMaxDouble else targetMaxInt
481 if not floating && choices > 4 && highTag - lowTag < toInteger (2 * choices) then
482 mkJumpTable am' sortedAlts lowTag highTag udlbl
484 mkBinaryTree am' floating sortedAlts choices lowest highest udlbl
486 `thenUs` \ alt_code ->
487 gencode absC `thenUs` \ dflt_code ->
489 returnUs (\xs -> alt_code (StLabel udlbl : dflt_code (StLabel ujlbl : xs)))
492 floating = isFloatingRep (getAmodeRep am)
493 choices = length alts
495 (x@(MachChar _),_) `leAlt` (y,_) = intTag x <= intTag y
496 (x@(MachInt _), _) `leAlt` (y,_) = intTag x <= intTag y
497 (x@(MachWord _), _) `leAlt` (y,_) = intTag x <= intTag y
498 (x,_) `leAlt` (y,_) = fltTag x <= fltTag y
502 We use jump tables when doing an integer switch on a relatively dense
503 list of alternatives. We expect to be given a list of alternatives,
504 sorted by tag, and a range of values for which we are to generate a
505 table. Of course, the tags of the alternatives should lie within the
506 indicated range. The alternatives need not cover the range; a default
507 target is provided for the missing alternatives.
509 If a join is necessary after the switch, the alternatives should
510 already finish with a jump to the join point.
515 :: StixTree -- discriminant
516 -> [(Literal, AbstractC)] -- alternatives
517 -> Integer -- low tag
518 -> Integer -- high tag
519 -> CLabel -- default label
520 -> UniqSM StixTreeList
523 mkJumpTable am alts lowTag highTag dflt
524 = getUniqLabelNCG `thenUs` \ utlbl ->
525 mapUs genLabel alts `thenUs` \ branches ->
526 let cjmpLo = StCondJump dflt (StPrim IntLtOp [am, StInt (toInteger lowTag)])
527 cjmpHi = StCondJump dflt (StPrim IntGtOp [am, StInt (toInteger highTag)])
529 offset = StPrim IntSubOp [am, StInt lowTag]
531 jump = StJump (StInd PtrRep (StIndex PtrRep (StCLbl utlbl) offset))
533 table = StData PtrRep (mkTable branches [lowTag..highTag] [])
535 mapUs mkBranch branches `thenUs` \ alts ->
537 returnUs (\xs -> cjmpLo : cjmpHi : jump :
538 StSegment DataSegment : tlbl : table :
539 StSegment TextSegment : foldr1 (.) alts xs)
542 genLabel x = getUniqLabelNCG `thenUs` \ lbl -> returnUs (lbl, x)
544 mkBranch (lbl,(_,alt)) =
545 gencode alt `thenUs` \ alt_code ->
546 returnUs (\xs -> StLabel lbl : alt_code xs)
548 mkTable _ [] tbl = reverse tbl
549 mkTable [] (x:xs) tbl = mkTable [] xs (StCLbl dflt : tbl)
550 mkTable alts@((lbl,(tag,_)):rest) (x:xs) tbl
551 | intTag tag == x = mkTable rest xs (StCLbl lbl : tbl)
552 | otherwise = mkTable alts xs (StCLbl dflt : tbl)
556 We generate binary comparison trees when a jump table is inappropriate.
557 We expect to be given a list of alternatives, sorted by tag, and for
558 convenience, the length of the alternative list. We recursively break
559 the list in half and do a comparison on the first tag of the second half
560 of the list. (Odd lists are broken so that the second half of the list
561 is longer.) We can handle either integer or floating kind alternatives,
562 so long as they are not mixed. (We assume that the type of the discriminant
563 determines the type of the alternatives.)
565 As with the jump table approach, if a join is necessary after the switch, the
566 alternatives should already finish with a jump to the join point.
571 :: StixTree -- discriminant
572 -> Bool -- floating point?
573 -> [(Literal, AbstractC)] -- alternatives
574 -> Int -- number of choices
575 -> Literal -- low tag
576 -> Literal -- high tag
577 -> CLabel -- default code label
578 -> UniqSM StixTreeList
581 mkBinaryTree am floating [(tag,alt)] _ lowTag highTag udlbl
582 | rangeOfOne = gencode alt
584 = let tag' = a2stix (CLit tag)
585 cmpOp = if floating then DoubleNeOp else IntNeOp
586 test = StPrim cmpOp [am, tag']
587 cjmp = StCondJump udlbl test
589 gencode alt `thenUs` \ alt_code ->
590 returnUs (\xs -> cjmp : alt_code xs)
593 rangeOfOne = not floating && intTag lowTag + 1 >= intTag highTag
594 -- When there is only one possible tag left in range, we skip the comparison
596 mkBinaryTree am floating alts choices lowTag highTag udlbl
597 = getUniqLabelNCG `thenUs` \ uhlbl ->
598 let tag' = a2stix (CLit splitTag)
599 cmpOp = if floating then DoubleGeOp else IntGeOp
600 test = StPrim cmpOp [am, tag']
601 cjmp = StCondJump uhlbl test
603 mkBinaryTree am floating alts_lo half lowTag splitTag udlbl
604 `thenUs` \ lo_code ->
605 mkBinaryTree am floating alts_hi (choices - half) splitTag highTag udlbl
606 `thenUs` \ hi_code ->
608 returnUs (\xs -> cjmp : lo_code (StLabel uhlbl : hi_code xs))
611 half = choices `div` 2
612 (alts_lo, alts_hi) = splitAt half alts
613 splitTag = fst (head alts_hi)
620 :: CAddrMode -- discriminant
622 -> AbstractC -- if-part
623 -> AbstractC -- else-part
624 -> UniqSM StixTreeList
627 mkIfThenElse discrim tag alt deflt
628 = getUniqLabelNCG `thenUs` \ ujlbl ->
629 getUniqLabelNCG `thenUs` \ utlbl ->
630 let discrim' = a2stix discrim
631 tag' = a2stix (CLit tag)
632 cmpOp = if (isFloatingRep (getAmodeRep discrim)) then DoubleNeOp else IntNeOp
633 test = StPrim cmpOp [discrim', tag']
634 cjmp = StCondJump utlbl test
638 gencode (mkJoin alt ujlbl) `thenUs` \ alt_code ->
639 gencode deflt `thenUs` \ dflt_code ->
640 returnUs (\xs -> cjmp : alt_code (dest : dflt_code (join : xs)))
642 mkJoin :: AbstractC -> CLabel -> AbstractC
645 | mightFallThrough code = mkAbsCStmts code (CJump (CLbl lbl PtrRep))
649 %---------------------------------------------------------------------------
651 This answers the question: Can the code fall through to the next
652 line(s) of code? This errs towards saying True if it can't choose,
653 because it is used for eliminating needless jumps. In other words, if
654 you might possibly {\em not} jump, then say yes to falling through.
657 mightFallThrough :: AbstractC -> Bool
659 mightFallThrough absC = ft absC True
661 ft AbsCNop if_empty = if_empty
663 ft (CJump _) if_empty = False
664 ft (CReturn _ _) if_empty = False
665 ft (CSwitch _ alts deflt) if_empty
666 = ft deflt if_empty ||
667 or [ft alt if_empty | (_,alt) <- alts]
669 ft (AbsCStmts c1 c2) if_empty = ft c2 (ft c1 if_empty)
670 ft _ if_empty = if_empty
672 {- Old algorithm, which called nonemptyAbsC for every subexpression! =========
673 fallThroughAbsC (AbsCStmts c1 c2)
674 = case nonemptyAbsC c2 of
675 Nothing -> fallThroughAbsC c1
676 Just x -> fallThroughAbsC x
677 fallThroughAbsC (CJump _) = False
678 fallThroughAbsC (CReturn _ _) = False
679 fallThroughAbsC (CSwitch _ choices deflt)
680 = (not (isEmptyAbsC deflt) && fallThroughAbsC deflt)
681 || or (map (fallThroughAbsC . snd) choices)
682 fallThroughAbsC other = True
684 isEmptyAbsC :: AbstractC -> Bool
685 isEmptyAbsC = not . maybeToBool . nonemptyAbsC
686 ================= End of old, quadratic, algorithm -}