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