Merge branch 'master' of git://github.com/christiaanb/clash into cλash
[matthijs/master-project/cλash.git] / cλash / CLasH / Utils / Core / CoreTools.hs
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.
5 module CLasH.Utils.Core.CoreTools where
6
7 --Standard modules
8 import qualified Maybe
9 import System.IO.Unsafe
10
11 -- GHC API
12 import qualified GHC
13 import qualified Type
14 import qualified TcType
15 import qualified HsExpr
16 import qualified HsTypes
17 import qualified HsBinds
18 import qualified HscTypes
19 import qualified RdrName
20 import qualified Name
21 import qualified OccName
22 import qualified TysWiredIn
23 import qualified Bag
24 import qualified DynFlags
25 import qualified SrcLoc
26 import qualified CoreSyn
27 import qualified Var
28 import qualified VarSet
29 import qualified Unique
30 import qualified CoreUtils
31 import qualified CoreFVs
32 import qualified Literal
33
34 -- Local imports
35 import CLasH.Utils.GhcTools
36 import CLasH.Utils.HsTools
37 import CLasH.Utils.Pretty
38
39 -- | Evaluate a core Type representing type level int from the tfp
40 -- library to a real int.
41 eval_tfp_int :: HscTypes.HscEnv -> Type.Type -> Int
42 eval_tfp_int env ty =
43   unsafeRunGhc libdir $ do
44     GHC.setSession env
45     -- Automatically import modules for any fully qualified identifiers
46     setDynFlag DynFlags.Opt_ImplicitImportQualified
47
48     let from_int_t_name = mkRdrName "Types.Data.Num.Ops" "fromIntegerT"
49     let from_int_t = SrcLoc.noLoc $ HsExpr.HsVar from_int_t_name
50     let undef = hsTypedUndef $ coreToHsType ty
51     let app = SrcLoc.noLoc $ HsExpr.HsApp (from_int_t) (undef)
52     let int_ty = SrcLoc.noLoc $ HsTypes.HsTyVar TysWiredIn.intTyCon_RDR
53     let expr = HsExpr.ExprWithTySig app int_ty
54     core <- toCore expr
55     execCore core
56   where
57     libdir = DynFlags.topDir dynflags
58     dynflags = HscTypes.hsc_dflags env
59
60 normalise_tfp_int :: HscTypes.HscEnv -> Type.Type -> Type.Type
61 normalise_tfp_int env ty =
62    unsafePerformIO $ do
63      nty <- normaliseType env ty
64      return nty
65
66 -- | Get the width of a SizedWord type
67 -- sized_word_len :: HscTypes.HscEnv -> Type.Type -> Int
68 -- sized_word_len env ty = eval_tfp_int env (sized_word_len_ty ty)
69     
70 sized_word_len_ty :: Type.Type -> Type.Type
71 sized_word_len_ty ty = len
72   where
73     args = case Type.splitTyConApp_maybe ty of
74       Just (tycon, args) -> args
75       Nothing -> error $ "\nCoreTools.sized_word_len_ty: Not a sized word type: " ++ (pprString ty)
76     [len]         = args
77
78 -- | Get the width of a SizedInt type
79 -- sized_int_len :: HscTypes.HscEnv -> Type.Type -> Int
80 -- sized_int_len env ty = eval_tfp_int env (sized_int_len_ty ty)
81
82 sized_int_len_ty :: Type.Type -> Type.Type
83 sized_int_len_ty ty = len
84   where
85     args = case Type.splitTyConApp_maybe ty of
86       Just (tycon, args) -> args
87       Nothing -> error $ "\nCoreTools.sized_int_len_ty: Not a sized int type: " ++ (pprString ty)
88     [len]         = args
89     
90 -- | Get the upperbound of a RangedWord type
91 -- ranged_word_bound :: HscTypes.HscEnv -> Type.Type -> Int
92 -- ranged_word_bound env ty = eval_tfp_int env (ranged_word_bound_ty ty)
93     
94 ranged_word_bound_ty :: Type.Type -> Type.Type
95 ranged_word_bound_ty ty = len
96   where
97     args = case Type.splitTyConApp_maybe ty of
98       Just (tycon, args) -> args
99       Nothing -> error $ "\nCoreTools.ranged_word_bound_ty: Not a sized word type: " ++ (pprString ty)
100     [len]         = args
101
102 -- | Evaluate a core Type representing type level int from the TypeLevel
103 -- library to a real int.
104 -- eval_type_level_int :: Type.Type -> Int
105 -- eval_type_level_int ty =
106 --   unsafeRunGhc $ do
107 --     -- Automatically import modules for any fully qualified identifiers
108 --     setDynFlag DynFlags.Opt_ImplicitImportQualified
109 -- 
110 --     let to_int_name = mkRdrName "Data.TypeLevel.Num.Sets" "toInt"
111 --     let to_int = SrcLoc.noLoc $ HsExpr.HsVar to_int_name
112 --     let undef = hsTypedUndef $ coreToHsType ty
113 --     let app = HsExpr.HsApp (to_int) (undef)
114 -- 
115 --     core <- toCore [] app
116 --     execCore core 
117
118 -- | Get the length of a FSVec type
119 -- tfvec_len :: HscTypes.HscEnv -> Type.Type -> Int
120 -- tfvec_len env ty = eval_tfp_int env (tfvec_len_ty ty)
121
122 tfvec_len_ty :: Type.Type -> Type.Type
123 tfvec_len_ty ty = len
124   where  
125     args = case Type.splitTyConApp_maybe ty of
126       Just (tycon, args) -> args
127       Nothing -> error $ "\nCoreTools.tfvec_len_ty: Not a vector type: " ++ (pprString ty)
128     [len, el_ty] = args
129     
130 -- | Get the element type of a TFVec type
131 tfvec_elem :: Type.Type -> Type.Type
132 tfvec_elem ty = el_ty
133   where
134     args = case Type.splitTyConApp_maybe ty of
135       Just (tycon, args) -> args
136       Nothing -> error $ "\nCoreTools.tfvec_len: Not a vector type: " ++ (pprString ty)
137     [len, el_ty] = args
138
139 -- Is the given core expression a lambda abstraction?
140 is_lam :: CoreSyn.CoreExpr -> Bool
141 is_lam (CoreSyn.Lam _ _) = True
142 is_lam _ = False
143
144 -- Is the given core expression of a function type?
145 is_fun :: CoreSyn.CoreExpr -> Bool
146 -- Treat Type arguments differently, because exprType is not defined for them.
147 is_fun (CoreSyn.Type _) = False
148 is_fun expr = (Type.isFunTy . CoreUtils.exprType) expr
149
150 -- Is the given core expression polymorphic (i.e., does it accept type
151 -- arguments?).
152 is_poly :: CoreSyn.CoreExpr -> Bool
153 -- Treat Type arguments differently, because exprType is not defined for them.
154 is_poly (CoreSyn.Type _) = False
155 is_poly expr = (Maybe.isJust . Type.splitForAllTy_maybe . CoreUtils.exprType) expr
156
157 -- Is the given core expression a variable reference?
158 is_var :: CoreSyn.CoreExpr -> Bool
159 is_var (CoreSyn.Var _) = True
160 is_var _ = False
161
162 is_lit :: CoreSyn.CoreExpr -> Bool
163 is_lit (CoreSyn.Lit _) = True
164 is_lit _ = False
165
166 -- Can the given core expression be applied to something? This is true for
167 -- applying to a value as well as a type.
168 is_applicable :: CoreSyn.CoreExpr -> Bool
169 is_applicable expr = is_fun expr || is_poly expr
170
171 -- Is the given core expression a variable or an application?
172 is_simple :: CoreSyn.CoreExpr -> Bool
173 is_simple (CoreSyn.App _ _) = True
174 is_simple (CoreSyn.Var _) = True
175 is_simple (CoreSyn.Cast expr _) = is_simple expr
176 is_simple _ = False
177
178 -- Does the given CoreExpr have any free type vars?
179 has_free_tyvars :: CoreSyn.CoreExpr -> Bool
180 has_free_tyvars = not . VarSet.isEmptyVarSet . (CoreFVs.exprSomeFreeVars Var.isTyVar)
181
182 -- Does the given CoreExpr have any free local vars?
183 has_free_vars :: CoreSyn.CoreExpr -> Bool
184 has_free_vars = not . VarSet.isEmptyVarSet . CoreFVs.exprFreeVars
185
186 -- Turns a Var CoreExpr into the Id inside it. Will of course only work for
187 -- simple Var CoreExprs, not complexer ones.
188 exprToVar :: CoreSyn.CoreExpr -> Var.Id
189 exprToVar (CoreSyn.Var id) = id
190 exprToVar expr = error $ "\nCoreTools.exprToVar: Not a var: " ++ show expr
191
192 -- Turns a Lit CoreExpr into the Literal inside it.
193 exprToLit :: CoreSyn.CoreExpr -> Literal.Literal
194 exprToLit (CoreSyn.Lit lit) = lit
195 exprToLit expr = error $ "\nCoreTools.exprToLit: Not a lit: " ++ show expr
196
197 -- Removes all the type and dictionary arguments from the given argument list,
198 -- leaving only the normal value arguments. The type given is the type of the
199 -- expression applied to this argument list.
200 get_val_args :: Type.Type -> [CoreSyn.CoreExpr] -> [CoreSyn.CoreExpr]
201 get_val_args ty args = drop n args
202   where
203     (tyvars, predtypes, _) = TcType.tcSplitSigmaTy ty
204     -- The first (length tyvars) arguments should be types, the next 
205     -- (length predtypes) arguments should be dictionaries. We drop this many
206     -- arguments, to get at the value arguments.
207     n = length tyvars + length predtypes
208
209 getLiterals :: CoreSyn.CoreExpr -> [CoreSyn.CoreExpr]
210 getLiterals app@(CoreSyn.App _ _) = literals
211   where
212     (CoreSyn.Var f, args) = CoreSyn.collectArgs app
213     literals = filter (is_lit) args
214
215 -- reduceCoreListToHsList :: CoreExpr -> [a]
216 reduceCoreListToHsList app@(CoreSyn.App _ _) = out
217   where
218     (fun, args) = CoreSyn.collectArgs app
219     len = length args
220     out = case len of
221           3 -> ((args!!1) : (reduceCoreListToHsList (args!!2)))
222           otherwise -> []
223
224 reduceCoreListToHsList _ = []