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 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 GhcTools
  36 import HsTools
  37 import 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 $ 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" "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     let foo_name = mkRdrName "Types.Data.Num" "foo"
  55     let foo_bind_name = RdrName.mkRdrUnqual $ OccName.mkVarOcc "foo"
  56     let binds = Bag.listToBag [SrcLoc.noLoc $ HsBinds.VarBind foo_bind_name (SrcLoc.noLoc $ HsExpr.HsVar foo_name)]
  57     let letexpr = HsExpr.HsLet
  58           (HsBinds.HsValBinds $ (HsBinds.ValBindsIn binds) [])
  59           (SrcLoc.noLoc expr)
  60
  61     let modules = map GHC.mkModuleName ["Types.Data.Num"]
  62     core <- toCore modules expr
  63     execCore core
  64
  65 normalise_tfp_int :: HscTypes.HscEnv -> Type.Type -> Type.Type
  66 normalise_tfp_int env ty =
  67    unsafePerformIO $ do
  68      nty <- normaliseType env ty
  69      return nty
  70
  71 -- | Get the width of a SizedWord type
  72 -- sized_word_len :: HscTypes.HscEnv -> Type.Type -> Int
  73 -- sized_word_len env ty = eval_tfp_int env (sized_word_len_ty ty)
  74
  75 sized_word_len_ty :: Type.Type -> Type.Type
  76 sized_word_len_ty ty = len
  77   where
  78     args = case Type.splitTyConApp_maybe ty of
  79       Just (tycon, args) -> args
  80       Nothing -> error $ "\nCoreTools.sized_word_len_ty: Not a sized word type: " ++ (pprString ty)
  81     [len]         = args
  82
  83 -- | Get the width of a SizedInt type
  84 -- sized_int_len :: HscTypes.HscEnv -> Type.Type -> Int
  85 -- sized_int_len env ty = eval_tfp_int env (sized_int_len_ty ty)
  86
  87 sized_int_len_ty :: Type.Type -> Type.Type
  88 sized_int_len_ty ty = len
  89   where
  90     args = case Type.splitTyConApp_maybe ty of
  91       Just (tycon, args) -> args
  92       Nothing -> error $ "\nCoreTools.sized_int_len_ty: Not a sized int type: " ++ (pprString ty)
  93     [len]         = args
  94
  95 -- | Get the upperbound of a RangedWord type
  96 -- ranged_word_bound :: HscTypes.HscEnv -> Type.Type -> Int
  97 -- ranged_word_bound env ty = eval_tfp_int env (ranged_word_bound_ty ty)
  98
  99 ranged_word_bound_ty :: Type.Type -> Type.Type
 100 ranged_word_bound_ty ty = len
 101   where
 102     args = case Type.splitTyConApp_maybe ty of
 103       Just (tycon, args) -> args
 104       Nothing -> error $ "\nCoreTools.ranged_word_bound_ty: Not a sized word type: " ++ (pprString ty)
 105     [len]         = args
 106
 107 -- | Evaluate a core Type representing type level int from the TypeLevel
 108 -- library to a real int.
 109 -- eval_type_level_int :: Type.Type -> Int
 110 -- eval_type_level_int ty =
 111 --   unsafeRunGhc $ do
 112 --     -- Automatically import modules for any fully qualified identifiers
 113 --     setDynFlag DynFlags.Opt_ImplicitImportQualified
 114 --
 115 --     let to_int_name = mkRdrName "Data.TypeLevel.Num.Sets" "toInt"
 116 --     let to_int = SrcLoc.noLoc $ HsExpr.HsVar to_int_name
 117 --     let undef = hsTypedUndef $ coreToHsType ty
 118 --     let app = HsExpr.HsApp (to_int) (undef)
 119 --
 120 --     core <- toCore [] app
 121 --     execCore core
 122
 123 -- | Get the length of a FSVec type
 124 -- tfvec_len :: HscTypes.HscEnv -> Type.Type -> Int
 125 -- tfvec_len env ty = eval_tfp_int env (tfvec_len_ty ty)
 126
 127 tfvec_len_ty :: Type.Type -> Type.Type
 128 tfvec_len_ty ty = len
 129   where
 130     args = case Type.splitTyConApp_maybe ty of
 131       Just (tycon, args) -> args
 132       Nothing -> error $ "\nCoreTools.tfvec_len_ty: Not a vector type: " ++ (pprString ty)
 133     [len, el_ty] = args
 134
 135 -- | Get the element type of a TFVec type
 136 tfvec_elem :: Type.Type -> Type.Type
 137 tfvec_elem ty = el_ty
 138   where
 139     args = case Type.splitTyConApp_maybe ty of
 140       Just (tycon, args) -> args
 141       Nothing -> error $ "\nCoreTools.tfvec_len: Not a vector type: " ++ (pprString ty)
 142     [len, el_ty] = args
 143
 144 -- Is this a wild binder?
 145 is_wild :: CoreSyn.CoreBndr -> Bool
 146 -- wild binders have a particular unique, that we copied from MkCore.lhs to
 147 -- here. However, this comparison didn't work, so we'll just check the
 148 -- occstring for now... TODO
 149 --(Var.varUnique bndr) == (Unique.mkBuiltinUnique 1)
 150 is_wild bndr = "wild" == (OccName.occNameString . Name.nameOccName . Var.varName) bndr
 151
 152 -- Is the given core expression a lambda abstraction?
 153 is_lam :: CoreSyn.CoreExpr -> Bool
 154 is_lam (CoreSyn.Lam _ _) = True
 155 is_lam _ = False
 156
 157 -- Is the given core expression of a function type?
 158 is_fun :: CoreSyn.CoreExpr -> Bool
 159 -- Treat Type arguments differently, because exprType is not defined for them.
 160 is_fun (CoreSyn.Type _) = False
 161 is_fun expr = (Type.isFunTy . CoreUtils.exprType) expr
 162
 163 -- Is the given core expression polymorphic (i.e., does it accept type
 164 -- arguments?).
 165 is_poly :: CoreSyn.CoreExpr -> Bool
 166 -- Treat Type arguments differently, because exprType is not defined for them.
 167 is_poly (CoreSyn.Type _) = False
 168 is_poly expr = (Maybe.isJust . Type.splitForAllTy_maybe . CoreUtils.exprType) expr
 169
 170 -- Is the given core expression a variable reference?
 171 is_var :: CoreSyn.CoreExpr -> Bool
 172 is_var (CoreSyn.Var _) = True
 173 is_var _ = False
 174
 175 is_lit :: CoreSyn.CoreExpr -> Bool
 176 is_lit (CoreSyn.Lit _) = True
 177 is_lit _ = False
 178
 179 -- Can the given core expression be applied to something? This is true for
 180 -- applying to a value as well as a type.
 181 is_applicable :: CoreSyn.CoreExpr -> Bool
 182 is_applicable expr = is_fun expr || is_poly expr
 183
 184 -- Is the given core expression a variable or an application?
 185 is_simple :: CoreSyn.CoreExpr -> Bool
 186 is_simple (CoreSyn.App _ _) = True
 187 is_simple (CoreSyn.Var _) = True
 188 is_simple (CoreSyn.Cast expr _) = is_simple expr
 189 is_simple _ = False
 190
 191 -- Does the given CoreExpr have any free type vars?
 192 has_free_tyvars :: CoreSyn.CoreExpr -> Bool
 193 has_free_tyvars = not . VarSet.isEmptyVarSet . (CoreFVs.exprSomeFreeVars Var.isTyVar)
 194
 195 -- Does the given CoreExpr have any free local vars?
 196 has_free_vars :: CoreSyn.CoreExpr -> Bool
 197 has_free_vars = not . VarSet.isEmptyVarSet . CoreFVs.exprFreeVars
 198
 199 -- Turns a Var CoreExpr into the Id inside it. Will of course only work for
 200 -- simple Var CoreExprs, not complexer ones.
 201 exprToVar :: CoreSyn.CoreExpr -> Var.Id
 202 exprToVar (CoreSyn.Var id) = id
 203 exprToVar expr = error $ "\nCoreTools.exprToVar: Not a var: " ++ show expr
 204
 205 -- Turns a Lit CoreExpr into the Literal inside it.
 206 exprToLit :: CoreSyn.CoreExpr -> Literal.Literal
 207 exprToLit (CoreSyn.Lit lit) = lit
 208 exprToLit expr = error $ "\nCoreTools.exprToLit: Not a lit: " ++ show expr
 209
 210 -- Removes all the type and dictionary arguments from the given argument list,
 211 -- leaving only the normal value arguments. The type given is the type of the
 212 -- expression applied to this argument list.
 213 get_val_args :: Type.Type -> [CoreSyn.CoreExpr] -> [CoreSyn.CoreExpr]
 214 get_val_args ty args = drop n args
 215   where
 216     (tyvars, predtypes, _) = TcType.tcSplitSigmaTy ty
 217     -- The first (length tyvars) arguments should be types, the next
 218     -- (length predtypes) arguments should be dictionaries. We drop this many
 219     -- arguments, to get at the value arguments.
 220     n = length tyvars + length predtypes
 221
 222 getLiterals :: CoreSyn.CoreExpr -> [CoreSyn.CoreExpr]
 223 getLiterals app@(CoreSyn.App _ _) = literals
 224   where
 225     (CoreSyn.Var f, args) = CoreSyn.collectArgs app
 226     literals = filter (is_lit) args