Split off the VHDL type generating code.
[matthijs/master-project/cλash.git] / 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 CoreTools where
6
7 --Standard modules
8 import qualified Maybe
9
10 -- GHC API
11 import qualified GHC
12 import qualified Type
13 import qualified HsExpr
14 import qualified HsTypes
15 import qualified HsBinds
16 import qualified RdrName
17 import qualified Name
18 import qualified OccName
19 import qualified TysWiredIn
20 import qualified Bag
21 import qualified DynFlags
22 import qualified SrcLoc
23 import qualified CoreSyn
24 import qualified Var
25 import qualified VarSet
26 import qualified Unique
27 import qualified CoreUtils
28 import qualified CoreFVs
29
30 import GhcTools
31 import HsTools
32
33 -- | Evaluate a core Type representing type level int from the tfp
34 -- library to a real int.
35 eval_tfp_int :: Type.Type -> Int
36 eval_tfp_int ty =
37   unsafeRunGhc $ do
38     -- Automatically import modules for any fully qualified identifiers
39     setDynFlag DynFlags.Opt_ImplicitImportQualified
40     --setDynFlag DynFlags.Opt_D_dump_if_trace
41
42     let from_int_t_name = mkRdrName "Types.Data.Num" "fromIntegerT"
43     let from_int_t = SrcLoc.noLoc $ HsExpr.HsVar from_int_t_name
44     let undef = hsTypedUndef $ coreToHsType ty
45     let app = SrcLoc.noLoc $ HsExpr.HsApp (from_int_t) (undef)
46     let int_ty = SrcLoc.noLoc $ HsTypes.HsTyVar TysWiredIn.intTyCon_RDR
47     let expr = HsExpr.ExprWithTySig app int_ty
48     let foo_name = mkRdrName "Types.Data.Num" "foo"
49     let foo_bind_name = RdrName.mkRdrUnqual $ OccName.mkVarOcc "foo"
50     let binds = Bag.listToBag [SrcLoc.noLoc $ HsBinds.VarBind foo_bind_name (SrcLoc.noLoc $ HsExpr.HsVar foo_name)]
51     let letexpr = HsExpr.HsLet 
52           (HsBinds.HsValBinds $ (HsBinds.ValBindsIn binds) [])
53           (SrcLoc.noLoc expr)
54
55     let modules = map GHC.mkModuleName ["Types.Data.Num"]
56     core <- toCore modules expr
57     execCore core 
58
59 -- | Get the width of a SizedWord type
60 sized_word_len :: Type.Type -> Int
61 sized_word_len ty =
62   eval_tfp_int len
63   where 
64     (tycon, args) = Type.splitTyConApp ty
65     [len] = args
66
67 -- | Evaluate a core Type representing type level int from the TypeLevel
68 -- library to a real int.
69 -- eval_type_level_int :: Type.Type -> Int
70 -- eval_type_level_int ty =
71 --   unsafeRunGhc $ do
72 --     -- Automatically import modules for any fully qualified identifiers
73 --     setDynFlag DynFlags.Opt_ImplicitImportQualified
74 -- 
75 --     let to_int_name = mkRdrName "Data.TypeLevel.Num.Sets" "toInt"
76 --     let to_int = SrcLoc.noLoc $ HsExpr.HsVar to_int_name
77 --     let undef = hsTypedUndef $ coreToHsType ty
78 --     let app = HsExpr.HsApp (to_int) (undef)
79 -- 
80 --     core <- toCore [] app
81 --     execCore core 
82
83 -- | Get the length of a FSVec type
84 tfvec_len :: Type.Type -> Int
85 tfvec_len ty =
86   eval_tfp_int len
87   where 
88     (tycon, args) = Type.splitTyConApp ty
89     [len, el_ty] = args
90
91 -- Is this a wild binder?
92 is_wild :: CoreSyn.CoreBndr -> Bool
93 -- wild binders have a particular unique, that we copied from MkCore.lhs to
94 -- here. However, this comparison didn't work, so we'll just check the
95 -- occstring for now... TODO
96 --(Var.varUnique bndr) == (Unique.mkBuiltinUnique 1)
97 is_wild bndr = "wild" == (OccName.occNameString . Name.nameOccName . Var.varName) bndr
98
99 -- Is the given core expression a lambda abstraction?
100 is_lam :: CoreSyn.CoreExpr -> Bool
101 is_lam (CoreSyn.Lam _ _) = True
102 is_lam _ = False
103
104 -- Is the given core expression of a function type?
105 is_fun :: CoreSyn.CoreExpr -> Bool
106 -- Treat Type arguments differently, because exprType is not defined for them.
107 is_fun (CoreSyn.Type _) = False
108 is_fun expr = (Type.isFunTy . CoreUtils.exprType) expr
109
110 -- Is the given core expression polymorphic (i.e., does it accept type
111 -- arguments?).
112 is_poly :: CoreSyn.CoreExpr -> Bool
113 -- Treat Type arguments differently, because exprType is not defined for them.
114 is_poly (CoreSyn.Type _) = False
115 is_poly expr = (Maybe.isJust . Type.splitForAllTy_maybe . CoreUtils.exprType) expr
116
117 -- Is the given core expression a variable reference?
118 is_var :: CoreSyn.CoreExpr -> Bool
119 is_var (CoreSyn.Var _) = True
120 is_var _ = False
121
122 -- Can the given core expression be applied to something? This is true for
123 -- applying to a value as well as a type.
124 is_applicable :: CoreSyn.CoreExpr -> Bool
125 is_applicable expr = is_fun expr || is_poly expr
126
127 -- Does the given CoreExpr have any free type vars?
128 has_free_tyvars :: CoreSyn.CoreExpr -> Bool
129 has_free_tyvars = not . VarSet.isEmptyVarSet . (CoreFVs.exprSomeFreeVars Var.isTyVar)