ghc/compiler/nativeGen/AbsCStixGen.lhs

   1 %
   2 % (c) The AQUA Project, Glasgow University, 1993-1996
   3 %
   4
   5 \begin{code}
   6 #include "HsVersions.h"
   7
   8 module AbsCStixGen ( genCodeAbstractC ) where
   9
  10 IMP_Ubiq(){-uitous-}
  11 IMPORT_1_3(Ratio(Rational))
  12
  13 import AbsCSyn
  14 import Stix
  15
  16 import MachMisc
  17 #if __GLASGOW_HASKELL__ >= 202
  18 import MachRegs hiding (Addr)
  19 #else
  20 import MachRegs
  21 #endif
  22
  23 import AbsCUtils        ( getAmodeRep, mixedTypeLocn,
  24                           nonemptyAbsC, mkAbsCStmts, mkAbsCStmtList
  25                         )
  26 import Constants        ( mIN_UPD_SIZE )
  27 import CLabel           ( CLabel )
  28 import ClosureInfo      ( infoTableLabelFromCI, entryLabelFromCI,
  29                           fastLabelFromCI, closureUpdReqd
  30                         )
  31 import HeapOffs         ( hpRelToInt )
  32 import Literal          ( Literal(..) )
  33 import Maybes           ( maybeToBool )
  34 import OrdList          ( OrdList )
  35 import PrimOp           ( primOpNeedsWrapper, PrimOp(..) )
  36 import PrimRep          ( isFloatingRep, PrimRep(..) )
  37 import StixInfo         ( genCodeInfoTable )
  38 import StixMacro        ( macroCode )
  39 import StixPrim         ( primCode, amodeToStix, amodeToStix' )
  40 import UniqSupply       ( returnUs, thenUs, mapUs, getUnique, SYN_IE(UniqSM) )
  41 import Util             ( naturalMergeSortLe, panic )
  42
  43 #ifdef REALLY_HASKELL_1_3
  44 ord = fromEnum :: Char -> Int
  45 #endif
  46 \end{code}
  47
  48 For each independent chunk of AbstractC code, we generate a list of
  49 @StixTree@s, where each tree corresponds to a single Stix instruction.
  50 We leave the chunks separated so that register allocation can be
  51 performed locally within the chunk.
  52
  53 \begin{code}
  54 genCodeAbstractC :: AbstractC -> UniqSM [[StixTree]]
  55
  56 genCodeAbstractC absC
  57   = mapUs gentopcode (mkAbsCStmtList absC) `thenUs` \ trees ->
  58     returnUs ([StComment SLIT("Native Code")] : trees)
  59  where
  60  a2stix      = amodeToStix
  61  a2stix'     = amodeToStix'
  62  volsaves    = volatileSaves
  63  volrestores = volatileRestores
  64  p2stix      = primCode
  65  macro_code  = macroCode
  66  hp_rel      = hpRelToInt
  67  -- real code follows... ---------
  68 \end{code}
  69
  70 Here we handle top-level things, like @CCodeBlock@s and
  71 @CClosureInfoTable@s.
  72
  73 \begin{code}
  74  {-
  75  genCodeTopAbsC
  76     :: AbstractC
  77     -> UniqSM [StixTree]
  78  -}
  79
  80  gentopcode (CCodeBlock label absC)
  81   = gencode absC                                `thenUs` \ code ->
  82     returnUs (StSegment TextSegment : StFunBegin label : code [StFunEnd label])
  83
  84  gentopcode stmt@(CStaticClosure label _ _ _)
  85   = genCodeStaticClosure stmt                   `thenUs` \ code ->
  86     returnUs (StSegment DataSegment : StLabel label : code [])
  87
  88  gentopcode stmt@(CRetUnVector _ _) = returnUs []
  89
  90  gentopcode stmt@(CFlatRetVector label _)
  91   = genCodeVecTbl stmt                          `thenUs` \ code ->
  92     returnUs (StSegment TextSegment : code [StLabel label])
  93
  94  gentopcode stmt@(CClosureInfoAndCode cl_info slow Nothing _ _ _)
  95
  96   | slow_is_empty
  97   = genCodeInfoTable stmt               `thenUs` \ itbl ->
  98     returnUs (StSegment TextSegment : itbl [])
  99
 100   | otherwise
 101   = genCodeInfoTable stmt               `thenUs` \ itbl ->
 102     gencode slow                        `thenUs` \ slow_code ->
 103     returnUs (StSegment TextSegment : itbl (StFunBegin slow_lbl :
 104               slow_code [StFunEnd slow_lbl]))
 105   where
 106     slow_is_empty = not (maybeToBool (nonemptyAbsC slow))
 107     slow_lbl = entryLabelFromCI cl_info
 108
 109  gentopcode stmt@(CClosureInfoAndCode cl_info slow (Just fast) _ _ _) =
 110  -- ToDo: what if this is empty? ------------------------^^^^
 111     genCodeInfoTable stmt               `thenUs` \ itbl ->
 112     gencode slow                        `thenUs` \ slow_code ->
 113     gencode fast                        `thenUs` \ fast_code ->
 114     returnUs (StSegment TextSegment : itbl (StFunBegin slow_lbl :
 115               slow_code (StFunEnd slow_lbl : StFunBegin fast_lbl :
 116               fast_code [StFunEnd fast_lbl])))
 117   where
 118     slow_lbl = entryLabelFromCI cl_info
 119     fast_lbl = fastLabelFromCI cl_info
 120
 121  gentopcode absC
 122   = gencode absC                                `thenUs` \ code ->
 123     returnUs (StSegment TextSegment : code [])
 124
 125 \end{code}
 126
 127 Vector tables are trivial!
 128
 129 \begin{code}
 130  {-
 131  genCodeVecTbl
 132     :: AbstractC
 133     -> UniqSM StixTreeList
 134  -}
 135  genCodeVecTbl (CFlatRetVector label amodes)
 136   = returnUs (\xs -> vectbl : xs)
 137   where
 138     vectbl = StData PtrRep (reverse (map a2stix amodes))
 139
 140 \end{code}
 141
 142 Static closures are not so hard either.
 143
 144 \begin{code}
 145  {-
 146  genCodeStaticClosure
 147     :: AbstractC
 148     -> UniqSM StixTreeList
 149  -}
 150  genCodeStaticClosure (CStaticClosure _ cl_info cost_centre amodes)
 151   = returnUs (\xs -> table : xs)
 152   where
 153     table = StData PtrRep (StCLbl info_lbl : body)
 154     info_lbl = infoTableLabelFromCI cl_info
 155
 156     body = if closureUpdReqd cl_info then
 157                 take (max mIN_UPD_SIZE (length amodes')) (amodes' ++ zeros)
 158            else
 159                 amodes'
 160
 161     zeros = StInt 0 : zeros
 162
 163     amodes' = map amodeZeroVoid amodes
 164
 165         -- Watch out for VoidKinds...cf. PprAbsC
 166     amodeZeroVoid item
 167       | getAmodeRep item == VoidRep = StInt 0
 168       | otherwise = a2stix item
 169
 170 \end{code}
 171
 172 Now the individual AbstractC statements.
 173
 174 \begin{code}
 175  {-
 176  gencode
 177     :: AbstractC
 178     -> UniqSM StixTreeList
 179  -}
 180 \end{code}
 181
 182 @AbsCNop@s just disappear.
 183
 184 \begin{code}
 185
 186  gencode AbsCNop = returnUs id
 187
 188 \end{code}
 189
 190 Split markers are a NOP in this land.
 191
 192 \begin{code}
 193
 194  gencode CSplitMarker = returnUs id
 195
 196 \end{code}
 197
 198 AbstractC instruction sequences are handled individually, and the
 199 resulting StixTreeLists are joined together.
 200
 201 \begin{code}
 202
 203  gencode (AbsCStmts c1 c2)
 204   = gencode c1                          `thenUs` \ b1 ->
 205     gencode c2                          `thenUs` \ b2 ->
 206     returnUs (b1 . b2)
 207
 208 \end{code}
 209
 210 Initialising closure headers in the heap...a fairly complex ordeal if
 211 done properly.  For now, we just set the info pointer, but we should
 212 really take a peek at the flags to determine whether or not there are
 213 other things to be done (setting cost centres, age headers, global
 214 addresses, etc.)
 215
 216 \begin{code}
 217
 218  gencode (CInitHdr cl_info reg_rel _ _)
 219   = let
 220         lhs = a2stix (CVal reg_rel PtrRep)
 221         lbl = infoTableLabelFromCI cl_info
 222     in
 223         returnUs (\xs -> StAssign PtrRep lhs (StCLbl lbl) : xs)
 224
 225 \end{code}
 226
 227 Assignment, the curse of von Neumann, is the center of the code we
 228 produce.  In most cases, the type of the assignment is determined
 229 by the type of the destination.  However, when the destination can
 230 have mixed types, the type of the assignment is ``StgWord'' (we use
 231 PtrRep for lack of anything better).  Think:  do we also want a cast
 232 of the source?  Be careful about floats/doubles.
 233
 234 \begin{code}
 235
 236  gencode (CAssign lhs rhs)
 237   | getAmodeRep lhs == VoidRep = returnUs id
 238   | otherwise
 239   = let pk = getAmodeRep lhs
 240         pk' = if mixedTypeLocn lhs && not (isFloatingRep pk) then IntRep else pk
 241         lhs' = a2stix lhs
 242         rhs' = a2stix' rhs
 243     in
 244         returnUs (\xs -> StAssign pk' lhs' rhs' : xs)
 245
 246 \end{code}
 247
 248 Unconditional jumps, including the special ``enter closure'' operation.
 249 Note that the new entry convention requires that we load the InfoPtr (R2)
 250 with the address of the info table before jumping to the entry code for Node.
 251
 252 \begin{code}
 253
 254  gencode (CJump dest)
 255   = returnUs (\xs -> StJump (a2stix dest) : xs)
 256
 257  gencode (CFallThrough (CLbl lbl _))
 258   = returnUs (\xs -> StFallThrough lbl : xs)
 259
 260  gencode (CReturn dest DirectReturn)
 261   = returnUs (\xs -> StJump (a2stix dest) : xs)
 262
 263  gencode (CReturn table (StaticVectoredReturn n))
 264   = returnUs (\xs -> StJump dest : xs)
 265   where
 266     dest = StInd PtrRep (StIndex PtrRep (a2stix table)
 267                                           (StInt (toInteger (-n-1))))
 268
 269  gencode (CReturn table (DynamicVectoredReturn am))
 270   = returnUs (\xs -> StJump dest : xs)
 271   where
 272     dest = StInd PtrRep (StIndex PtrRep (a2stix table) dyn_off)
 273     dyn_off = StPrim IntSubOp [StPrim IntNegOp [a2stix am], StInt 1]
 274
 275 \end{code}
 276
 277 Now the PrimOps, some of which may need caller-saves register wrappers.
 278
 279 \begin{code}
 280
 281  gencode (COpStmt results op args liveness_mask vols)
 282   -- ToDo (ADR?): use that liveness mask
 283   | primOpNeedsWrapper op
 284   = let
 285         saves = volsaves vols
 286         restores = volrestores vols
 287     in
 288         p2stix (nonVoid results) op (nonVoid args)
 289                                                         `thenUs` \ code ->
 290         returnUs (\xs -> saves ++ code (restores ++ xs))
 291
 292   | otherwise = p2stix (nonVoid results) op (nonVoid args)
 293     where
 294         nonVoid = filter ((/= VoidRep) . getAmodeRep)
 295
 296 \end{code}
 297
 298 Now the dreaded conditional jump.
 299
 300 Now the if statement.  Almost *all* flow of control are of this form.
 301 @
 302         if (am==lit) { absC } else { absCdef }
 303 @
 304         =>
 305 @
 306         IF am = lit GOTO l1:
 307         absC
 308         jump l2:
 309    l1:
 310         absCdef
 311    l2:
 312 @
 313
 314 \begin{code}
 315
 316  gencode (CSwitch discrim alts deflt)
 317   = case alts of
 318       [] -> gencode deflt
 319
 320       [(tag,alt_code)] -> case maybe_empty_deflt of
 321                                 Nothing -> gencode alt_code
 322                                 Just dc -> mkIfThenElse discrim tag alt_code dc
 323
 324       [(tag1@(MachInt i1 _), alt_code1),
 325        (tag2@(MachInt i2 _), alt_code2)]
 326         | deflt_is_empty && i1 == 0 && i2 == 1
 327         -> mkIfThenElse discrim tag1 alt_code1 alt_code2
 328         | deflt_is_empty && i1 == 1 && i2 == 0
 329         -> mkIfThenElse discrim tag2 alt_code2 alt_code1
 330
 331         -- If the @discrim@ is simple, then this unfolding is safe.
 332       other | simple_discrim -> mkSimpleSwitches discrim alts deflt
 333
 334         -- Otherwise, we need to do a bit of work.
 335       other ->  getUnique                         `thenUs` \ u ->
 336                 gencode (AbsCStmts
 337                 (CAssign (CTemp u pk) discrim)
 338                 (CSwitch (CTemp u pk) alts deflt))
 339
 340   where
 341     maybe_empty_deflt = nonemptyAbsC deflt
 342     deflt_is_empty = case maybe_empty_deflt of
 343                         Nothing -> True
 344                         Just _  -> False
 345
 346     pk = getAmodeRep discrim
 347
 348     simple_discrim = case discrim of
 349                         CReg _    -> True
 350                         CTemp _ _ -> True
 351                         other     -> False
 352 \end{code}
 353
 354
 355
 356 Finally, all of the disgusting AbstractC macros.
 357
 358 \begin{code}
 359
 360  gencode (CMacroStmt macro args) = macro_code macro args
 361
 362  gencode (CCallProfCtrMacro macro _)
 363   = returnUs (\xs -> StComment macro : xs)
 364
 365  gencode (CCallProfCCMacro macro _)
 366   = returnUs (\xs -> StComment macro : xs)
 367
 368 \end{code}
 369
 370 Here, we generate a jump table if there are more than four (integer) alternatives and
 371 the jump table occupancy is greater than 50%.  Otherwise, we generate a binary
 372 comparison tree.  (Perhaps this could be tuned.)
 373
 374 \begin{code}
 375
 376  intTag :: Literal -> Integer
 377  intTag (MachChar c) = toInteger (ord c)
 378  intTag (MachInt i _) = i
 379  intTag _ = panic "intTag"
 380
 381  fltTag :: Literal -> Rational
 382
 383  fltTag (MachFloat f) = f
 384  fltTag (MachDouble d) = d
 385  fltTag _ = panic "fltTag"
 386
 387  {-
 388  mkSimpleSwitches
 389     :: CAddrMode -> [(Literal,AbstractC)] -> AbstractC
 390     -> UniqSM StixTreeList
 391  -}
 392  mkSimpleSwitches am alts absC
 393   = getUniqLabelNCG                                     `thenUs` \ udlbl ->
 394     getUniqLabelNCG                                     `thenUs` \ ujlbl ->
 395     let am' = a2stix am
 396         joinedAlts = map (\ (tag,code) -> (tag, mkJoin code ujlbl)) alts
 397         sortedAlts = naturalMergeSortLe leAlt joinedAlts
 398                      -- naturalMergeSortLe, because we often get sorted alts to begin with
 399
 400         lowTag = intTag (fst (head sortedAlts))
 401         highTag = intTag (fst (last sortedAlts))
 402
 403         -- lowest and highest possible values the discriminant could take
 404         lowest = if floating then targetMinDouble else targetMinInt
 405         highest = if floating then targetMaxDouble else targetMaxInt
 406     in
 407         (
 408         if not floating && choices > 4 && highTag - lowTag < toInteger (2 * choices) then
 409             mkJumpTable am' sortedAlts lowTag highTag udlbl
 410         else
 411             mkBinaryTree am' floating sortedAlts choices lowest highest udlbl
 412         )
 413                                                         `thenUs` \ alt_code ->
 414         gencode absC                            `thenUs` \ dflt_code ->
 415
 416         returnUs (\xs -> alt_code (StLabel udlbl : dflt_code (StLabel ujlbl : xs)))
 417
 418     where
 419         floating = isFloatingRep (getAmodeRep am)
 420         choices = length alts
 421
 422         (x@(MachChar _),_)  `leAlt` (y,_) = intTag x <= intTag y
 423         (x@(MachInt _ _),_) `leAlt` (y,_) = intTag x <= intTag y
 424         (x,_)               `leAlt` (y,_) = fltTag x <= fltTag y
 425
 426 \end{code}
 427
 428 We use jump tables when doing an integer switch on a relatively dense
 429 list of alternatives.  We expect to be given a list of alternatives,
 430 sorted by tag, and a range of values for which we are to generate a
 431 table.  Of course, the tags of the alternatives should lie within the
 432 indicated range.  The alternatives need not cover the range; a default
 433 target is provided for the missing alternatives.
 434
 435 If a join is necessary after the switch, the alternatives should
 436 already finish with a jump to the join point.
 437
 438 \begin{code}
 439  {-
 440  mkJumpTable
 441     :: StixTree                 -- discriminant
 442     -> [(Literal, AbstractC)]   -- alternatives
 443     -> Integer                  -- low tag
 444     -> Integer                  -- high tag
 445     -> CLabel                   -- default label
 446     -> UniqSM StixTreeList
 447  -}
 448
 449  mkJumpTable am alts lowTag highTag dflt
 450   = getUniqLabelNCG                                     `thenUs` \ utlbl ->
 451     mapUs genLabel alts                                 `thenUs` \ branches ->
 452     let cjmpLo = StCondJump dflt (StPrim IntLtOp [am, StInt lowTag])
 453         cjmpHi = StCondJump dflt (StPrim IntGtOp [am, StInt highTag])
 454
 455         offset = StPrim IntSubOp [am, StInt lowTag]
 456         jump = StJump (StInd PtrRep (StIndex PtrRep (StCLbl utlbl) offset))
 457
 458         tlbl = StLabel utlbl
 459         table = StData PtrRep (mkTable branches [lowTag..highTag] [])
 460     in
 461         mapUs mkBranch branches                         `thenUs` \ alts ->
 462
 463         returnUs (\xs -> cjmpLo : cjmpHi : jump :
 464                          StSegment DataSegment : tlbl : table :
 465                          StSegment TextSegment : foldr1 (.) alts xs)
 466
 467     where
 468         genLabel x = getUniqLabelNCG `thenUs` \ lbl -> returnUs (lbl, x)
 469
 470         mkBranch (lbl,(_,alt)) =
 471             gencode alt                         `thenUs` \ alt_code ->
 472             returnUs (\xs -> StLabel lbl : alt_code xs)
 473
 474         mkTable _  []     tbl = reverse tbl
 475         mkTable [] (x:xs) tbl = mkTable [] xs (StCLbl dflt : tbl)
 476         mkTable alts@((lbl,(tag,_)):rest) (x:xs) tbl
 477           | intTag tag == x = mkTable rest xs (StCLbl lbl : tbl)
 478           | otherwise = mkTable alts xs (StCLbl dflt : tbl)
 479
 480 \end{code}
 481
 482 We generate binary comparison trees when a jump table is inappropriate.
 483 We expect to be given a list of alternatives, sorted by tag, and for
 484 convenience, the length of the alternative list.  We recursively break
 485 the list in half and do a comparison on the first tag of the second half
 486 of the list.  (Odd lists are broken so that the second half of the list
 487 is longer.)  We can handle either integer or floating kind alternatives,
 488 so long as they are not mixed.  (We assume that the type of the discriminant
 489 determines the type of the alternatives.)
 490
 491 As with the jump table approach, if a join is necessary after the switch, the
 492 alternatives should already finish with a jump to the join point.
 493
 494 \begin{code}
 495  {-
 496  mkBinaryTree
 497     :: StixTree                 -- discriminant
 498     -> Bool                     -- floating point?
 499     -> [(Literal, AbstractC)]   -- alternatives
 500     -> Int                      -- number of choices
 501     -> Literal                  -- low tag
 502     -> Literal                  -- high tag
 503     -> CLabel                   -- default code label
 504     -> UniqSM StixTreeList
 505  -}
 506
 507  mkBinaryTree am floating [(tag,alt)] _ lowTag highTag udlbl
 508   | rangeOfOne = gencode alt
 509   | otherwise
 510   = let tag' = a2stix (CLit tag)
 511         cmpOp = if floating then DoubleNeOp else IntNeOp
 512         test = StPrim cmpOp [am, tag']
 513         cjmp = StCondJump udlbl test
 514     in
 515         gencode alt                             `thenUs` \ alt_code ->
 516         returnUs (\xs -> cjmp : alt_code xs)
 517
 518     where
 519         rangeOfOne = not floating && intTag lowTag + 1 >= intTag highTag
 520         -- When there is only one possible tag left in range, we skip the comparison
 521
 522  mkBinaryTree am floating alts choices lowTag highTag udlbl
 523   = getUniqLabelNCG                                     `thenUs` \ uhlbl ->
 524     let tag' = a2stix (CLit splitTag)
 525         cmpOp = if floating then DoubleGeOp else IntGeOp
 526         test = StPrim cmpOp [am, tag']
 527         cjmp = StCondJump uhlbl test
 528     in
 529         mkBinaryTree am floating alts_lo half lowTag splitTag udlbl
 530                                                         `thenUs` \ lo_code ->
 531         mkBinaryTree am floating alts_hi (choices - half) splitTag highTag udlbl
 532                                                         `thenUs` \ hi_code ->
 533
 534         returnUs (\xs -> cjmp : lo_code (StLabel uhlbl : hi_code xs))
 535
 536     where
 537         half = choices `div` 2
 538         (alts_lo, alts_hi) = splitAt half alts
 539         splitTag = fst (head alts_hi)
 540
 541 \end{code}
 542
 543 \begin{code}
 544  {-
 545  mkIfThenElse
 546     :: CAddrMode            -- discriminant
 547     -> Literal              -- tag
 548     -> AbstractC            -- if-part
 549     -> AbstractC            -- else-part
 550     -> UniqSM StixTreeList
 551  -}
 552
 553  mkIfThenElse discrim tag alt deflt
 554   = getUniqLabelNCG                                     `thenUs` \ ujlbl ->
 555     getUniqLabelNCG                                     `thenUs` \ utlbl ->
 556     let discrim' = a2stix discrim
 557         tag' = a2stix (CLit tag)
 558         cmpOp = if (isFloatingRep (getAmodeRep discrim)) then DoubleNeOp else IntNeOp
 559         test = StPrim cmpOp [discrim', tag']
 560         cjmp = StCondJump utlbl test
 561         dest = StLabel utlbl
 562         join = StLabel ujlbl
 563     in
 564         gencode (mkJoin alt ujlbl)              `thenUs` \ alt_code ->
 565         gencode deflt                           `thenUs` \ dflt_code ->
 566         returnUs (\xs -> cjmp : alt_code (dest : dflt_code (join : xs)))
 567
 568 mkJoin :: AbstractC -> CLabel -> AbstractC
 569
 570 mkJoin code lbl
 571   | mightFallThrough code = mkAbsCStmts code (CJump (CLbl lbl PtrRep))
 572   | otherwise = code
 573 \end{code}
 574
 575 %---------------------------------------------------------------------------
 576
 577 This answers the question: Can the code fall through to the next
 578 line(s) of code?  This errs towards saying True if it can't choose,
 579 because it is used for eliminating needless jumps.  In other words, if
 580 you might possibly {\em not} jump, then say yes to falling through.
 581
 582 \begin{code}
 583 mightFallThrough :: AbstractC -> Bool
 584
 585 mightFallThrough absC = ft absC True
 586  where
 587   ft AbsCNop       if_empty = if_empty
 588
 589   ft (CJump _)       if_empty = False
 590   ft (CReturn _ _)   if_empty = False
 591   ft (CSwitch _ alts deflt) if_empty
 592         = ft deflt if_empty ||
 593           or [ft alt if_empty | (_,alt) <- alts]
 594
 595   ft (AbsCStmts c1 c2) if_empty = ft c2 (ft c1 if_empty)
 596   ft _ if_empty = if_empty
 597
 598 {- Old algorithm, which called nonemptyAbsC for every subexpression! =========
 599 fallThroughAbsC (AbsCStmts c1 c2)
 600   = case nonemptyAbsC c2 of
 601         Nothing -> fallThroughAbsC c1
 602         Just x -> fallThroughAbsC x
 603 fallThroughAbsC (CJump _)        = False
 604 fallThroughAbsC (CReturn _ _)    = False
 605 fallThroughAbsC (CSwitch _ choices deflt)
 606   = (not (isEmptyAbsC deflt) && fallThroughAbsC deflt)
 607     || or (map (fallThroughAbsC . snd) choices)
 608 fallThroughAbsC other            = True
 609
 610 isEmptyAbsC :: AbstractC -> Bool
 611 isEmptyAbsC = not . maybeToBool . nonemptyAbsC
 612 ================= End of old, quadratic, algorithm -}
 613 \end{code}