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