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(..) )
  35 import PrimOp           ( PrimOp )
  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 <> char '\'')
 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                                   ppr k <+> pprStixTree o)
 167        StInd k t        -> ppr k <> char '[' <> pprStixTree t <> char ']'
 168        StAssign k d s   -> pprStixTree d <> text "  :=" <> ppr 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" <+> ppr k <+>
 178                                   hsep (map pprStixTree ds))
 179        StPrim op ts     -> paren (text "Prim" <+> ppr op <+>
 180                                   hsep (map pprStixTree ts))
 181        StCall nm cc k args
 182                         -> paren (text "Call" <+> ptext nm <+>
 183                                   pprCallConv cc <+> ppr k <+>
 184                                   hsep (map pprStixTree args))
 185        StScratchWord i  -> text "ScratchWord" <> paren (int i)
 186 \end{code}
 187
 188 Stix registers can have two forms.  They {\em may} or {\em may not}
 189 map to real, machine-level registers.
 190
 191 \begin{code}
 192 data StixReg
 193   = StixMagicId MagicId -- Regs which are part of the abstract machine model
 194
 195   | StixTemp Unique PrimRep -- "Regs" which model local variables (CTemps) in
 196                                         -- the abstract C.
 197
 198 ppStixReg (StixMagicId mid)
 199    = ppMId mid
 200 ppStixReg (StixTemp u pr)
 201    = hcat [text "Temp(", ppr u, ppr pr, char ')']
 202
 203
 204 ppMId BaseReg              = text "BaseReg"
 205 ppMId (VanillaReg kind n)  = hcat [ppr kind, text "IntReg(",
 206                                    int (iBox n), char ')']
 207 ppMId (FloatReg n)         = hcat [text "FltReg(", int (iBox n), char ')']
 208 ppMId (DoubleReg n)        = hcat [text "DblReg(", int (iBox n), char ')']
 209 ppMId (LongReg kind n)     = hcat [ppr kind, text "LongReg(",
 210                                    int (iBox n), char ')']
 211 ppMId Sp                   = text "Sp"
 212 ppMId Su                   = text "Su"
 213 ppMId SpLim                = text "SpLim"
 214 ppMId Hp                   = text "Hp"
 215 ppMId HpLim                = text "HpLim"
 216 ppMId CurCostCentre        = text "CCC"
 217 ppMId VoidReg              = text "VoidReg"
 218 \end{code}
 219
 220 We hope that every machine supports the idea of data segment and text
 221 segment (or that it has no segments at all, and we can lump these
 222 together).
 223
 224 \begin{code}
 225 data CodeSegment = DataSegment | TextSegment | RoDataSegment deriving (Eq, Show)
 226 ppCodeSegment = text . show
 227
 228 type StixTreeList = [StixTree] -> [StixTree]
 229 \end{code}
 230
 231 Stix Trees for STG registers:
 232 \begin{code}
 233 stgBaseReg, stgNode, stgSp, stgSu, stgSpLim, stgHp, stgHpLim
 234         :: StixTree
 235
 236 stgBaseReg          = StReg (StixMagicId BaseReg)
 237 stgNode             = StReg (StixMagicId node)
 238 stgTagReg           = StReg (StixMagicId tagreg)
 239 stgSp               = StReg (StixMagicId Sp)
 240 stgSu               = StReg (StixMagicId Su)
 241 stgSpLim            = StReg (StixMagicId SpLim)
 242 stgHp               = StReg (StixMagicId Hp)
 243 stgHpLim            = StReg (StixMagicId HpLim)
 244 stgCurrentTSO       = StReg (StixMagicId CurrentTSO)
 245 stgCurrentNursery   = StReg (StixMagicId CurrentNursery)
 246 stgR9               = StReg (StixMagicId (VanillaReg WordRep (_ILIT 9)))
 247 stgR10              = StReg (StixMagicId (VanillaReg WordRep (_ILIT 10)))
 248
 249 getNatLabelNCG :: NatM CLabel
 250 getNatLabelNCG
 251   = getUniqueNat `thenNat` \ u ->
 252     returnNat (mkAsmTempLabel u)
 253
 254 getUniqLabelNCG :: UniqSM CLabel
 255 getUniqLabelNCG
 256   = getUniqueUs `thenUs` \ u ->
 257     returnUs (mkAsmTempLabel u)
 258
 259 fixedHS     = StInt (toInteger fixedHdrSize)
 260 arrWordsHS  = StInt (toInteger arrWordsHdrSize)
 261 arrPtrsHS   = StInt (toInteger arrPtrsHdrSize)
 262 \end{code}
 263
 264 Stix optimisation passes may wish to find out how many times a
 265 given temporary appears in a tree, so as to be able to decide
 266 whether or not to inline the assignment's RHS at usage site(s).
 267
 268 \begin{code}
 269 stixCountTempUses :: Unique -> StixTree -> Int
 270 stixCountTempUses u t
 271    = let qq = stixCountTempUses u
 272      in
 273      case t of
 274         StReg reg
 275            -> case reg of
 276                  StixTemp uu pr  -> if u == uu then 1 else 0
 277                  StixMagicId mid -> 0
 278
 279         StIndex    pk t1 t2       -> qq t1 + qq t2
 280         StInd      pk t1          -> qq t1
 281         StAssign   pk t1 t2       -> qq t1 + qq t2
 282         StJump     dsts t1        -> qq t1
 283         StCondJump lbl t1         -> qq t1
 284         StData     pk ts          -> sum (map qq ts)
 285         StPrim     op ts          -> sum (map qq ts)
 286         StCall     nm cconv pk ts -> sum (map qq ts)
 287
 288         StSegment _      -> 0
 289         StInt _          -> 0
 290         StFloat _        -> 0
 291         StDouble _       -> 0
 292         StString _       -> 0
 293         StCLbl _         -> 0
 294         StLabel _        -> 0
 295         StFunBegin _     -> 0
 296         StFunEnd _       -> 0
 297         StFallThrough _  -> 0
 298         StScratchWord _  -> 0
 299         StComment _      -> 0
 300
 301
 302 stixSubst :: Unique -> StixTree -> StixTree -> StixTree
 303 stixSubst u new_u in_this_tree
 304    = stixMapUniques f in_this_tree
 305      where
 306         f :: Unique -> Maybe StixTree
 307         f uu = if uu == u then Just new_u else Nothing
 308
 309
 310 stixMapUniques :: (Unique -> Maybe StixTree) -> StixTree -> StixTree
 311 stixMapUniques f t
 312    = let qq = stixMapUniques f
 313      in
 314      case t of
 315         StReg reg
 316            -> case reg of
 317                  StixMagicId mid -> t
 318                  StixTemp uu pr
 319                     -> case f uu of
 320                           Just xx -> xx
 321                           Nothing -> t
 322
 323         StIndex    pk t1 t2       -> StIndex    pk (qq t1) (qq t2)
 324         StInd      pk t1          -> StInd      pk (qq t1)
 325         StAssign   pk t1 t2       -> StAssign   pk (qq t1) (qq t2)
 326         StJump     dsts t1        -> StJump     dsts (qq t1)
 327         StCondJump lbl t1         -> StCondJump lbl (qq t1)
 328         StData     pk ts          -> StData     pk (map qq ts)
 329         StPrim     op ts          -> StPrim     op (map qq ts)
 330         StCall     nm cconv pk ts -> StCall     nm cconv pk (map qq ts)
 331
 332         StSegment _      -> t
 333         StInt _          -> t
 334         StFloat _        -> t
 335         StDouble _       -> t
 336         StString _       -> t
 337         StCLbl _         -> t
 338         StLabel _        -> t
 339         StFunBegin _     -> t
 340         StFunEnd _       -> t
 341         StFallThrough _  -> t
 342         StScratchWord _  -> t
 343         StComment _      -> t
 344 \end{code}
 345
 346 \begin{code}
 347 data NatM_State = NatM_State UniqSupply Int
 348 type NatM result = NatM_State -> (result, NatM_State)
 349
 350 mkNatM_State :: UniqSupply -> Int -> NatM_State
 351 mkNatM_State = NatM_State
 352
 353 uniqOfNatM_State  (NatM_State us delta) = us
 354 deltaOfNatM_State (NatM_State us delta) = delta
 355
 356
 357 initNat :: NatM_State -> NatM a -> (a, NatM_State)
 358 initNat init_st m = case m init_st of { (r,st) -> (r,st) }
 359
 360 thenNat :: NatM a -> (a -> NatM b) -> NatM b
 361 thenNat expr cont st
 362   = case expr st of { (result, st') -> cont result st' }
 363
 364 returnNat :: a -> NatM a
 365 returnNat result st = (result, st)
 366
 367 mapNat :: (a -> NatM b) -> [a] -> NatM [b]
 368 mapNat f []     = returnNat []
 369 mapNat f (x:xs)
 370   = f x          `thenNat` \ r  ->
 371     mapNat f xs  `thenNat` \ rs ->
 372     returnNat (r:rs)
 373
 374 mapAndUnzipNat :: (a -> NatM (b,c))   -> [a] -> NatM ([b],[c])
 375 mapAndUnzipNat f [] = returnNat ([],[])
 376 mapAndUnzipNat f (x:xs)
 377   = f x                 `thenNat` \ (r1,  r2)  ->
 378     mapAndUnzipNat f xs `thenNat` \ (rs1, rs2) ->
 379     returnNat (r1:rs1, r2:rs2)
 380
 381 mapAccumLNat :: (acc -> x -> NatM (acc, y))
 382                 -> acc
 383                 -> [x]
 384                 -> NatM (acc, [y])
 385
 386 mapAccumLNat f b []
 387   = returnNat (b, [])
 388 mapAccumLNat f b (x:xs)
 389   = f b x                           `thenNat` \ (b__2, x__2) ->
 390     mapAccumLNat f b__2 xs          `thenNat` \ (b__3, xs__2) ->
 391     returnNat (b__3, x__2:xs__2)
 392
 393
 394 getUniqueNat :: NatM Unique
 395 getUniqueNat (NatM_State us delta)
 396     = case splitUniqSupply us of
 397          (us1,us2) -> (uniqFromSupply us1, (NatM_State us2 delta))
 398
 399 getDeltaNat :: NatM Int
 400 getDeltaNat st@(NatM_State us delta)
 401    = (delta, st)
 402
 403 setDeltaNat :: Int -> NatM ()
 404 setDeltaNat delta (NatM_State us _)
 405    = ((), NatM_State us delta)
 406 \end{code}