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