1 {-# LANGUAGE PatternGuards, TypeSynonymInstances #-}
2 -- | This module provides a number of functions to find out things about Core
3 -- programs. This module does not provide the actual plumbing to work with
4 -- Core and Haskell (it uses HsTools for this), but only the functions that
5 -- know about various libraries and know which functions to call.
6 module CLasH.Utils.Core.CoreTools where
10 import System.IO.Unsafe
15 import qualified TcType
16 import qualified HsExpr
17 import qualified HsTypes
18 import qualified HsBinds
19 import qualified HscTypes
20 import qualified RdrName
22 import qualified OccName
25 import qualified TyCon
26 import qualified TysWiredIn
28 import qualified DynFlags
29 import qualified SrcLoc
30 import qualified CoreSyn
32 import qualified VarSet
33 import qualified Unique
34 import qualified CoreUtils
35 import qualified CoreFVs
36 import qualified Literal
39 import CLasH.Translator.TranslatorTypes
40 import CLasH.Utils.GhcTools
41 import CLasH.Utils.HsTools
42 import CLasH.Utils.Pretty
44 -- | Evaluate a core Type representing type level int from the tfp
45 -- library to a real int.
46 eval_tfp_int :: HscTypes.HscEnv -> Type.Type -> Int
48 unsafeRunGhc libdir $ do
50 -- Automatically import modules for any fully qualified identifiers
51 setDynFlag DynFlags.Opt_ImplicitImportQualified
53 let from_int_t_name = mkRdrName "Types.Data.Num.Ops" "fromIntegerT"
54 let from_int_t = SrcLoc.noLoc $ HsExpr.HsVar from_int_t_name
55 let undef = hsTypedUndef $ coreToHsType ty
56 let app = SrcLoc.noLoc $ HsExpr.HsApp (from_int_t) (undef)
57 let int_ty = SrcLoc.noLoc $ HsTypes.HsTyVar TysWiredIn.intTyCon_RDR
58 let expr = HsExpr.ExprWithTySig app int_ty
62 libdir = DynFlags.topDir dynflags
63 dynflags = HscTypes.hsc_dflags env
65 normalise_tfp_int :: HscTypes.HscEnv -> Type.Type -> Type.Type
66 normalise_tfp_int env ty =
68 nty <- normaliseType env ty
71 -- | Get the width of a SizedWord type
72 -- sized_word_len :: HscTypes.HscEnv -> Type.Type -> Int
73 -- sized_word_len env ty = eval_tfp_int env (sized_word_len_ty ty)
75 sized_word_len_ty :: Type.Type -> Type.Type
76 sized_word_len_ty ty = len
78 args = case Type.splitTyConApp_maybe ty of
79 Just (tycon, args) -> args
80 Nothing -> error $ "\nCoreTools.sized_word_len_ty: Not a sized word type: " ++ (pprString ty)
83 -- | Get the width of a SizedInt type
84 -- sized_int_len :: HscTypes.HscEnv -> Type.Type -> Int
85 -- sized_int_len env ty = eval_tfp_int env (sized_int_len_ty ty)
87 sized_int_len_ty :: Type.Type -> Type.Type
88 sized_int_len_ty ty = len
90 args = case Type.splitTyConApp_maybe ty of
91 Just (tycon, args) -> args
92 Nothing -> error $ "\nCoreTools.sized_int_len_ty: Not a sized int type: " ++ (pprString ty)
95 -- | Get the upperbound of a RangedWord type
96 -- ranged_word_bound :: HscTypes.HscEnv -> Type.Type -> Int
97 -- ranged_word_bound env ty = eval_tfp_int env (ranged_word_bound_ty ty)
99 ranged_word_bound_ty :: Type.Type -> Type.Type
100 ranged_word_bound_ty ty = len
102 args = case Type.splitTyConApp_maybe ty of
103 Just (tycon, args) -> args
104 Nothing -> error $ "\nCoreTools.ranged_word_bound_ty: Not a sized word type: " ++ (pprString ty)
107 -- | Evaluate a core Type representing type level int from the TypeLevel
108 -- library to a real int.
109 -- eval_type_level_int :: Type.Type -> Int
110 -- eval_type_level_int ty =
112 -- -- Automatically import modules for any fully qualified identifiers
113 -- setDynFlag DynFlags.Opt_ImplicitImportQualified
115 -- let to_int_name = mkRdrName "Data.TypeLevel.Num.Sets" "toInt"
116 -- let to_int = SrcLoc.noLoc $ HsExpr.HsVar to_int_name
117 -- let undef = hsTypedUndef $ coreToHsType ty
118 -- let app = HsExpr.HsApp (to_int) (undef)
120 -- core <- toCore [] app
123 -- | Get the length of a FSVec type
124 -- tfvec_len :: HscTypes.HscEnv -> Type.Type -> Int
125 -- tfvec_len env ty = eval_tfp_int env (tfvec_len_ty ty)
127 tfvec_len_ty :: Type.Type -> Type.Type
128 tfvec_len_ty ty = len
130 args = case Type.splitTyConApp_maybe ty of
131 Just (tycon, args) -> args
132 Nothing -> error $ "\nCoreTools.tfvec_len_ty: Not a vector type: " ++ (pprString ty)
135 -- | Get the element type of a TFVec type
136 tfvec_elem :: Type.Type -> Type.Type
137 tfvec_elem ty = el_ty
139 args = case Type.splitTyConApp_maybe ty of
140 Just (tycon, args) -> args
141 Nothing -> error $ "\nCoreTools.tfvec_len: Not a vector type: " ++ (pprString ty)
144 -- Is the given core expression a lambda abstraction?
145 is_lam :: CoreSyn.CoreExpr -> Bool
146 is_lam (CoreSyn.Lam _ _) = True
149 -- Is the given core expression of a function type?
150 is_fun :: CoreSyn.CoreExpr -> Bool
151 -- Treat Type arguments differently, because exprType is not defined for them.
152 is_fun (CoreSyn.Type _) = False
153 is_fun expr = (Type.isFunTy . CoreUtils.exprType) expr
155 -- Is the given core expression polymorphic (i.e., does it accept type
157 is_poly :: CoreSyn.CoreExpr -> Bool
158 -- Treat Type arguments differently, because exprType is not defined for them.
159 is_poly (CoreSyn.Type _) = False
160 is_poly expr = (Maybe.isJust . Type.splitForAllTy_maybe . CoreUtils.exprType) expr
162 -- Is the given core expression a variable reference?
163 is_var :: CoreSyn.CoreExpr -> Bool
164 is_var (CoreSyn.Var _) = True
167 is_lit :: CoreSyn.CoreExpr -> Bool
168 is_lit (CoreSyn.Lit _) = True
171 -- Can the given core expression be applied to something? This is true for
172 -- applying to a value as well as a type.
173 is_applicable :: CoreSyn.CoreExpr -> Bool
174 is_applicable expr = is_fun expr || is_poly expr
176 -- Is the given core expression a variable or an application?
177 is_simple :: CoreSyn.CoreExpr -> Bool
178 is_simple (CoreSyn.App _ _) = True
179 is_simple (CoreSyn.Var _) = True
180 is_simple (CoreSyn.Cast expr _) = is_simple expr
183 -- Does the given CoreExpr have any free type vars?
184 has_free_tyvars :: CoreSyn.CoreExpr -> Bool
185 has_free_tyvars = not . VarSet.isEmptyVarSet . (CoreFVs.exprSomeFreeVars Var.isTyVar)
187 -- Does the given CoreExpr have any free local vars?
188 has_free_vars :: CoreSyn.CoreExpr -> Bool
189 has_free_vars = not . VarSet.isEmptyVarSet . CoreFVs.exprFreeVars
191 -- Does the given expression use any of the given binders?
192 expr_uses_binders :: [CoreSyn.CoreBndr] -> CoreSyn.CoreExpr -> Bool
193 expr_uses_binders bndrs = not . VarSet.isEmptyVarSet . (CoreFVs.exprSomeFreeVars (`elem` bndrs))
195 -- Turns a Var CoreExpr into the Id inside it. Will of course only work for
196 -- simple Var CoreExprs, not complexer ones.
197 exprToVar :: CoreSyn.CoreExpr -> Var.Id
198 exprToVar (CoreSyn.Var id) = id
199 exprToVar expr = error $ "\nCoreTools.exprToVar: Not a var: " ++ show expr
201 -- Turns a Lit CoreExpr into the Literal inside it.
202 exprToLit :: CoreSyn.CoreExpr -> Literal.Literal
203 exprToLit (CoreSyn.Lit lit) = lit
204 exprToLit expr = error $ "\nCoreTools.exprToLit: Not a lit: " ++ show expr
206 -- Removes all the type and dictionary arguments from the given argument list,
207 -- leaving only the normal value arguments. The type given is the type of the
208 -- expression applied to this argument list.
209 get_val_args :: Type.Type -> [CoreSyn.CoreExpr] -> [CoreSyn.CoreExpr]
210 get_val_args ty args = drop n args
212 (tyvars, predtypes, _) = TcType.tcSplitSigmaTy ty
213 -- The first (length tyvars) arguments should be types, the next
214 -- (length predtypes) arguments should be dictionaries. We drop this many
215 -- arguments, to get at the value arguments.
216 n = length tyvars + length predtypes
218 getLiterals :: CoreSyn.CoreExpr -> [CoreSyn.CoreExpr]
219 getLiterals app@(CoreSyn.App _ _) = literals
221 (CoreSyn.Var f, args) = CoreSyn.collectArgs app
222 literals = filter (is_lit) args
224 getLiterals lit@(CoreSyn.Lit _) = [lit]
226 reduceCoreListToHsList ::
227 [HscTypes.CoreModule] -- ^ The modules where parts of the list are hidden
228 -> CoreSyn.CoreExpr -- ^ The refence to atleast one of the nodes
229 -> TranslatorSession [CoreSyn.CoreExpr]
230 reduceCoreListToHsList cores app@(CoreSyn.App _ _) = do {
231 ; let { (fun, args) = CoreSyn.collectArgs app
236 ; let topelem = args!!1
238 (varz@(CoreSyn.Var id)) -> do {
239 ; binds <- mapM (findExpr (isVarName id)) cores
240 ; otherelems <- reduceCoreListToHsList cores (head (Maybe.catMaybes binds))
241 ; return (topelem:otherelems)
243 (appz@(CoreSyn.App _ _)) -> do {
244 ; otherelems <- reduceCoreListToHsList cores appz
245 ; return (topelem:otherelems)
247 otherwise -> return [topelem]
249 otherwise -> return []
252 isVarName :: Monad m => Var.Var -> Var.Var -> m Bool
253 isVarName lookfor bind = return $ (Var.varName lookfor) == (Var.varName bind)
255 reduceCoreListToHsList _ _ = return []
257 -- | Is the given type a State type?
258 isStateType :: Type.Type -> Bool
259 -- Resolve any type synonyms remaining
260 isStateType ty | Just ty' <- Type.tcView ty = isStateType ty'
261 isStateType ty = Maybe.isJust $ do
262 -- Split the type. Don't use normal splitAppTy, since that looks through
263 -- newtypes, and we want to see the State newtype.
264 (typef, _) <- Type.repSplitAppTy_maybe ty
265 -- See if the applied type is a type constructor
266 (tycon, _) <- Type.splitTyConApp_maybe typef
267 if TyCon.isNewTyCon tycon && Name.getOccString tycon == "State"
273 -- | Does the given TypedThing have a State type?
274 hasStateType :: (TypedThing t) => t -> Bool
275 hasStateType expr = case getType expr of
277 Just ty -> isStateType ty
280 -- | A class of things that (optionally) have a core Type. The type is
281 -- optional, since Type expressions don't have a type themselves.
282 class TypedThing t where
283 getType :: t -> Maybe Type.Type
285 instance TypedThing CoreSyn.CoreExpr where
286 getType (CoreSyn.Type _) = Nothing
287 getType expr = Just $ CoreUtils.exprType expr
289 instance TypedThing CoreSyn.CoreBndr where
290 getType = return . Id.idType
292 instance TypedThing Type.Type where
293 getType = return . id