PageRenderTime 29ms CodeModel.GetById 16ms app.highlight 9ms RepoModel.GetById 2ms app.codeStats 0ms

/src/Gen2/StgAst.hs

http://github.com/ghcjs/ghcjs
Haskell | 155 lines | 122 code | 17 blank | 16 comment | 2 complexity | d2a389bde3c6b4402fbf13c933998647 MD5 | raw file
  1{-
  2   some instances for printing the StgSyn AST in Haskell syntax.
  3-}
  4
  5{-# LANGUAGE CPP                #-}
  6{-# LANGUAGE DeriveDataTypeable #-}
  7{-# LANGUAGE FlexibleInstances  #-}
  8{-# LANGUAGE StandaloneDeriving #-}
  9
 10module Gen2.StgAst where
 11
 12import           Data.Char     (isSpace)
 13import qualified Data.Foldable as F
 14import           Data.Set      (Set)
 15import qualified Data.Set      as S
 16import           DataCon
 17import           DynFlags
 18
 19import           BasicTypes
 20import           Control.Lens
 21import           CoreSyn
 22import           CostCentre
 23import           ForeignCall
 24import           Id
 25import           Literal
 26import           Module
 27import           Name
 28import           Outputable    hiding ((<>))
 29import           PrimOp
 30import           StgSyn
 31import           TyCon
 32import           Type
 33import           Unique
 34import           UniqFM
 35import           IdInfo
 36import qualified Var
 37
 38import           Coercion
 39import           CoAxiom
 40import           Gen2.Utils
 41
 42-- this is a hack to be able to use pprShow in a Show instance, should be removed
 43{-# NOINLINE hackPprDflags #-}
 44hackPprDflags :: DynFlags
 45hackPprDflags = unsafeGlobalDynFlags
 46
 47-- | replace all whitespace with space
 48fixSpace :: String -> String
 49fixSpace xs = map f xs
 50  where
 51    f c | isSpace c = ' '
 52        | otherwise = c
 53
 54
 55-- fixme make this more informative
 56instance Show Type where
 57  show ty = fixSpace (showPpr hackPprDflags ty)
 58instance Show CostCentre where show _ = "CostCentre"
 59instance Show CostCentreStack where show _ = "CostCentreStack"
 60instance Show StgBinderInfo where show _ = "StgBinderInfo"
 61instance Show Module where show m = unitIdString (moduleUnitId m) ++ ":" ++ moduleNameString (moduleName m)
 62-- instance Show (UniqFM Id) where show u = "[" ++ show (uniqSetToList u) ++ "]"
 63instance Show TyCon where show = show . tyConName
 64instance Show Name where
 65  show n = case nameModule_maybe n of
 66                  Nothing -> show (nameOccName n)
 67                  Just m  -> show m ++ "." ++ show (nameOccName n)
 68instance Show OccName where show = occNameString
 69instance Show DataCon where show d = show (dataConName d)
 70instance Show Var where show v = "(" ++ show (Var.varName v) ++ "[" ++
 71                                 encodeUnique (getKey (getUnique v)) ++
 72                                 "]" ++ if isGlobalId v then "G" else "L" ++
 73                                 " <" ++ show (idDetails v) ++ "> :: " ++
 74                                 show (Var.varType v) ++ ")"
 75instance Show IdDetails where
 76  show VanillaId          = "VanillaId"
 77  show (RecSelId {})      = "RecSelId"
 78  show (DataConWorkId dc) = "DataConWorkId " ++ show dc
 79  show (DataConWrapId dc) = "DataConWrapId " ++ show dc
 80  show (ClassOpId {})     = "ClassOpId"
 81  show (PrimOpId {})      = "PrimOpId"
 82  show (FCallId {})       = "FCallId"
 83  show (TickBoxOpId {})   = "VanillaId"
 84  show (DFunId {})        = "DFunId"
 85  show CoVarId            = "CoVarId"
 86  show (JoinId {})        = "JoinId"
 87
 88deriving instance Show UpdateFlag
 89deriving instance Show PrimOpVecCat
 90deriving instance Show LitNumType
 91deriving instance Show Literal
 92deriving instance Show PrimOp
 93deriving instance Show AltCon
 94deriving instance Show AltType
 95deriving instance Show PrimCall
 96deriving instance Show ForeignCall
 97deriving instance Show CCallTarget
 98deriving instance Show CCallSpec
 99deriving instance Show CCallConv
100deriving instance Show FunctionOrData
101deriving instance Show StgExpr
102deriving instance Show StgBinding
103deriving instance Show StgTopBinding
104deriving instance Show StgRhs
105deriving instance Show StgOp
106deriving instance Show a => Show (Tickish a)
107--
108instance Show Coercion where show co = showPpr hackPprDflags co
109deriving instance Show a => Show (Expr a)
110deriving instance Show a => Show (Bind a)
111instance Show CoAxiomRule where show _ = "CoAxiomRule"
112instance Show (CoAxiom a) where show _ = "CoAxiom"
113deriving instance Show LeftOrRight
114deriving instance Show Role
115instance Show (GenStgArg Var) where
116  show a@(StgVarArg occ) = "StgVarArg " ++ show occ ++ " :: " ++ show (stgArgType a)
117  show (StgLitArg l)   = "StgLitArg " ++ show l
118deriving instance Show UnfoldingGuidance
119deriving instance Show UnfoldingSource
120deriving instance Show Unfolding
121
122
123s :: a -> Set a
124s = S.singleton
125
126l :: (a -> Set Id) -> [a] -> Set Id
127l = F.foldMap
128
129-- | collect Ids that this binding refers to
130--   (does not include the bindees themselves)
131-- first argument is Id -> StgExpr map for unfloated arguments
132bindingRefs :: UniqFM StgExpr -> StgBinding -> Set Id
133bindingRefs u (StgNonRec _ rhs) = rhsRefs u rhs
134bindingRefs u (StgRec bs)       = l (rhsRefs u . snd) bs
135
136rhsRefs :: UniqFM StgExpr -> StgRhs -> Set Id
137rhsRefs u (StgRhsClosure _ _ _ _ _ body) = exprRefs u body
138rhsRefs u (StgRhsCon _ d args) = l s [ i | AnId i <- dataConImplicitTyThings d] <> l (argRefs u) args
139
140exprRefs :: UniqFM StgExpr -> StgExpr -> Set Id
141exprRefs u (StgApp f args) = s f <> l (argRefs u) args
142exprRefs u (StgConApp d args _) = l s [ i | AnId i <- dataConImplicitTyThings d] <> l (argRefs u) args
143exprRefs u (StgOpApp _ args _) = l (argRefs u) args
144exprRefs _ (StgLit {}) = mempty
145exprRefs _ (StgLam {}) = mempty
146exprRefs u (StgCase expr _ _ alts) = exprRefs u expr <> alts^.folded._3.to (exprRefs u)
147exprRefs u (StgLet bnd expr) = bindingRefs u bnd <> exprRefs u expr
148exprRefs u (StgLetNoEscape bnd expr) = bindingRefs u bnd <> exprRefs u expr
149exprRefs u (StgTick _ expr) = exprRefs u expr
150
151argRefs :: UniqFM StgExpr -> StgArg -> Set Id
152argRefs u (StgVarArg id)
153  | Just e <- lookupUFM u id = exprRefs u e
154  | otherwise                = s id
155argRefs _ _ = mempty