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, 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 Int8Rep = IntRep
 225     promote_to_word CharRep = IntRep
 226     promote_to_word other   = other
 227
 228     -- always at least one padding word: this is the static link field
 229     -- for the garbage collector.
 230     padding_wds = if closureUpdReqd cl_info then
 231                         take (max 0 (mIN_UPD_SIZE - length amodes)) zeros
 232                   else
 233                         []
 234
 235     static_link | 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
 376  gencode (COpStmt results op args vols)
 377   -- ToDo (ADR?): use that liveness mask
 378   | primOpNeedsWrapper op
 379   = let
 380         saves = volsaves vols
 381         restores = volrestores vols
 382     in
 383         p2stix (nonVoid results) op (nonVoid args)
 384                                                         `thenUs` \ code ->
 385         returnUs (\xs -> saves ++ code (restores ++ xs))
 386
 387   | otherwise = p2stix (nonVoid results) op (nonVoid args)
 388     where
 389         nonVoid = filter ((/= VoidRep) . getAmodeRep)
 390
 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 \end{code}
 466
 467 Here, we generate a jump table if there are more than four (integer)
 468 alternatives and the jump table occupancy is greater than 50%.
 469 Otherwise, we generate a binary comparison tree.  (Perhaps this could
 470 be tuned.)
 471
 472 \begin{code}
 473
 474  intTag :: Literal -> Integer
 475  intTag (MachChar c)  = toInteger c
 476  intTag (MachInt i)   = i
 477  intTag (MachWord w)  = intTag (word2IntLit (MachWord w))
 478  intTag _             = panic "intTag"
 479
 480  fltTag :: Literal -> Rational
 481
 482  fltTag (MachFloat f)  = f
 483  fltTag (MachDouble d) = d
 484  fltTag x              = pprPanic "fltTag" (ppr x)
 485
 486  {-
 487  mkSimpleSwitches
 488     :: CAddrMode -> [(Literal,AbstractC)] -> AbstractC
 489     -> UniqSM StixTreeList
 490  -}
 491  mkSimpleSwitches am alts absC
 492   = getUniqLabelNCG                                     `thenUs` \ udlbl ->
 493     getUniqLabelNCG                                     `thenUs` \ ujlbl ->
 494     let am' = a2stix am
 495         joinedAlts = map (\ (tag,code) -> (tag, mkJoin code ujlbl)) alts
 496         sortedAlts = naturalMergeSortLe leAlt joinedAlts
 497                      -- naturalMergeSortLe, because we often get sorted alts to begin with
 498
 499         lowTag = intTag (fst (head sortedAlts))
 500         highTag = intTag (fst (last sortedAlts))
 501
 502         -- lowest and highest possible values the discriminant could take
 503         lowest = if floating then targetMinDouble else targetMinInt
 504         highest = if floating then targetMaxDouble else targetMaxInt
 505     in
 506         (
 507         if  not floating && choices > 4
 508             && highTag - lowTag < toInteger (2 * choices)
 509         then
 510             mkJumpTable am' sortedAlts lowTag highTag udlbl
 511         else
 512             mkBinaryTree am' floating sortedAlts choices lowest highest udlbl
 513         )
 514                                                 `thenUs` \ alt_code ->
 515         gencode absC                            `thenUs` \ dflt_code ->
 516
 517         returnUs (\xs -> alt_code (StLabel udlbl : dflt_code (StLabel ujlbl : xs)))
 518
 519     where
 520         floating = isFloatingRep (getAmodeRep am)
 521         choices = length alts
 522
 523         (x@(MachChar _),_)  `leAlt` (y,_) = intTag x <= intTag y
 524         (x@(MachInt _), _)  `leAlt` (y,_) = intTag x <= intTag y
 525         (x@(MachWord _), _) `leAlt` (y,_) = intTag x <= intTag y
 526         (x,_)               `leAlt` (y,_) = fltTag x <= fltTag y
 527
 528 \end{code}
 529
 530 We use jump tables when doing an integer switch on a relatively dense
 531 list of alternatives.  We expect to be given a list of alternatives,
 532 sorted by tag, and a range of values for which we are to generate a
 533 table.  Of course, the tags of the alternatives should lie within the
 534 indicated range.  The alternatives need not cover the range; a default
 535 target is provided for the missing alternatives.
 536
 537 If a join is necessary after the switch, the alternatives should
 538 already finish with a jump to the join point.
 539
 540 \begin{code}
 541  {-
 542  mkJumpTable
 543     :: StixTree                 -- discriminant
 544     -> [(Literal, AbstractC)]   -- alternatives
 545     -> Integer                  -- low tag
 546     -> Integer                  -- high tag
 547     -> CLabel                   -- default label
 548     -> UniqSM StixTreeList
 549  -}
 550
 551  mkJumpTable am alts lowTag highTag dflt
 552   = getUniqLabelNCG                                     `thenUs` \ utlbl ->
 553     mapUs genLabel alts                                 `thenUs` \ branches ->
 554     let cjmpLo = StCondJump dflt (StPrim IntLtOp [am, StInt (toInteger lowTag)])
 555         cjmpHi = StCondJump dflt (StPrim IntGtOp [am, StInt (toInteger highTag)])
 556
 557         offset = StPrim IntSubOp [am, StInt lowTag]
 558         dsts   = DestInfo (dflt : map fst branches)
 559
 560         jump = StJump dsts (StInd PtrRep (StIndex PtrRep (StCLbl utlbl) offset))
 561         tlbl = StLabel utlbl
 562         table = StData PtrRep (mkTable branches [lowTag..highTag] [])
 563     in
 564         mapUs mkBranch branches                         `thenUs` \ alts ->
 565
 566         returnUs (\xs -> cjmpLo : cjmpHi : jump :
 567                          StSegment DataSegment : tlbl : table :
 568                          StSegment TextSegment : foldr1 (.) alts xs)
 569
 570     where
 571         genLabel x = getUniqLabelNCG `thenUs` \ lbl -> returnUs (lbl, x)
 572
 573         mkBranch (lbl,(_,alt)) =
 574             gencode alt                         `thenUs` \ alt_code ->
 575             returnUs (\xs -> StLabel lbl : alt_code xs)
 576
 577         mkTable _  []     tbl = reverse tbl
 578         mkTable [] (x:xs) tbl = mkTable [] xs (StCLbl dflt : tbl)
 579         mkTable alts@((lbl,(tag,_)):rest) (x:xs) tbl
 580           | intTag tag == x = mkTable rest xs (StCLbl lbl : tbl)
 581           | otherwise = mkTable alts xs (StCLbl dflt : tbl)
 582
 583 \end{code}
 584
 585 We generate binary comparison trees when a jump table is inappropriate.
 586 We expect to be given a list of alternatives, sorted by tag, and for
 587 convenience, the length of the alternative list.  We recursively break
 588 the list in half and do a comparison on the first tag of the second half
 589 of the list.  (Odd lists are broken so that the second half of the list
 590 is longer.)  We can handle either integer or floating kind alternatives,
 591 so long as they are not mixed.  (We assume that the type of the discriminant
 592 determines the type of the alternatives.)
 593
 594 As with the jump table approach, if a join is necessary after the switch, the
 595 alternatives should already finish with a jump to the join point.
 596
 597 \begin{code}
 598  {-
 599  mkBinaryTree
 600     :: StixTree                 -- discriminant
 601     -> Bool                     -- floating point?
 602     -> [(Literal, AbstractC)]   -- alternatives
 603     -> Int                      -- number of choices
 604     -> Literal                  -- low tag
 605     -> Literal                  -- high tag
 606     -> CLabel                   -- default code label
 607     -> UniqSM StixTreeList
 608  -}
 609
 610  mkBinaryTree am floating [(tag,alt)] _ lowTag highTag udlbl
 611   | rangeOfOne = gencode alt
 612   | otherwise
 613   = let tag' = a2stix (CLit tag)
 614         cmpOp = if floating then DoubleNeOp else IntNeOp
 615         test = StPrim cmpOp [am, tag']
 616         cjmp = StCondJump udlbl test
 617     in
 618         gencode alt                             `thenUs` \ alt_code ->
 619         returnUs (\xs -> cjmp : alt_code xs)
 620
 621     where
 622         rangeOfOne = not floating && intTag lowTag + 1 >= intTag highTag
 623         -- When there is only one possible tag left in range, we skip the comparison
 624
 625  mkBinaryTree am floating alts choices lowTag highTag udlbl
 626   = getUniqLabelNCG                                     `thenUs` \ uhlbl ->
 627     let tag' = a2stix (CLit splitTag)
 628         cmpOp = if floating then DoubleGeOp else IntGeOp
 629         test = StPrim cmpOp [am, tag']
 630         cjmp = StCondJump uhlbl test
 631     in
 632         mkBinaryTree am floating alts_lo half lowTag splitTag udlbl
 633                                                         `thenUs` \ lo_code ->
 634         mkBinaryTree am floating alts_hi (choices - half) splitTag highTag udlbl
 635                                                         `thenUs` \ hi_code ->
 636
 637         returnUs (\xs -> cjmp : lo_code (StLabel uhlbl : hi_code xs))
 638
 639     where
 640         half = choices `div` 2
 641         (alts_lo, alts_hi) = splitAt half alts
 642         splitTag = fst (head alts_hi)
 643
 644 \end{code}
 645
 646 \begin{code}
 647  {-
 648  mkIfThenElse
 649     :: CAddrMode            -- discriminant
 650     -> Literal              -- tag
 651     -> AbstractC            -- if-part
 652     -> AbstractC            -- else-part
 653     -> UniqSM StixTreeList
 654  -}
 655
 656  mkIfThenElse discrim tag alt deflt
 657   = getUniqLabelNCG                                     `thenUs` \ ujlbl ->
 658     getUniqLabelNCG                                     `thenUs` \ utlbl ->
 659     let discrim' = a2stix discrim
 660         tag' = a2stix (CLit tag)
 661         cmpOp = if (isFloatingRep (getAmodeRep discrim)) then DoubleNeOp else IntNeOp
 662         test = StPrim cmpOp [discrim', tag']
 663         cjmp = StCondJump utlbl test
 664         dest = StLabel utlbl
 665         join = StLabel ujlbl
 666     in
 667         gencode (mkJoin alt ujlbl)              `thenUs` \ alt_code ->
 668         gencode deflt                           `thenUs` \ dflt_code ->
 669         returnUs (\xs -> cjmp : alt_code (dest : dflt_code (join : xs)))
 670
 671 mkJoin :: AbstractC -> CLabel -> AbstractC
 672
 673 mkJoin code lbl
 674   | mightFallThrough code = mkAbsCStmts code (CJump (CLbl lbl PtrRep))
 675   | otherwise = code
 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}