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