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