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