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