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 labelDynamic, mkSplitMarkerLabel )
28 import ClosureInfo ( infoTableLabelFromCI, entryLabelFromCI,
29 fastLabelFromCI, closureUpdReqd,
30 staticClosureNeedsLink
32 import Literal ( Literal(..), word2IntLit )
33 import Maybes ( maybeToBool )
34 import StgSyn ( StgOp(..) )
35 import PrimOp ( primOpNeedsWrapper, PrimOp(..) )
36 import PrimRep ( isFloatingRep, PrimRep(..) )
37 import StixInfo ( genCodeInfoTable, genBitmapInfoTable )
38 import StixMacro ( macroCode, checkCode )
39 import StixPrim ( primCode, foreignCallCode, amodeToStix, amodeToStix' )
40 import Outputable ( pprPanic, ppr )
41 import UniqSupply ( returnUs, thenUs, mapUs, getUniqueUs, UniqSM )
42 import Util ( naturalMergeSortLe )
43 import Panic ( panic )
44 import TyCon ( tyConDataCons )
45 import DataCon ( dataConWrapId )
46 import BitSet ( intBS )
47 import Name ( NamedThing(..) )
48 import CmdLineOpts ( opt_Static, opt_EnsureSplittableC )
49 import Outputable ( assertPanic )
52 For each independent chunk of AbstractC code, we generate a list of
53 @StixTree@s, where each tree corresponds to a single Stix instruction.
54 We leave the chunks separated so that register allocation can be
55 performed locally within the chunk.
58 genCodeAbstractC :: AbstractC -> UniqSM [StixTree]
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 ->
90 then StSegment DataSegment
91 : StLabel lbl : code []
92 else StSegment DataSegment
93 : StData PtrRep [StInt 0] -- DLLised world, need extra zero word
94 : StLabel lbl : code []
97 gentopcode stmt@(CRetVector lbl _ _ _)
98 = genCodeVecTbl stmt `thenUs` \ code ->
99 returnUs (StSegment TextSegment : code [StLabel lbl])
101 gentopcode stmt@(CRetDirect uniq absC srt liveness)
102 = gencode absC `thenUs` \ code ->
103 genBitmapInfoTable liveness srt closure_type False `thenUs` \ itbl ->
104 returnUs (StSegment TextSegment :
105 itbl (StLabel lbl_info : StLabel lbl_ret : code []))
107 lbl_info = mkReturnInfoLabel uniq
108 lbl_ret = mkReturnPtLabel uniq
109 closure_type = case liveness of
110 LvSmall _ -> rET_SMALL
113 gentopcode stmt@(CClosureInfoAndCode cl_info slow Nothing _)
116 = genCodeInfoTable stmt `thenUs` \ itbl ->
117 returnUs (StSegment TextSegment : itbl [])
120 = genCodeInfoTable stmt `thenUs` \ itbl ->
121 gencode slow `thenUs` \ slow_code ->
122 returnUs (StSegment TextSegment : itbl (StFunBegin slow_lbl :
123 slow_code [StFunEnd slow_lbl]))
125 slow_is_empty = not (maybeToBool (nonemptyAbsC slow))
126 slow_lbl = entryLabelFromCI cl_info
128 gentopcode stmt@(CClosureInfoAndCode cl_info slow (Just fast) _) =
129 -- ToDo: what if this is empty? ------------------------^^^^
130 genCodeInfoTable stmt `thenUs` \ itbl ->
131 gencode slow `thenUs` \ slow_code ->
132 gencode fast `thenUs` \ fast_code ->
133 returnUs (StSegment TextSegment : itbl (StFunBegin slow_lbl :
134 slow_code (StFunEnd slow_lbl : StFunBegin fast_lbl :
135 fast_code [StFunEnd fast_lbl])))
137 slow_lbl = entryLabelFromCI cl_info
138 fast_lbl = fastLabelFromCI cl_info
140 gentopcode stmt@(CSRT lbl closures)
141 = returnUs [ StSegment TextSegment
143 , StData DataPtrRep (map mk_StCLbl_for_SRT closures)
146 mk_StCLbl_for_SRT :: CLabel -> StixTree
147 mk_StCLbl_for_SRT label
149 = StIndex Int8Rep (StCLbl label) (StInt 1)
153 gentopcode stmt@(CBitmap lbl mask)
154 = returnUs [ StSegment TextSegment
156 , StData WordRep (StInt (toInteger (length mask)) :
157 map (StInt . toInteger . intBS) mask)
160 gentopcode stmt@(CClosureTbl tycon)
161 = returnUs [ StSegment TextSegment
162 , StLabel (mkClosureTblLabel tycon)
163 , StData DataPtrRep (map (StCLbl . mkClosureLabel . getName . dataConWrapId)
164 (tyConDataCons tycon) )
167 gentopcode stmt@(CModuleInitBlock lbl absC)
168 = gencode absC `thenUs` \ code ->
169 getUniqLabelNCG `thenUs` \ tmp_lbl ->
170 getUniqLabelNCG `thenUs` \ flag_lbl ->
171 returnUs ( StSegment DataSegment
173 : StData IntRep [StInt 0]
174 : StSegment TextSegment
176 : StCondJump tmp_lbl (StPrim IntNeOp
177 [StInd IntRep (StCLbl flag_lbl),
179 : StAssign IntRep (StInd IntRep (StCLbl flag_lbl)) (StInt 1)
182 , StAssign PtrRep stgSp
183 (StIndex PtrRep stgSp (StInt (-1)))
184 , StJump NoDestInfo (StInd WordRep stgSp)
188 = gencode absC `thenUs` \ code ->
189 returnUs (StSegment TextSegment : code [])
196 -> UniqSM StixTreeList
198 genCodeVecTbl (CRetVector lbl amodes srt liveness)
199 = genBitmapInfoTable liveness srt closure_type True `thenUs` \itbl ->
200 returnUs (\xs -> vectbl : itbl xs)
202 vectbl = StData PtrRep (reverse (map a2stix amodes))
203 closure_type = case liveness of
204 LvSmall _ -> rET_VEC_SMALL
205 LvLarge _ -> rET_VEC_BIG
213 -> UniqSM StixTreeList
215 genCodeStaticClosure (CStaticClosure _ cl_info cost_centre amodes)
216 = returnUs (\xs -> table ++ xs)
218 table = StData PtrRep [StCLbl (infoTableLabelFromCI cl_info)] :
219 map do_one_amode amodes ++
220 [StData PtrRep (padding_wds ++ static_link)]
223 = StData (promote_to_word (getAmodeRep amode)) [a2stix amode]
225 -- We need to promote any item smaller than a word to a word
227 | sizeOf pk >= sizeOf IntRep = pk
230 upd_reqd = closureUpdReqd cl_info
233 | upd_reqd = take (max 0 (mIN_UPD_SIZE - length amodes)) zeros
236 static_link | upd_reqd || staticClosureNeedsLink cl_info = [StInt 0]
239 zeros = StInt 0 : zeros
242 -- Watch out for VoidKinds...cf. PprAbsC
244 | getAmodeRep item == VoidRep = StInt 0
245 | otherwise = a2stix item
250 Now the individual AbstractC statements.
256 -> UniqSM StixTreeList
260 @AbsCNop@s just disappear.
264 gencode AbsCNop = returnUs id
268 Split markers just insert a __stg_split_marker, which is caught by the
269 split-mangler later on and used to split the assembly into chunks.
274 | opt_EnsureSplittableC = returnUs (\xs -> StLabel mkSplitMarkerLabel : xs)
275 | otherwise = returnUs id
279 AbstractC instruction sequences are handled individually, and the
280 resulting StixTreeLists are joined together.
284 gencode (AbsCStmts c1 c2)
285 = gencode c1 `thenUs` \ b1 ->
286 gencode c2 `thenUs` \ b2 ->
291 Initialising closure headers in the heap...a fairly complex ordeal if
292 done properly. For now, we just set the info pointer, but we should
293 really take a peek at the flags to determine whether or not there are
294 other things to be done (setting cost centres, age headers, global
299 gencode (CInitHdr cl_info reg_rel _)
302 lbl = infoTableLabelFromCI cl_info
304 returnUs (\xs -> StAssign PtrRep (StInd PtrRep lhs) (StCLbl lbl) : xs)
312 gencode (CCheck macro args assts)
313 = gencode assts `thenUs` \assts_stix ->
314 checkCode macro args assts_stix
318 Assignment, the curse of von Neumann, is the center of the code we
319 produce. In most cases, the type of the assignment is determined
320 by the type of the destination. However, when the destination can
321 have mixed types, the type of the assignment is ``StgWord'' (we use
322 PtrRep for lack of anything better). Think: do we also want a cast
323 of the source? Be careful about floats/doubles.
327 gencode (CAssign lhs rhs)
328 | getAmodeRep lhs == VoidRep = returnUs id
330 = let pk = getAmodeRep lhs
331 pk' = if mixedTypeLocn lhs && not (isFloatingRep pk) then IntRep else pk
335 returnUs (\xs -> StAssign pk' lhs' rhs' : xs)
339 Unconditional jumps, including the special ``enter closure'' operation.
340 Note that the new entry convention requires that we load the InfoPtr (R2)
341 with the address of the info table before jumping to the entry code for Node.
343 For a vectored return, we must subtract the size of the info table to
344 get at the return vector. This depends on the size of the info table,
345 which varies depending on whether we're profiling etc.
350 = returnUs (\xs -> StJump NoDestInfo (a2stix dest) : xs)
352 gencode (CFallThrough (CLbl lbl _))
353 = returnUs (\xs -> StFallThrough lbl : xs)
355 gencode (CReturn dest DirectReturn)
356 = returnUs (\xs -> StJump NoDestInfo (a2stix dest) : xs)
358 gencode (CReturn table (StaticVectoredReturn n))
359 = returnUs (\xs -> StJump NoDestInfo dest : xs)
361 dest = StInd PtrRep (StIndex PtrRep (a2stix table)
362 (StInt (toInteger (-n-fixedItblSize-1))))
364 gencode (CReturn table (DynamicVectoredReturn am))
365 = returnUs (\xs -> StJump NoDestInfo dest : xs)
367 dest = StInd PtrRep (StIndex PtrRep (a2stix table) dyn_off)
368 dyn_off = StPrim IntSubOp [StPrim IntNegOp [a2stix am],
369 StInt (toInteger (fixedItblSize+1))]
373 Now the PrimOps, some of which may need caller-saves register wrappers.
376 gencode (COpStmt results (StgFCallOp fcall _) args vols)
377 = ASSERT( null vols )
378 foreignCallCode (nonVoid results) fcall (nonVoid args)
380 gencode (COpStmt results (StgPrimOp op) args vols)
381 -- ToDo (ADR?): use that liveness mask
382 | primOpNeedsWrapper op
384 saves = volsaves vols
385 restores = volrestores vols
387 p2stix (nonVoid results) op (nonVoid args)
389 returnUs (\xs -> saves ++ code (restores ++ xs))
391 | otherwise = p2stix (nonVoid results) op (nonVoid args)
394 Now the dreaded conditional jump.
396 Now the if statement. Almost *all* flow of control are of this form.
398 if (am==lit) { absC } else { absCdef }
412 gencode (CSwitch discrim alts deflt)
416 [(tag,alt_code)] -> case maybe_empty_deflt of
417 Nothing -> gencode alt_code
418 Just dc -> mkIfThenElse discrim tag alt_code dc
420 [(tag1@(MachInt i1), alt_code1),
421 (tag2@(MachInt i2), alt_code2)]
422 | deflt_is_empty && i1 == 0 && i2 == 1
423 -> mkIfThenElse discrim tag1 alt_code1 alt_code2
424 | deflt_is_empty && i1 == 1 && i2 == 0
425 -> mkIfThenElse discrim tag2 alt_code2 alt_code1
427 -- If the @discrim@ is simple, then this unfolding is safe.
428 other | simple_discrim -> mkSimpleSwitches discrim alts deflt
430 -- Otherwise, we need to do a bit of work.
431 other -> getUniqueUs `thenUs` \ u ->
433 (CAssign (CTemp u pk) discrim)
434 (CSwitch (CTemp u pk) alts deflt))
437 maybe_empty_deflt = nonemptyAbsC deflt
438 deflt_is_empty = case maybe_empty_deflt of
442 pk = getAmodeRep discrim
444 simple_discrim = case discrim of
452 Finally, all of the disgusting AbstractC macros.
456 gencode (CMacroStmt macro args) = macro_code macro args
458 gencode (CCallProfCtrMacro macro _)
459 = returnUs (\xs -> StComment macro : xs)
461 gencode (CCallProfCCMacro macro _)
462 = returnUs (\xs -> StComment macro : xs)
465 = pprPanic "AbsCStixGen.gencode" (dumpRealC other)
467 nonVoid = filter ((/= VoidRep) . getAmodeRep)
470 Here, we generate a jump table if there are more than four (integer)
471 alternatives and the jump table occupancy is greater than 50%.
472 Otherwise, we generate a binary comparison tree. (Perhaps this could
477 intTag :: Literal -> Integer
478 intTag (MachChar c) = toInteger c
479 intTag (MachInt i) = i
480 intTag (MachWord w) = intTag (word2IntLit (MachWord w))
481 intTag _ = panic "intTag"
483 fltTag :: Literal -> Rational
485 fltTag (MachFloat f) = f
486 fltTag (MachDouble d) = d
487 fltTag x = pprPanic "fltTag" (ppr x)
491 :: CAddrMode -> [(Literal,AbstractC)] -> AbstractC
492 -> UniqSM StixTreeList
494 mkSimpleSwitches am alts absC
495 = getUniqLabelNCG `thenUs` \ udlbl ->
496 getUniqLabelNCG `thenUs` \ ujlbl ->
498 joinedAlts = map (\ (tag,code) -> (tag, mkJoin code ujlbl)) alts
499 sortedAlts = naturalMergeSortLe leAlt joinedAlts
500 -- naturalMergeSortLe, because we often get sorted alts to begin with
502 lowTag = intTag (fst (head sortedAlts))
503 highTag = intTag (fst (last sortedAlts))
505 -- lowest and highest possible values the discriminant could take
506 lowest = if floating then targetMinDouble else targetMinInt
507 highest = if floating then targetMaxDouble else targetMaxInt
510 if not floating && choices > 4
511 && highTag - lowTag < toInteger (2 * choices)
513 mkJumpTable am' sortedAlts lowTag highTag udlbl
515 mkBinaryTree am' floating sortedAlts choices lowest highest udlbl
517 `thenUs` \ alt_code ->
518 gencode absC `thenUs` \ dflt_code ->
520 returnUs (\xs -> alt_code (StLabel udlbl : dflt_code (StLabel ujlbl : xs)))
523 floating = isFloatingRep (getAmodeRep am)
524 choices = length alts
526 (x@(MachChar _),_) `leAlt` (y,_) = intTag x <= intTag y
527 (x@(MachInt _), _) `leAlt` (y,_) = intTag x <= intTag y
528 (x@(MachWord _), _) `leAlt` (y,_) = intTag x <= intTag y
529 (x,_) `leAlt` (y,_) = fltTag x <= fltTag y
533 We use jump tables when doing an integer switch on a relatively dense
534 list of alternatives. We expect to be given a list of alternatives,
535 sorted by tag, and a range of values for which we are to generate a
536 table. Of course, the tags of the alternatives should lie within the
537 indicated range. The alternatives need not cover the range; a default
538 target is provided for the missing alternatives.
540 If a join is necessary after the switch, the alternatives should
541 already finish with a jump to the join point.
546 :: StixTree -- discriminant
547 -> [(Literal, AbstractC)] -- alternatives
548 -> Integer -- low tag
549 -> Integer -- high tag
550 -> CLabel -- default label
551 -> UniqSM StixTreeList
554 mkJumpTable am alts lowTag highTag dflt
555 = getUniqLabelNCG `thenUs` \ utlbl ->
556 mapUs genLabel alts `thenUs` \ branches ->
557 let cjmpLo = StCondJump dflt (StPrim IntLtOp [am, StInt (toInteger lowTag)])
558 cjmpHi = StCondJump dflt (StPrim IntGtOp [am, StInt (toInteger highTag)])
560 offset = StPrim IntSubOp [am, StInt lowTag]
561 dsts = DestInfo (dflt : map fst branches)
563 jump = StJump dsts (StInd PtrRep (StIndex PtrRep (StCLbl utlbl) offset))
565 table = StData PtrRep (mkTable branches [lowTag..highTag] [])
567 mapUs mkBranch branches `thenUs` \ alts ->
569 returnUs (\xs -> cjmpLo : cjmpHi : jump :
570 StSegment DataSegment : tlbl : table :
571 StSegment TextSegment : foldr1 (.) alts xs)
574 genLabel x = getUniqLabelNCG `thenUs` \ lbl -> returnUs (lbl, x)
576 mkBranch (lbl,(_,alt)) =
577 gencode alt `thenUs` \ alt_code ->
578 returnUs (\xs -> StLabel lbl : alt_code xs)
580 mkTable _ [] tbl = reverse tbl
581 mkTable [] (x:xs) tbl = mkTable [] xs (StCLbl dflt : tbl)
582 mkTable alts@((lbl,(tag,_)):rest) (x:xs) tbl
583 | intTag tag == x = mkTable rest xs (StCLbl lbl : tbl)
584 | otherwise = mkTable alts xs (StCLbl dflt : tbl)
588 We generate binary comparison trees when a jump table is inappropriate.
589 We expect to be given a list of alternatives, sorted by tag, and for
590 convenience, the length of the alternative list. We recursively break
591 the list in half and do a comparison on the first tag of the second half
592 of the list. (Odd lists are broken so that the second half of the list
593 is longer.) We can handle either integer or floating kind alternatives,
594 so long as they are not mixed. (We assume that the type of the discriminant
595 determines the type of the alternatives.)
597 As with the jump table approach, if a join is necessary after the switch, the
598 alternatives should already finish with a jump to the join point.
603 :: StixTree -- discriminant
604 -> Bool -- floating point?
605 -> [(Literal, AbstractC)] -- alternatives
606 -> Int -- number of choices
607 -> Literal -- low tag
608 -> Literal -- high tag
609 -> CLabel -- default code label
610 -> UniqSM StixTreeList
613 mkBinaryTree am floating [(tag,alt)] _ lowTag highTag udlbl
614 | rangeOfOne = gencode alt
616 = let tag' = a2stix (CLit tag)
617 cmpOp = if floating then DoubleNeOp else IntNeOp
618 test = StPrim cmpOp [am, tag']
619 cjmp = StCondJump udlbl test
621 gencode alt `thenUs` \ alt_code ->
622 returnUs (\xs -> cjmp : alt_code xs)
625 rangeOfOne = not floating && intTag lowTag + 1 >= intTag highTag
626 -- When there is only one possible tag left in range, we skip the comparison
628 mkBinaryTree am floating alts choices lowTag highTag udlbl
629 = getUniqLabelNCG `thenUs` \ uhlbl ->
630 let tag' = a2stix (CLit splitTag)
631 cmpOp = if floating then DoubleGeOp else IntGeOp
632 test = StPrim cmpOp [am, tag']
633 cjmp = StCondJump uhlbl test
635 mkBinaryTree am floating alts_lo half lowTag splitTag udlbl
636 `thenUs` \ lo_code ->
637 mkBinaryTree am floating alts_hi (choices - half) splitTag highTag udlbl
638 `thenUs` \ hi_code ->
640 returnUs (\xs -> cjmp : lo_code (StLabel uhlbl : hi_code xs))
643 half = choices `div` 2
644 (alts_lo, alts_hi) = splitAt half alts
645 splitTag = fst (head alts_hi)
652 :: CAddrMode -- discriminant
654 -> AbstractC -- if-part
655 -> AbstractC -- else-part
656 -> UniqSM StixTreeList
659 mkIfThenElse discrim tag alt deflt
660 = getUniqLabelNCG `thenUs` \ ujlbl ->
661 getUniqLabelNCG `thenUs` \ utlbl ->
662 let discrim' = a2stix discrim
663 tag' = a2stix (CLit tag)
664 cmpOp = if (isFloatingRep (getAmodeRep discrim)) then DoubleNeOp else IntNeOp
665 test = StPrim cmpOp [discrim', tag']
666 cjmp = StCondJump utlbl test
670 gencode (mkJoin alt ujlbl) `thenUs` \ alt_code ->
671 gencode deflt `thenUs` \ dflt_code ->
672 returnUs (\xs -> cjmp : alt_code (dest : dflt_code (join : xs)))
674 mkJoin :: AbstractC -> CLabel -> AbstractC
677 | mightFallThrough code = mkAbsCStmts code (CJump (CLbl lbl PtrRep))
681 %---------------------------------------------------------------------------
683 This answers the question: Can the code fall through to the next
684 line(s) of code? This errs towards saying True if it can't choose,
685 because it is used for eliminating needless jumps. In other words, if
686 you might possibly {\em not} jump, then say yes to falling through.
689 mightFallThrough :: AbstractC -> Bool
691 mightFallThrough absC = ft absC True
693 ft AbsCNop if_empty = if_empty
695 ft (CJump _) if_empty = False
696 ft (CReturn _ _) if_empty = False
697 ft (CSwitch _ alts deflt) if_empty
698 = ft deflt if_empty ||
699 or [ft alt if_empty | (_,alt) <- alts]
701 ft (AbsCStmts c1 c2) if_empty = ft c2 (ft c1 if_empty)
702 ft _ if_empty = if_empty
704 {- Old algorithm, which called nonemptyAbsC for every subexpression! =========
705 fallThroughAbsC (AbsCStmts c1 c2)
706 = case nonemptyAbsC c2 of
707 Nothing -> fallThroughAbsC c1
708 Just x -> fallThroughAbsC x
709 fallThroughAbsC (CJump _) = False
710 fallThroughAbsC (CReturn _ _) = False
711 fallThroughAbsC (CSwitch _ choices deflt)
712 = (not (isEmptyAbsC deflt) && fallThroughAbsC deflt)
713 || or (map (fallThroughAbsC . snd) choices)
714 fallThroughAbsC other = True
716 isEmptyAbsC :: AbstractC -> Bool
717 isEmptyAbsC = not . maybeToBool . nonemptyAbsC
718 ================= End of old, quadratic, algorithm -}