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