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