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