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