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