1 -- | This module provides a number of functions to find out things about Core
2 -- programs. This module does not provide the actual plumbing to work with
3 -- Core and Haskell (it uses HsTools for this), but only the functions that
4 -- know about various libraries and know which functions to call.
9 import System.IO.Unsafe
14 import qualified TcType
15 import qualified HsExpr
16 import qualified HsTypes
17 import qualified HsBinds
18 import qualified HscTypes
19 import qualified RdrName
21 import qualified OccName
22 import qualified TysWiredIn
24 import qualified DynFlags
25 import qualified SrcLoc
26 import qualified CoreSyn
28 import qualified VarSet
29 import qualified Unique
30 import qualified CoreUtils
31 import qualified CoreFVs
32 import qualified Literal
39 -- | Evaluate a core Type representing type level int from the tfp
40 -- library to a real int.
41 eval_tfp_int :: Type.Type -> Int
44 -- Automatically import modules for any fully qualified identifiers
45 setDynFlag DynFlags.Opt_ImplicitImportQualified
47 let from_int_t_name = mkRdrName "Types.Data.Num" "fromIntegerT"
48 let from_int_t = SrcLoc.noLoc $ HsExpr.HsVar from_int_t_name
49 let undef = hsTypedUndef $ coreToHsType ty
50 let app = SrcLoc.noLoc $ HsExpr.HsApp (from_int_t) (undef)
51 let int_ty = SrcLoc.noLoc $ HsTypes.HsTyVar TysWiredIn.intTyCon_RDR
52 let expr = HsExpr.ExprWithTySig app int_ty
53 let foo_name = mkRdrName "Types.Data.Num" "foo"
54 let foo_bind_name = RdrName.mkRdrUnqual $ OccName.mkVarOcc "foo"
55 let binds = Bag.listToBag [SrcLoc.noLoc $ HsBinds.VarBind foo_bind_name (SrcLoc.noLoc $ HsExpr.HsVar foo_name)]
56 let letexpr = HsExpr.HsLet
57 (HsBinds.HsValBinds $ (HsBinds.ValBindsIn binds) [])
60 let modules = map GHC.mkModuleName ["Types.Data.Num"]
61 core <- toCore modules expr
64 normalise_tfp_int :: HscTypes.HscEnv -> Type.Type -> Type.Type
65 normalise_tfp_int env ty =
67 nty <- normaliseType env ty
70 -- | Get the width of a SizedWord type
71 -- sized_word_len :: HscTypes.HscEnv -> Type.Type -> Int
72 -- sized_word_len env ty = eval_tfp_int env (sized_word_len_ty ty)
74 sized_word_len_ty :: Type.Type -> Type.Type
75 sized_word_len_ty ty = len
77 args = case Type.splitTyConApp_maybe ty of
78 Just (tycon, args) -> args
79 Nothing -> error $ "\nCoreTools.sized_word_len_ty: Not a sized word type: " ++ (pprString ty)
82 -- | Get the width of a SizedInt type
83 -- sized_int_len :: HscTypes.HscEnv -> Type.Type -> Int
84 -- sized_int_len env ty = eval_tfp_int env (sized_int_len_ty ty)
86 sized_int_len_ty :: Type.Type -> Type.Type
87 sized_int_len_ty ty = len
89 args = case Type.splitTyConApp_maybe ty of
90 Just (tycon, args) -> args
91 Nothing -> error $ "\nCoreTools.sized_int_len_ty: Not a sized int type: " ++ (pprString ty)
94 -- | Get the upperbound of a RangedWord type
95 -- ranged_word_bound :: HscTypes.HscEnv -> Type.Type -> Int
96 -- ranged_word_bound env ty = eval_tfp_int env (ranged_word_bound_ty ty)
98 ranged_word_bound_ty :: Type.Type -> Type.Type
99 ranged_word_bound_ty ty = len
101 args = case Type.splitTyConApp_maybe ty of
102 Just (tycon, args) -> args
103 Nothing -> error $ "\nCoreTools.ranged_word_bound_ty: Not a sized word type: " ++ (pprString ty)
106 -- | Evaluate a core Type representing type level int from the TypeLevel
107 -- library to a real int.
108 -- eval_type_level_int :: Type.Type -> Int
109 -- eval_type_level_int ty =
111 -- -- Automatically import modules for any fully qualified identifiers
112 -- setDynFlag DynFlags.Opt_ImplicitImportQualified
114 -- let to_int_name = mkRdrName "Data.TypeLevel.Num.Sets" "toInt"
115 -- let to_int = SrcLoc.noLoc $ HsExpr.HsVar to_int_name
116 -- let undef = hsTypedUndef $ coreToHsType ty
117 -- let app = HsExpr.HsApp (to_int) (undef)
119 -- core <- toCore [] app
122 -- | Get the length of a FSVec type
123 -- tfvec_len :: HscTypes.HscEnv -> Type.Type -> Int
124 -- tfvec_len env ty = eval_tfp_int env (tfvec_len_ty ty)
126 tfvec_len_ty :: Type.Type -> Type.Type
127 tfvec_len_ty ty = len
129 args = case Type.splitTyConApp_maybe ty of
130 Just (tycon, args) -> args
131 Nothing -> error $ "\nCoreTools.tfvec_len_ty: Not a vector type: " ++ (pprString ty)
134 -- | Get the element type of a TFVec type
135 tfvec_elem :: Type.Type -> Type.Type
136 tfvec_elem ty = el_ty
138 args = case Type.splitTyConApp_maybe ty of
139 Just (tycon, args) -> args
140 Nothing -> error $ "\nCoreTools.tfvec_len: Not a vector type: " ++ (pprString ty)
143 -- Is this a wild binder?
144 is_wild :: CoreSyn.CoreBndr -> Bool
145 -- wild binders have a particular unique, that we copied from MkCore.lhs to
146 -- here. However, this comparison didn't work, so we'll just check the
147 -- occstring for now... TODO
148 --(Var.varUnique bndr) == (Unique.mkBuiltinUnique 1)
149 is_wild bndr = "wild" == (OccName.occNameString . Name.nameOccName . Var.varName) bndr
151 -- Is the given core expression a lambda abstraction?
152 is_lam :: CoreSyn.CoreExpr -> Bool
153 is_lam (CoreSyn.Lam _ _) = True
156 -- Is the given core expression of a function type?
157 is_fun :: CoreSyn.CoreExpr -> Bool
158 -- Treat Type arguments differently, because exprType is not defined for them.
159 is_fun (CoreSyn.Type _) = False
160 is_fun expr = (Type.isFunTy . CoreUtils.exprType) expr
162 -- Is the given core expression polymorphic (i.e., does it accept type
164 is_poly :: CoreSyn.CoreExpr -> Bool
165 -- Treat Type arguments differently, because exprType is not defined for them.
166 is_poly (CoreSyn.Type _) = False
167 is_poly expr = (Maybe.isJust . Type.splitForAllTy_maybe . CoreUtils.exprType) expr
169 -- Is the given core expression a variable reference?
170 is_var :: CoreSyn.CoreExpr -> Bool
171 is_var (CoreSyn.Var _) = True
174 is_lit :: CoreSyn.CoreExpr -> Bool
175 is_lit (CoreSyn.Lit _) = True
178 -- Can the given core expression be applied to something? This is true for
179 -- applying to a value as well as a type.
180 is_applicable :: CoreSyn.CoreExpr -> Bool
181 is_applicable expr = is_fun expr || is_poly expr
183 -- Is the given core expression a variable or an application?
184 is_simple :: CoreSyn.CoreExpr -> Bool
185 is_simple (CoreSyn.App _ _) = True
186 is_simple (CoreSyn.Var _) = True
187 is_simple (CoreSyn.Cast expr _) = is_simple expr
190 -- Does the given CoreExpr have any free type vars?
191 has_free_tyvars :: CoreSyn.CoreExpr -> Bool
192 has_free_tyvars = not . VarSet.isEmptyVarSet . (CoreFVs.exprSomeFreeVars Var.isTyVar)
194 -- Does the given CoreExpr have any free local vars?
195 has_free_vars :: CoreSyn.CoreExpr -> Bool
196 has_free_vars = not . VarSet.isEmptyVarSet . CoreFVs.exprFreeVars
198 -- Turns a Var CoreExpr into the Id inside it. Will of course only work for
199 -- simple Var CoreExprs, not complexer ones.
200 exprToVar :: CoreSyn.CoreExpr -> Var.Id
201 exprToVar (CoreSyn.Var id) = id
202 exprToVar expr = error $ "\nCoreTools.exprToVar: Not a var: " ++ show expr
204 -- Turns a Lit CoreExpr into the Literal inside it.
205 exprToLit :: CoreSyn.CoreExpr -> Literal.Literal
206 exprToLit (CoreSyn.Lit lit) = lit
207 exprToLit expr = error $ "\nCoreTools.exprToLit: Not a lit: " ++ show expr
209 -- Removes all the type and dictionary arguments from the given argument list,
210 -- leaving only the normal value arguments. The type given is the type of the
211 -- expression applied to this argument list.
212 get_val_args :: Type.Type -> [CoreSyn.CoreExpr] -> [CoreSyn.CoreExpr]
213 get_val_args ty args = drop n args
215 (tyvars, predtypes, _) = TcType.tcSplitSigmaTy ty
216 -- The first (length tyvars) arguments should be types, the next
217 -- (length predtypes) arguments should be dictionaries. We drop this many
218 -- arguments, to get at the value arguments.
219 n = length tyvars + length predtypes
221 getLiterals :: CoreSyn.CoreExpr -> [CoreSyn.CoreExpr]
222 getLiterals app@(CoreSyn.App _ _) = literals
224 (CoreSyn.Var f, args) = CoreSyn.collectArgs app
225 literals = filter (is_lit) args