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