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           ( 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 (Just 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  -- Ordinary MachOps are passed through unchanged.
 429  gencode (CMachOpStmt Nothing (MO_WriteOSBI off_w rep) [base,index,val] vols)
 430   = returnUs (\xs ->
 431        StAssignMem
 432           rep
 433           (StMachOp MO_Nat_Add
 434                     [StIndex rep (a2stix base) (a2stix index),
 435                      StInt (toInteger (off_w * wORD_SIZE))])
 436           (a2stix val)
 437        : xs
 438     )
 439
 440  gencode (CMachOpStmt (Just r1) mop args vols)
 441   = case resultRepsOfMachOp mop of
 442        Just rep
 443           -> returnUs (\xs ->
 444                 mkStAssign rep (a2stix r1)
 445                                (StMachOp mop (map a2stix args))
 446                 : xs
 447              )
 448 \end{code}
 449
 450 Now the dreaded conditional jump.
 451
 452 Now the if statement.  Almost *all* flow of control are of this form.
 453 @
 454         if (am==lit) { absC } else { absCdef }
 455 @
 456         =>
 457 @
 458         IF am = lit GOTO l1:
 459         absC
 460         jump l2:
 461    l1:
 462         absCdef
 463    l2:
 464 @
 465
 466 \begin{code}
 467
 468  gencode (CSwitch discrim alts deflt)
 469   = case alts of
 470       [] -> gencode deflt
 471
 472       [(tag,alt_code)] -> case maybe_empty_deflt of
 473                                 Nothing -> gencode alt_code
 474                                 Just dc -> mkIfThenElse discrim tag alt_code dc
 475
 476       [(tag1@(MachInt i1), alt_code1),
 477        (tag2@(MachInt i2), alt_code2)]
 478         | deflt_is_empty && i1 == 0 && i2 == 1
 479         -> mkIfThenElse discrim tag1 alt_code1 alt_code2
 480         | deflt_is_empty && i1 == 1 && i2 == 0
 481         -> mkIfThenElse discrim tag2 alt_code2 alt_code1
 482
 483         -- If the @discrim@ is simple, then this unfolding is safe.
 484       other | simple_discrim -> mkSimpleSwitches discrim alts deflt
 485
 486         -- Otherwise, we need to do a bit of work.
 487       other ->  getUniqueUs                       `thenUs` \ u ->
 488                 gencode (AbsCStmts
 489                 (CAssign (CTemp u pk) discrim)
 490                 (CSwitch (CTemp u pk) alts deflt))
 491
 492   where
 493     maybe_empty_deflt = nonemptyAbsC deflt
 494     deflt_is_empty = case maybe_empty_deflt of
 495                         Nothing -> True
 496                         Just _  -> False
 497
 498     pk = getAmodeRep discrim
 499
 500     simple_discrim = case discrim of
 501                         CReg _    -> True
 502                         CTemp _ _ -> True
 503                         other     -> False
 504 \end{code}
 505
 506
 507
 508 Finally, all of the disgusting AbstractC macros.
 509
 510 \begin{code}
 511
 512  gencode (CMacroStmt macro args) = macro_code macro args
 513
 514  gencode (CCallProfCtrMacro macro _)
 515   = returnUs (\xs -> StComment macro : xs)
 516
 517  gencode (CCallProfCCMacro macro _)
 518   = returnUs (\xs -> StComment macro : xs)
 519
 520  gencode CCallTypedef{} = returnUs id
 521
 522  gencode other
 523   = pprPanic "AbsCStixGen.gencode" (dumpRealC other)
 524
 525  nonVoid = filter ((/= VoidRep) . getAmodeRep)
 526 \end{code}
 527
 528 Here, we generate a jump table if there are more than four (integer)
 529 alternatives and the jump table occupancy is greater than 50%.
 530 Otherwise, we generate a binary comparison tree.  (Perhaps this could
 531 be tuned.)
 532
 533 \begin{code}
 534
 535  intTag :: Literal -> Integer
 536  intTag (MachChar c)  = toInteger c
 537  intTag (MachInt i)   = i
 538  intTag (MachWord w)  = intTag (word2IntLit (MachWord w))
 539  intTag _             = panic "intTag"
 540
 541  fltTag :: Literal -> Rational
 542
 543  fltTag (MachFloat f)  = f
 544  fltTag (MachDouble d) = d
 545  fltTag x              = pprPanic "fltTag" (ppr x)
 546
 547  {-
 548  mkSimpleSwitches
 549     :: CAddrMode -> [(Literal,AbstractC)] -> AbstractC
 550     -> UniqSM StixTreeList
 551  -}
 552  mkSimpleSwitches am alts absC
 553   = getUniqLabelNCG                                     `thenUs` \ udlbl ->
 554     getUniqLabelNCG                                     `thenUs` \ ujlbl ->
 555     let am' = a2stix am
 556         joinedAlts = map (\ (tag,code) -> (tag, mkJoin code ujlbl)) alts
 557         sortedAlts = naturalMergeSortLe leAlt joinedAlts
 558                      -- naturalMergeSortLe, because we often get sorted alts to begin with
 559
 560         lowTag = intTag (fst (head sortedAlts))
 561         highTag = intTag (fst (last sortedAlts))
 562
 563         -- lowest and highest possible values the discriminant could take
 564         lowest = if floating then targetMinDouble else targetMinInt
 565         highest = if floating then targetMaxDouble else targetMaxInt
 566     in
 567         (
 568         if  not floating && choices > 4
 569             && highTag - lowTag < toInteger (2 * choices)
 570         then
 571             mkJumpTable am' sortedAlts lowTag highTag udlbl
 572         else
 573             mkBinaryTree am' floating sortedAlts choices lowest highest udlbl
 574         )
 575                                                 `thenUs` \ alt_code ->
 576         gencode absC                            `thenUs` \ dflt_code ->
 577
 578         returnUs (\xs -> alt_code (StLabel udlbl : dflt_code (StLabel ujlbl : xs)))
 579
 580     where
 581         floating = isFloatingRep (getAmodeRep am)
 582         choices = length alts
 583
 584         (x@(MachChar _),_)  `leAlt` (y,_) = intTag x <= intTag y
 585         (x@(MachInt _), _)  `leAlt` (y,_) = intTag x <= intTag y
 586         (x@(MachWord _), _) `leAlt` (y,_) = intTag x <= intTag y
 587         (x,_)               `leAlt` (y,_) = fltTag x <= fltTag y
 588
 589 \end{code}
 590
 591 We use jump tables when doing an integer switch on a relatively dense
 592 list of alternatives.  We expect to be given a list of alternatives,
 593 sorted by tag, and a range of values for which we are to generate a
 594 table.  Of course, the tags of the alternatives should lie within the
 595 indicated range.  The alternatives need not cover the range; a default
 596 target is provided for the missing alternatives.
 597
 598 If a join is necessary after the switch, the alternatives should
 599 already finish with a jump to the join point.
 600
 601 \begin{code}
 602  {-
 603  mkJumpTable
 604     :: StixTree                 -- discriminant
 605     -> [(Literal, AbstractC)]   -- alternatives
 606     -> Integer                  -- low tag
 607     -> Integer                  -- high tag
 608     -> CLabel                   -- default label
 609     -> UniqSM StixTreeList
 610  -}
 611
 612  mkJumpTable am alts lowTag highTag dflt
 613   = getUniqLabelNCG                                     `thenUs` \ utlbl ->
 614     mapUs genLabel alts                                 `thenUs` \ branches ->
 615     let cjmpLo = StCondJump dflt (StMachOp MO_NatS_Lt [am, StInt (toInteger lowTag)])
 616         cjmpHi = StCondJump dflt (StMachOp MO_NatS_Gt [am, StInt (toInteger highTag)])
 617
 618         offset = StMachOp MO_Nat_Sub [am, StInt lowTag]
 619         dsts   = DestInfo (dflt : map fst branches)
 620
 621         jump = StJump dsts (StInd PtrRep (StIndex PtrRep (StCLbl utlbl) offset))
 622         tlbl = StLabel utlbl
 623         table = StData PtrRep (mkTable branches [lowTag..highTag] [])
 624     in
 625         mapUs mkBranch branches                         `thenUs` \ alts ->
 626
 627         returnUs (\xs -> cjmpLo : cjmpHi : jump :
 628                          StSegment DataSegment : tlbl : table :
 629                          StSegment TextSegment : foldr1 (.) alts xs)
 630
 631     where
 632         genLabel x = getUniqLabelNCG `thenUs` \ lbl -> returnUs (lbl, x)
 633
 634         mkBranch (lbl,(_,alt)) =
 635             gencode alt                         `thenUs` \ alt_code ->
 636             returnUs (\xs -> StLabel lbl : alt_code xs)
 637
 638         mkTable _  []     tbl = reverse tbl
 639         mkTable [] (x:xs) tbl = mkTable [] xs (StCLbl dflt : tbl)
 640         mkTable alts@((lbl,(tag,_)):rest) (x:xs) tbl
 641           | intTag tag == x = mkTable rest xs (StCLbl lbl : tbl)
 642           | otherwise = mkTable alts xs (StCLbl dflt : tbl)
 643
 644 \end{code}
 645
 646 We generate binary comparison trees when a jump table is inappropriate.
 647 We expect to be given a list of alternatives, sorted by tag, and for
 648 convenience, the length of the alternative list.  We recursively break
 649 the list in half and do a comparison on the first tag of the second half
 650 of the list.  (Odd lists are broken so that the second half of the list
 651 is longer.)  We can handle either integer or floating kind alternatives,
 652 so long as they are not mixed.  (We assume that the type of the discriminant
 653 determines the type of the alternatives.)
 654
 655 As with the jump table approach, if a join is necessary after the switch, the
 656 alternatives should already finish with a jump to the join point.
 657
 658 \begin{code}
 659  {-
 660  mkBinaryTree
 661     :: StixTree                 -- discriminant
 662     -> Bool                     -- floating point?
 663     -> [(Literal, AbstractC)]   -- alternatives
 664     -> Int                      -- number of choices
 665     -> Literal                  -- low tag
 666     -> Literal                  -- high tag
 667     -> CLabel                   -- default code label
 668     -> UniqSM StixTreeList
 669  -}
 670
 671  mkBinaryTree am floating [(tag,alt)] _ lowTag highTag udlbl
 672   | rangeOfOne = gencode alt
 673   | otherwise
 674   = let tag' = a2stix (CLit tag)
 675         cmpOp = if floating then MO_Dbl_Ne else MO_Nat_Ne
 676         test = StMachOp cmpOp [am, tag']
 677         cjmp = StCondJump udlbl test
 678     in
 679         gencode alt                             `thenUs` \ alt_code ->
 680         returnUs (\xs -> cjmp : alt_code xs)
 681
 682     where
 683         rangeOfOne = not floating && intTag lowTag + 1 >= intTag highTag
 684         -- When there is only one possible tag left in range, we skip the comparison
 685
 686  mkBinaryTree am floating alts choices lowTag highTag udlbl
 687   = getUniqLabelNCG                                     `thenUs` \ uhlbl ->
 688     let tag' = a2stix (CLit splitTag)
 689         cmpOp = if floating then MO_Dbl_Ge else MO_NatS_Ge
 690         test = StMachOp cmpOp [am, tag']
 691         cjmp = StCondJump uhlbl test
 692     in
 693         mkBinaryTree am floating alts_lo half lowTag splitTag udlbl
 694                                                         `thenUs` \ lo_code ->
 695         mkBinaryTree am floating alts_hi (choices - half) splitTag highTag udlbl
 696                                                         `thenUs` \ hi_code ->
 697
 698         returnUs (\xs -> cjmp : lo_code (StLabel uhlbl : hi_code xs))
 699
 700     where
 701         half = choices `div` 2
 702         (alts_lo, alts_hi) = splitAt half alts
 703         splitTag = fst (head alts_hi)
 704
 705 \end{code}
 706
 707 \begin{code}
 708  {-
 709  mkIfThenElse
 710     :: CAddrMode            -- discriminant
 711     -> Literal              -- tag
 712     -> AbstractC            -- if-part
 713     -> AbstractC            -- else-part
 714     -> UniqSM StixTreeList
 715  -}
 716
 717  mkIfThenElse discrim tag alt deflt
 718   = getUniqLabelNCG                                     `thenUs` \ ujlbl ->
 719     getUniqLabelNCG                                     `thenUs` \ utlbl ->
 720     let discrim' = a2stix discrim
 721         tag' = a2stix (CLit tag)
 722         cmpOp = if (isFloatingRep (getAmodeRep discrim)) then MO_Dbl_Ne else MO_Nat_Ne
 723         test = StMachOp cmpOp [discrim', tag']
 724         cjmp = StCondJump utlbl test
 725         dest = StLabel utlbl
 726         join = StLabel ujlbl
 727     in
 728         gencode (mkJoin alt ujlbl)              `thenUs` \ alt_code ->
 729         gencode deflt                           `thenUs` \ dflt_code ->
 730         returnUs (\xs -> cjmp : alt_code (dest : dflt_code (join : xs)))
 731
 732
 733 mkJoin :: AbstractC -> CLabel -> AbstractC
 734 mkJoin code lbl
 735   | mightFallThrough code = mkAbsCStmts code (CJump (CLbl lbl PtrRep))
 736   | otherwise = code
 737 \end{code}
 738
 739 %---------------------------------------------------------------------------
 740
 741 This answers the question: Can the code fall through to the next
 742 line(s) of code?  This errs towards saying True if it can't choose,
 743 because it is used for eliminating needless jumps.  In other words, if
 744 you might possibly {\em not} jump, then say yes to falling through.
 745
 746 \begin{code}
 747 mightFallThrough :: AbstractC -> Bool
 748
 749 mightFallThrough absC = ft absC True
 750  where
 751   ft AbsCNop       if_empty = if_empty
 752
 753   ft (CJump _)       if_empty = False
 754   ft (CReturn _ _)   if_empty = False
 755   ft (CSwitch _ alts deflt) if_empty
 756         = ft deflt if_empty ||
 757           or [ft alt if_empty | (_,alt) <- alts]
 758
 759   ft (AbsCStmts c1 c2) if_empty = ft c2 (ft c1 if_empty)
 760   ft _ if_empty = if_empty
 761
 762 {- Old algorithm, which called nonemptyAbsC for every subexpression! =========
 763 fallThroughAbsC (AbsCStmts c1 c2)
 764   = case nonemptyAbsC c2 of
 765         Nothing -> fallThroughAbsC c1
 766         Just x -> fallThroughAbsC x
 767 fallThroughAbsC (CJump _)        = False
 768 fallThroughAbsC (CReturn _ _)    = False
 769 fallThroughAbsC (CSwitch _ choices deflt)
 770   = (not (isEmptyAbsC deflt) && fallThroughAbsC deflt)
 771     || or (map (fallThroughAbsC . snd) choices)
 772 fallThroughAbsC other            = True
 773
 774 isEmptyAbsC :: AbstractC -> Bool
 775 isEmptyAbsC = not . maybeToBool . nonemptyAbsC
 776 ================= End of old, quadratic, algorithm -}
 777 \end{code}