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