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