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