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