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