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