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