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 import qualified Literal
  31
  32 -- Local imports
  33 import GhcTools
  34 import HsTools
  35 import Pretty
  36
  37 -- | Evaluate a core Type representing type level int from the tfp
  38 -- library to a real int.
  39 eval_tfp_int :: Type.Type -> Int
  40 eval_tfp_int ty =
  41   unsafeRunGhc $ do
  42     -- Automatically import modules for any fully qualified identifiers
  43     setDynFlag DynFlags.Opt_ImplicitImportQualified
  44     --setDynFlag DynFlags.Opt_D_dump_if_trace
  45
  46     let from_int_t_name = mkRdrName "Types.Data.Num" "fromIntegerT"
  47     let from_int_t = SrcLoc.noLoc $ HsExpr.HsVar from_int_t_name
  48     let undef = hsTypedUndef $ coreToHsType ty
  49     let app = SrcLoc.noLoc $ HsExpr.HsApp (from_int_t) (undef)
  50     let int_ty = SrcLoc.noLoc $ HsTypes.HsTyVar TysWiredIn.intTyCon_RDR
  51     let expr = HsExpr.ExprWithTySig app int_ty
  52     let foo_name = mkRdrName "Types.Data.Num" "foo"
  53     let foo_bind_name = RdrName.mkRdrUnqual $ OccName.mkVarOcc "foo"
  54     let binds = Bag.listToBag [SrcLoc.noLoc $ HsBinds.VarBind foo_bind_name (SrcLoc.noLoc $ HsExpr.HsVar foo_name)]
  55     let letexpr = HsExpr.HsLet
  56           (HsBinds.HsValBinds $ (HsBinds.ValBindsIn binds) [])
  57           (SrcLoc.noLoc expr)
  58
  59     let modules = map GHC.mkModuleName ["Types.Data.Num"]
  60     core <- toCore modules expr
  61     execCore core
  62
  63 -- | Get the width of a SizedWord type
  64 sized_word_len :: Type.Type -> Int
  65 sized_word_len ty = eval_tfp_int (sized_word_len_ty ty)
  66
  67 sized_word_len_ty :: Type.Type -> Type.Type
  68 sized_word_len_ty ty = len
  69   where
  70     args = case Type.splitTyConApp_maybe ty of
  71       Just (tycon, args) -> args
  72       Nothing -> error $ "\nCoreTools.sized_word_len_ty: Not a sized word type: " ++ (pprString ty)
  73     [len]         = args
  74
  75 -- | Get the width of a SizedInt type
  76 sized_int_len :: Type.Type -> Int
  77 sized_int_len ty = eval_tfp_int (sized_int_len_ty ty)
  78
  79 sized_int_len_ty :: Type.Type -> Type.Type
  80 sized_int_len_ty ty = len
  81   where
  82     args = case Type.splitTyConApp_maybe ty of
  83       Just (tycon, args) -> args
  84       Nothing -> error $ "\nCoreTools.sized_int_len_ty: Not a sized int type: " ++ (pprString ty)
  85     [len]         = args
  86
  87 -- | Get the upperbound of a RangedWord type
  88 ranged_word_bound :: Type.Type -> Int
  89 ranged_word_bound ty = eval_tfp_int (ranged_word_bound_ty ty)
  90
  91 ranged_word_bound_ty :: Type.Type -> Type.Type
  92 ranged_word_bound_ty ty = len
  93   where
  94     args = case Type.splitTyConApp_maybe ty of
  95       Just (tycon, args) -> args
  96       Nothing -> error $ "\nCoreTools.ranged_word_bound_ty: Not a sized word type: " ++ (pprString ty)
  97     [len]         = args
  98
  99 -- | Evaluate a core Type representing type level int from the TypeLevel
 100 -- library to a real int.
 101 -- eval_type_level_int :: Type.Type -> Int
 102 -- eval_type_level_int ty =
 103 --   unsafeRunGhc $ do
 104 --     -- Automatically import modules for any fully qualified identifiers
 105 --     setDynFlag DynFlags.Opt_ImplicitImportQualified
 106 --
 107 --     let to_int_name = mkRdrName "Data.TypeLevel.Num.Sets" "toInt"
 108 --     let to_int = SrcLoc.noLoc $ HsExpr.HsVar to_int_name
 109 --     let undef = hsTypedUndef $ coreToHsType ty
 110 --     let app = HsExpr.HsApp (to_int) (undef)
 111 --
 112 --     core <- toCore [] app
 113 --     execCore core
 114
 115 -- | Get the length of a FSVec type
 116 tfvec_len :: Type.Type -> Int
 117 tfvec_len ty = eval_tfp_int (tfvec_len_ty ty)
 118
 119 tfvec_len_ty :: Type.Type -> Type.Type
 120 tfvec_len_ty ty = len
 121   where
 122     args = case Type.splitTyConApp_maybe ty of
 123       Just (tycon, args) -> args
 124       Nothing -> error $ "\nCoreTools.tfvec_len_ty: Not a vector type: " ++ (pprString ty)
 125     [len, el_ty] = args
 126
 127 -- | Get the element type of a TFVec type
 128 tfvec_elem :: Type.Type -> Type.Type
 129 tfvec_elem ty = el_ty
 130   where
 131     args = case Type.splitTyConApp_maybe ty of
 132       Just (tycon, args) -> args
 133       Nothing -> error $ "\nCoreTools.tfvec_len: Not a vector type: " ++ (pprString ty)
 134     [len, el_ty] = args
 135
 136 -- Is this a wild binder?
 137 is_wild :: CoreSyn.CoreBndr -> Bool
 138 -- wild binders have a particular unique, that we copied from MkCore.lhs to
 139 -- here. However, this comparison didn't work, so we'll just check the
 140 -- occstring for now... TODO
 141 --(Var.varUnique bndr) == (Unique.mkBuiltinUnique 1)
 142 is_wild bndr = "wild" == (OccName.occNameString . Name.nameOccName . Var.varName) bndr
 143
 144 -- Is the given core expression a lambda abstraction?
 145 is_lam :: CoreSyn.CoreExpr -> Bool
 146 is_lam (CoreSyn.Lam _ _) = True
 147 is_lam _ = False
 148
 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
 154
 155 -- Is the given core expression polymorphic (i.e., does it accept type
 156 -- arguments?).
 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
 161
 162 -- Is the given core expression a variable reference?
 163 is_var :: CoreSyn.CoreExpr -> Bool
 164 is_var (CoreSyn.Var _) = True
 165 is_var _ = False
 166
 167 is_lit :: CoreSyn.CoreExpr -> Bool
 168 is_lit (CoreSyn.Lit _) = True
 169 is_lit _ = False
 170
 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
 175
 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
 181 is_simple _ = False
 182
 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)
 186
 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
 190
 191 -- Turns a Var CoreExpr into the Id inside it. Will of course only work for
 192 -- simple Var CoreExprs, not complexer ones.
 193 exprToVar :: CoreSyn.CoreExpr -> Var.Id
 194 exprToVar (CoreSyn.Var id) = id
 195 exprToVar expr = error $ "\nCoreTools.exprToVar: Not a var: " ++ show expr
 196
 197 -- Turns a Lit CoreExpr into the Literal inside it.
 198 exprToLit :: CoreSyn.CoreExpr -> Literal.Literal
 199 exprToLit (CoreSyn.Lit lit) = lit
 200 exprToLit expr = error $ "\nCoreTools.exprToLit: Not a lit: " ++ show expr
 201
 202 -- Removes all the type and dictionary arguments from the given argument list,
 203 -- leaving only the normal value arguments. The type given is the type of the
 204 -- expression applied to this argument list.
 205 get_val_args :: Type.Type -> [CoreSyn.CoreExpr] -> [CoreSyn.CoreExpr]
 206 get_val_args ty args = drop n args
 207   where
 208     (tyvars, predtypes, _) = TcType.tcSplitSigmaTy ty
 209     -- The first (length tyvars) arguments should be types, the next
 210     -- (length predtypes) arguments should be dictionaries. We drop this many
 211     -- arguments, to get at the value arguments.
 212     n = length tyvars + length predtypes
 213
 214 getLiterals :: CoreSyn.CoreExpr -> [CoreSyn.CoreExpr]
 215 getLiterals app@(CoreSyn.App _ _) = literals
 216   where
 217     (CoreSyn.Var f, args) = CoreSyn.collectArgs app
 218     literals = filter (is_lit) args