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