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 =
  65   eval_tfp_int len
  66   where
  67     (tycon, args) = Type.splitTyConApp ty
  68     [len] = args
  69
  70 -- | Get the upperbound of a RangedWord type
  71 ranged_word_bound :: Type.Type -> Int
  72 ranged_word_bound ty =
  73   eval_tfp_int len
  74   where
  75     (tycon, args) = Type.splitTyConApp ty
  76     [len]         = args
  77
  78 -- | Evaluate a core Type representing type level int from the TypeLevel
  79 -- library to a real int.
  80 -- eval_type_level_int :: Type.Type -> Int
  81 -- eval_type_level_int ty =
  82 --   unsafeRunGhc $ do
  83 --     -- Automatically import modules for any fully qualified identifiers
  84 --     setDynFlag DynFlags.Opt_ImplicitImportQualified
  85 --
  86 --     let to_int_name = mkRdrName "Data.TypeLevel.Num.Sets" "toInt"
  87 --     let to_int = SrcLoc.noLoc $ HsExpr.HsVar to_int_name
  88 --     let undef = hsTypedUndef $ coreToHsType ty
  89 --     let app = HsExpr.HsApp (to_int) (undef)
  90 --
  91 --     core <- toCore [] app
  92 --     execCore core
  93
  94 -- | Get the length of a FSVec type
  95 tfvec_len :: Type.Type -> Int
  96 tfvec_len ty =
  97   eval_tfp_int len
  98   where
  99     args = case Type.splitTyConApp_maybe ty of
 100       Just (tycon, args) -> args
 101       Nothing -> error $ "CoreTools.tfvec_len Not a vector type: " ++ (pprString ty)
 102     [len, el_ty] = args
 103
 104 -- | Get the element type of a TFVec type
 105 tfvec_elem :: Type.Type -> Type.Type
 106 tfvec_elem ty = el_ty
 107   where
 108     args = case Type.splitTyConApp_maybe ty of
 109       Just (tycon, args) -> args
 110       Nothing -> error $ "CoreTools.tfvec_len Not a vector type: " ++ (pprString ty)
 111     [len, el_ty] = args
 112
 113 -- Is this a wild binder?
 114 is_wild :: CoreSyn.CoreBndr -> Bool
 115 -- wild binders have a particular unique, that we copied from MkCore.lhs to
 116 -- here. However, this comparison didn't work, so we'll just check the
 117 -- occstring for now... TODO
 118 --(Var.varUnique bndr) == (Unique.mkBuiltinUnique 1)
 119 is_wild bndr = "wild" == (OccName.occNameString . Name.nameOccName . Var.varName) bndr
 120
 121 -- Is the given core expression a lambda abstraction?
 122 is_lam :: CoreSyn.CoreExpr -> Bool
 123 is_lam (CoreSyn.Lam _ _) = True
 124 is_lam _ = False
 125
 126 -- Is the given core expression of a function type?
 127 is_fun :: CoreSyn.CoreExpr -> Bool
 128 -- Treat Type arguments differently, because exprType is not defined for them.
 129 is_fun (CoreSyn.Type _) = False
 130 is_fun expr = (Type.isFunTy . CoreUtils.exprType) expr
 131
 132 -- Is the given core expression polymorphic (i.e., does it accept type
 133 -- arguments?).
 134 is_poly :: CoreSyn.CoreExpr -> Bool
 135 -- Treat Type arguments differently, because exprType is not defined for them.
 136 is_poly (CoreSyn.Type _) = False
 137 is_poly expr = (Maybe.isJust . Type.splitForAllTy_maybe . CoreUtils.exprType) expr
 138
 139 -- Is the given core expression a variable reference?
 140 is_var :: CoreSyn.CoreExpr -> Bool
 141 is_var (CoreSyn.Var _) = True
 142 is_var _ = False
 143
 144 -- Can the given core expression be applied to something? This is true for
 145 -- applying to a value as well as a type.
 146 is_applicable :: CoreSyn.CoreExpr -> Bool
 147 is_applicable expr = is_fun expr || is_poly expr
 148
 149 -- Is the given core expression a variable or an application?
 150 is_simple :: CoreSyn.CoreExpr -> Bool
 151 is_simple (CoreSyn.App _ _) = True
 152 is_simple (CoreSyn.Var _) = True
 153 is_simple (CoreSyn.Cast expr _) = is_simple expr
 154 is_simple _ = False
 155
 156 -- Does the given CoreExpr have any free type vars?
 157 has_free_tyvars :: CoreSyn.CoreExpr -> Bool
 158 has_free_tyvars = not . VarSet.isEmptyVarSet . (CoreFVs.exprSomeFreeVars Var.isTyVar)
 159
 160 -- Does the given CoreExpr have any free local vars?
 161 has_free_vars :: CoreSyn.CoreExpr -> Bool
 162 has_free_vars = not . VarSet.isEmptyVarSet . CoreFVs.exprFreeVars
 163
 164 -- Turns a Var CoreExpr into the Id inside it. Will of course only work for
 165 -- simple Var CoreExprs, not complexer ones.
 166 exprToVar :: CoreSyn.CoreExpr -> Var.Id
 167 exprToVar (CoreSyn.Var id) = id
 168 exprToVar expr = error $ "CoreTools.exprToVar Not a var: " ++ show expr
 169
 170 -- Removes all the type and dictionary arguments from the given argument list,
 171 -- leaving only the normal value arguments. The type given is the type of the
 172 -- expression applied to this argument list.
 173 get_val_args :: Type.Type -> [CoreSyn.CoreExpr] -> [CoreSyn.CoreExpr]
 174 get_val_args ty args = drop n args
 175   where
 176     (tyvars, predtypes, _) = TcType.tcSplitSigmaTy ty
 177     -- The first (length tyvars) arguments should be types, the next
 178     -- (length predtypes) arguments should be dictionaries. We drop this many
 179     -- arguments, to get at the value arguments.
 180     n = length tyvars + length predtypes