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