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