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