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