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