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 (\amode -> StData (getAmodeRep amode) [a2stix amode]) amodes ++
 220             [StData PtrRep (padding_wds ++ static_link)]
 221
 222     -- always at least one padding word: this is the static link field
 223     -- for the garbage collector.
 224     padding_wds = if closureUpdReqd cl_info then
 225                         take (max 0 (mIN_UPD_SIZE - length amodes)) zeros
 226                   else
 227                         []
 228
 229     static_link | staticClosureNeedsLink cl_info = [StInt 0]
 230                 | otherwise                      = []
 231
 232     zeros = StInt 0 : zeros
 233
 234     {- needed??? --SDM
 235         -- Watch out for VoidKinds...cf. PprAbsC
 236     amodeZeroVoid item
 237       | getAmodeRep item == VoidRep = StInt 0
 238       | otherwise = a2stix item
 239     -}
 240
 241 \end{code}
 242
 243 Now the individual AbstractC statements.
 244
 245 \begin{code}
 246  {-
 247  gencode
 248     :: AbstractC
 249     -> UniqSM StixTreeList
 250  -}
 251 \end{code}
 252
 253 @AbsCNop@s just disappear.
 254
 255 \begin{code}
 256
 257  gencode AbsCNop = returnUs id
 258
 259 \end{code}
 260
 261 Split markers just insert a __stg_split_marker, which is caught by the
 262 split-mangler later on and used to split the assembly into chunks.
 263
 264 \begin{code}
 265
 266  gencode CSplitMarker
 267    | opt_EnsureSplittableC = returnUs (\xs -> StLabel mkSplitMarkerLabel : xs)
 268    | otherwise             = returnUs id
 269
 270 \end{code}
 271
 272 AbstractC instruction sequences are handled individually, and the
 273 resulting StixTreeLists are joined together.
 274
 275 \begin{code}
 276
 277  gencode (AbsCStmts c1 c2)
 278   = gencode c1                          `thenUs` \ b1 ->
 279     gencode c2                          `thenUs` \ b2 ->
 280     returnUs (b1 . b2)
 281
 282 \end{code}
 283
 284 Initialising closure headers in the heap...a fairly complex ordeal if
 285 done properly.  For now, we just set the info pointer, but we should
 286 really take a peek at the flags to determine whether or not there are
 287 other things to be done (setting cost centres, age headers, global
 288 addresses, etc.)
 289
 290 \begin{code}
 291
 292  gencode (CInitHdr cl_info reg_rel _)
 293   = let
 294         lhs = a2stix reg_rel
 295         lbl = infoTableLabelFromCI cl_info
 296     in
 297         returnUs (\xs -> StAssign PtrRep (StInd PtrRep lhs) (StCLbl lbl) : xs)
 298
 299 \end{code}
 300
 301 Heap/Stack Checks.
 302
 303 \begin{code}
 304
 305  gencode (CCheck macro args assts)
 306   = gencode assts `thenUs` \assts_stix ->
 307     checkCode macro args assts_stix
 308
 309 \end{code}
 310
 311 Assignment, the curse of von Neumann, is the center of the code we
 312 produce.  In most cases, the type of the assignment is determined
 313 by the type of the destination.  However, when the destination can
 314 have mixed types, the type of the assignment is ``StgWord'' (we use
 315 PtrRep for lack of anything better).  Think:  do we also want a cast
 316 of the source?  Be careful about floats/doubles.
 317
 318 \begin{code}
 319
 320  gencode (CAssign lhs rhs)
 321   | getAmodeRep lhs == VoidRep = returnUs id
 322   | otherwise
 323   = let pk = getAmodeRep lhs
 324         pk' = if mixedTypeLocn lhs && not (isFloatingRep pk) then IntRep else pk
 325         lhs' = a2stix lhs
 326         rhs' = a2stix' rhs
 327     in
 328         returnUs (\xs -> StAssign pk' lhs' rhs' : xs)
 329
 330 \end{code}
 331
 332 Unconditional jumps, including the special ``enter closure'' operation.
 333 Note that the new entry convention requires that we load the InfoPtr (R2)
 334 with the address of the info table before jumping to the entry code for Node.
 335
 336 For a vectored return, we must subtract the size of the info table to
 337 get at the return vector.  This depends on the size of the info table,
 338 which varies depending on whether we're profiling etc.
 339
 340 \begin{code}
 341
 342  gencode (CJump dest)
 343   = returnUs (\xs -> StJump (a2stix dest) : xs)
 344
 345  gencode (CFallThrough (CLbl lbl _))
 346   = returnUs (\xs -> StFallThrough lbl : xs)
 347
 348  gencode (CReturn dest DirectReturn)
 349   = returnUs (\xs -> StJump (a2stix dest) : xs)
 350
 351  gencode (CReturn table (StaticVectoredReturn n))
 352   = returnUs (\xs -> StJump dest : xs)
 353   where
 354     dest = StInd PtrRep (StIndex PtrRep (a2stix table)
 355                                   (StInt (toInteger (-n-fixedItblSize-1))))
 356
 357  gencode (CReturn table (DynamicVectoredReturn am))
 358   = returnUs (\xs -> StJump dest : xs)
 359   where
 360     dest = StInd PtrRep (StIndex PtrRep (a2stix table) dyn_off)
 361     dyn_off = StPrim IntSubOp [StPrim IntNegOp [a2stix am],
 362                                StInt (toInteger (fixedItblSize+1))]
 363
 364 \end{code}
 365
 366 Now the PrimOps, some of which may need caller-saves register wrappers.
 367
 368 \begin{code}
 369
 370  gencode (COpStmt results op args vols)
 371   -- ToDo (ADR?): use that liveness mask
 372   | primOpNeedsWrapper op
 373   = let
 374         saves = volsaves vols
 375         restores = volrestores vols
 376     in
 377         p2stix (nonVoid results) op (nonVoid args)
 378                                                         `thenUs` \ code ->
 379         returnUs (\xs -> saves ++ code (restores ++ xs))
 380
 381   | otherwise = p2stix (nonVoid results) op (nonVoid args)
 382     where
 383         nonVoid = filter ((/= VoidRep) . getAmodeRep)
 384
 385 \end{code}
 386
 387 Now the dreaded conditional jump.
 388
 389 Now the if statement.  Almost *all* flow of control are of this form.
 390 @
 391         if (am==lit) { absC } else { absCdef }
 392 @
 393         =>
 394 @
 395         IF am = lit GOTO l1:
 396         absC
 397         jump l2:
 398    l1:
 399         absCdef
 400    l2:
 401 @
 402
 403 \begin{code}
 404
 405  gencode (CSwitch discrim alts deflt)
 406   = case alts of
 407       [] -> gencode deflt
 408
 409       [(tag,alt_code)] -> case maybe_empty_deflt of
 410                                 Nothing -> gencode alt_code
 411                                 Just dc -> mkIfThenElse discrim tag alt_code dc
 412
 413       [(tag1@(MachInt i1), alt_code1),
 414        (tag2@(MachInt i2), alt_code2)]
 415         | deflt_is_empty && i1 == 0 && i2 == 1
 416         -> mkIfThenElse discrim tag1 alt_code1 alt_code2
 417         | deflt_is_empty && i1 == 1 && i2 == 0
 418         -> mkIfThenElse discrim tag2 alt_code2 alt_code1
 419
 420         -- If the @discrim@ is simple, then this unfolding is safe.
 421       other | simple_discrim -> mkSimpleSwitches discrim alts deflt
 422
 423         -- Otherwise, we need to do a bit of work.
 424       other ->  getUniqueUs                       `thenUs` \ u ->
 425                 gencode (AbsCStmts
 426                 (CAssign (CTemp u pk) discrim)
 427                 (CSwitch (CTemp u pk) alts deflt))
 428
 429   where
 430     maybe_empty_deflt = nonemptyAbsC deflt
 431     deflt_is_empty = case maybe_empty_deflt of
 432                         Nothing -> True
 433                         Just _  -> False
 434
 435     pk = getAmodeRep discrim
 436
 437     simple_discrim = case discrim of
 438                         CReg _    -> True
 439                         CTemp _ _ -> True
 440                         other     -> False
 441 \end{code}
 442
 443
 444
 445 Finally, all of the disgusting AbstractC macros.
 446
 447 \begin{code}
 448
 449  gencode (CMacroStmt macro args) = macro_code macro args
 450
 451  gencode (CCallProfCtrMacro macro _)
 452   = returnUs (\xs -> StComment macro : xs)
 453
 454  gencode (CCallProfCCMacro macro _)
 455   = returnUs (\xs -> StComment macro : xs)
 456
 457  gencode other
 458   = pprPanic "AbsCStixGen.gencode" (dumpRealC other)
 459 \end{code}
 460
 461 Here, we generate a jump table if there are more than four (integer)
 462 alternatives and the jump table occupancy is greater than 50%.
 463 Otherwise, we generate a binary comparison tree.  (Perhaps this could
 464 be tuned.)
 465
 466 \begin{code}
 467
 468  intTag :: Literal -> Integer
 469  intTag (MachChar c)  = toInteger (ord c)
 470  intTag (MachInt i)   = i
 471  intTag (MachWord w)  = intTag (word2IntLit (MachWord w))
 472  intTag _             = panic "intTag"
 473
 474  fltTag :: Literal -> Rational
 475
 476  fltTag (MachFloat f)  = f
 477  fltTag (MachDouble d) = d
 478  fltTag x              = pprPanic "fltTag" (ppr x)
 479
 480  {-
 481  mkSimpleSwitches
 482     :: CAddrMode -> [(Literal,AbstractC)] -> AbstractC
 483     -> UniqSM StixTreeList
 484  -}
 485  mkSimpleSwitches am alts absC
 486   = getUniqLabelNCG                                     `thenUs` \ udlbl ->
 487     getUniqLabelNCG                                     `thenUs` \ ujlbl ->
 488     let am' = a2stix am
 489         joinedAlts = map (\ (tag,code) -> (tag, mkJoin code ujlbl)) alts
 490         sortedAlts = naturalMergeSortLe leAlt joinedAlts
 491                      -- naturalMergeSortLe, because we often get sorted alts to begin with
 492
 493         lowTag = intTag (fst (head sortedAlts))
 494         highTag = intTag (fst (last sortedAlts))
 495
 496         -- lowest and highest possible values the discriminant could take
 497         lowest = if floating then targetMinDouble else targetMinInt
 498         highest = if floating then targetMaxDouble else targetMaxInt
 499     in
 500         (
 501         if not floating && choices > 4 && highTag - lowTag < toInteger (2 * choices) then
 502             mkJumpTable am' sortedAlts lowTag highTag udlbl
 503         else
 504             mkBinaryTree am' floating sortedAlts choices lowest highest udlbl
 505         )
 506                                                         `thenUs` \ alt_code ->
 507         gencode absC                            `thenUs` \ dflt_code ->
 508
 509         returnUs (\xs -> alt_code (StLabel udlbl : dflt_code (StLabel ujlbl : xs)))
 510
 511     where
 512         floating = isFloatingRep (getAmodeRep am)
 513         choices = length alts
 514
 515         (x@(MachChar _),_)  `leAlt` (y,_) = intTag x <= intTag y
 516         (x@(MachInt _), _)  `leAlt` (y,_) = intTag x <= intTag y
 517         (x@(MachWord _), _) `leAlt` (y,_) = intTag x <= intTag y
 518         (x,_)               `leAlt` (y,_) = fltTag x <= fltTag y
 519
 520 \end{code}
 521
 522 We use jump tables when doing an integer switch on a relatively dense
 523 list of alternatives.  We expect to be given a list of alternatives,
 524 sorted by tag, and a range of values for which we are to generate a
 525 table.  Of course, the tags of the alternatives should lie within the
 526 indicated range.  The alternatives need not cover the range; a default
 527 target is provided for the missing alternatives.
 528
 529 If a join is necessary after the switch, the alternatives should
 530 already finish with a jump to the join point.
 531
 532 \begin{code}
 533  {-
 534  mkJumpTable
 535     :: StixTree                 -- discriminant
 536     -> [(Literal, AbstractC)]   -- alternatives
 537     -> Integer                  -- low tag
 538     -> Integer                  -- high tag
 539     -> CLabel                   -- default label
 540     -> UniqSM StixTreeList
 541  -}
 542
 543  mkJumpTable am alts lowTag highTag dflt
 544   = getUniqLabelNCG                                     `thenUs` \ utlbl ->
 545     mapUs genLabel alts                                 `thenUs` \ branches ->
 546     let cjmpLo = StCondJump dflt (StPrim IntLtOp [am, StInt (toInteger lowTag)])
 547         cjmpHi = StCondJump dflt (StPrim IntGtOp [am, StInt (toInteger highTag)])
 548
 549         offset = StPrim IntSubOp [am, StInt lowTag]
 550
 551         jump = StJump (StInd PtrRep (StIndex PtrRep (StCLbl utlbl) offset))
 552         tlbl = StLabel utlbl
 553         table = StData PtrRep (mkTable branches [lowTag..highTag] [])
 554     in
 555         mapUs mkBranch branches                         `thenUs` \ alts ->
 556
 557         returnUs (\xs -> cjmpLo : cjmpHi : jump :
 558                          StSegment DataSegment : tlbl : table :
 559                          StSegment TextSegment : foldr1 (.) alts xs)
 560
 561     where
 562         genLabel x = getUniqLabelNCG `thenUs` \ lbl -> returnUs (lbl, x)
 563
 564         mkBranch (lbl,(_,alt)) =
 565             gencode alt                         `thenUs` \ alt_code ->
 566             returnUs (\xs -> StLabel lbl : alt_code xs)
 567
 568         mkTable _  []     tbl = reverse tbl
 569         mkTable [] (x:xs) tbl = mkTable [] xs (StCLbl dflt : tbl)
 570         mkTable alts@((lbl,(tag,_)):rest) (x:xs) tbl
 571           | intTag tag == x = mkTable rest xs (StCLbl lbl : tbl)
 572           | otherwise = mkTable alts xs (StCLbl dflt : tbl)
 573
 574 \end{code}
 575
 576 We generate binary comparison trees when a jump table is inappropriate.
 577 We expect to be given a list of alternatives, sorted by tag, and for
 578 convenience, the length of the alternative list.  We recursively break
 579 the list in half and do a comparison on the first tag of the second half
 580 of the list.  (Odd lists are broken so that the second half of the list
 581 is longer.)  We can handle either integer or floating kind alternatives,
 582 so long as they are not mixed.  (We assume that the type of the discriminant
 583 determines the type of the alternatives.)
 584
 585 As with the jump table approach, if a join is necessary after the switch, the
 586 alternatives should already finish with a jump to the join point.
 587
 588 \begin{code}
 589  {-
 590  mkBinaryTree
 591     :: StixTree                 -- discriminant
 592     -> Bool                     -- floating point?
 593     -> [(Literal, AbstractC)]   -- alternatives
 594     -> Int                      -- number of choices
 595     -> Literal                  -- low tag
 596     -> Literal                  -- high tag
 597     -> CLabel                   -- default code label
 598     -> UniqSM StixTreeList
 599  -}
 600
 601  mkBinaryTree am floating [(tag,alt)] _ lowTag highTag udlbl
 602   | rangeOfOne = gencode alt
 603   | otherwise
 604   = let tag' = a2stix (CLit tag)
 605         cmpOp = if floating then DoubleNeOp else IntNeOp
 606         test = StPrim cmpOp [am, tag']
 607         cjmp = StCondJump udlbl test
 608     in
 609         gencode alt                             `thenUs` \ alt_code ->
 610         returnUs (\xs -> cjmp : alt_code xs)
 611
 612     where
 613         rangeOfOne = not floating && intTag lowTag + 1 >= intTag highTag
 614         -- When there is only one possible tag left in range, we skip the comparison
 615
 616  mkBinaryTree am floating alts choices lowTag highTag udlbl
 617   = getUniqLabelNCG                                     `thenUs` \ uhlbl ->
 618     let tag' = a2stix (CLit splitTag)
 619         cmpOp = if floating then DoubleGeOp else IntGeOp
 620         test = StPrim cmpOp [am, tag']
 621         cjmp = StCondJump uhlbl test
 622     in
 623         mkBinaryTree am floating alts_lo half lowTag splitTag udlbl
 624                                                         `thenUs` \ lo_code ->
 625         mkBinaryTree am floating alts_hi (choices - half) splitTag highTag udlbl
 626                                                         `thenUs` \ hi_code ->
 627
 628         returnUs (\xs -> cjmp : lo_code (StLabel uhlbl : hi_code xs))
 629
 630     where
 631         half = choices `div` 2
 632         (alts_lo, alts_hi) = splitAt half alts
 633         splitTag = fst (head alts_hi)
 634
 635 \end{code}
 636
 637 \begin{code}
 638  {-
 639  mkIfThenElse
 640     :: CAddrMode            -- discriminant
 641     -> Literal              -- tag
 642     -> AbstractC            -- if-part
 643     -> AbstractC            -- else-part
 644     -> UniqSM StixTreeList
 645  -}
 646
 647  mkIfThenElse discrim tag alt deflt
 648   = getUniqLabelNCG                                     `thenUs` \ ujlbl ->
 649     getUniqLabelNCG                                     `thenUs` \ utlbl ->
 650     let discrim' = a2stix discrim
 651         tag' = a2stix (CLit tag)
 652         cmpOp = if (isFloatingRep (getAmodeRep discrim)) then DoubleNeOp else IntNeOp
 653         test = StPrim cmpOp [discrim', tag']
 654         cjmp = StCondJump utlbl test
 655         dest = StLabel utlbl
 656         join = StLabel ujlbl
 657     in
 658         gencode (mkJoin alt ujlbl)              `thenUs` \ alt_code ->
 659         gencode deflt                           `thenUs` \ dflt_code ->
 660         returnUs (\xs -> cjmp : alt_code (dest : dflt_code (join : xs)))
 661
 662 mkJoin :: AbstractC -> CLabel -> AbstractC
 663
 664 mkJoin code lbl
 665   | mightFallThrough code = mkAbsCStmts code (CJump (CLbl lbl PtrRep))
 666   | otherwise = code
 667 \end{code}
 668
 669 %---------------------------------------------------------------------------
 670
 671 This answers the question: Can the code fall through to the next
 672 line(s) of code?  This errs towards saying True if it can't choose,
 673 because it is used for eliminating needless jumps.  In other words, if
 674 you might possibly {\em not} jump, then say yes to falling through.
 675
 676 \begin{code}
 677 mightFallThrough :: AbstractC -> Bool
 678
 679 mightFallThrough absC = ft absC True
 680  where
 681   ft AbsCNop       if_empty = if_empty
 682
 683   ft (CJump _)       if_empty = False
 684   ft (CReturn _ _)   if_empty = False
 685   ft (CSwitch _ alts deflt) if_empty
 686         = ft deflt if_empty ||
 687           or [ft alt if_empty | (_,alt) <- alts]
 688
 689   ft (AbsCStmts c1 c2) if_empty = ft c2 (ft c1 if_empty)
 690   ft _ if_empty = if_empty
 691
 692 {- Old algorithm, which called nonemptyAbsC for every subexpression! =========
 693 fallThroughAbsC (AbsCStmts c1 c2)
 694   = case nonemptyAbsC c2 of
 695         Nothing -> fallThroughAbsC c1
 696         Just x -> fallThroughAbsC x
 697 fallThroughAbsC (CJump _)        = False
 698 fallThroughAbsC (CReturn _ _)    = False
 699 fallThroughAbsC (CSwitch _ choices deflt)
 700   = (not (isEmptyAbsC deflt) && fallThroughAbsC deflt)
 701     || or (map (fallThroughAbsC . snd) choices)
 702 fallThroughAbsC other            = True
 703
 704 isEmptyAbsC :: AbstractC -> Bool
 705 isEmptyAbsC = not . maybeToBool . nonemptyAbsC
 706 ================= End of old, quadratic, algorithm -}
 707 \end{code}