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, wORD_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 ( Maybe012(..), maybeToBool )
34 import StgSyn ( StgOp(..) )
35 import MachOp ( MachOp(..), resultRepsOfMachOp )
36 import PrimRep ( isFloatingRep, PrimRep(..) )
37 import StixInfo ( genCodeInfoTable, genBitmapInfoTable,
38 livenessIsSmall, bitmapToIntegers )
39 import StixMacro ( macroCode, checkCode )
40 import StixPrim ( foreignCallCode, amodeToStix, amodeToStix' )
41 import Outputable ( pprPanic, ppr )
42 import UniqSupply ( returnUs, thenUs, mapUs, getUniqueUs, UniqSM )
43 import Util ( naturalMergeSortLe )
44 import Panic ( panic )
45 import TyCon ( tyConDataCons )
46 import DataCon ( dataConWrapId )
47 import Name ( NamedThing(..) )
48 import CmdLineOpts ( opt_Static, opt_EnsureSplittableC )
49 import Outputable ( assertPanic )
52 --import IOExts ( trace )
53 --import Outputable ( showSDoc )
54 --import MachOp ( pprMachOp )
58 For each independent chunk of AbstractC code, we generate a list of
59 @StixTree@s, where each tree corresponds to a single Stix instruction.
60 We leave the chunks separated so that register allocation can be
61 performed locally within the chunk.
64 genCodeAbstractC :: AbstractC -> UniqSM [StixStmt]
70 a2stix' = amodeToStix'
71 volsaves = volatileSaves
72 volrestores = volatileRestores
73 macro_code = macroCode
74 -- real code follows... ---------
77 Here we handle top-level things, like @CCodeBlock@s and
87 gentopcode (CCodeBlock lbl absC)
88 = gencode absC `thenUs` \ code ->
89 returnUs (StSegment TextSegment : StFunBegin lbl : code [StFunEnd lbl])
91 gentopcode stmt@(CStaticClosure lbl _ _ _)
92 = genCodeStaticClosure stmt `thenUs` \ code ->
95 then StSegment DataSegment
96 : StLabel lbl : code []
97 else StSegment DataSegment
98 : StData PtrRep [StInt 0] -- DLLised world, need extra zero word
99 : StLabel lbl : code []
102 gentopcode stmt@(CRetVector lbl _ _ _)
103 = genCodeVecTbl stmt `thenUs` \ code ->
104 returnUs (StSegment TextSegment
105 : code [StLabel lbl, vtbl_post_label_word])
107 -- We put a dummy word after the vtbl label so as to ensure the label
108 -- is in the same (Text) section as the vtbl it labels. This is critical
109 -- for ensuring the GC works correctly, although GC crashes due to
110 -- misclassification are much more likely to show up in the interactive
111 -- system than in compile code. For details see comment near line 1164
112 -- of ghc/driver/mangler/ghc-asm.lprl, which contains an analogous fix for
113 -- the mangled via-C route.
114 vtbl_post_label_word = StData PtrRep [StInt 0]
116 gentopcode stmt@(CRetDirect uniq absC srt liveness)
117 = gencode absC `thenUs` \ code ->
118 genBitmapInfoTable liveness srt closure_type False `thenUs` \ itbl ->
119 returnUs (StSegment TextSegment :
120 itbl (StLabel lbl_info : StLabel lbl_ret : code []))
122 lbl_info = mkReturnInfoLabel uniq
123 lbl_ret = mkReturnPtLabel uniq
124 closure_type = if livenessIsSmall liveness then rET_SMALL else rET_BIG
126 gentopcode stmt@(CClosureInfoAndCode cl_info slow Nothing _)
129 = genCodeInfoTable stmt `thenUs` \ itbl ->
130 returnUs (StSegment TextSegment : itbl [])
133 = genCodeInfoTable stmt `thenUs` \ itbl ->
134 gencode slow `thenUs` \ slow_code ->
135 returnUs (StSegment TextSegment : itbl (StFunBegin slow_lbl :
136 slow_code [StFunEnd slow_lbl]))
138 slow_is_empty = not (maybeToBool (nonemptyAbsC slow))
139 slow_lbl = entryLabelFromCI cl_info
141 gentopcode stmt@(CClosureInfoAndCode cl_info slow (Just fast) _) =
142 -- ToDo: what if this is empty? ------------------------^^^^
143 genCodeInfoTable stmt `thenUs` \ itbl ->
144 gencode slow `thenUs` \ slow_code ->
145 gencode fast `thenUs` \ fast_code ->
146 returnUs (StSegment TextSegment : itbl (StFunBegin slow_lbl :
147 slow_code (StFunEnd slow_lbl : StFunBegin fast_lbl :
148 fast_code [StFunEnd fast_lbl])))
150 slow_lbl = entryLabelFromCI cl_info
151 fast_lbl = fastLabelFromCI cl_info
153 gentopcode stmt@(CSRT lbl closures)
154 = returnUs [ StSegment TextSegment
156 , StData DataPtrRep (map mk_StCLbl_for_SRT closures)
159 mk_StCLbl_for_SRT :: CLabel -> StixExpr
160 mk_StCLbl_for_SRT label
162 = StIndex Int8Rep (StCLbl label) (StInt 1)
166 gentopcode stmt@(CBitmap lbl mask)
167 = returnUs $ case bitmapToIntegers mask of
169 [ StSegment TextSegment
171 , StData WordRep (map StInt (toInteger (length mask') : mask'))
175 gentopcode stmt@(CClosureTbl tycon)
176 = returnUs [ StSegment TextSegment
177 , StLabel (mkClosureTblLabel tycon)
178 , StData DataPtrRep (map (StCLbl . mkClosureLabel . getName . dataConWrapId)
179 (tyConDataCons tycon) )
182 gentopcode stmt@(CModuleInitBlock lbl absC)
183 = gencode absC `thenUs` \ code ->
184 getUniqLabelNCG `thenUs` \ tmp_lbl ->
185 getUniqLabelNCG `thenUs` \ flag_lbl ->
186 returnUs ( StSegment DataSegment
188 : StData IntRep [StInt 0]
189 : StSegment TextSegment
191 : StCondJump tmp_lbl (StMachOp MO_Nat_Ne
192 [StInd IntRep (StCLbl flag_lbl),
194 : StAssignMem IntRep (StCLbl flag_lbl) (StInt 1)
197 , StAssignReg PtrRep stgSp
198 (StIndex PtrRep (StReg stgSp) (StInt (-1)))
199 , StJump NoDestInfo (StInd WordRep (StReg stgSp))
203 = gencode absC `thenUs` \ code ->
204 returnUs (StSegment TextSegment : code [])
211 -> UniqSM StixTreeList
213 genCodeVecTbl (CRetVector lbl amodes srt liveness)
214 = genBitmapInfoTable liveness srt closure_type True `thenUs` \itbl ->
215 returnUs (\xs -> vectbl : itbl xs)
217 vectbl = StData PtrRep (reverse (map a2stix amodes))
218 closure_type = if livenessIsSmall liveness then rET_VEC_SMALL else rET_VEC_BIG
226 -> UniqSM StixTreeList
228 genCodeStaticClosure (CStaticClosure _ cl_info cost_centre amodes)
229 = returnUs (\xs -> table ++ xs)
231 table = StData PtrRep [StCLbl (infoTableLabelFromCI cl_info)] :
232 map do_one_amode amodes ++
233 [StData PtrRep (padding_wds ++ static_link)]
236 = StData (promote_to_word (getAmodeRep amode)) [a2stix amode]
238 -- We need to promote any item smaller than a word to a word
240 | sizeOf pk >= sizeOf IntRep = pk
243 upd_reqd = closureUpdReqd cl_info
246 | upd_reqd = take (max 0 (mIN_UPD_SIZE - length amodes)) zeros
249 static_link | upd_reqd || staticClosureNeedsLink cl_info = [StInt 0]
252 zeros = StInt 0 : zeros
255 -- Watch out for VoidKinds...cf. PprAbsC
257 | getAmodeRep item == VoidRep = StInt 0
258 | otherwise = a2stix item
263 Now the individual AbstractC statements.
269 -> UniqSM StixTreeList
273 @AbsCNop@s just disappear.
277 gencode AbsCNop = returnUs id
281 Split markers just insert a __stg_split_marker, which is caught by the
282 split-mangler later on and used to split the assembly into chunks.
287 | opt_EnsureSplittableC = returnUs (\xs -> StLabel mkSplitMarkerLabel : xs)
288 | otherwise = returnUs id
292 AbstractC instruction sequences are handled individually, and the
293 resulting StixTreeLists are joined together.
297 gencode (AbsCStmts c1 c2)
298 = gencode c1 `thenUs` \ b1 ->
299 gencode c2 `thenUs` \ b2 ->
302 gencode (CSequential stuff)
306 foo (s:ss) = gencode s `thenUs` \ stix ->
307 foo ss `thenUs` \ stixes ->
308 returnUs (stix . stixes)
312 Initialising closure headers in the heap...a fairly complex ordeal if
313 done properly. For now, we just set the info pointer, but we should
314 really take a peek at the flags to determine whether or not there are
315 other things to be done (setting cost centres, age headers, global
320 gencode (CInitHdr cl_info reg_rel _ _)
323 lbl = infoTableLabelFromCI cl_info
325 returnUs (\xs -> StAssignMem PtrRep lhs (StCLbl lbl) : xs)
333 gencode (CCheck macro args assts)
334 = gencode assts `thenUs` \assts_stix ->
335 checkCode macro args assts_stix
339 Assignment, the curse of von Neumann, is the center of the code we
340 produce. In most cases, the type of the assignment is determined
341 by the type of the destination. However, when the destination can
342 have mixed types, the type of the assignment is ``StgWord'' (we use
343 PtrRep for lack of anything better). Think: do we also want a cast
344 of the source? Be careful about floats/doubles.
348 gencode (CAssign lhs rhs)
349 | getAmodeRep lhs == VoidRep = returnUs id
351 = let pk = getAmodeRep lhs
352 pk' = if mixedTypeLocn lhs && not (isFloatingRep pk) then IntRep else pk
356 returnUs (\xs -> mkStAssign pk' lhs' rhs' : xs)
360 Unconditional jumps, including the special ``enter closure'' operation.
361 Note that the new entry convention requires that we load the InfoPtr (R2)
362 with the address of the info table before jumping to the entry code for Node.
364 For a vectored return, we must subtract the size of the info table to
365 get at the return vector. This depends on the size of the info table,
366 which varies depending on whether we're profiling etc.
371 = returnUs (\xs -> StJump NoDestInfo (a2stix dest) : xs)
373 gencode (CFallThrough (CLbl lbl _))
374 = returnUs (\xs -> StFallThrough lbl : xs)
376 gencode (CReturn dest DirectReturn)
377 = returnUs (\xs -> StJump NoDestInfo (a2stix dest) : xs)
379 gencode (CReturn table (StaticVectoredReturn n))
380 = returnUs (\xs -> StJump NoDestInfo dest : xs)
382 dest = StInd PtrRep (StIndex PtrRep (a2stix table)
383 (StInt (toInteger (-n-fixedItblSize-1))))
385 gencode (CReturn table (DynamicVectoredReturn am))
386 = returnUs (\xs -> StJump NoDestInfo dest : xs)
388 dest = StInd PtrRep (StIndex PtrRep (a2stix table) dyn_off)
389 dyn_off = StMachOp MO_Nat_Sub [StMachOp MO_NatS_Neg [a2stix am],
390 StInt (toInteger (fixedItblSize+1))]
394 Now the PrimOps, some of which may need caller-saves register wrappers.
397 gencode (COpStmt results (StgFCallOp fcall _) args vols)
398 = ASSERT( null vols )
399 foreignCallCode (nonVoid results) fcall (nonVoid args)
401 gencode (COpStmt results (StgPrimOp op) args vols)
402 = panic "AbsCStixGen.gencode: un-translated PrimOp"
404 -- Translate out array indexing primops right here, so that
405 -- individual targets don't have to deal with them
407 gencode (CMachOpStmt (Just1 r1) (MO_ReadOSBI off_w rep) [base,index] vols)
412 (StInd rep (StMachOp MO_Nat_Add
413 [StIndex rep (a2stix base) (a2stix index),
414 StInt (toInteger (off_w * wORD_SIZE))]))
418 gencode (CMachOpStmt Just0 (MO_WriteOSBI off_w rep) [base,index,val] vols)
423 [StIndex rep (a2stix base) (a2stix index),
424 StInt (toInteger (off_w * wORD_SIZE))])
429 -- Gruesome cases for multiple-result primops
430 gencode (CMachOpStmt (Just2 r1 r2) mop [arg1, arg2] vols)
431 | mop `elem` [MO_NatS_AddC, MO_NatS_SubC, MO_NatS_MulC]
432 = getUniqueUs `thenUs` \ u1 ->
433 getUniqueUs `thenUs` \ u2 ->
434 let vr1 = StixVReg u1 IntRep
435 vr2 = StixVReg u2 IntRep
440 StAssignMachOp (Just2 vr1 vr2) mop [a2stix arg1, a2stix arg2]
441 : mkStAssign IntRep r1s (StReg (StixTemp vr1))
442 : mkStAssign IntRep r2s (StReg (StixTemp vr2))
446 -- Ordinary MachOps are passed through unchanged.
448 gencode (CMachOpStmt (Just1 r1) mop args vols)
449 = let (Just1 rep) = resultRepsOfMachOp mop
452 mkStAssign rep (a2stix r1)
453 (StMachOp mop (map a2stix args))
458 Now the dreaded conditional jump.
460 Now the if statement. Almost *all* flow of control are of this form.
462 if (am==lit) { absC } else { absCdef }
476 gencode (CSwitch discrim alts deflt)
480 [(tag,alt_code)] -> case maybe_empty_deflt of
481 Nothing -> gencode alt_code
482 Just dc -> mkIfThenElse discrim tag alt_code dc
484 [(tag1@(MachInt i1), alt_code1),
485 (tag2@(MachInt i2), alt_code2)]
486 | deflt_is_empty && i1 == 0 && i2 == 1
487 -> mkIfThenElse discrim tag1 alt_code1 alt_code2
488 | deflt_is_empty && i1 == 1 && i2 == 0
489 -> mkIfThenElse discrim tag2 alt_code2 alt_code1
491 -- If the @discrim@ is simple, then this unfolding is safe.
492 other | simple_discrim -> mkSimpleSwitches discrim alts deflt
494 -- Otherwise, we need to do a bit of work.
495 other -> getUniqueUs `thenUs` \ u ->
497 (CAssign (CTemp u pk) discrim)
498 (CSwitch (CTemp u pk) alts deflt))
501 maybe_empty_deflt = nonemptyAbsC deflt
502 deflt_is_empty = case maybe_empty_deflt of
506 pk = getAmodeRep discrim
508 simple_discrim = case discrim of
516 Finally, all of the disgusting AbstractC macros.
520 gencode (CMacroStmt macro args) = macro_code macro args
522 gencode (CCallProfCtrMacro macro _)
523 = returnUs (\xs -> StComment macro : xs)
525 gencode (CCallProfCCMacro macro _)
526 = returnUs (\xs -> StComment macro : xs)
528 gencode CCallTypedef{} = returnUs id
531 = pprPanic "AbsCStixGen.gencode" (dumpRealC other)
533 nonVoid = filter ((/= VoidRep) . getAmodeRep)
536 Here, we generate a jump table if there are more than four (integer)
537 alternatives and the jump table occupancy is greater than 50%.
538 Otherwise, we generate a binary comparison tree. (Perhaps this could
543 intTag :: Literal -> Integer
544 intTag (MachChar c) = toInteger c
545 intTag (MachInt i) = i
546 intTag (MachWord w) = intTag (word2IntLit (MachWord w))
547 intTag _ = panic "intTag"
549 fltTag :: Literal -> Rational
551 fltTag (MachFloat f) = f
552 fltTag (MachDouble d) = d
553 fltTag x = pprPanic "fltTag" (ppr x)
557 :: CAddrMode -> [(Literal,AbstractC)] -> AbstractC
558 -> UniqSM StixTreeList
560 mkSimpleSwitches am alts absC
561 = getUniqLabelNCG `thenUs` \ udlbl ->
562 getUniqLabelNCG `thenUs` \ ujlbl ->
564 joinedAlts = map (\ (tag,code) -> (tag, mkJoin code ujlbl)) alts
565 sortedAlts = naturalMergeSortLe leAlt joinedAlts
566 -- naturalMergeSortLe, because we often get sorted alts to begin with
568 lowTag = intTag (fst (head sortedAlts))
569 highTag = intTag (fst (last sortedAlts))
571 -- lowest and highest possible values the discriminant could take
572 lowest = if floating then targetMinDouble else targetMinInt
573 highest = if floating then targetMaxDouble else targetMaxInt
576 if not floating && choices > 4
577 && highTag - lowTag < toInteger (2 * choices)
579 mkJumpTable am' sortedAlts lowTag highTag udlbl
581 mkBinaryTree am' floating sortedAlts choices lowest highest udlbl
583 `thenUs` \ alt_code ->
584 gencode absC `thenUs` \ dflt_code ->
586 returnUs (\xs -> alt_code (StLabel udlbl : dflt_code (StLabel ujlbl : xs)))
589 floating = isFloatingRep (getAmodeRep am)
590 choices = length alts
592 (x@(MachChar _),_) `leAlt` (y,_) = intTag x <= intTag y
593 (x@(MachInt _), _) `leAlt` (y,_) = intTag x <= intTag y
594 (x@(MachWord _), _) `leAlt` (y,_) = intTag x <= intTag y
595 (x,_) `leAlt` (y,_) = fltTag x <= fltTag y
599 We use jump tables when doing an integer switch on a relatively dense
600 list of alternatives. We expect to be given a list of alternatives,
601 sorted by tag, and a range of values for which we are to generate a
602 table. Of course, the tags of the alternatives should lie within the
603 indicated range. The alternatives need not cover the range; a default
604 target is provided for the missing alternatives.
606 If a join is necessary after the switch, the alternatives should
607 already finish with a jump to the join point.
612 :: StixTree -- discriminant
613 -> [(Literal, AbstractC)] -- alternatives
614 -> Integer -- low tag
615 -> Integer -- high tag
616 -> CLabel -- default label
617 -> UniqSM StixTreeList
620 mkJumpTable am alts lowTag highTag dflt
621 = getUniqLabelNCG `thenUs` \ utlbl ->
622 mapUs genLabel alts `thenUs` \ branches ->
623 let cjmpLo = StCondJump dflt (StMachOp MO_NatS_Lt [am, StInt (toInteger lowTag)])
624 cjmpHi = StCondJump dflt (StMachOp MO_NatS_Gt [am, StInt (toInteger highTag)])
626 offset = StMachOp MO_Nat_Sub [am, StInt lowTag]
627 dsts = DestInfo (dflt : map fst branches)
629 jump = StJump dsts (StInd PtrRep (StIndex PtrRep (StCLbl utlbl) offset))
631 table = StData PtrRep (mkTable branches [lowTag..highTag] [])
633 mapUs mkBranch branches `thenUs` \ alts ->
635 returnUs (\xs -> cjmpLo : cjmpHi : jump :
636 StSegment DataSegment : tlbl : table :
637 StSegment TextSegment : foldr1 (.) alts xs)
640 genLabel x = getUniqLabelNCG `thenUs` \ lbl -> returnUs (lbl, x)
642 mkBranch (lbl,(_,alt)) =
643 gencode alt `thenUs` \ alt_code ->
644 returnUs (\xs -> StLabel lbl : alt_code xs)
646 mkTable _ [] tbl = reverse tbl
647 mkTable [] (x:xs) tbl = mkTable [] xs (StCLbl dflt : tbl)
648 mkTable alts@((lbl,(tag,_)):rest) (x:xs) tbl
649 | intTag tag == x = mkTable rest xs (StCLbl lbl : tbl)
650 | otherwise = mkTable alts xs (StCLbl dflt : tbl)
654 We generate binary comparison trees when a jump table is inappropriate.
655 We expect to be given a list of alternatives, sorted by tag, and for
656 convenience, the length of the alternative list. We recursively break
657 the list in half and do a comparison on the first tag of the second half
658 of the list. (Odd lists are broken so that the second half of the list
659 is longer.) We can handle either integer or floating kind alternatives,
660 so long as they are not mixed. (We assume that the type of the discriminant
661 determines the type of the alternatives.)
663 As with the jump table approach, if a join is necessary after the switch, the
664 alternatives should already finish with a jump to the join point.
669 :: StixTree -- discriminant
670 -> Bool -- floating point?
671 -> [(Literal, AbstractC)] -- alternatives
672 -> Int -- number of choices
673 -> Literal -- low tag
674 -> Literal -- high tag
675 -> CLabel -- default code label
676 -> UniqSM StixTreeList
679 mkBinaryTree am floating [(tag,alt)] _ lowTag highTag udlbl
680 | rangeOfOne = gencode alt
682 = let tag' = a2stix (CLit tag)
683 cmpOp = if floating then MO_Dbl_Ne else MO_Nat_Ne
684 test = StMachOp cmpOp [am, tag']
685 cjmp = StCondJump udlbl test
687 gencode alt `thenUs` \ alt_code ->
688 returnUs (\xs -> cjmp : alt_code xs)
691 rangeOfOne = not floating && intTag lowTag + 1 >= intTag highTag
692 -- When there is only one possible tag left in range, we skip the comparison
694 mkBinaryTree am floating alts choices lowTag highTag udlbl
695 = getUniqLabelNCG `thenUs` \ uhlbl ->
696 let tag' = a2stix (CLit splitTag)
697 cmpOp = if floating then MO_Dbl_Ge else MO_NatS_Ge
698 test = StMachOp cmpOp [am, tag']
699 cjmp = StCondJump uhlbl test
701 mkBinaryTree am floating alts_lo half lowTag splitTag udlbl
702 `thenUs` \ lo_code ->
703 mkBinaryTree am floating alts_hi (choices - half) splitTag highTag udlbl
704 `thenUs` \ hi_code ->
706 returnUs (\xs -> cjmp : lo_code (StLabel uhlbl : hi_code xs))
709 half = choices `div` 2
710 (alts_lo, alts_hi) = splitAt half alts
711 splitTag = fst (head alts_hi)
718 :: CAddrMode -- discriminant
720 -> AbstractC -- if-part
721 -> AbstractC -- else-part
722 -> UniqSM StixTreeList
725 mkIfThenElse discrim tag alt deflt
726 = getUniqLabelNCG `thenUs` \ ujlbl ->
727 getUniqLabelNCG `thenUs` \ utlbl ->
728 let discrim' = a2stix discrim
729 tag' = a2stix (CLit tag)
730 cmpOp = if (isFloatingRep (getAmodeRep discrim)) then MO_Dbl_Ne else MO_Nat_Ne
731 test = StMachOp cmpOp [discrim', tag']
732 cjmp = StCondJump utlbl test
736 gencode (mkJoin alt ujlbl) `thenUs` \ alt_code ->
737 gencode deflt `thenUs` \ dflt_code ->
738 returnUs (\xs -> cjmp : alt_code (dest : dflt_code (join : xs)))
741 mkJoin :: AbstractC -> CLabel -> AbstractC
743 | mightFallThrough code = mkAbsCStmts code (CJump (CLbl lbl PtrRep))
747 %---------------------------------------------------------------------------
749 This answers the question: Can the code fall through to the next
750 line(s) of code? This errs towards saying True if it can't choose,
751 because it is used for eliminating needless jumps. In other words, if
752 you might possibly {\em not} jump, then say yes to falling through.
755 mightFallThrough :: AbstractC -> Bool
757 mightFallThrough absC = ft absC True
759 ft AbsCNop if_empty = if_empty
761 ft (CJump _) if_empty = False
762 ft (CReturn _ _) if_empty = False
763 ft (CSwitch _ alts deflt) if_empty
764 = ft deflt if_empty ||
765 or [ft alt if_empty | (_,alt) <- alts]
767 ft (AbsCStmts c1 c2) if_empty = ft c2 (ft c1 if_empty)
768 ft _ if_empty = if_empty
770 {- Old algorithm, which called nonemptyAbsC for every subexpression! =========
771 fallThroughAbsC (AbsCStmts c1 c2)
772 = case nonemptyAbsC c2 of
773 Nothing -> fallThroughAbsC c1
774 Just x -> fallThroughAbsC x
775 fallThroughAbsC (CJump _) = False
776 fallThroughAbsC (CReturn _ _) = False
777 fallThroughAbsC (CSwitch _ choices deflt)
778 = (not (isEmptyAbsC deflt) && fallThroughAbsC deflt)
779 || or (map (fallThroughAbsC . snd) choices)
780 fallThroughAbsC other = True
782 isEmptyAbsC :: AbstractC -> Bool
783 isEmptyAbsC = not . maybeToBool . nonemptyAbsC
784 ================= End of old, quadratic, algorithm -}