cλash/CLasH/Utils/Core/CoreTools.hs

   1 {-# LANGUAGE PatternGuards, TypeSynonymInstances #-}
   2 -- | This module provides a number of functions to find out things about Core
   3 -- programs. This module does not provide the actual plumbing to work with
   4 -- Core and Haskell (it uses HsTools for this), but only the functions that
   5 -- know about various libraries and know which functions to call.
   6 module CLasH.Utils.Core.CoreTools where
   7
   8 --Standard modules
   9 import qualified Maybe
  10 import System.IO.Unsafe
  11
  12 -- GHC API
  13 import qualified GHC
  14 import qualified Type
  15 import qualified TcType
  16 import qualified HsExpr
  17 import qualified HsTypes
  18 import qualified HsBinds
  19 import qualified HscTypes
  20 import qualified RdrName
  21 import qualified Name
  22 import qualified OccName
  23 import qualified Type
  24 import qualified Id
  25 import qualified TyCon
  26 import qualified TysWiredIn
  27 import qualified Bag
  28 import qualified DynFlags
  29 import qualified SrcLoc
  30 import qualified CoreSyn
  31 import qualified Var
  32 import qualified VarSet
  33 import qualified Unique
  34 import qualified CoreUtils
  35 import qualified CoreFVs
  36 import qualified Literal
  37
  38 -- Local imports
  39 import CLasH.Translator.TranslatorTypes
  40 import CLasH.Utils.GhcTools
  41 import CLasH.Utils.HsTools
  42 import CLasH.Utils.Pretty
  43
  44 -- | Evaluate a core Type representing type level int from the tfp
  45 -- library to a real int.
  46 eval_tfp_int :: HscTypes.HscEnv -> Type.Type -> Int
  47 eval_tfp_int env ty =
  48   unsafeRunGhc libdir $ do
  49     GHC.setSession env
  50     -- Automatically import modules for any fully qualified identifiers
  51     setDynFlag DynFlags.Opt_ImplicitImportQualified
  52
  53     let from_int_t_name = mkRdrName "Types.Data.Num.Ops" "fromIntegerT"
  54     let from_int_t = SrcLoc.noLoc $ HsExpr.HsVar from_int_t_name
  55     let undef = hsTypedUndef $ coreToHsType ty
  56     let app = SrcLoc.noLoc $ HsExpr.HsApp (from_int_t) (undef)
  57     let int_ty = SrcLoc.noLoc $ HsTypes.HsTyVar TysWiredIn.intTyCon_RDR
  58     let expr = HsExpr.ExprWithTySig app int_ty
  59     core <- toCore expr
  60     execCore core
  61   where
  62     libdir = DynFlags.topDir dynflags
  63     dynflags = HscTypes.hsc_dflags env
  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 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 -- Does the given expression use any of the given binders?
 192 expr_uses_binders :: [CoreSyn.CoreBndr] -> CoreSyn.CoreExpr -> Bool
 193 expr_uses_binders bndrs = not . VarSet.isEmptyVarSet . (CoreFVs.exprSomeFreeVars (`elem` bndrs))
 194
 195 -- Turns a Var CoreExpr into the Id inside it. Will of course only work for
 196 -- simple Var CoreExprs, not complexer ones.
 197 exprToVar :: CoreSyn.CoreExpr -> Var.Id
 198 exprToVar (CoreSyn.Var id) = id
 199 exprToVar expr = error $ "\nCoreTools.exprToVar: Not a var: " ++ show expr
 200
 201 -- Turns a Lit CoreExpr into the Literal inside it.
 202 exprToLit :: CoreSyn.CoreExpr -> Literal.Literal
 203 exprToLit (CoreSyn.Lit lit) = lit
 204 exprToLit expr = error $ "\nCoreTools.exprToLit: Not a lit: " ++ show expr
 205
 206 -- Removes all the type and dictionary arguments from the given argument list,
 207 -- leaving only the normal value arguments. The type given is the type of the
 208 -- expression applied to this argument list.
 209 get_val_args :: Type.Type -> [CoreSyn.CoreExpr] -> [CoreSyn.CoreExpr]
 210 get_val_args ty args = drop n args
 211   where
 212     (tyvars, predtypes, _) = TcType.tcSplitSigmaTy ty
 213     -- The first (length tyvars) arguments should be types, the next
 214     -- (length predtypes) arguments should be dictionaries. We drop this many
 215     -- arguments, to get at the value arguments.
 216     n = length tyvars + length predtypes
 217
 218 getLiterals :: CoreSyn.CoreExpr -> [CoreSyn.CoreExpr]
 219 getLiterals app@(CoreSyn.App _ _) = literals
 220   where
 221     (CoreSyn.Var f, args) = CoreSyn.collectArgs app
 222     literals = filter (is_lit) args
 223
 224 getLiterals lit@(CoreSyn.Lit _) = [lit]
 225
 226 reduceCoreListToHsList ::
 227   [HscTypes.CoreModule] -- ^ The modules where parts of the list are hidden
 228   -> CoreSyn.CoreExpr   -- ^ The refence to atleast one of the nodes
 229   -> TranslatorSession [CoreSyn.CoreExpr]
 230 reduceCoreListToHsList cores app@(CoreSyn.App _ _) = do {
 231   ; let { (fun, args) = CoreSyn.collectArgs app
 232         ; len         = length args
 233         } ;
 234   ; case len of
 235       3 -> do {
 236         ; let topelem = args!!1
 237         ; case (args!!2) of
 238             (varz@(CoreSyn.Var id)) -> do {
 239               ; binds <- mapM (findExpr (isVarName id)) cores
 240               ; otherelems <- reduceCoreListToHsList cores (head (Maybe.catMaybes binds))
 241               ; return (topelem:otherelems)
 242               }
 243             (appz@(CoreSyn.App _ _)) -> do {
 244               ; otherelems <- reduceCoreListToHsList cores appz
 245               ; return (topelem:otherelems)
 246               }
 247             otherwise -> return [topelem]
 248         }
 249       otherwise -> return []
 250   }
 251   where
 252     isVarName :: Monad m => Var.Var -> Var.Var -> m Bool
 253     isVarName lookfor bind = return $ (Var.varName lookfor) == (Var.varName bind)
 254
 255 reduceCoreListToHsList _ _ = return []
 256
 257 -- | Is the given type a State type?
 258 isStateType :: Type.Type -> Bool
 259 -- Resolve any type synonyms remaining
 260 isStateType ty | Just ty' <- Type.tcView ty = isStateType ty'
 261 isStateType ty  = Maybe.isJust $ do
 262   -- Split the type. Don't use normal splitAppTy, since that looks through
 263   -- newtypes, and we want to see the State newtype.
 264   (typef, _) <- Type.repSplitAppTy_maybe ty
 265   -- See if the applied type is a type constructor
 266   (tycon, _) <- Type.splitTyConApp_maybe typef
 267   if TyCon.isNewTyCon tycon && Name.getOccString tycon == "State"
 268     then
 269       Just ()
 270     else
 271       Nothing
 272
 273 -- | Does the given TypedThing have a State type?
 274 hasStateType :: (TypedThing t) => t -> Bool
 275 hasStateType expr = case getType expr of
 276   Nothing -> False
 277   Just ty -> isStateType ty
 278
 279
 280 -- | A class of things that (optionally) have a core Type. The type is
 281 -- optional, since Type expressions don't have a type themselves.
 282 class TypedThing t where
 283   getType :: t -> Maybe Type.Type
 284
 285 instance TypedThing CoreSyn.CoreExpr where
 286   getType (CoreSyn.Type _) = Nothing
 287   getType expr = Just $ CoreUtils.exprType expr
 288
 289 instance TypedThing CoreSyn.CoreBndr where
 290   getType = return . Id.idType
 291
 292 instance TypedThing Type.Type where
 293   getType = return . id