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