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