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