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