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
  14         fixedHS, arrWordsHS, arrPtrsHS,
  15
  16         NatM, initNat, thenNat, returnNat,
  17         mapNat, mapAndUnzipNat,
  18         getUniqueNat, getDeltaNat, setDeltaNat,
  19         NatM_State, mkNatM_State,
  20         uniqOfNatM_State, deltaOfNatM_State,
  21
  22         getUniqLabelNCG, getNatLabelNCG,
  23     ) where
  24
  25 #include "HsVersions.h"
  26
  27 import Ratio            ( Rational )
  28
  29 import AbsCSyn          ( node, tagreg, MagicId(..) )
  30 import AbsCUtils        ( magicIdPrimRep )
  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   | StDouble    Rational
  55   | StString    FAST_STRING
  56   | StLitLbl    SDoc    -- literal labels
  57                             -- (will be _-prefixed on some machines)
  58
  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 sStLitLbl :: FAST_STRING -> StixTree
 125 sStLitLbl s = StLitLbl (ptext s)
 126
 127
 128 pprStixTrees :: [StixTree] -> SDoc
 129 pprStixTrees ts
 130   = vcat [
 131        vcat (map ppStixTree ts),
 132        char ' ',
 133        char ' '
 134     ]
 135
 136 paren t = char '(' <> t <> char ')'
 137
 138 ppStixTree :: StixTree -> SDoc
 139 ppStixTree t
 140    = case t of
 141        StSegment cseg   -> paren (ppCodeSegment cseg)
 142        StInt i          -> paren (integer i)
 143        StDouble rat     -> paren (text "Double" <+> rational rat)
 144        StString str     -> paren (text "Str" <+> ptext str)
 145        StComment str    -> paren (text "Comment" <+> ptext str)
 146        StLitLbl sd      -> sd
 147        StCLbl lbl       -> pprCLabel lbl
 148        StReg reg        -> ppStixReg reg
 149        StIndex k b o    -> paren (ppStixTree b <+> char '+' <>
 150                                   pprPrimRep k <+> ppStixTree o)
 151        StInd k t        -> pprPrimRep k <> char '[' <> ppStixTree t <> char ']'
 152        StAssign k d s   -> ppStixTree d <> text "  :=" <> pprPrimRep k
 153                                           <> text "  " <> ppStixTree s
 154        StLabel ll       -> pprCLabel ll <+> char ':'
 155        StFunBegin ll    -> char ' ' $$ paren (text "FunBegin" <+> pprCLabel ll)
 156        StFunEnd ll      -> paren (text "FunEnd" <+> pprCLabel ll)
 157        StJump t         -> paren (text "Jump" <+> ppStixTree t)
 158        StFallThrough ll -> paren (text "FallThru" <+> pprCLabel ll)
 159        StCondJump l t   -> paren (text "JumpC" <+> pprCLabel l
 160                                                <+> ppStixTree t)
 161        StData k ds      -> paren (text "Data" <+> pprPrimRep k <+>
 162                                   hsep (map ppStixTree ds))
 163        StPrim op ts     -> paren (text "Prim" <+> pprPrimOp op <+>
 164                                   hsep (map ppStixTree ts))
 165        StCall nm cc k args
 166                         -> paren (text "Call" <+> ptext nm <+>
 167                                   pprCallConv cc <+> pprPrimRep k <+>
 168                                   hsep (map ppStixTree args))
 169        StScratchWord i  -> text "ScratchWord" <> paren (int i)
 170
 171 pprPrimRep = text . showPrimRep
 172 \end{code}
 173
 174 Stix registers can have two forms.  They {\em may} or {\em may not}
 175 map to real, machine-level registers.
 176
 177 \begin{code}
 178 data StixReg
 179   = StixMagicId MagicId -- Regs which are part of the abstract machine model
 180
 181   | StixTemp Unique PrimRep -- "Regs" which model local variables (CTemps) in
 182                                         -- the abstract C.
 183
 184 ppStixReg (StixMagicId mid)
 185    = ppMId mid
 186 ppStixReg (StixTemp u pr)
 187    = hcat [text "Temp(", ppr u, ppr pr, char ')']
 188
 189
 190 ppMId BaseReg              = text "BaseReg"
 191 ppMId (VanillaReg kind n)  = hcat [pprPrimRep kind, text "IntReg(",
 192                                    int (I# n), char ')']
 193 ppMId (FloatReg n)         = hcat [text "FltReg(", int (I# n), char ')']
 194 ppMId (DoubleReg n)        = hcat [text "DblReg(", int (I# n), char ')']
 195 ppMId (LongReg kind n)     = hcat [pprPrimRep kind, text "LongReg(",
 196                                    int (I# n), char ')']
 197 ppMId Sp                   = text "Sp"
 198 ppMId Su                   = text "Su"
 199 ppMId SpLim                = text "SpLim"
 200 ppMId Hp                   = text "Hp"
 201 ppMId HpLim                = text "HpLim"
 202 ppMId CurCostCentre        = text "CCC"
 203 ppMId VoidReg              = text "VoidReg"
 204 \end{code}
 205
 206 We hope that every machine supports the idea of data segment and text
 207 segment (or that it has no segments at all, and we can lump these
 208 together).
 209
 210 \begin{code}
 211 data CodeSegment = DataSegment | TextSegment deriving (Eq, Show)
 212 ppCodeSegment = text . show
 213
 214 type StixTreeList = [StixTree] -> [StixTree]
 215 \end{code}
 216
 217 Stix Trees for STG registers:
 218 \begin{code}
 219 stgBaseReg, stgNode, stgSp, stgSu, stgSpLim, stgHp, stgHpLim
 220         :: StixTree
 221
 222 stgBaseReg          = StReg (StixMagicId BaseReg)
 223 stgNode             = StReg (StixMagicId node)
 224 stgTagReg           = StReg (StixMagicId tagreg)
 225 stgSp               = StReg (StixMagicId Sp)
 226 stgSu               = StReg (StixMagicId Su)
 227 stgSpLim            = StReg (StixMagicId SpLim)
 228 stgHp               = StReg (StixMagicId Hp)
 229 stgHpLim            = StReg (StixMagicId HpLim)
 230 stgR9               = StReg (StixMagicId (VanillaReg WordRep ILIT(9)))
 231 stgR10              = StReg (StixMagicId (VanillaReg WordRep ILIT(10)))
 232
 233 getNatLabelNCG :: NatM CLabel
 234 getNatLabelNCG
 235   = getUniqueNat `thenNat` \ u ->
 236     returnNat (mkAsmTempLabel u)
 237
 238 getUniqLabelNCG :: UniqSM CLabel
 239 getUniqLabelNCG
 240   = getUniqueUs `thenUs` \ u ->
 241     returnUs (mkAsmTempLabel u)
 242
 243 fixedHS     = StInt (toInteger fixedHdrSize)
 244 arrWordsHS  = StInt (toInteger arrWordsHdrSize)
 245 arrPtrsHS   = StInt (toInteger arrPtrsHdrSize)
 246 \end{code}
 247
 248 Stix optimisation passes may wish to find out how many times a
 249 given temporary appears in a tree, so as to be able to decide
 250 whether or not to inline the assignment's RHS at usage site(s).
 251
 252 \begin{code}
 253 stixCountTempUses :: Unique -> StixTree -> Int
 254 stixCountTempUses u t
 255    = let qq = stixCountTempUses u
 256      in
 257      case t of
 258         StReg reg
 259            -> case reg of
 260                  StixTemp uu pr  -> if u == uu then 1 else 0
 261                  StixMagicId mid -> 0
 262
 263         StIndex    pk t1 t2       -> qq t1 + qq t2
 264         StInd      pk t1          -> qq t1
 265         StAssign   pk t1 t2       -> qq t1 + qq t2
 266         StJump     t1             -> qq t1
 267         StCondJump lbl t1         -> qq t1
 268         StData     pk ts          -> sum (map qq ts)
 269         StPrim     op ts          -> sum (map qq ts)
 270         StCall     nm cconv pk ts -> sum (map qq ts)
 271
 272         StSegment _      -> 0
 273         StInt _          -> 0
 274         StDouble _       -> 0
 275         StString _       -> 0
 276         StLitLbl _       -> 0
 277         StCLbl _         -> 0
 278         StLabel _        -> 0
 279         StFunBegin _     -> 0
 280         StFunEnd _       -> 0
 281         StFallThrough _  -> 0
 282         StScratchWord _  -> 0
 283         StComment _      -> 0
 284
 285
 286 stixSubst :: Unique -> StixTree -> StixTree -> StixTree
 287 stixSubst u new_u in_this_tree
 288    = stixMapUniques f in_this_tree
 289      where
 290         f :: Unique -> Maybe StixTree
 291         f uu = if uu == u then Just new_u else Nothing
 292
 293
 294 stixMapUniques :: (Unique -> Maybe StixTree) -> StixTree -> StixTree
 295 stixMapUniques f t
 296    = let qq = stixMapUniques f
 297      in
 298      case t of
 299         StReg reg
 300            -> case reg of
 301                  StixMagicId mid -> t
 302                  StixTemp uu pr
 303                     -> case f uu of
 304                           Just xx -> xx
 305                           Nothing -> t
 306
 307         StIndex    pk t1 t2       -> StIndex    pk (qq t1) (qq t2)
 308         StInd      pk t1          -> StInd      pk (qq t1)
 309         StAssign   pk t1 t2       -> StAssign   pk (qq t1) (qq t2)
 310         StJump     t1             -> StJump     (qq t1)
 311         StCondJump lbl t1         -> StCondJump lbl (qq t1)
 312         StData     pk ts          -> StData     pk (map qq ts)
 313         StPrim     op ts          -> StPrim     op (map qq ts)
 314         StCall     nm cconv pk ts -> StCall     nm cconv pk (map qq ts)
 315
 316         StSegment _      -> t
 317         StInt _          -> t
 318         StDouble _       -> t
 319         StString _       -> t
 320         StLitLbl _       -> t
 321         StCLbl _         -> t
 322         StLabel _        -> t
 323         StFunBegin _     -> t
 324         StFunEnd _       -> t
 325         StFallThrough _  -> t
 326         StScratchWord _  -> t
 327         StComment _      -> t
 328 \end{code}
 329
 330 \begin{code}
 331 data NatM_State = NatM_State UniqSupply Int
 332 type NatM result = NatM_State -> (result, NatM_State)
 333
 334 mkNatM_State :: UniqSupply -> Int -> NatM_State
 335 mkNatM_State = NatM_State
 336
 337 uniqOfNatM_State  (NatM_State us delta) = us
 338 deltaOfNatM_State (NatM_State us delta) = delta
 339
 340
 341 initNat :: NatM_State -> NatM a -> (a, NatM_State)
 342 initNat init_st m = case m init_st of { (r,st) -> (r,st) }
 343
 344 thenNat :: NatM a -> (a -> NatM b) -> NatM b
 345 thenNat expr cont st
 346   = case expr st of { (result, st') -> cont result st' }
 347
 348 returnNat :: a -> NatM a
 349 returnNat result st = (result, st)
 350
 351 mapNat :: (a -> NatM b) -> [a] -> NatM [b]
 352 mapNat f []     = returnNat []
 353 mapNat f (x:xs)
 354   = f x          `thenNat` \ r  ->
 355     mapNat f xs  `thenNat` \ rs ->
 356     returnNat (r:rs)
 357
 358 mapAndUnzipNat :: (a -> NatM (b,c))   -> [a] -> NatM ([b],[c])
 359 mapAndUnzipNat f [] = returnNat ([],[])
 360 mapAndUnzipNat f (x:xs)
 361   = f x                 `thenNat` \ (r1,  r2)  ->
 362     mapAndUnzipNat f xs `thenNat` \ (rs1, rs2) ->
 363     returnNat (r1:rs1, r2:rs2)
 364
 365
 366 getUniqueNat :: NatM Unique
 367 getUniqueNat (NatM_State us delta)
 368     = case splitUniqSupply us of
 369          (us1,us2) -> (uniqFromSupply us1, (NatM_State us2 delta))
 370
 371 getDeltaNat :: NatM Int
 372 getDeltaNat st@(NatM_State us delta)
 373    = (delta, st)
 374
 375 setDeltaNat :: Int -> NatM ()
 376 setDeltaNat delta (NatM_State us _)
 377    = ((), NatM_State us delta)
 378 \end{code}