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                           moduleRegdLabel, labelDynamic,
  28                           mkSplitMarkerLabel )
  29 import ClosureInfo      ( infoTableLabelFromCI, entryLabelFromCI,
  30                           fastLabelFromCI, closureUpdReqd,
  31                           staticClosureNeedsLink
  32                         )
  33 import Literal          ( Literal(..), word2IntLit )
  34 import Maybes           ( maybeToBool )
  35 import PrimOp           ( primOpNeedsWrapper, PrimOp(..) )
  36 import PrimRep          ( isFloatingRep, PrimRep(..) )
  37 import StixInfo         ( genCodeInfoTable, genBitmapInfoTable )
  38 import StixMacro        ( macroCode, checkCode )
  39 import StixPrim         ( primCode, 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 Char             ( ord )
  49 import CmdLineOpts      ( opt_Static, opt_EnsureSplittableC )
  50 \end{code}
  51
  52 For each independent chunk of AbstractC code, we generate a list of
  53 @StixTree@s, where each tree corresponds to a single Stix instruction.
  54 We leave the chunks separated so that register allocation can be
  55 performed locally within the chunk.
  56
  57 \begin{code}
  58 genCodeAbstractC :: AbstractC -> UniqSM [StixTree]
  59
  60 genCodeAbstractC absC
  61   = gentopcode absC
  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 do_one_amode amodes ++
 220             [StData PtrRep (padding_wds ++ static_link)]
 221
 222     do_one_amode amode
 223        = StData (promote_to_word (getAmodeRep amode)) [a2stix amode]
 224
 225     -- We need to promote any item smaller than a word to a word
 226     promote_to_word CharRep = WordRep
 227     promote_to_word other   = other
 228
 229     -- always at least one padding word: this is the static link field
 230     -- for the garbage collector.
 231     padding_wds = if closureUpdReqd cl_info then
 232                         take (max 0 (mIN_UPD_SIZE - length amodes)) zeros
 233                   else
 234                         []
 235
 236     static_link | staticClosureNeedsLink cl_info = [StInt 0]
 237                 | otherwise                      = []
 238
 239     zeros = StInt 0 : zeros
 240
 241     {- needed??? --SDM
 242         -- Watch out for VoidKinds...cf. PprAbsC
 243     amodeZeroVoid item
 244       | getAmodeRep item == VoidRep = StInt 0
 245       | otherwise = a2stix item
 246     -}
 247
 248 \end{code}
 249
 250 Now the individual AbstractC statements.
 251
 252 \begin{code}
 253  {-
 254  gencode
 255     :: AbstractC
 256     -> UniqSM StixTreeList
 257  -}
 258 \end{code}
 259
 260 @AbsCNop@s just disappear.
 261
 262 \begin{code}
 263
 264  gencode AbsCNop = returnUs id
 265
 266 \end{code}
 267
 268 Split markers just insert a __stg_split_marker, which is caught by the
 269 split-mangler later on and used to split the assembly into chunks.
 270
 271 \begin{code}
 272
 273  gencode CSplitMarker
 274    | opt_EnsureSplittableC = returnUs (\xs -> StLabel mkSplitMarkerLabel : xs)
 275    | otherwise             = returnUs id
 276
 277 \end{code}
 278
 279 AbstractC instruction sequences are handled individually, and the
 280 resulting StixTreeLists are joined together.
 281
 282 \begin{code}
 283
 284  gencode (AbsCStmts c1 c2)
 285   = gencode c1                          `thenUs` \ b1 ->
 286     gencode c2                          `thenUs` \ b2 ->
 287     returnUs (b1 . b2)
 288
 289 \end{code}
 290
 291 Initialising closure headers in the heap...a fairly complex ordeal if
 292 done properly.  For now, we just set the info pointer, but we should
 293 really take a peek at the flags to determine whether or not there are
 294 other things to be done (setting cost centres, age headers, global
 295 addresses, etc.)
 296
 297 \begin{code}
 298
 299  gencode (CInitHdr cl_info reg_rel _)
 300   = let
 301         lhs = a2stix reg_rel
 302         lbl = infoTableLabelFromCI cl_info
 303     in
 304         returnUs (\xs -> StAssign PtrRep (StInd PtrRep lhs) (StCLbl lbl) : xs)
 305
 306 \end{code}
 307
 308 Heap/Stack Checks.
 309
 310 \begin{code}
 311
 312  gencode (CCheck macro args assts)
 313   = gencode assts `thenUs` \assts_stix ->
 314     checkCode macro args assts_stix
 315
 316 \end{code}
 317
 318 Assignment, the curse of von Neumann, is the center of the code we
 319 produce.  In most cases, the type of the assignment is determined
 320 by the type of the destination.  However, when the destination can
 321 have mixed types, the type of the assignment is ``StgWord'' (we use
 322 PtrRep for lack of anything better).  Think:  do we also want a cast
 323 of the source?  Be careful about floats/doubles.
 324
 325 \begin{code}
 326
 327  gencode (CAssign lhs rhs)
 328   | getAmodeRep lhs == VoidRep = returnUs id
 329   | otherwise
 330   = let pk = getAmodeRep lhs
 331         pk' = if mixedTypeLocn lhs && not (isFloatingRep pk) then IntRep else pk
 332         lhs' = a2stix lhs
 333         rhs' = a2stix' rhs
 334     in
 335         returnUs (\xs -> StAssign pk' lhs' rhs' : xs)
 336
 337 \end{code}
 338
 339 Unconditional jumps, including the special ``enter closure'' operation.
 340 Note that the new entry convention requires that we load the InfoPtr (R2)
 341 with the address of the info table before jumping to the entry code for Node.
 342
 343 For a vectored return, we must subtract the size of the info table to
 344 get at the return vector.  This depends on the size of the info table,
 345 which varies depending on whether we're profiling etc.
 346
 347 \begin{code}
 348
 349  gencode (CJump dest)
 350   = returnUs (\xs -> StJump (a2stix dest) : xs)
 351
 352  gencode (CFallThrough (CLbl lbl _))
 353   = returnUs (\xs -> StFallThrough lbl : xs)
 354
 355  gencode (CReturn dest DirectReturn)
 356   = returnUs (\xs -> StJump (a2stix dest) : xs)
 357
 358  gencode (CReturn table (StaticVectoredReturn n))
 359   = returnUs (\xs -> StJump dest : xs)
 360   where
 361     dest = StInd PtrRep (StIndex PtrRep (a2stix table)
 362                                   (StInt (toInteger (-n-fixedItblSize-1))))
 363
 364  gencode (CReturn table (DynamicVectoredReturn am))
 365   = returnUs (\xs -> StJump dest : xs)
 366   where
 367     dest = StInd PtrRep (StIndex PtrRep (a2stix table) dyn_off)
 368     dyn_off = StPrim IntSubOp [StPrim IntNegOp [a2stix am],
 369                                StInt (toInteger (fixedItblSize+1))]
 370
 371 \end{code}
 372
 373 Now the PrimOps, some of which may need caller-saves register wrappers.
 374
 375 \begin{code}
 376
 377  gencode (COpStmt results op args vols)
 378   -- ToDo (ADR?): use that liveness mask
 379   | primOpNeedsWrapper op
 380   = let
 381         saves = volsaves vols
 382         restores = volrestores vols
 383     in
 384         p2stix (nonVoid results) op (nonVoid args)
 385                                                         `thenUs` \ code ->
 386         returnUs (\xs -> saves ++ code (restores ++ xs))
 387
 388   | otherwise = p2stix (nonVoid results) op (nonVoid args)
 389     where
 390         nonVoid = filter ((/= VoidRep) . getAmodeRep)
 391
 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 (ord 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 && highTag - lowTag < toInteger (2 * choices) then
 509             mkJumpTable am' sortedAlts lowTag highTag udlbl
 510         else
 511             mkBinaryTree am' floating sortedAlts choices lowest highest udlbl
 512         )
 513                                                         `thenUs` \ alt_code ->
 514         gencode absC                            `thenUs` \ dflt_code ->
 515
 516         returnUs (\xs -> alt_code (StLabel udlbl : dflt_code (StLabel ujlbl : xs)))
 517
 518     where
 519         floating = isFloatingRep (getAmodeRep am)
 520         choices = length alts
 521
 522         (x@(MachChar _),_)  `leAlt` (y,_) = intTag x <= intTag y
 523         (x@(MachInt _), _)  `leAlt` (y,_) = intTag x <= intTag y
 524         (x@(MachWord _), _) `leAlt` (y,_) = intTag x <= intTag y
 525         (x,_)               `leAlt` (y,_) = fltTag x <= fltTag y
 526
 527 \end{code}
 528
 529 We use jump tables when doing an integer switch on a relatively dense
 530 list of alternatives.  We expect to be given a list of alternatives,
 531 sorted by tag, and a range of values for which we are to generate a
 532 table.  Of course, the tags of the alternatives should lie within the
 533 indicated range.  The alternatives need not cover the range; a default
 534 target is provided for the missing alternatives.
 535
 536 If a join is necessary after the switch, the alternatives should
 537 already finish with a jump to the join point.
 538
 539 \begin{code}
 540  {-
 541  mkJumpTable
 542     :: StixTree                 -- discriminant
 543     -> [(Literal, AbstractC)]   -- alternatives
 544     -> Integer                  -- low tag
 545     -> Integer                  -- high tag
 546     -> CLabel                   -- default label
 547     -> UniqSM StixTreeList
 548  -}
 549
 550  mkJumpTable am alts lowTag highTag dflt
 551   = getUniqLabelNCG                                     `thenUs` \ utlbl ->
 552     mapUs genLabel alts                                 `thenUs` \ branches ->
 553     let cjmpLo = StCondJump dflt (StPrim IntLtOp [am, StInt (toInteger lowTag)])
 554         cjmpHi = StCondJump dflt (StPrim IntGtOp [am, StInt (toInteger highTag)])
 555
 556         offset = StPrim IntSubOp [am, StInt lowTag]
 557
 558         jump = StJump (StInd PtrRep (StIndex PtrRep (StCLbl utlbl) offset))
 559         tlbl = StLabel utlbl
 560         table = StData PtrRep (mkTable branches [lowTag..highTag] [])
 561     in
 562         mapUs mkBranch branches                         `thenUs` \ alts ->
 563
 564         returnUs (\xs -> cjmpLo : cjmpHi : jump :
 565                          StSegment DataSegment : tlbl : table :
 566                          StSegment TextSegment : foldr1 (.) alts xs)
 567
 568     where
 569         genLabel x = getUniqLabelNCG `thenUs` \ lbl -> returnUs (lbl, x)
 570
 571         mkBranch (lbl,(_,alt)) =
 572             gencode alt                         `thenUs` \ alt_code ->
 573             returnUs (\xs -> StLabel lbl : alt_code xs)
 574
 575         mkTable _  []     tbl = reverse tbl
 576         mkTable [] (x:xs) tbl = mkTable [] xs (StCLbl dflt : tbl)
 577         mkTable alts@((lbl,(tag,_)):rest) (x:xs) tbl
 578           | intTag tag == x = mkTable rest xs (StCLbl lbl : tbl)
 579           | otherwise = mkTable alts xs (StCLbl dflt : tbl)
 580
 581 \end{code}
 582
 583 We generate binary comparison trees when a jump table is inappropriate.
 584 We expect to be given a list of alternatives, sorted by tag, and for
 585 convenience, the length of the alternative list.  We recursively break
 586 the list in half and do a comparison on the first tag of the second half
 587 of the list.  (Odd lists are broken so that the second half of the list
 588 is longer.)  We can handle either integer or floating kind alternatives,
 589 so long as they are not mixed.  (We assume that the type of the discriminant
 590 determines the type of the alternatives.)
 591
 592 As with the jump table approach, if a join is necessary after the switch, the
 593 alternatives should already finish with a jump to the join point.
 594
 595 \begin{code}
 596  {-
 597  mkBinaryTree
 598     :: StixTree                 -- discriminant
 599     -> Bool                     -- floating point?
 600     -> [(Literal, AbstractC)]   -- alternatives
 601     -> Int                      -- number of choices
 602     -> Literal                  -- low tag
 603     -> Literal                  -- high tag
 604     -> CLabel                   -- default code label
 605     -> UniqSM StixTreeList
 606  -}
 607
 608  mkBinaryTree am floating [(tag,alt)] _ lowTag highTag udlbl
 609   | rangeOfOne = gencode alt
 610   | otherwise
 611   = let tag' = a2stix (CLit tag)
 612         cmpOp = if floating then DoubleNeOp else IntNeOp
 613         test = StPrim cmpOp [am, tag']
 614         cjmp = StCondJump udlbl test
 615     in
 616         gencode alt                             `thenUs` \ alt_code ->
 617         returnUs (\xs -> cjmp : alt_code xs)
 618
 619     where
 620         rangeOfOne = not floating && intTag lowTag + 1 >= intTag highTag
 621         -- When there is only one possible tag left in range, we skip the comparison
 622
 623  mkBinaryTree am floating alts choices lowTag highTag udlbl
 624   = getUniqLabelNCG                                     `thenUs` \ uhlbl ->
 625     let tag' = a2stix (CLit splitTag)
 626         cmpOp = if floating then DoubleGeOp else IntGeOp
 627         test = StPrim cmpOp [am, tag']
 628         cjmp = StCondJump uhlbl test
 629     in
 630         mkBinaryTree am floating alts_lo half lowTag splitTag udlbl
 631                                                         `thenUs` \ lo_code ->
 632         mkBinaryTree am floating alts_hi (choices - half) splitTag highTag udlbl
 633                                                         `thenUs` \ hi_code ->
 634
 635         returnUs (\xs -> cjmp : lo_code (StLabel uhlbl : hi_code xs))
 636
 637     where
 638         half = choices `div` 2
 639         (alts_lo, alts_hi) = splitAt half alts
 640         splitTag = fst (head alts_hi)
 641
 642 \end{code}
 643
 644 \begin{code}
 645  {-
 646  mkIfThenElse
 647     :: CAddrMode            -- discriminant
 648     -> Literal              -- tag
 649     -> AbstractC            -- if-part
 650     -> AbstractC            -- else-part
 651     -> UniqSM StixTreeList
 652  -}
 653
 654  mkIfThenElse discrim tag alt deflt
 655   = getUniqLabelNCG                                     `thenUs` \ ujlbl ->
 656     getUniqLabelNCG                                     `thenUs` \ utlbl ->
 657     let discrim' = a2stix discrim
 658         tag' = a2stix (CLit tag)
 659         cmpOp = if (isFloatingRep (getAmodeRep discrim)) then DoubleNeOp else IntNeOp
 660         test = StPrim cmpOp [discrim', tag']
 661         cjmp = StCondJump utlbl test
 662         dest = StLabel utlbl
 663         join = StLabel ujlbl
 664     in
 665         gencode (mkJoin alt ujlbl)              `thenUs` \ alt_code ->
 666         gencode deflt                           `thenUs` \ dflt_code ->
 667         returnUs (\xs -> cjmp : alt_code (dest : dflt_code (join : xs)))
 668
 669 mkJoin :: AbstractC -> CLabel -> AbstractC
 670
 671 mkJoin code lbl
 672   | mightFallThrough code = mkAbsCStmts code (CJump (CLbl lbl PtrRep))
 673   | otherwise = code
 674 \end{code}
 675
 676 %---------------------------------------------------------------------------
 677
 678 This answers the question: Can the code fall through to the next
 679 line(s) of code?  This errs towards saying True if it can't choose,
 680 because it is used for eliminating needless jumps.  In other words, if
 681 you might possibly {\em not} jump, then say yes to falling through.
 682
 683 \begin{code}
 684 mightFallThrough :: AbstractC -> Bool
 685
 686 mightFallThrough absC = ft absC True
 687  where
 688   ft AbsCNop       if_empty = if_empty
 689
 690   ft (CJump _)       if_empty = False
 691   ft (CReturn _ _)   if_empty = False
 692   ft (CSwitch _ alts deflt) if_empty
 693         = ft deflt if_empty ||
 694           or [ft alt if_empty | (_,alt) <- alts]
 695
 696   ft (AbsCStmts c1 c2) if_empty = ft c2 (ft c1 if_empty)
 697   ft _ if_empty = if_empty
 698
 699 {- Old algorithm, which called nonemptyAbsC for every subexpression! =========
 700 fallThroughAbsC (AbsCStmts c1 c2)
 701   = case nonemptyAbsC c2 of
 702         Nothing -> fallThroughAbsC c1
 703         Just x -> fallThroughAbsC x
 704 fallThroughAbsC (CJump _)        = False
 705 fallThroughAbsC (CReturn _ _)    = False
 706 fallThroughAbsC (CSwitch _ choices deflt)
 707   = (not (isEmptyAbsC deflt) && fallThroughAbsC deflt)
 708     || or (map (fallThroughAbsC . snd) choices)
 709 fallThroughAbsC other            = True
 710
 711 isEmptyAbsC :: AbstractC -> Bool
 712 isEmptyAbsC = not . maybeToBool . nonemptyAbsC
 713 ================= End of old, quadratic, algorithm -}
 714 \end{code}