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 SMRep ( fixedItblSize,
21 rET_VEC_SMALL, rET_VEC_BIG
23 import Constants ( mIN_UPD_SIZE )
24 import CLabel ( CLabel, mkReturnInfoLabel, mkReturnPtLabel )
25 import ClosureInfo ( infoTableLabelFromCI, entryLabelFromCI,
26 fastLabelFromCI, closureUpdReqd
28 import Const ( Literal(..) )
29 import Maybes ( maybeToBool )
30 import PrimOp ( primOpNeedsWrapper, PrimOp(..) )
31 import PrimRep ( isFloatingRep, PrimRep(..) )
32 import StixInfo ( genCodeInfoTable, genBitmapInfoTable )
33 import StixMacro ( macroCode, checkCode )
34 import StixPrim ( primCode, amodeToStix, amodeToStix' )
35 import UniqSupply ( returnUs, thenUs, mapUs, getUniqueUs, UniqSM )
36 import Util ( naturalMergeSortLe )
37 import Panic ( panic )
38 import BitSet ( intBS )
40 #ifdef REALLY_HASKELL_1_3
41 ord = fromEnum :: Char -> Int
45 For each independent chunk of AbstractC code, we generate a list of
46 @StixTree@s, where each tree corresponds to a single Stix instruction.
47 We leave the chunks separated so that register allocation can be
48 performed locally within the chunk.
51 genCodeAbstractC :: AbstractC -> UniqSM [[StixTree]]
54 = mapUs gentopcode (mkAbsCStmtList absC) `thenUs` \ trees ->
55 returnUs ([StComment SLIT("Native Code")] : trees)
58 a2stix' = amodeToStix'
59 volsaves = volatileSaves
60 volrestores = volatileRestores
62 macro_code = macroCode
63 -- real code follows... ---------
66 Here we handle top-level things, like @CCodeBlock@s and
76 gentopcode (CCodeBlock label absC)
77 = gencode absC `thenUs` \ code ->
78 returnUs (StSegment TextSegment : StFunBegin label : code [StFunEnd label])
80 gentopcode stmt@(CStaticClosure label _ _ _)
81 = genCodeStaticClosure stmt `thenUs` \ code ->
82 returnUs (StSegment DataSegment : StLabel label : code [])
84 gentopcode stmt@(CRetVector label _ _ _)
85 = genCodeVecTbl stmt `thenUs` \ code ->
86 returnUs (StSegment TextSegment : code [StLabel label])
88 gentopcode stmt@(CRetDirect uniq absC srt liveness)
89 = gencode absC `thenUs` \ code ->
90 genBitmapInfoTable liveness srt closure_type False `thenUs` \ itbl ->
91 returnUs (StSegment TextSegment :
92 itbl (StLabel lbl_info : StLabel lbl_ret : code []))
94 lbl_info = mkReturnInfoLabel uniq
95 lbl_ret = mkReturnPtLabel uniq
96 closure_type = case liveness of
97 LvSmall _ -> rET_SMALL
100 gentopcode stmt@(CClosureInfoAndCode cl_info slow Nothing _ _)
103 = genCodeInfoTable stmt `thenUs` \ itbl ->
104 returnUs (StSegment TextSegment : itbl [])
107 = genCodeInfoTable stmt `thenUs` \ itbl ->
108 gencode slow `thenUs` \ slow_code ->
109 returnUs (StSegment TextSegment : itbl (StFunBegin slow_lbl :
110 slow_code [StFunEnd slow_lbl]))
112 slow_is_empty = not (maybeToBool (nonemptyAbsC slow))
113 slow_lbl = entryLabelFromCI cl_info
115 gentopcode stmt@(CClosureInfoAndCode cl_info slow (Just fast) _ _) =
116 -- ToDo: what if this is empty? ------------------------^^^^
117 genCodeInfoTable stmt `thenUs` \ itbl ->
118 gencode slow `thenUs` \ slow_code ->
119 gencode fast `thenUs` \ fast_code ->
120 returnUs (StSegment TextSegment : itbl (StFunBegin slow_lbl :
121 slow_code (StFunEnd slow_lbl : StFunBegin fast_lbl :
122 fast_code [StFunEnd fast_lbl])))
124 slow_lbl = entryLabelFromCI cl_info
125 fast_lbl = fastLabelFromCI cl_info
127 gentopcode stmt@(CSRT lbl closures)
128 = returnUs [ StSegment TextSegment
130 , StData DataPtrRep (map StCLbl closures)
133 gentopcode stmt@(CBitmap lbl mask)
134 = returnUs [ StSegment TextSegment
136 , StData WordRep (StInt (toInteger (length mask)) :
137 map (StInt . toInteger . intBS) mask)
141 = gencode absC `thenUs` \ code ->
142 returnUs (StSegment TextSegment : code [])
150 -> UniqSM StixTreeList
152 genCodeVecTbl (CRetVector label amodes srt liveness)
153 = genBitmapInfoTable liveness srt closure_type True `thenUs` \itbl ->
154 returnUs (\xs -> vectbl : itbl xs)
156 vectbl = StData PtrRep (reverse (map a2stix amodes))
157 closure_type = case liveness of
158 LvSmall _ -> rET_VEC_SMALL
159 LvLarge _ -> rET_VEC_BIG
167 -> UniqSM StixTreeList
169 genCodeStaticClosure (CStaticClosure _ cl_info cost_centre amodes)
170 = returnUs (\xs -> table : xs)
172 table = StData PtrRep (StCLbl info_lbl : body)
173 info_lbl = infoTableLabelFromCI cl_info
175 -- always at least one padding word: this is the static link field
176 -- for the garbage collector.
177 body = if closureUpdReqd cl_info then
178 take (1 + max mIN_UPD_SIZE (length amodes')) (amodes' ++ zeros)
182 zeros = StInt 0 : zeros
184 amodes' = map amodeZeroVoid amodes
186 -- Watch out for VoidKinds...cf. PprAbsC
188 | getAmodeRep item == VoidRep = StInt 0
189 | otherwise = a2stix item
193 Now the individual AbstractC statements.
199 -> UniqSM StixTreeList
203 @AbsCNop@s just disappear.
207 gencode AbsCNop = returnUs id
211 Split markers are a NOP in this land.
215 gencode CSplitMarker = returnUs id
219 AbstractC instruction sequences are handled individually, and the
220 resulting StixTreeLists are joined together.
224 gencode (AbsCStmts c1 c2)
225 = gencode c1 `thenUs` \ b1 ->
226 gencode c2 `thenUs` \ b2 ->
231 Initialising closure headers in the heap...a fairly complex ordeal if
232 done properly. For now, we just set the info pointer, but we should
233 really take a peek at the flags to determine whether or not there are
234 other things to be done (setting cost centres, age headers, global
239 gencode (CInitHdr cl_info reg_rel _)
241 lhs = a2stix (CVal reg_rel PtrRep)
242 lbl = infoTableLabelFromCI cl_info
244 returnUs (\xs -> StAssign PtrRep lhs (StCLbl lbl) : xs)
252 gencode (CCheck macro args assts)
253 = gencode assts `thenUs` \assts_stix ->
254 checkCode macro args assts_stix
258 Assignment, the curse of von Neumann, is the center of the code we
259 produce. In most cases, the type of the assignment is determined
260 by the type of the destination. However, when the destination can
261 have mixed types, the type of the assignment is ``StgWord'' (we use
262 PtrRep for lack of anything better). Think: do we also want a cast
263 of the source? Be careful about floats/doubles.
267 gencode (CAssign lhs rhs)
268 | getAmodeRep lhs == VoidRep = returnUs id
270 = let pk = getAmodeRep lhs
271 pk' = if mixedTypeLocn lhs && not (isFloatingRep pk) then IntRep else pk
275 returnUs (\xs -> StAssign pk' lhs' rhs' : xs)
279 Unconditional jumps, including the special ``enter closure'' operation.
280 Note that the new entry convention requires that we load the InfoPtr (R2)
281 with the address of the info table before jumping to the entry code for Node.
283 For a vectored return, we must subtract the size of the info table to
284 get at the return vector. This depends on the size of the info table,
285 which varies depending on whether we're profiling etc.
290 = returnUs (\xs -> StJump (a2stix dest) : xs)
292 gencode (CFallThrough (CLbl lbl _))
293 = returnUs (\xs -> StFallThrough lbl : xs)
295 gencode (CReturn dest DirectReturn)
296 = returnUs (\xs -> StJump (a2stix dest) : xs)
298 gencode (CReturn table (StaticVectoredReturn n))
299 = returnUs (\xs -> StJump dest : xs)
301 dest = StInd PtrRep (StIndex PtrRep (a2stix table)
302 (StInt (toInteger (-n-fixedItblSize-1))))
304 gencode (CReturn table (DynamicVectoredReturn am))
305 = returnUs (\xs -> StJump dest : xs)
307 dest = StInd PtrRep (StIndex PtrRep (a2stix table) dyn_off)
308 dyn_off = StPrim IntSubOp [StPrim IntNegOp [a2stix am],
309 StInt (toInteger (fixedItblSize+1))]
313 Now the PrimOps, some of which may need caller-saves register wrappers.
317 gencode (COpStmt results op args vols)
318 -- ToDo (ADR?): use that liveness mask
319 | primOpNeedsWrapper op
321 saves = volsaves vols
322 restores = volrestores vols
324 p2stix (nonVoid results) op (nonVoid args)
326 returnUs (\xs -> saves ++ code (restores ++ xs))
328 | otherwise = p2stix (nonVoid results) op (nonVoid args)
330 nonVoid = filter ((/= VoidRep) . getAmodeRep)
334 Now the dreaded conditional jump.
336 Now the if statement. Almost *all* flow of control are of this form.
338 if (am==lit) { absC } else { absCdef }
352 gencode (CSwitch discrim alts deflt)
356 [(tag,alt_code)] -> case maybe_empty_deflt of
357 Nothing -> gencode alt_code
358 Just dc -> mkIfThenElse discrim tag alt_code dc
360 [(tag1@(MachInt i1 _), alt_code1),
361 (tag2@(MachInt i2 _), alt_code2)]
362 | deflt_is_empty && i1 == 0 && i2 == 1
363 -> mkIfThenElse discrim tag1 alt_code1 alt_code2
364 | deflt_is_empty && i1 == 1 && i2 == 0
365 -> mkIfThenElse discrim tag2 alt_code2 alt_code1
367 -- If the @discrim@ is simple, then this unfolding is safe.
368 other | simple_discrim -> mkSimpleSwitches discrim alts deflt
370 -- Otherwise, we need to do a bit of work.
371 other -> getUniqueUs `thenUs` \ u ->
373 (CAssign (CTemp u pk) discrim)
374 (CSwitch (CTemp u pk) alts deflt))
377 maybe_empty_deflt = nonemptyAbsC deflt
378 deflt_is_empty = case maybe_empty_deflt of
382 pk = getAmodeRep discrim
384 simple_discrim = case discrim of
392 Finally, all of the disgusting AbstractC macros.
396 gencode (CMacroStmt macro args) = macro_code macro args
398 gencode (CCallProfCtrMacro macro _)
399 = returnUs (\xs -> StComment macro : xs)
401 gencode (CCallProfCCMacro macro _)
402 = returnUs (\xs -> StComment macro : xs)
406 Here, we generate a jump table if there are more than four (integer)
407 alternatives and the jump table occupancy is greater than 50%.
408 Otherwise, we generate a binary comparison tree. (Perhaps this could
413 intTag :: Literal -> Integer
414 intTag (MachChar c) = fromInt (ord c)
415 intTag (MachInt i _) = i
416 intTag _ = panic "intTag"
418 fltTag :: Literal -> Rational
420 fltTag (MachFloat f) = f
421 fltTag (MachDouble d) = d
422 fltTag _ = panic "fltTag"
426 :: CAddrMode -> [(Literal,AbstractC)] -> AbstractC
427 -> UniqSM StixTreeList
429 mkSimpleSwitches am alts absC
430 = getUniqLabelNCG `thenUs` \ udlbl ->
431 getUniqLabelNCG `thenUs` \ ujlbl ->
433 joinedAlts = map (\ (tag,code) -> (tag, mkJoin code ujlbl)) alts
434 sortedAlts = naturalMergeSortLe leAlt joinedAlts
435 -- naturalMergeSortLe, because we often get sorted alts to begin with
437 lowTag = intTag (fst (head sortedAlts))
438 highTag = intTag (fst (last sortedAlts))
440 -- lowest and highest possible values the discriminant could take
441 lowest = if floating then targetMinDouble else targetMinInt
442 highest = if floating then targetMaxDouble else targetMaxInt
445 if not floating && choices > 4 && highTag - lowTag < toInteger (2 * choices) then
446 mkJumpTable am' sortedAlts lowTag highTag udlbl
448 mkBinaryTree am' floating sortedAlts choices lowest highest udlbl
450 `thenUs` \ alt_code ->
451 gencode absC `thenUs` \ dflt_code ->
453 returnUs (\xs -> alt_code (StLabel udlbl : dflt_code (StLabel ujlbl : xs)))
456 floating = isFloatingRep (getAmodeRep am)
457 choices = length alts
459 (x@(MachChar _),_) `leAlt` (y,_) = intTag x <= intTag y
460 (x@(MachInt _ _),_) `leAlt` (y,_) = intTag x <= intTag y
461 (x,_) `leAlt` (y,_) = fltTag x <= fltTag y
465 We use jump tables when doing an integer switch on a relatively dense
466 list of alternatives. We expect to be given a list of alternatives,
467 sorted by tag, and a range of values for which we are to generate a
468 table. Of course, the tags of the alternatives should lie within the
469 indicated range. The alternatives need not cover the range; a default
470 target is provided for the missing alternatives.
472 If a join is necessary after the switch, the alternatives should
473 already finish with a jump to the join point.
478 :: StixTree -- discriminant
479 -> [(Literal, AbstractC)] -- alternatives
480 -> Integer -- low tag
481 -> Integer -- high tag
482 -> CLabel -- default label
483 -> UniqSM StixTreeList
486 mkJumpTable am alts lowTag highTag dflt
487 = getUniqLabelNCG `thenUs` \ utlbl ->
488 mapUs genLabel alts `thenUs` \ branches ->
489 let cjmpLo = StCondJump dflt (StPrim IntLtOp [am, StInt (toInteger lowTag)])
490 cjmpHi = StCondJump dflt (StPrim IntGtOp [am, StInt (toInteger highTag)])
492 offset = StPrim IntSubOp [am, StInt lowTag]
494 jump = StJump (StInd PtrRep (StIndex PtrRep (StCLbl utlbl) offset))
496 table = StData PtrRep (mkTable branches [lowTag..highTag] [])
498 mapUs mkBranch branches `thenUs` \ alts ->
500 returnUs (\xs -> cjmpLo : cjmpHi : jump :
501 StSegment DataSegment : tlbl : table :
502 StSegment TextSegment : foldr1 (.) alts xs)
505 genLabel x = getUniqLabelNCG `thenUs` \ lbl -> returnUs (lbl, x)
507 mkBranch (lbl,(_,alt)) =
508 gencode alt `thenUs` \ alt_code ->
509 returnUs (\xs -> StLabel lbl : alt_code xs)
511 mkTable _ [] tbl = reverse tbl
512 mkTable [] (x:xs) tbl = mkTable [] xs (StCLbl dflt : tbl)
513 mkTable alts@((lbl,(tag,_)):rest) (x:xs) tbl
514 | intTag tag == x = mkTable rest xs (StCLbl lbl : tbl)
515 | otherwise = mkTable alts xs (StCLbl dflt : tbl)
519 We generate binary comparison trees when a jump table is inappropriate.
520 We expect to be given a list of alternatives, sorted by tag, and for
521 convenience, the length of the alternative list. We recursively break
522 the list in half and do a comparison on the first tag of the second half
523 of the list. (Odd lists are broken so that the second half of the list
524 is longer.) We can handle either integer or floating kind alternatives,
525 so long as they are not mixed. (We assume that the type of the discriminant
526 determines the type of the alternatives.)
528 As with the jump table approach, if a join is necessary after the switch, the
529 alternatives should already finish with a jump to the join point.
534 :: StixTree -- discriminant
535 -> Bool -- floating point?
536 -> [(Literal, AbstractC)] -- alternatives
537 -> Int -- number of choices
538 -> Literal -- low tag
539 -> Literal -- high tag
540 -> CLabel -- default code label
541 -> UniqSM StixTreeList
544 mkBinaryTree am floating [(tag,alt)] _ lowTag highTag udlbl
545 | rangeOfOne = gencode alt
547 = let tag' = a2stix (CLit tag)
548 cmpOp = if floating then DoubleNeOp else IntNeOp
549 test = StPrim cmpOp [am, tag']
550 cjmp = StCondJump udlbl test
552 gencode alt `thenUs` \ alt_code ->
553 returnUs (\xs -> cjmp : alt_code xs)
556 rangeOfOne = not floating && intTag lowTag + 1 >= intTag highTag
557 -- When there is only one possible tag left in range, we skip the comparison
559 mkBinaryTree am floating alts choices lowTag highTag udlbl
560 = getUniqLabelNCG `thenUs` \ uhlbl ->
561 let tag' = a2stix (CLit splitTag)
562 cmpOp = if floating then DoubleGeOp else IntGeOp
563 test = StPrim cmpOp [am, tag']
564 cjmp = StCondJump uhlbl test
566 mkBinaryTree am floating alts_lo half lowTag splitTag udlbl
567 `thenUs` \ lo_code ->
568 mkBinaryTree am floating alts_hi (choices - half) splitTag highTag udlbl
569 `thenUs` \ hi_code ->
571 returnUs (\xs -> cjmp : lo_code (StLabel uhlbl : hi_code xs))
574 half = choices `div` 2
575 (alts_lo, alts_hi) = splitAt half alts
576 splitTag = fst (head alts_hi)
583 :: CAddrMode -- discriminant
585 -> AbstractC -- if-part
586 -> AbstractC -- else-part
587 -> UniqSM StixTreeList
590 mkIfThenElse discrim tag alt deflt
591 = getUniqLabelNCG `thenUs` \ ujlbl ->
592 getUniqLabelNCG `thenUs` \ utlbl ->
593 let discrim' = a2stix discrim
594 tag' = a2stix (CLit tag)
595 cmpOp = if (isFloatingRep (getAmodeRep discrim)) then DoubleNeOp else IntNeOp
596 test = StPrim cmpOp [discrim', tag']
597 cjmp = StCondJump utlbl test
601 gencode (mkJoin alt ujlbl) `thenUs` \ alt_code ->
602 gencode deflt `thenUs` \ dflt_code ->
603 returnUs (\xs -> cjmp : alt_code (dest : dflt_code (join : xs)))
605 mkJoin :: AbstractC -> CLabel -> AbstractC
608 | mightFallThrough code = mkAbsCStmts code (CJump (CLbl lbl PtrRep))
612 %---------------------------------------------------------------------------
614 This answers the question: Can the code fall through to the next
615 line(s) of code? This errs towards saying True if it can't choose,
616 because it is used for eliminating needless jumps. In other words, if
617 you might possibly {\em not} jump, then say yes to falling through.
620 mightFallThrough :: AbstractC -> Bool
622 mightFallThrough absC = ft absC True
624 ft AbsCNop if_empty = if_empty
626 ft (CJump _) if_empty = False
627 ft (CReturn _ _) if_empty = False
628 ft (CSwitch _ alts deflt) if_empty
629 = ft deflt if_empty ||
630 or [ft alt if_empty | (_,alt) <- alts]
632 ft (AbsCStmts c1 c2) if_empty = ft c2 (ft c1 if_empty)
633 ft _ if_empty = if_empty
635 {- Old algorithm, which called nonemptyAbsC for every subexpression! =========
636 fallThroughAbsC (AbsCStmts c1 c2)
637 = case nonemptyAbsC c2 of
638 Nothing -> fallThroughAbsC c1
639 Just x -> fallThroughAbsC x
640 fallThroughAbsC (CJump _) = False
641 fallThroughAbsC (CReturn _ _) = False
642 fallThroughAbsC (CSwitch _ choices deflt)
643 = (not (isEmptyAbsC deflt) && fallThroughAbsC deflt)
644 || or (map (fallThroughAbsC . snd) choices)
645 fallThroughAbsC other = True
647 isEmptyAbsC :: AbstractC -> Bool
648 isEmptyAbsC = not . maybeToBool . nonemptyAbsC
649 ================= End of old, quadratic, algorithm -}