ghc/compiler/nativeGen/AbsCStixGen.lhs

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