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