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, panic )
  37 import BitSet           ( intBS )
  38
  39 #ifdef REALLY_HASKELL_1_3
  40 ord = fromEnum :: Char -> Int
  41 #endif
  42 \end{code}
  43
  44 For each independent chunk of AbstractC code, we generate a list of
  45 @StixTree@s, where each tree corresponds to a single Stix instruction.
  46 We leave the chunks separated so that register allocation can be
  47 performed locally within the chunk.
  48
  49 \begin{code}
  50 genCodeAbstractC :: AbstractC -> UniqSM [[StixTree]]
  51
  52 genCodeAbstractC absC
  53   = mapUs gentopcode (mkAbsCStmtList absC) `thenUs` \ trees ->
  54     returnUs ([StComment SLIT("Native Code")] : trees)
  55  where
  56  a2stix      = amodeToStix
  57  a2stix'     = amodeToStix'
  58  volsaves    = volatileSaves
  59  volrestores = volatileRestores
  60  p2stix      = primCode
  61  macro_code  = macroCode
  62  -- real code follows... ---------
  63 \end{code}
  64
  65 Here we handle top-level things, like @CCodeBlock@s and
  66 @CClosureInfoTable@s.
  67
  68 \begin{code}
  69  {-
  70  genCodeTopAbsC
  71     :: AbstractC
  72     -> UniqSM [StixTree]
  73  -}
  74
  75  gentopcode (CCodeBlock label absC)
  76   = gencode absC                                `thenUs` \ code ->
  77     returnUs (StSegment TextSegment : StFunBegin label : code [StFunEnd label])
  78
  79  gentopcode stmt@(CStaticClosure label _ _ _)
  80   = genCodeStaticClosure stmt                   `thenUs` \ code ->
  81     returnUs (StSegment DataSegment : StLabel label : code [])
  82
  83  gentopcode stmt@(CRetVector label _ _ _)
  84   = genCodeVecTbl stmt                          `thenUs` \ code ->
  85     returnUs (StSegment TextSegment : code [StLabel label])
  86
  87  gentopcode stmt@(CRetDirect uniq absC srt liveness)
  88   = gencode absC                                       `thenUs` \ code ->
  89     genBitmapInfoTable liveness srt closure_type False `thenUs` \ itbl ->
  90     returnUs (StSegment TextSegment :
  91               itbl (StLabel lbl_info : StLabel lbl_ret : code []))
  92   where
  93         lbl_info = mkReturnInfoLabel uniq
  94         lbl_ret  = mkReturnPtLabel uniq
  95         closure_type = case liveness of
  96                          LvSmall _ -> rET_SMALL
  97                          LvLarge _ -> rET_BIG
  98
  99  gentopcode stmt@(CClosureInfoAndCode cl_info slow Nothing _ _)
 100
 101   | slow_is_empty
 102   = genCodeInfoTable stmt               `thenUs` \ itbl ->
 103     returnUs (StSegment TextSegment : itbl [])
 104
 105   | otherwise
 106   = genCodeInfoTable stmt               `thenUs` \ itbl ->
 107     gencode slow                        `thenUs` \ slow_code ->
 108     returnUs (StSegment TextSegment : itbl (StFunBegin slow_lbl :
 109               slow_code [StFunEnd slow_lbl]))
 110   where
 111     slow_is_empty = not (maybeToBool (nonemptyAbsC slow))
 112     slow_lbl = entryLabelFromCI cl_info
 113
 114  gentopcode stmt@(CClosureInfoAndCode cl_info slow (Just fast) _ _) =
 115  -- ToDo: what if this is empty? ------------------------^^^^
 116     genCodeInfoTable stmt               `thenUs` \ itbl ->
 117     gencode slow                        `thenUs` \ slow_code ->
 118     gencode fast                        `thenUs` \ fast_code ->
 119     returnUs (StSegment TextSegment : itbl (StFunBegin slow_lbl :
 120               slow_code (StFunEnd slow_lbl : StFunBegin fast_lbl :
 121               fast_code [StFunEnd fast_lbl])))
 122   where
 123     slow_lbl = entryLabelFromCI cl_info
 124     fast_lbl = fastLabelFromCI cl_info
 125
 126  gentopcode stmt@(CSRT lbl closures)
 127   = returnUs [ StSegment TextSegment
 128              , StLabel lbl
 129              , StData DataPtrRep (map StCLbl closures)
 130              ]
 131
 132  gentopcode stmt@(CBitmap lbl mask)
 133   = returnUs [ StSegment TextSegment
 134              , StLabel lbl
 135              , StData WordRep (StInt (toInteger (length mask)) :
 136                                 map  (StInt . toInteger . intBS) mask)
 137              ]
 138
 139  gentopcode absC
 140   = gencode absC                                `thenUs` \ code ->
 141     returnUs (StSegment TextSegment : code [])
 142
 143 \end{code}
 144
 145 \begin{code}
 146  {-
 147  genCodeVecTbl
 148     :: AbstractC
 149     -> UniqSM StixTreeList
 150  -}
 151  genCodeVecTbl (CRetVector label amodes srt liveness)
 152   = genBitmapInfoTable liveness srt closure_type True `thenUs` \itbl ->
 153     returnUs (\xs -> vectbl : itbl xs)
 154   where
 155     vectbl = StData PtrRep (reverse (map a2stix amodes))
 156     closure_type = case liveness of
 157                     LvSmall _ -> rET_VEC_SMALL
 158                     LvLarge _ -> rET_VEC_BIG
 159
 160 \end{code}
 161
 162 \begin{code}
 163  {-
 164  genCodeStaticClosure
 165     :: AbstractC
 166     -> UniqSM StixTreeList
 167  -}
 168  genCodeStaticClosure (CStaticClosure _ cl_info cost_centre amodes)
 169   = returnUs (\xs -> table : xs)
 170   where
 171     table = StData PtrRep (StCLbl info_lbl : body)
 172     info_lbl = infoTableLabelFromCI cl_info
 173
 174     -- always at least one padding word: this is the static link field
 175     -- for the garbage collector.
 176     body = if closureUpdReqd cl_info then
 177                 take (1 + max mIN_UPD_SIZE (length amodes')) (amodes' ++ zeros)
 178            else
 179                 amodes' ++ [StInt 0]
 180
 181     zeros = StInt 0 : zeros
 182
 183     amodes' = map amodeZeroVoid amodes
 184
 185         -- Watch out for VoidKinds...cf. PprAbsC
 186     amodeZeroVoid item
 187       | getAmodeRep item == VoidRep = StInt 0
 188       | otherwise = a2stix item
 189
 190 \end{code}
 191
 192 Now the individual AbstractC statements.
 193
 194 \begin{code}
 195  {-
 196  gencode
 197     :: AbstractC
 198     -> UniqSM StixTreeList
 199  -}
 200 \end{code}
 201
 202 @AbsCNop@s just disappear.
 203
 204 \begin{code}
 205
 206  gencode AbsCNop = returnUs id
 207
 208 \end{code}
 209
 210 Split markers are a NOP in this land.
 211
 212 \begin{code}
 213
 214  gencode CSplitMarker = returnUs id
 215
 216 \end{code}
 217
 218 AbstractC instruction sequences are handled individually, and the
 219 resulting StixTreeLists are joined together.
 220
 221 \begin{code}
 222
 223  gencode (AbsCStmts c1 c2)
 224   = gencode c1                          `thenUs` \ b1 ->
 225     gencode c2                          `thenUs` \ b2 ->
 226     returnUs (b1 . b2)
 227
 228 \end{code}
 229
 230 Initialising closure headers in the heap...a fairly complex ordeal if
 231 done properly.  For now, we just set the info pointer, but we should
 232 really take a peek at the flags to determine whether or not there are
 233 other things to be done (setting cost centres, age headers, global
 234 addresses, etc.)
 235
 236 \begin{code}
 237
 238  gencode (CInitHdr cl_info reg_rel _)
 239   = let
 240         lhs = a2stix (CVal reg_rel PtrRep)
 241         lbl = infoTableLabelFromCI cl_info
 242     in
 243         returnUs (\xs -> StAssign PtrRep lhs (StCLbl lbl) : xs)
 244
 245 \end{code}
 246
 247 Heap/Stack Checks.
 248
 249 \begin{code}
 250
 251  gencode (CCheck macro args assts)
 252   = gencode assts `thenUs` \assts_stix ->
 253     checkCode macro args assts_stix
 254
 255 \end{code}
 256
 257 Assignment, the curse of von Neumann, is the center of the code we
 258 produce.  In most cases, the type of the assignment is determined
 259 by the type of the destination.  However, when the destination can
 260 have mixed types, the type of the assignment is ``StgWord'' (we use
 261 PtrRep for lack of anything better).  Think:  do we also want a cast
 262 of the source?  Be careful about floats/doubles.
 263
 264 \begin{code}
 265
 266  gencode (CAssign lhs rhs)
 267   | getAmodeRep lhs == VoidRep = returnUs id
 268   | otherwise
 269   = let pk = getAmodeRep lhs
 270         pk' = if mixedTypeLocn lhs && not (isFloatingRep pk) then IntRep else pk
 271         lhs' = a2stix lhs
 272         rhs' = a2stix' rhs
 273     in
 274         returnUs (\xs -> StAssign pk' lhs' rhs' : xs)
 275
 276 \end{code}
 277
 278 Unconditional jumps, including the special ``enter closure'' operation.
 279 Note that the new entry convention requires that we load the InfoPtr (R2)
 280 with the address of the info table before jumping to the entry code for Node.
 281
 282 For a vectored return, we must subtract the size of the info table to
 283 get at the return vector.  This depends on the size of the info table,
 284 which varies depending on whether we're profiling etc.
 285
 286 \begin{code}
 287
 288  gencode (CJump dest)
 289   = returnUs (\xs -> StJump (a2stix dest) : xs)
 290
 291  gencode (CFallThrough (CLbl lbl _))
 292   = returnUs (\xs -> StFallThrough lbl : xs)
 293
 294  gencode (CReturn dest DirectReturn)
 295   = returnUs (\xs -> StJump (a2stix dest) : xs)
 296
 297  gencode (CReturn table (StaticVectoredReturn n))
 298   = returnUs (\xs -> StJump dest : xs)
 299   where
 300     dest = StInd PtrRep (StIndex PtrRep (a2stix table)
 301                                   (StInt (toInteger (-n-fixedItblSize-1))))
 302
 303  gencode (CReturn table (DynamicVectoredReturn am))
 304   = returnUs (\xs -> StJump dest : xs)
 305   where
 306     dest = StInd PtrRep (StIndex PtrRep (a2stix table) dyn_off)
 307     dyn_off = StPrim IntSubOp [StPrim IntNegOp [a2stix am],
 308                                StInt (toInteger (fixedItblSize+1))]
 309
 310 \end{code}
 311
 312 Now the PrimOps, some of which may need caller-saves register wrappers.
 313
 314 \begin{code}
 315
 316  gencode (COpStmt results op args vols)
 317   -- ToDo (ADR?): use that liveness mask
 318   | primOpNeedsWrapper op
 319   = let
 320         saves = volsaves vols
 321         restores = volrestores vols
 322     in
 323         p2stix (nonVoid results) op (nonVoid args)
 324                                                         `thenUs` \ code ->
 325         returnUs (\xs -> saves ++ code (restores ++ xs))
 326
 327   | otherwise = p2stix (nonVoid results) op (nonVoid args)
 328     where
 329         nonVoid = filter ((/= VoidRep) . getAmodeRep)
 330
 331 \end{code}
 332
 333 Now the dreaded conditional jump.
 334
 335 Now the if statement.  Almost *all* flow of control are of this form.
 336 @
 337         if (am==lit) { absC } else { absCdef }
 338 @
 339         =>
 340 @
 341         IF am = lit GOTO l1:
 342         absC
 343         jump l2:
 344    l1:
 345         absCdef
 346    l2:
 347 @
 348
 349 \begin{code}
 350
 351  gencode (CSwitch discrim alts deflt)
 352   = case alts of
 353       [] -> gencode deflt
 354
 355       [(tag,alt_code)] -> case maybe_empty_deflt of
 356                                 Nothing -> gencode alt_code
 357                                 Just dc -> mkIfThenElse discrim tag alt_code dc
 358
 359       [(tag1@(MachInt i1 _), alt_code1),
 360        (tag2@(MachInt i2 _), alt_code2)]
 361         | deflt_is_empty && i1 == 0 && i2 == 1
 362         -> mkIfThenElse discrim tag1 alt_code1 alt_code2
 363         | deflt_is_empty && i1 == 1 && i2 == 0
 364         -> mkIfThenElse discrim tag2 alt_code2 alt_code1
 365
 366         -- If the @discrim@ is simple, then this unfolding is safe.
 367       other | simple_discrim -> mkSimpleSwitches discrim alts deflt
 368
 369         -- Otherwise, we need to do a bit of work.
 370       other ->  getUniqueUs                       `thenUs` \ u ->
 371                 gencode (AbsCStmts
 372                 (CAssign (CTemp u pk) discrim)
 373                 (CSwitch (CTemp u pk) alts deflt))
 374
 375   where
 376     maybe_empty_deflt = nonemptyAbsC deflt
 377     deflt_is_empty = case maybe_empty_deflt of
 378                         Nothing -> True
 379                         Just _  -> False
 380
 381     pk = getAmodeRep discrim
 382
 383     simple_discrim = case discrim of
 384                         CReg _    -> True
 385                         CTemp _ _ -> True
 386                         other     -> False
 387 \end{code}
 388
 389
 390
 391 Finally, all of the disgusting AbstractC macros.
 392
 393 \begin{code}
 394
 395  gencode (CMacroStmt macro args) = macro_code macro args
 396
 397  gencode (CCallProfCtrMacro macro _)
 398   = returnUs (\xs -> StComment macro : xs)
 399
 400  gencode (CCallProfCCMacro macro _)
 401   = returnUs (\xs -> StComment macro : xs)
 402
 403 \end{code}
 404
 405 Here, we generate a jump table if there are more than four (integer)
 406 alternatives and the jump table occupancy is greater than 50%.
 407 Otherwise, we generate a binary comparison tree.  (Perhaps this could
 408 be tuned.)
 409
 410 \begin{code}
 411
 412  intTag :: Literal -> Integer
 413  intTag (MachChar c)  = fromInt (ord c)
 414  intTag (MachInt i _) = i
 415  intTag _ = panic "intTag"
 416
 417  fltTag :: Literal -> Rational
 418
 419  fltTag (MachFloat f) = f
 420  fltTag (MachDouble d) = d
 421  fltTag _ = panic "fltTag"
 422
 423  {-
 424  mkSimpleSwitches
 425     :: CAddrMode -> [(Literal,AbstractC)] -> AbstractC
 426     -> UniqSM StixTreeList
 427  -}
 428  mkSimpleSwitches am alts absC
 429   = getUniqLabelNCG                                     `thenUs` \ udlbl ->
 430     getUniqLabelNCG                                     `thenUs` \ ujlbl ->
 431     let am' = a2stix am
 432         joinedAlts = map (\ (tag,code) -> (tag, mkJoin code ujlbl)) alts
 433         sortedAlts = naturalMergeSortLe leAlt joinedAlts
 434                      -- naturalMergeSortLe, because we often get sorted alts to begin with
 435
 436         lowTag = intTag (fst (head sortedAlts))
 437         highTag = intTag (fst (last sortedAlts))
 438
 439         -- lowest and highest possible values the discriminant could take
 440         lowest = if floating then targetMinDouble else targetMinInt
 441         highest = if floating then targetMaxDouble else targetMaxInt
 442     in
 443         (
 444         if not floating && choices > 4 && highTag - lowTag < toInteger (2 * choices) then
 445             mkJumpTable am' sortedAlts lowTag highTag udlbl
 446         else
 447             mkBinaryTree am' floating sortedAlts choices lowest highest udlbl
 448         )
 449                                                         `thenUs` \ alt_code ->
 450         gencode absC                            `thenUs` \ dflt_code ->
 451
 452         returnUs (\xs -> alt_code (StLabel udlbl : dflt_code (StLabel ujlbl : xs)))
 453
 454     where
 455         floating = isFloatingRep (getAmodeRep am)
 456         choices = length alts
 457
 458         (x@(MachChar _),_)  `leAlt` (y,_) = intTag x <= intTag y
 459         (x@(MachInt _ _),_) `leAlt` (y,_) = intTag x <= intTag y
 460         (x,_)               `leAlt` (y,_) = fltTag x <= fltTag y
 461
 462 \end{code}
 463
 464 We use jump tables when doing an integer switch on a relatively dense
 465 list of alternatives.  We expect to be given a list of alternatives,
 466 sorted by tag, and a range of values for which we are to generate a
 467 table.  Of course, the tags of the alternatives should lie within the
 468 indicated range.  The alternatives need not cover the range; a default
 469 target is provided for the missing alternatives.
 470
 471 If a join is necessary after the switch, the alternatives should
 472 already finish with a jump to the join point.
 473
 474 \begin{code}
 475  {-
 476  mkJumpTable
 477     :: StixTree                 -- discriminant
 478     -> [(Literal, AbstractC)]   -- alternatives
 479     -> Integer                  -- low tag
 480     -> Integer                  -- high tag
 481     -> CLabel                   -- default label
 482     -> UniqSM StixTreeList
 483  -}
 484
 485  mkJumpTable am alts lowTag highTag dflt
 486   = getUniqLabelNCG                                     `thenUs` \ utlbl ->
 487     mapUs genLabel alts                                 `thenUs` \ branches ->
 488     let cjmpLo = StCondJump dflt (StPrim IntLtOp [am, StInt (toInteger lowTag)])
 489         cjmpHi = StCondJump dflt (StPrim IntGtOp [am, StInt (toInteger highTag)])
 490
 491         offset = StPrim IntSubOp [am, StInt lowTag]
 492
 493         jump = StJump (StInd PtrRep (StIndex PtrRep (StCLbl utlbl) offset))
 494         tlbl = StLabel utlbl
 495         table = StData PtrRep (mkTable branches [lowTag..highTag] [])
 496     in
 497         mapUs mkBranch branches                         `thenUs` \ alts ->
 498
 499         returnUs (\xs -> cjmpLo : cjmpHi : jump :
 500                          StSegment DataSegment : tlbl : table :
 501                          StSegment TextSegment : foldr1 (.) alts xs)
 502
 503     where
 504         genLabel x = getUniqLabelNCG `thenUs` \ lbl -> returnUs (lbl, x)
 505
 506         mkBranch (lbl,(_,alt)) =
 507             gencode alt                         `thenUs` \ alt_code ->
 508             returnUs (\xs -> StLabel lbl : alt_code xs)
 509
 510         mkTable _  []     tbl = reverse tbl
 511         mkTable [] (x:xs) tbl = mkTable [] xs (StCLbl dflt : tbl)
 512         mkTable alts@((lbl,(tag,_)):rest) (x:xs) tbl
 513           | intTag tag == x = mkTable rest xs (StCLbl lbl : tbl)
 514           | otherwise = mkTable alts xs (StCLbl dflt : tbl)
 515
 516 \end{code}
 517
 518 We generate binary comparison trees when a jump table is inappropriate.
 519 We expect to be given a list of alternatives, sorted by tag, and for
 520 convenience, the length of the alternative list.  We recursively break
 521 the list in half and do a comparison on the first tag of the second half
 522 of the list.  (Odd lists are broken so that the second half of the list
 523 is longer.)  We can handle either integer or floating kind alternatives,
 524 so long as they are not mixed.  (We assume that the type of the discriminant
 525 determines the type of the alternatives.)
 526
 527 As with the jump table approach, if a join is necessary after the switch, the
 528 alternatives should already finish with a jump to the join point.
 529
 530 \begin{code}
 531  {-
 532  mkBinaryTree
 533     :: StixTree                 -- discriminant
 534     -> Bool                     -- floating point?
 535     -> [(Literal, AbstractC)]   -- alternatives
 536     -> Int                      -- number of choices
 537     -> Literal                  -- low tag
 538     -> Literal                  -- high tag
 539     -> CLabel                   -- default code label
 540     -> UniqSM StixTreeList
 541  -}
 542
 543  mkBinaryTree am floating [(tag,alt)] _ lowTag highTag udlbl
 544   | rangeOfOne = gencode alt
 545   | otherwise
 546   = let tag' = a2stix (CLit tag)
 547         cmpOp = if floating then DoubleNeOp else IntNeOp
 548         test = StPrim cmpOp [am, tag']
 549         cjmp = StCondJump udlbl test
 550     in
 551         gencode alt                             `thenUs` \ alt_code ->
 552         returnUs (\xs -> cjmp : alt_code xs)
 553
 554     where
 555         rangeOfOne = not floating && intTag lowTag + 1 >= intTag highTag
 556         -- When there is only one possible tag left in range, we skip the comparison
 557
 558  mkBinaryTree am floating alts choices lowTag highTag udlbl
 559   = getUniqLabelNCG                                     `thenUs` \ uhlbl ->
 560     let tag' = a2stix (CLit splitTag)
 561         cmpOp = if floating then DoubleGeOp else IntGeOp
 562         test = StPrim cmpOp [am, tag']
 563         cjmp = StCondJump uhlbl test
 564     in
 565         mkBinaryTree am floating alts_lo half lowTag splitTag udlbl
 566                                                         `thenUs` \ lo_code ->
 567         mkBinaryTree am floating alts_hi (choices - half) splitTag highTag udlbl
 568                                                         `thenUs` \ hi_code ->
 569
 570         returnUs (\xs -> cjmp : lo_code (StLabel uhlbl : hi_code xs))
 571
 572     where
 573         half = choices `div` 2
 574         (alts_lo, alts_hi) = splitAt half alts
 575         splitTag = fst (head alts_hi)
 576
 577 \end{code}
 578
 579 \begin{code}
 580  {-
 581  mkIfThenElse
 582     :: CAddrMode            -- discriminant
 583     -> Literal              -- tag
 584     -> AbstractC            -- if-part
 585     -> AbstractC            -- else-part
 586     -> UniqSM StixTreeList
 587  -}
 588
 589  mkIfThenElse discrim tag alt deflt
 590   = getUniqLabelNCG                                     `thenUs` \ ujlbl ->
 591     getUniqLabelNCG                                     `thenUs` \ utlbl ->
 592     let discrim' = a2stix discrim
 593         tag' = a2stix (CLit tag)
 594         cmpOp = if (isFloatingRep (getAmodeRep discrim)) then DoubleNeOp else IntNeOp
 595         test = StPrim cmpOp [discrim', tag']
 596         cjmp = StCondJump utlbl test
 597         dest = StLabel utlbl
 598         join = StLabel ujlbl
 599     in
 600         gencode (mkJoin alt ujlbl)              `thenUs` \ alt_code ->
 601         gencode deflt                           `thenUs` \ dflt_code ->
 602         returnUs (\xs -> cjmp : alt_code (dest : dflt_code (join : xs)))
 603
 604 mkJoin :: AbstractC -> CLabel -> AbstractC
 605
 606 mkJoin code lbl
 607   | mightFallThrough code = mkAbsCStmts code (CJump (CLbl lbl PtrRep))
 608   | otherwise = code
 609 \end{code}
 610
 611 %---------------------------------------------------------------------------
 612
 613 This answers the question: Can the code fall through to the next
 614 line(s) of code?  This errs towards saying True if it can't choose,
 615 because it is used for eliminating needless jumps.  In other words, if
 616 you might possibly {\em not} jump, then say yes to falling through.
 617
 618 \begin{code}
 619 mightFallThrough :: AbstractC -> Bool
 620
 621 mightFallThrough absC = ft absC True
 622  where
 623   ft AbsCNop       if_empty = if_empty
 624
 625   ft (CJump _)       if_empty = False
 626   ft (CReturn _ _)   if_empty = False
 627   ft (CSwitch _ alts deflt) if_empty
 628         = ft deflt if_empty ||
 629           or [ft alt if_empty | (_,alt) <- alts]
 630
 631   ft (AbsCStmts c1 c2) if_empty = ft c2 (ft c1 if_empty)
 632   ft _ if_empty = if_empty
 633
 634 {- Old algorithm, which called nonemptyAbsC for every subexpression! =========
 635 fallThroughAbsC (AbsCStmts c1 c2)
 636   = case nonemptyAbsC c2 of
 637         Nothing -> fallThroughAbsC c1
 638         Just x -> fallThroughAbsC x
 639 fallThroughAbsC (CJump _)        = False
 640 fallThroughAbsC (CReturn _ _)    = False
 641 fallThroughAbsC (CSwitch _ choices deflt)
 642   = (not (isEmptyAbsC deflt) && fallThroughAbsC deflt)
 643     || or (map (fallThroughAbsC . snd) choices)
 644 fallThroughAbsC other            = True
 645
 646 isEmptyAbsC :: AbstractC -> Bool
 647 isEmptyAbsC = not . maybeToBool . nonemptyAbsC
 648 ================= End of old, quadratic, algorithm -}
 649 \end{code}