ghc/compiler/nativeGen/AbsCStixGen.lhs

   1 %
   2 % (c) The AQUA Project, Glasgow University, 1993-1998
   3 %
   4
   5 \begin{code}
   6 module AbsCStixGen ( genCodeAbstractC ) where
   7
   8 #include "HsVersions.h"
   9
  10 import Ratio    ( Rational )
  11
  12 import AbsCSyn
  13 import Stix
  14 import MachMisc
  15
  16 import AbsCUtils        ( getAmodeRep, mixedTypeLocn,
  17                           nonemptyAbsC, mkAbsCStmts, mkAbsCStmtList
  18                         )
  19 import SMRep            ( fixedItblSize,
  20                           rET_SMALL, rET_BIG,
  21                           rET_VEC_SMALL, rET_VEC_BIG
  22                         )
  23 import Constants        ( mIN_UPD_SIZE )
  24 import CLabel           ( CLabel, mkReturnInfoLabel, mkReturnPtLabel )
  25 import ClosureInfo      ( infoTableLabelFromCI, entryLabelFromCI,
  26                           fastLabelFromCI, closureUpdReqd
  27                         )
  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 )
  39
  40 #ifdef REALLY_HASKELL_1_3
  41 ord = fromEnum :: Char -> Int
  42 #endif
  43 \end{code}
  44
  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.
  49
  50 \begin{code}
  51 genCodeAbstractC :: AbstractC -> UniqSM [[StixTree]]
  52
  53 genCodeAbstractC absC
  54   = mapUs gentopcode (mkAbsCStmtList absC) `thenUs` \ trees ->
  55     returnUs ([StComment SLIT("Native Code")] : trees)
  56  where
  57  a2stix      = amodeToStix
  58  a2stix'     = amodeToStix'
  59  volsaves    = volatileSaves
  60  volrestores = volatileRestores
  61  p2stix      = primCode
  62  macro_code  = macroCode
  63  -- real code follows... ---------
  64 \end{code}
  65
  66 Here we handle top-level things, like @CCodeBlock@s and
  67 @CClosureInfoTable@s.
  68
  69 \begin{code}
  70  {-
  71  genCodeTopAbsC
  72     :: AbstractC
  73     -> UniqSM [StixTree]
  74  -}
  75
  76  gentopcode (CCodeBlock label absC)
  77   = gencode absC                                `thenUs` \ code ->
  78     returnUs (StSegment TextSegment : StFunBegin label : code [StFunEnd label])
  79
  80  gentopcode stmt@(CStaticClosure label _ _ _)
  81   = genCodeStaticClosure stmt                   `thenUs` \ code ->
  82     returnUs (StSegment DataSegment : StLabel label : code [])
  83
  84  gentopcode stmt@(CRetVector label _ _ _)
  85   = genCodeVecTbl stmt                          `thenUs` \ code ->
  86     returnUs (StSegment TextSegment : code [StLabel label])
  87
  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 []))
  93   where
  94         lbl_info = mkReturnInfoLabel uniq
  95         lbl_ret  = mkReturnPtLabel uniq
  96         closure_type = case liveness of
  97                          LvSmall _ -> rET_SMALL
  98                          LvLarge _ -> rET_BIG
  99
 100  gentopcode stmt@(CClosureInfoAndCode cl_info slow Nothing _ _)
 101
 102   | slow_is_empty
 103   = genCodeInfoTable stmt               `thenUs` \ itbl ->
 104     returnUs (StSegment TextSegment : itbl [])
 105
 106   | otherwise
 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]))
 111   where
 112     slow_is_empty = not (maybeToBool (nonemptyAbsC slow))
 113     slow_lbl = entryLabelFromCI cl_info
 114
 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])))
 123   where
 124     slow_lbl = entryLabelFromCI cl_info
 125     fast_lbl = fastLabelFromCI cl_info
 126
 127  gentopcode stmt@(CSRT lbl closures)
 128   = returnUs [ StSegment TextSegment
 129              , StLabel lbl
 130              , StData DataPtrRep (map StCLbl closures)
 131              ]
 132
 133  gentopcode stmt@(CBitmap lbl mask)
 134   = returnUs [ StSegment TextSegment
 135              , StLabel lbl
 136              , StData WordRep (StInt (toInteger (length mask)) :
 137                                 map  (StInt . toInteger . intBS) mask)
 138              ]
 139
 140  gentopcode absC
 141   = gencode absC                                `thenUs` \ code ->
 142     returnUs (StSegment TextSegment : code [])
 143
 144 \end{code}
 145
 146 \begin{code}
 147  {-
 148  genCodeVecTbl
 149     :: AbstractC
 150     -> UniqSM StixTreeList
 151  -}
 152  genCodeVecTbl (CRetVector label amodes srt liveness)
 153   = genBitmapInfoTable liveness srt closure_type True `thenUs` \itbl ->
 154     returnUs (\xs -> vectbl : itbl xs)
 155   where
 156     vectbl = StData PtrRep (reverse (map a2stix amodes))
 157     closure_type = case liveness of
 158                     LvSmall _ -> rET_VEC_SMALL
 159                     LvLarge _ -> rET_VEC_BIG
 160
 161 \end{code}
 162
 163 \begin{code}
 164  {-
 165  genCodeStaticClosure
 166     :: AbstractC
 167     -> UniqSM StixTreeList
 168  -}
 169  genCodeStaticClosure (CStaticClosure _ cl_info cost_centre amodes)
 170   = returnUs (\xs -> table : xs)
 171   where
 172     table = StData PtrRep (StCLbl info_lbl : body)
 173     info_lbl = infoTableLabelFromCI cl_info
 174
 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)
 179            else
 180                 amodes' ++ [StInt 0]
 181
 182     zeros = StInt 0 : zeros
 183
 184     amodes' = map amodeZeroVoid amodes
 185
 186         -- Watch out for VoidKinds...cf. PprAbsC
 187     amodeZeroVoid item
 188       | getAmodeRep item == VoidRep = StInt 0
 189       | otherwise = a2stix item
 190
 191 \end{code}
 192
 193 Now the individual AbstractC statements.
 194
 195 \begin{code}
 196  {-
 197  gencode
 198     :: AbstractC
 199     -> UniqSM StixTreeList
 200  -}
 201 \end{code}
 202
 203 @AbsCNop@s just disappear.
 204
 205 \begin{code}
 206
 207  gencode AbsCNop = returnUs id
 208
 209 \end{code}
 210
 211 Split markers are a NOP in this land.
 212
 213 \begin{code}
 214
 215  gencode CSplitMarker = returnUs id
 216
 217 \end{code}
 218
 219 AbstractC instruction sequences are handled individually, and the
 220 resulting StixTreeLists are joined together.
 221
 222 \begin{code}
 223
 224  gencode (AbsCStmts c1 c2)
 225   = gencode c1                          `thenUs` \ b1 ->
 226     gencode c2                          `thenUs` \ b2 ->
 227     returnUs (b1 . b2)
 228
 229 \end{code}
 230
 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
 235 addresses, etc.)
 236
 237 \begin{code}
 238
 239  gencode (CInitHdr cl_info reg_rel _)
 240   = let
 241         lhs = a2stix (CVal reg_rel PtrRep)
 242         lbl = infoTableLabelFromCI cl_info
 243     in
 244         returnUs (\xs -> StAssign PtrRep lhs (StCLbl lbl) : xs)
 245
 246 \end{code}
 247
 248 Heap/Stack Checks.
 249
 250 \begin{code}
 251
 252  gencode (CCheck macro args assts)
 253   = gencode assts `thenUs` \assts_stix ->
 254     checkCode macro args assts_stix
 255
 256 \end{code}
 257
 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.
 264
 265 \begin{code}
 266
 267  gencode (CAssign lhs rhs)
 268   | getAmodeRep lhs == VoidRep = returnUs id
 269   | otherwise
 270   = let pk = getAmodeRep lhs
 271         pk' = if mixedTypeLocn lhs && not (isFloatingRep pk) then IntRep else pk
 272         lhs' = a2stix lhs
 273         rhs' = a2stix' rhs
 274     in
 275         returnUs (\xs -> StAssign pk' lhs' rhs' : xs)
 276
 277 \end{code}
 278
 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.
 282
 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.
 286
 287 \begin{code}
 288
 289  gencode (CJump dest)
 290   = returnUs (\xs -> StJump (a2stix dest) : xs)
 291
 292  gencode (CFallThrough (CLbl lbl _))
 293   = returnUs (\xs -> StFallThrough lbl : xs)
 294
 295  gencode (CReturn dest DirectReturn)
 296   = returnUs (\xs -> StJump (a2stix dest) : xs)
 297
 298  gencode (CReturn table (StaticVectoredReturn n))
 299   = returnUs (\xs -> StJump dest : xs)
 300   where
 301     dest = StInd PtrRep (StIndex PtrRep (a2stix table)
 302                                   (StInt (toInteger (-n-fixedItblSize-1))))
 303
 304  gencode (CReturn table (DynamicVectoredReturn am))
 305   = returnUs (\xs -> StJump dest : xs)
 306   where
 307     dest = StInd PtrRep (StIndex PtrRep (a2stix table) dyn_off)
 308     dyn_off = StPrim IntSubOp [StPrim IntNegOp [a2stix am],
 309                                StInt (toInteger (fixedItblSize+1))]
 310
 311 \end{code}
 312
 313 Now the PrimOps, some of which may need caller-saves register wrappers.
 314
 315 \begin{code}
 316
 317  gencode (COpStmt results op args vols)
 318   -- ToDo (ADR?): use that liveness mask
 319   | primOpNeedsWrapper op
 320   = let
 321         saves = volsaves vols
 322         restores = volrestores vols
 323     in
 324         p2stix (nonVoid results) op (nonVoid args)
 325                                                         `thenUs` \ code ->
 326         returnUs (\xs -> saves ++ code (restores ++ xs))
 327
 328   | otherwise = p2stix (nonVoid results) op (nonVoid args)
 329     where
 330         nonVoid = filter ((/= VoidRep) . getAmodeRep)
 331
 332 \end{code}
 333
 334 Now the dreaded conditional jump.
 335
 336 Now the if statement.  Almost *all* flow of control are of this form.
 337 @
 338         if (am==lit) { absC } else { absCdef }
 339 @
 340         =>
 341 @
 342         IF am = lit GOTO l1:
 343         absC
 344         jump l2:
 345    l1:
 346         absCdef
 347    l2:
 348 @
 349
 350 \begin{code}
 351
 352  gencode (CSwitch discrim alts deflt)
 353   = case alts of
 354       [] -> gencode deflt
 355
 356       [(tag,alt_code)] -> case maybe_empty_deflt of
 357                                 Nothing -> gencode alt_code
 358                                 Just dc -> mkIfThenElse discrim tag alt_code dc
 359
 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
 366
 367         -- If the @discrim@ is simple, then this unfolding is safe.
 368       other | simple_discrim -> mkSimpleSwitches discrim alts deflt
 369
 370         -- Otherwise, we need to do a bit of work.
 371       other ->  getUniqueUs                       `thenUs` \ u ->
 372                 gencode (AbsCStmts
 373                 (CAssign (CTemp u pk) discrim)
 374                 (CSwitch (CTemp u pk) alts deflt))
 375
 376   where
 377     maybe_empty_deflt = nonemptyAbsC deflt
 378     deflt_is_empty = case maybe_empty_deflt of
 379                         Nothing -> True
 380                         Just _  -> False
 381
 382     pk = getAmodeRep discrim
 383
 384     simple_discrim = case discrim of
 385                         CReg _    -> True
 386                         CTemp _ _ -> True
 387                         other     -> False
 388 \end{code}
 389
 390
 391
 392 Finally, all of the disgusting AbstractC macros.
 393
 394 \begin{code}
 395
 396  gencode (CMacroStmt macro args) = macro_code macro args
 397
 398  gencode (CCallProfCtrMacro macro _)
 399   = returnUs (\xs -> StComment macro : xs)
 400
 401  gencode (CCallProfCCMacro macro _)
 402   = returnUs (\xs -> StComment macro : xs)
 403
 404 \end{code}
 405
 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
 409 be tuned.)
 410
 411 \begin{code}
 412
 413  intTag :: Literal -> Integer
 414  intTag (MachChar c)  = fromInt (ord c)
 415  intTag (MachInt i _) = i
 416  intTag _ = panic "intTag"
 417
 418  fltTag :: Literal -> Rational
 419
 420  fltTag (MachFloat f) = f
 421  fltTag (MachDouble d) = d
 422  fltTag _ = panic "fltTag"
 423
 424  {-
 425  mkSimpleSwitches
 426     :: CAddrMode -> [(Literal,AbstractC)] -> AbstractC
 427     -> UniqSM StixTreeList
 428  -}
 429  mkSimpleSwitches am alts absC
 430   = getUniqLabelNCG                                     `thenUs` \ udlbl ->
 431     getUniqLabelNCG                                     `thenUs` \ ujlbl ->
 432     let am' = a2stix am
 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
 436
 437         lowTag = intTag (fst (head sortedAlts))
 438         highTag = intTag (fst (last sortedAlts))
 439
 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
 443     in
 444         (
 445         if not floating && choices > 4 && highTag - lowTag < toInteger (2 * choices) then
 446             mkJumpTable am' sortedAlts lowTag highTag udlbl
 447         else
 448             mkBinaryTree am' floating sortedAlts choices lowest highest udlbl
 449         )
 450                                                         `thenUs` \ alt_code ->
 451         gencode absC                            `thenUs` \ dflt_code ->
 452
 453         returnUs (\xs -> alt_code (StLabel udlbl : dflt_code (StLabel ujlbl : xs)))
 454
 455     where
 456         floating = isFloatingRep (getAmodeRep am)
 457         choices = length alts
 458
 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
 462
 463 \end{code}
 464
 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.
 471
 472 If a join is necessary after the switch, the alternatives should
 473 already finish with a jump to the join point.
 474
 475 \begin{code}
 476  {-
 477  mkJumpTable
 478     :: StixTree                 -- discriminant
 479     -> [(Literal, AbstractC)]   -- alternatives
 480     -> Integer                  -- low tag
 481     -> Integer                  -- high tag
 482     -> CLabel                   -- default label
 483     -> UniqSM StixTreeList
 484  -}
 485
 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)])
 491
 492         offset = StPrim IntSubOp [am, StInt lowTag]
 493
 494         jump = StJump (StInd PtrRep (StIndex PtrRep (StCLbl utlbl) offset))
 495         tlbl = StLabel utlbl
 496         table = StData PtrRep (mkTable branches [lowTag..highTag] [])
 497     in
 498         mapUs mkBranch branches                         `thenUs` \ alts ->
 499
 500         returnUs (\xs -> cjmpLo : cjmpHi : jump :
 501                          StSegment DataSegment : tlbl : table :
 502                          StSegment TextSegment : foldr1 (.) alts xs)
 503
 504     where
 505         genLabel x = getUniqLabelNCG `thenUs` \ lbl -> returnUs (lbl, x)
 506
 507         mkBranch (lbl,(_,alt)) =
 508             gencode alt                         `thenUs` \ alt_code ->
 509             returnUs (\xs -> StLabel lbl : alt_code xs)
 510
 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)
 516
 517 \end{code}
 518
 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.)
 527
 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.
 530
 531 \begin{code}
 532  {-
 533  mkBinaryTree
 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
 542  -}
 543
 544  mkBinaryTree am floating [(tag,alt)] _ lowTag highTag udlbl
 545   | rangeOfOne = gencode alt
 546   | otherwise
 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
 551     in
 552         gencode alt                             `thenUs` \ alt_code ->
 553         returnUs (\xs -> cjmp : alt_code xs)
 554
 555     where
 556         rangeOfOne = not floating && intTag lowTag + 1 >= intTag highTag
 557         -- When there is only one possible tag left in range, we skip the comparison
 558
 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
 565     in
 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 ->
 570
 571         returnUs (\xs -> cjmp : lo_code (StLabel uhlbl : hi_code xs))
 572
 573     where
 574         half = choices `div` 2
 575         (alts_lo, alts_hi) = splitAt half alts
 576         splitTag = fst (head alts_hi)
 577
 578 \end{code}
 579
 580 \begin{code}
 581  {-
 582  mkIfThenElse
 583     :: CAddrMode            -- discriminant
 584     -> Literal              -- tag
 585     -> AbstractC            -- if-part
 586     -> AbstractC            -- else-part
 587     -> UniqSM StixTreeList
 588  -}
 589
 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
 598         dest = StLabel utlbl
 599         join = StLabel ujlbl
 600     in
 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)))
 604
 605 mkJoin :: AbstractC -> CLabel -> AbstractC
 606
 607 mkJoin code lbl
 608   | mightFallThrough code = mkAbsCStmts code (CJump (CLbl lbl PtrRep))
 609   | otherwise = code
 610 \end{code}
 611
 612 %---------------------------------------------------------------------------
 613
 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.
 618
 619 \begin{code}
 620 mightFallThrough :: AbstractC -> Bool
 621
 622 mightFallThrough absC = ft absC True
 623  where
 624   ft AbsCNop       if_empty = if_empty
 625
 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]
 631
 632   ft (AbsCStmts c1 c2) if_empty = ft c2 (ft c1 if_empty)
 633   ft _ if_empty = if_empty
 634
 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
 646
 647 isEmptyAbsC :: AbstractC -> Bool
 648 isEmptyAbsC = not . maybeToBool . nonemptyAbsC
 649 ================= End of old, quadratic, algorithm -}
 650 \end{code}