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