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 TcType
  14 import qualified HsExpr
  15 import qualified HsTypes
  16 import qualified HsBinds
  17 import qualified RdrName
  18 import qualified Name
  19 import qualified OccName
  20 import qualified TysWiredIn
  21 import qualified Bag
  22 import qualified DynFlags
  23 import qualified SrcLoc
  24 import qualified CoreSyn
  25 import qualified Var
  26 import qualified VarSet
  27 import qualified Unique
  28 import qualified CoreUtils
  29 import qualified CoreFVs
  30
  31 -- Local imports
  32 import GhcTools
  33 import HsTools
  34 import Pretty
  35
  36 -- | Evaluate a core Type representing type level int from the tfp
  37 -- library to a real int.
  38 eval_tfp_int :: Type.Type -> Int
  39 eval_tfp_int ty =
  40   unsafeRunGhc $ do
  41     -- Automatically import modules for any fully qualified identifiers
  42     setDynFlag DynFlags.Opt_ImplicitImportQualified
  43     --setDynFlag DynFlags.Opt_D_dump_if_trace
  44
  45     let from_int_t_name = mkRdrName "Types.Data.Num" "fromIntegerT"
  46     let from_int_t = SrcLoc.noLoc $ HsExpr.HsVar from_int_t_name
  47     let undef = hsTypedUndef $ coreToHsType ty
  48     let app = SrcLoc.noLoc $ HsExpr.HsApp (from_int_t) (undef)
  49     let int_ty = SrcLoc.noLoc $ HsTypes.HsTyVar TysWiredIn.intTyCon_RDR
  50     let expr = HsExpr.ExprWithTySig app int_ty
  51     let foo_name = mkRdrName "Types.Data.Num" "foo"
  52     let foo_bind_name = RdrName.mkRdrUnqual $ OccName.mkVarOcc "foo"
  53     let binds = Bag.listToBag [SrcLoc.noLoc $ HsBinds.VarBind foo_bind_name (SrcLoc.noLoc $ HsExpr.HsVar foo_name)]
  54     let letexpr = HsExpr.HsLet
  55           (HsBinds.HsValBinds $ (HsBinds.ValBindsIn binds) [])
  56           (SrcLoc.noLoc expr)
  57
  58     let modules = map GHC.mkModuleName ["Types.Data.Num"]
  59     core <- toCore modules expr
  60     execCore core
  61
  62 -- | Get the width of a SizedWord type
  63 sized_word_len :: Type.Type -> Int
  64 sized_word_len ty = eval_tfp_int (sized_word_len_ty ty)
  65
  66 sized_word_len_ty :: Type.Type -> Type.Type
  67 sized_word_len_ty ty = len
  68   where
  69     args = case Type.splitTyConApp_maybe ty of
  70       Just (tycon, args) -> args
  71       Nothing -> error $ "\nCoreTools.sized_word_len_ty: Not a sized word type: " ++ (pprString ty)
  72     [len]         = args
  73
  74 -- | Get the width of a SizedInt type
  75 sized_int_len :: Type.Type -> Int
  76 sized_int_len ty = eval_tfp_int (sized_int_len_ty ty)
  77
  78 sized_int_len_ty :: Type.Type -> Type.Type
  79 sized_int_len_ty ty = len
  80   where
  81     args = case Type.splitTyConApp_maybe ty of
  82       Just (tycon, args) -> args
  83       Nothing -> error $ "\nCoreTools.sized_int_len_ty: Not a sized int type: " ++ (pprString ty)
  84     [len]         = args
  85
  86 -- | Get the upperbound of a RangedWord type
  87 ranged_word_bound :: Type.Type -> Int
  88 ranged_word_bound ty = eval_tfp_int (ranged_word_bound_ty ty)
  89
  90 ranged_word_bound_ty :: Type.Type -> Type.Type
  91 ranged_word_bound_ty ty = len
  92   where
  93     args = case Type.splitTyConApp_maybe ty of
  94       Just (tycon, args) -> args
  95       Nothing -> error $ "\nCoreTools.ranged_word_bound_ty: Not a sized word type: " ++ (pprString ty)
  96     [len]         = args
  97
  98 -- | Evaluate a core Type representing type level int from the TypeLevel
  99 -- library to a real int.
 100 -- eval_type_level_int :: Type.Type -> Int
 101 -- eval_type_level_int ty =
 102 --   unsafeRunGhc $ do
 103 --     -- Automatically import modules for any fully qualified identifiers
 104 --     setDynFlag DynFlags.Opt_ImplicitImportQualified
 105 --
 106 --     let to_int_name = mkRdrName "Data.TypeLevel.Num.Sets" "toInt"
 107 --     let to_int = SrcLoc.noLoc $ HsExpr.HsVar to_int_name
 108 --     let undef = hsTypedUndef $ coreToHsType ty
 109 --     let app = HsExpr.HsApp (to_int) (undef)
 110 --
 111 --     core <- toCore [] app
 112 --     execCore core
 113
 114 -- | Get the length of a FSVec type
 115 tfvec_len :: Type.Type -> Int
 116 tfvec_len ty = eval_tfp_int (tfvec_len_ty ty)
 117
 118 tfvec_len_ty :: Type.Type -> Type.Type
 119 tfvec_len_ty ty = len
 120   where
 121     args = case Type.splitTyConApp_maybe ty of
 122       Just (tycon, args) -> args
 123       Nothing -> error $ "\nCoreTools.tfvec_len_ty: Not a vector type: " ++ (pprString ty)
 124     [len, el_ty] = args
 125
 126 -- | Get the element type of a TFVec type
 127 tfvec_elem :: Type.Type -> Type.Type
 128 tfvec_elem ty = el_ty
 129   where
 130     args = case Type.splitTyConApp_maybe ty of
 131       Just (tycon, args) -> args
 132       Nothing -> error $ "\nCoreTools.tfvec_len: Not a vector type: " ++ (pprString ty)
 133     [len, el_ty] = args
 134
 135 -- Is this a wild binder?
 136 is_wild :: CoreSyn.CoreBndr -> Bool
 137 -- wild binders have a particular unique, that we copied from MkCore.lhs to
 138 -- here. However, this comparison didn't work, so we'll just check the
 139 -- occstring for now... TODO
 140 --(Var.varUnique bndr) == (Unique.mkBuiltinUnique 1)
 141 is_wild bndr = "wild" == (OccName.occNameString . Name.nameOccName . Var.varName) bndr
 142
 143 -- Is the given core expression a lambda abstraction?
 144 is_lam :: CoreSyn.CoreExpr -> Bool
 145 is_lam (CoreSyn.Lam _ _) = True
 146 is_lam _ = False
 147
 148 -- Is the given core expression of a function type?
 149 is_fun :: CoreSyn.CoreExpr -> Bool
 150 -- Treat Type arguments differently, because exprType is not defined for them.
 151 is_fun (CoreSyn.Type _) = False
 152 is_fun expr = (Type.isFunTy . CoreUtils.exprType) expr
 153
 154 -- Is the given core expression polymorphic (i.e., does it accept type
 155 -- arguments?).
 156 is_poly :: CoreSyn.CoreExpr -> Bool
 157 -- Treat Type arguments differently, because exprType is not defined for them.
 158 is_poly (CoreSyn.Type _) = False
 159 is_poly expr = (Maybe.isJust . Type.splitForAllTy_maybe . CoreUtils.exprType) expr
 160
 161 -- Is the given core expression a variable reference?
 162 is_var :: CoreSyn.CoreExpr -> Bool
 163 is_var (CoreSyn.Var _) = True
 164 is_var _ = 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 -- Removes all the type and dictionary arguments from the given argument list,
 193 -- leaving only the normal value arguments. The type given is the type of the
 194 -- expression applied to this argument list.
 195 get_val_args :: Type.Type -> [CoreSyn.CoreExpr] -> [CoreSyn.CoreExpr]
 196 get_val_args ty args = drop n args
 197   where
 198     (tyvars, predtypes, _) = TcType.tcSplitSigmaTy ty
 199     -- The first (length tyvars) arguments should be types, the next
 200     -- (length predtypes) arguments should be dictionaries. We drop this many
 201     -- arguments, to get at the value arguments.
 202     n = length tyvars + length predtypes