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