ghc/compiler/nativeGen/Stix.lhs

   1 %
   2 % (c) The AQUA Project, Glasgow University, 1993-1998
   3 %
   4
   5 \begin{code}
   6 module Stix (
   7         CodeSegment(..), StixReg(..), StixTree(..), StixTreeList,
   8         pprStixTrees, pprStixTree, ppStixReg,
   9         stixCountTempUses, stixSubst,
  10         DestInfo(..), hasDestInfo,
  11
  12         stgBaseReg, stgNode, stgSp, stgSu, stgSpLim,
  13         stgHp, stgHpLim, stgTagReg, stgR9, stgR10,
  14         stgCurrentTSO, stgCurrentNursery,
  15
  16         fixedHS, arrWordsHS, arrPtrsHS,
  17
  18         NatM, initNat, thenNat, returnNat,
  19         mapNat, mapAndUnzipNat, mapAccumLNat,
  20         getUniqueNat, getDeltaNat, setDeltaNat,
  21         NatM_State, mkNatM_State,
  22         uniqOfNatM_State, deltaOfNatM_State,
  23
  24         getUniqLabelNCG, getNatLabelNCG,
  25     ) where
  26
  27 #include "HsVersions.h"
  28
  29 import Ratio            ( Rational )
  30
  31 import AbsCSyn          ( node, tagreg, MagicId(..) )
  32 import CallConv         ( CallConv, pprCallConv )
  33 import CLabel           ( mkAsmTempLabel, CLabel, pprCLabel )
  34 import PrimRep          ( PrimRep(..), showPrimRep )
  35 import PrimOp           ( PrimOp, pprPrimOp )
  36 import Unique           ( Unique )
  37 import SMRep            ( fixedHdrSize, arrWordsHdrSize, arrPtrsHdrSize )
  38 import UniqSupply       ( UniqSupply, splitUniqSupply, uniqFromSupply,
  39                           UniqSM, thenUs, returnUs, getUniqueUs )
  40 import Outputable
  41 import FastTypes
  42 \end{code}
  43
  44 Here is the tag at the nodes of our @StixTree@.  Notice its
  45 relationship with @PrimOp@ in prelude/PrimOp.
  46
  47 \begin{code}
  48 data StixTree
  49   = -- Segment (text or data)
  50
  51     StSegment CodeSegment
  52
  53     -- We can tag the leaves with constants/immediates.
  54
  55   | StInt       Integer     -- ** add Kind at some point
  56   | StFloat     Rational
  57   | StDouble    Rational
  58   | StString    FAST_STRING
  59   | StCLbl      CLabel      -- labels that we might index into
  60
  61     -- Abstract registers of various kinds
  62
  63   | StReg StixReg
  64
  65     -- A typed offset from a base location
  66
  67   | StIndex PrimRep StixTree StixTree -- kind, base, offset
  68
  69     -- An indirection from an address to its contents.
  70
  71   | StInd PrimRep StixTree
  72
  73     -- Assignment is typed to determine size and register placement
  74
  75   | StAssign PrimRep StixTree StixTree -- dst, src
  76
  77     -- A simple assembly label that we might jump to.
  78
  79   | StLabel CLabel
  80
  81     -- A function header and footer
  82
  83   | StFunBegin CLabel
  84   | StFunEnd CLabel
  85
  86     -- An unconditional jump. This instruction may or may not jump
  87     -- out of the register allocation domain (basic block, more or
  88     -- less).  For correct register allocation when this insn is used
  89     -- to jump through a jump table, we optionally allow a list of
  90     -- the exact targets to be attached, so that the allocator can
  91     -- easily construct the exact flow edges leaving this insn.
  92     -- Dynamic targets are allowed.
  93
  94   | StJump DestInfo StixTree
  95
  96     -- A fall-through, from slow to fast
  97
  98   | StFallThrough CLabel
  99
 100     -- A conditional jump. This instruction can be non-terminal :-)
 101     -- Only static, local, forward labels are allowed
 102
 103   | StCondJump CLabel StixTree
 104
 105     -- Raw data (as in an info table).
 106
 107   | StData PrimRep [StixTree]
 108
 109     -- Primitive Operations
 110
 111   | StPrim PrimOp [StixTree]
 112
 113     -- Calls to C functions
 114
 115   | StCall FAST_STRING CallConv PrimRep [StixTree]
 116
 117     -- A volatile memory scratch array, which is allocated
 118     -- relative to the stack pointer.  It is an array of
 119     -- ptr/word/int sized things.  Do not expect to be preserved
 120     -- beyond basic blocks or over a ccall.  Current max size
 121     -- is 6, used in StixInteger.
 122
 123   | StScratchWord Int
 124
 125     -- Assembly-language comments
 126
 127   | StComment FAST_STRING
 128
 129
 130 -- used by insnFuture in RegAllocInfo.lhs
 131 data DestInfo
 132    = NoDestInfo             -- no supplied dests; infer from context
 133    | DestInfo [CLabel]      -- precisely these dests and no others
 134
 135 hasDestInfo NoDestInfo   = False
 136 hasDestInfo (DestInfo _) = True
 137
 138 pprDests :: DestInfo -> SDoc
 139 pprDests NoDestInfo      = text "NoDestInfo"
 140 pprDests (DestInfo dsts) = brack (hsep (map pprCLabel dsts))
 141
 142
 143 pprStixTrees :: [StixTree] -> SDoc
 144 pprStixTrees ts
 145   = vcat [
 146        vcat (map pprStixTree ts),
 147        char ' ',
 148        char ' '
 149     ]
 150
 151 paren t = char '(' <> t <> char ')'
 152 brack t = char '[' <> t <> char ']'
 153
 154 pprStixTree :: StixTree -> SDoc
 155 pprStixTree t
 156    = case t of
 157        StSegment cseg   -> paren (ppCodeSegment cseg)
 158        StInt i          -> paren (integer i)
 159        StFloat rat      -> paren (text "Float" <+> rational rat)
 160        StDouble rat     -> paren (text "Double" <+> rational rat)
 161        StString str     -> paren (text "Str" <+> ptext str)
 162        StComment str    -> paren (text "Comment" <+> ptext str)
 163        StCLbl lbl       -> pprCLabel lbl
 164        StReg reg        -> ppStixReg reg
 165        StIndex k b o    -> paren (pprStixTree b <+> char '+' <>
 166                                   pprPrimRep k <+> pprStixTree o)
 167        StInd k t        -> pprPrimRep k <> char '[' <> pprStixTree t <> char ']'
 168        StAssign k d s   -> pprStixTree d <> text "  :=" <> pprPrimRep k
 169                                          <> text "  " <> pprStixTree s
 170        StLabel ll       -> pprCLabel ll <+> char ':'
 171        StFunBegin ll    -> char ' ' $$ paren (text "FunBegin" <+> pprCLabel ll)
 172        StFunEnd ll      -> paren (text "FunEnd" <+> pprCLabel ll)
 173        StJump dsts t    -> paren (text "Jump" <+> pprDests dsts <+> pprStixTree t)
 174        StFallThrough ll -> paren (text "FallThru" <+> pprCLabel ll)
 175        StCondJump l t   -> paren (text "JumpC" <+> pprCLabel l
 176                                                <+> pprStixTree t)
 177        StData k ds      -> paren (text "Data" <+> pprPrimRep k <+>
 178                                   hsep (map pprStixTree ds))
 179        StPrim op ts     -> paren (text "Prim" <+> pprPrimOp op <+>
 180                                   hsep (map pprStixTree ts))
 181        StCall nm cc k args
 182                         -> paren (text "Call" <+> ptext nm <+>
 183                                   pprCallConv cc <+> pprPrimRep k <+>
 184                                   hsep (map pprStixTree args))
 185        StScratchWord i  -> text "ScratchWord" <> paren (int i)
 186
 187 pprPrimRep = text . showPrimRep
 188 \end{code}
 189
 190 Stix registers can have two forms.  They {\em may} or {\em may not}
 191 map to real, machine-level registers.
 192
 193 \begin{code}
 194 data StixReg
 195   = StixMagicId MagicId -- Regs which are part of the abstract machine model
 196
 197   | StixTemp Unique PrimRep -- "Regs" which model local variables (CTemps) in
 198                                         -- the abstract C.
 199
 200 ppStixReg (StixMagicId mid)
 201    = ppMId mid
 202 ppStixReg (StixTemp u pr)
 203    = hcat [text "Temp(", ppr u, ppr pr, char ')']
 204
 205
 206 ppMId BaseReg              = text "BaseReg"
 207 ppMId (VanillaReg kind n)  = hcat [pprPrimRep kind, text "IntReg(",
 208                                    int (iBox n), char ')']
 209 ppMId (FloatReg n)         = hcat [text "FltReg(", int (iBox n), char ')']
 210 ppMId (DoubleReg n)        = hcat [text "DblReg(", int (iBox n), char ')']
 211 ppMId (LongReg kind n)     = hcat [pprPrimRep kind, text "LongReg(",
 212                                    int (iBox n), char ')']
 213 ppMId Sp                   = text "Sp"
 214 ppMId Su                   = text "Su"
 215 ppMId SpLim                = text "SpLim"
 216 ppMId Hp                   = text "Hp"
 217 ppMId HpLim                = text "HpLim"
 218 ppMId CurCostCentre        = text "CCC"
 219 ppMId VoidReg              = text "VoidReg"
 220 \end{code}
 221
 222 We hope that every machine supports the idea of data segment and text
 223 segment (or that it has no segments at all, and we can lump these
 224 together).
 225
 226 \begin{code}
 227 data CodeSegment = DataSegment | TextSegment deriving (Eq, Show)
 228 ppCodeSegment = text . show
 229
 230 type StixTreeList = [StixTree] -> [StixTree]
 231 \end{code}
 232
 233 Stix Trees for STG registers:
 234 \begin{code}
 235 stgBaseReg, stgNode, stgSp, stgSu, stgSpLim, stgHp, stgHpLim
 236         :: StixTree
 237
 238 stgBaseReg          = StReg (StixMagicId BaseReg)
 239 stgNode             = StReg (StixMagicId node)
 240 stgTagReg           = StReg (StixMagicId tagreg)
 241 stgSp               = StReg (StixMagicId Sp)
 242 stgSu               = StReg (StixMagicId Su)
 243 stgSpLim            = StReg (StixMagicId SpLim)
 244 stgHp               = StReg (StixMagicId Hp)
 245 stgHpLim            = StReg (StixMagicId HpLim)
 246 stgCurrentTSO       = StReg (StixMagicId CurrentTSO)
 247 stgCurrentNursery   = StReg (StixMagicId CurrentNursery)
 248 stgR9               = StReg (StixMagicId (VanillaReg WordRep (_ILIT 9)))
 249 stgR10              = StReg (StixMagicId (VanillaReg WordRep (_ILIT 10)))
 250
 251 getNatLabelNCG :: NatM CLabel
 252 getNatLabelNCG
 253   = getUniqueNat `thenNat` \ u ->
 254     returnNat (mkAsmTempLabel u)
 255
 256 getUniqLabelNCG :: UniqSM CLabel
 257 getUniqLabelNCG
 258   = getUniqueUs `thenUs` \ u ->
 259     returnUs (mkAsmTempLabel u)
 260
 261 fixedHS     = StInt (toInteger fixedHdrSize)
 262 arrWordsHS  = StInt (toInteger arrWordsHdrSize)
 263 arrPtrsHS   = StInt (toInteger arrPtrsHdrSize)
 264 \end{code}
 265
 266 Stix optimisation passes may wish to find out how many times a
 267 given temporary appears in a tree, so as to be able to decide
 268 whether or not to inline the assignment's RHS at usage site(s).
 269
 270 \begin{code}
 271 stixCountTempUses :: Unique -> StixTree -> Int
 272 stixCountTempUses u t
 273    = let qq = stixCountTempUses u
 274      in
 275      case t of
 276         StReg reg
 277            -> case reg of
 278                  StixTemp uu pr  -> if u == uu then 1 else 0
 279                  StixMagicId mid -> 0
 280
 281         StIndex    pk t1 t2       -> qq t1 + qq t2
 282         StInd      pk t1          -> qq t1
 283         StAssign   pk t1 t2       -> qq t1 + qq t2
 284         StJump     dsts t1        -> qq t1
 285         StCondJump lbl t1         -> qq t1
 286         StData     pk ts          -> sum (map qq ts)
 287         StPrim     op ts          -> sum (map qq ts)
 288         StCall     nm cconv pk ts -> sum (map qq ts)
 289
 290         StSegment _      -> 0
 291         StInt _          -> 0
 292         StFloat _        -> 0
 293         StDouble _       -> 0
 294         StString _       -> 0
 295         StCLbl _         -> 0
 296         StLabel _        -> 0
 297         StFunBegin _     -> 0
 298         StFunEnd _       -> 0
 299         StFallThrough _  -> 0
 300         StScratchWord _  -> 0
 301         StComment _      -> 0
 302
 303
 304 stixSubst :: Unique -> StixTree -> StixTree -> StixTree
 305 stixSubst u new_u in_this_tree
 306    = stixMapUniques f in_this_tree
 307      where
 308         f :: Unique -> Maybe StixTree
 309         f uu = if uu == u then Just new_u else Nothing
 310
 311
 312 stixMapUniques :: (Unique -> Maybe StixTree) -> StixTree -> StixTree
 313 stixMapUniques f t
 314    = let qq = stixMapUniques f
 315      in
 316      case t of
 317         StReg reg
 318            -> case reg of
 319                  StixMagicId mid -> t
 320                  StixTemp uu pr
 321                     -> case f uu of
 322                           Just xx -> xx
 323                           Nothing -> t
 324
 325         StIndex    pk t1 t2       -> StIndex    pk (qq t1) (qq t2)
 326         StInd      pk t1          -> StInd      pk (qq t1)
 327         StAssign   pk t1 t2       -> StAssign   pk (qq t1) (qq t2)
 328         StJump     dsts t1        -> StJump     dsts (qq t1)
 329         StCondJump lbl t1         -> StCondJump lbl (qq t1)
 330         StData     pk ts          -> StData     pk (map qq ts)
 331         StPrim     op ts          -> StPrim     op (map qq ts)
 332         StCall     nm cconv pk ts -> StCall     nm cconv pk (map qq ts)
 333
 334         StSegment _      -> t
 335         StInt _          -> t
 336         StFloat _        -> t
 337         StDouble _       -> t
 338         StString _       -> t
 339         StCLbl _         -> t
 340         StLabel _        -> t
 341         StFunBegin _     -> t
 342         StFunEnd _       -> t
 343         StFallThrough _  -> t
 344         StScratchWord _  -> t
 345         StComment _      -> t
 346 \end{code}
 347
 348 \begin{code}
 349 data NatM_State = NatM_State UniqSupply Int
 350 type NatM result = NatM_State -> (result, NatM_State)
 351
 352 mkNatM_State :: UniqSupply -> Int -> NatM_State
 353 mkNatM_State = NatM_State
 354
 355 uniqOfNatM_State  (NatM_State us delta) = us
 356 deltaOfNatM_State (NatM_State us delta) = delta
 357
 358
 359 initNat :: NatM_State -> NatM a -> (a, NatM_State)
 360 initNat init_st m = case m init_st of { (r,st) -> (r,st) }
 361
 362 thenNat :: NatM a -> (a -> NatM b) -> NatM b
 363 thenNat expr cont st
 364   = case expr st of { (result, st') -> cont result st' }
 365
 366 returnNat :: a -> NatM a
 367 returnNat result st = (result, st)
 368
 369 mapNat :: (a -> NatM b) -> [a] -> NatM [b]
 370 mapNat f []     = returnNat []
 371 mapNat f (x:xs)
 372   = f x          `thenNat` \ r  ->
 373     mapNat f xs  `thenNat` \ rs ->
 374     returnNat (r:rs)
 375
 376 mapAndUnzipNat :: (a -> NatM (b,c))   -> [a] -> NatM ([b],[c])
 377 mapAndUnzipNat f [] = returnNat ([],[])
 378 mapAndUnzipNat f (x:xs)
 379   = f x                 `thenNat` \ (r1,  r2)  ->
 380     mapAndUnzipNat f xs `thenNat` \ (rs1, rs2) ->
 381     returnNat (r1:rs1, r2:rs2)
 382
 383 mapAccumLNat :: (acc -> x -> NatM (acc, y))
 384                 -> acc
 385                 -> [x]
 386                 -> NatM (acc, [y])
 387
 388 mapAccumLNat f b []
 389   = returnNat (b, [])
 390 mapAccumLNat f b (x:xs)
 391   = f b x                           `thenNat` \ (b__2, x__2) ->
 392     mapAccumLNat f b__2 xs          `thenNat` \ (b__3, xs__2) ->
 393     returnNat (b__3, x__2:xs__2)
 394
 395
 396 getUniqueNat :: NatM Unique
 397 getUniqueNat (NatM_State us delta)
 398     = case splitUniqSupply us of
 399          (us1,us2) -> (uniqFromSupply us1, (NatM_State us2 delta))
 400
 401 getDeltaNat :: NatM Int
 402 getDeltaNat st@(NatM_State us delta)
 403    = (delta, st)
 404
 405 setDeltaNat :: Int -> NatM ()
 406 setDeltaNat delta (NatM_State us _)
 407    = ((), NatM_State us delta)
 408 \end{code}