ghcjs /src/Gen2/StgAst.hs

Language Haskell Lines 139
MD5 Hash 7ba29eb9310f9904503e10a78442f18e Estimated Cost $2,738 (why?)
Repository git://github.com/ghcjs/ghcjs.git View Raw File
  1
  2
  3
  4
  5
  6
  7
  8
  9
 10
 11
 12
 13
 14
 15
 16
 17
 18
 19
 20
 21
 22
 23
 24
 25
 26
 27
 28
 29
 30
 31
 32
 33
 34
 35
 36
 37
 38
 39
 40
 41
 42
 43
 44
 45
 46
 47
 48
 49
 50
 51
 52
 53
 54
 55
 56
 57
 58
 59
 60
 61
 62
 63
 64
 65
 66
 67
 68
 69
 70
 71
 72
 73
 74
 75
 76
 77
 78
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
{-
   some instances for printing the StgSyn AST in Haskell syntax.
-}

{-# LANGUAGE CPP                #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleInstances  #-}
{-# LANGUAGE StandaloneDeriving #-}

module Gen2.StgAst where

import           BasicTypes
import           Control.Lens
import           CoreSyn
import           CostCentre
import           Data.Char (isSpace)
import qualified Data.Foldable as F
import qualified Data.List      as L
import           Data.Monoid
import           Data.Set      (Set)
import qualified Data.Set      as S
import           DataCon
import           DynFlags
import           ForeignCall
import           Id
import           Literal
import           Module
import           Name
import           Outputable    hiding ((<>))
import           PrimOp
import           StgSyn
import           SysTools (initSysTools)
import           TyCon
import           Type
import           UniqFM
import           UniqSet
import qualified Var

import           Compiler.Info

import           Control.Monad
import           System.Environment (getArgs)
import           System.IO.Unsafe

-- this is a hack to be able to use pprShow in a Show instance, should be removed
{-# NOINLINE hackPprDflags #-}
hackPprDflags :: DynFlags
hackPprDflags = unsafePerformIO $ do
  args <- getArgs
  let (minusB_args, args1) = L.partition ("-B" `L.isPrefixOf`) args
      mbMinusB | null minusB_args = Nothing
               | otherwise = Just . drop 2 . last $ minusB_args
  libDir <- getGlobalPackageBase
  mySettings <- initSysTools (mbMinusB `mplus` Just libDir)
  initDynFlags (defaultDynFlags mySettings)

fixSpace :: String -> String
fixSpace xs = map f xs
  where
    f c | isSpace c = ' '
        | otherwise = c


-- fixme make this more informative
instance Show Type where
  show ty = fixSpace (showPpr hackPprDflags ty)
instance Show CostCentre where show _ = "CostCentre"
instance Show CostCentreStack where show _ = "CostCentreStack"
instance Show StgBinderInfo where show _ = "StgBinderInfo"
instance Show Module where show m = packageIdString (modulePackageId m) ++ ":" ++ moduleNameString (moduleName m)
instance Show (UniqFM Id) where show u = "[" ++ show (uniqSetToList u) ++ "]"
instance Show TyCon where show = show . tyConName
instance Show SRT where
  show NoSRT = "SRT:NO"
  show (SRTEntries e) = "SRT:" ++ show e
  show (SRT i j b) = "SRT:BMP" ++ show [i,j]
instance Show PackageId where show = packageIdString
instance Show Name where
  show n = case nameModule_maybe n of
                  Nothing -> show (nameOccName n)
                  Just m  -> show m ++ "." ++ show (nameOccName n)
instance Show OccName where show = occNameString
instance Show DataCon where show d = show (dataConName d)
instance Show Var where show v = "(" ++ show (Var.varName v) ++ " :: " ++ show (Var.varType v) ++ ")"

deriving instance Show UpdateFlag
deriving instance Show PrimOpVecCat
deriving instance Show Literal
deriving instance Show PrimOp
deriving instance Show AltCon
deriving instance Show AltType
deriving instance Show PrimCall
deriving instance Show ForeignCall
deriving instance Show CCallTarget
deriving instance Show CCallSpec
deriving instance Show CCallConv
deriving instance Show FunctionOrData
deriving instance Show StgExpr
deriving instance Show StgBinding
deriving instance Show StgRhs
deriving instance Show StgOp

instance Show (GenStgArg Var) where
  show a@(StgVarArg occ) = "StgVarArg " ++ show occ ++ " :: " ++ show (stgArgType a)
  show (StgLitArg l)   = "StgLitArg " ++ show l

s = S.singleton
l = F.foldMap

-- | collect Ids that this binding refers to
--   (does not include the bindees themselves)
-- first argument is Id -> StgExpr map for unfloated arguments
bindingRefs :: UniqFM StgExpr -> StgBinding -> Set Id
bindingRefs u (StgNonRec _ rhs) = rhsRefs u rhs
bindingRefs u (StgRec bs)       = l (rhsRefs u . snd) bs

rhsRefs :: UniqFM StgExpr -> StgRhs -> Set Id
rhsRefs u (StgRhsClosure _ _ _ _ _ _ body) = exprRefs u body
rhsRefs u (StgRhsCon _ d args) = l s (dataConImplicitIds d) <> l (argRefs u) args

exprRefs :: UniqFM StgExpr -> StgExpr -> Set Id
exprRefs u (StgApp f args) = s f <> l (argRefs u) args
exprRefs u (StgConApp d args) = l s (dataConImplicitIds d) <> l (argRefs u) args
exprRefs u (StgOpApp _ args _) = l (argRefs u) args
exprRefs u (StgLit {}) = mempty
exprRefs u (StgLam {}) = mempty
exprRefs u (StgCase expr _ _ _ _ _ alts) = exprRefs u expr <> alts^.folded._4.to (exprRefs u)
exprRefs u (StgLet bnd expr) = bindingRefs u bnd <> exprRefs u expr
exprRefs u (StgLetNoEscape _ _ bnd expr) = bindingRefs u bnd <> exprRefs u expr
exprRefs u (StgSCC _ _ _ expr) = exprRefs u expr
exprRefs u (StgTick _ _ expr) = exprRefs u expr

argRefs :: UniqFM StgExpr -> StgArg -> Set Id
argRefs u (StgVarArg id)
  | Just e <- lookupUFM u id = exprRefs u e
  | otherwise                = s id
argRefs u _ = mempty
Back to Top