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