X-Git-Url: https://git.stderr.nl/gitweb?a=blobdiff_plain;f=c%CE%BBash%2FCLasH%2FUtils%2FCore%2FCoreTools.hs;h=ce42678a7683634edd4368351709384b8d777310;hb=6da4d5f5547f8107200d1d8766d82e81a626c647;hp=45721a891a7bf6d1662465322795daa2995a67ff;hpb=b2967df7f237e5b4db15d069895ca01c31712d9e;p=matthijs%2Fmaster-project%2Fc%CE%BBash.git diff --git "a/c\316\273ash/CLasH/Utils/Core/CoreTools.hs" "b/c\316\273ash/CLasH/Utils/Core/CoreTools.hs" index 45721a8..ce42678 100644 --- "a/c\316\273ash/CLasH/Utils/Core/CoreTools.hs" +++ "b/c\316\273ash/CLasH/Utils/Core/CoreTools.hs" @@ -1,3 +1,4 @@ +{-# LANGUAGE PatternGuards, TypeSynonymInstances #-} -- | This module provides a number of functions to find out things about Core -- programs. This module does not provide the actual plumbing to work with -- Core and Haskell (it uses HsTools for this), but only the functions that @@ -6,7 +7,9 @@ module CLasH.Utils.Core.CoreTools where --Standard modules import qualified Maybe -import System.IO.Unsafe +import qualified System.IO.Unsafe +import qualified Data.Map as Map +import qualified Data.Accessor.Monad.Trans.State as MonadState -- GHC API import qualified GHC @@ -14,51 +17,94 @@ import qualified Type import qualified TcType import qualified HsExpr import qualified HsTypes -import qualified HsBinds import qualified HscTypes -import qualified RdrName import qualified Name -import qualified OccName +import qualified Id +import qualified TyCon +import qualified DataCon import qualified TysWiredIn -import qualified Bag import qualified DynFlags import qualified SrcLoc import qualified CoreSyn import qualified Var +import qualified IdInfo import qualified VarSet -import qualified Unique import qualified CoreUtils import qualified CoreFVs import qualified Literal +import qualified MkCore +import qualified VarEnv -- Local imports +import CLasH.Translator.TranslatorTypes import CLasH.Utils.GhcTools +import CLasH.Utils.Core.BinderTools import CLasH.Utils.HsTools import CLasH.Utils.Pretty +import CLasH.Utils +import qualified CLasH.Utils.Core.BinderTools as BinderTools + +-- | A single binding, used as a shortcut to simplify type signatures. +type Binding = (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -- | Evaluate a core Type representing type level int from the tfp --- library to a real int. +-- library to a real int. Checks if the type really is a Dec type and +-- caches the results. +tfp_to_int :: Type.Type -> TypeSession Int +tfp_to_int ty = do + hscenv <- MonadState.get tsHscEnv + let norm_ty = normalise_tfp_int hscenv ty + case Type.splitTyConApp_maybe norm_ty of + Just (tycon, args) -> do + let name = Name.getOccString (TyCon.tyConName tycon) + case name of + "Dec" -> + tfp_to_int' ty + otherwise -> do + return $ error ("Callin tfp_to_int on non-dec:" ++ (show ty)) + Nothing -> return $ error ("Callin tfp_to_int on non-dec:" ++ (show ty)) + +-- | Evaluate a core Type representing type level int from the tfp +-- library to a real int. Caches the results. Do not use directly, use +-- tfp_to_int instead. +tfp_to_int' :: Type.Type -> TypeSession Int +tfp_to_int' ty = do + lens <- MonadState.get tsTfpInts + hscenv <- MonadState.get tsHscEnv + let norm_ty = normalise_tfp_int hscenv ty + let existing_len = Map.lookup (OrdType norm_ty) lens + case existing_len of + Just len -> return len + Nothing -> do + let new_len = eval_tfp_int hscenv ty + MonadState.modify tsTfpInts (Map.insert (OrdType norm_ty) (new_len)) + return new_len + +-- | Evaluate a core Type representing type level int from the tfp +-- library to a real int. Do not use directly, use tfp_to_int instead. eval_tfp_int :: HscTypes.HscEnv -> Type.Type -> Int eval_tfp_int env ty = - unsafeRunGhc $ do + unsafeRunGhc libdir $ do GHC.setSession env -- Automatically import modules for any fully qualified identifiers setDynFlag DynFlags.Opt_ImplicitImportQualified - let from_int_t_name = mkRdrName "Types.Data.Num" "fromIntegerT" + let from_int_t_name = mkRdrName "Types.Data.Num.Ops" "fromIntegerT" let from_int_t = SrcLoc.noLoc $ HsExpr.HsVar from_int_t_name let undef = hsTypedUndef $ coreToHsType ty let app = SrcLoc.noLoc $ HsExpr.HsApp (from_int_t) (undef) let int_ty = SrcLoc.noLoc $ HsTypes.HsTyVar TysWiredIn.intTyCon_RDR let expr = HsExpr.ExprWithTySig app int_ty core <- toCore expr - execCore core + execCore core + where + libdir = DynFlags.topDir dynflags + dynflags = HscTypes.hsc_dflags env normalise_tfp_int :: HscTypes.HscEnv -> Type.Type -> Type.Type normalise_tfp_int env ty = - unsafePerformIO $ do - nty <- normaliseType env ty - return nty + System.IO.Unsafe.unsafePerformIO $ + normaliseType env ty -- | Get the width of a SizedWord type -- sized_word_len :: HscTypes.HscEnv -> Type.Type -> Int @@ -138,6 +184,11 @@ is_lam :: CoreSyn.CoreExpr -> Bool is_lam (CoreSyn.Lam _ _) = True is_lam _ = False +-- Is the given core expression a let expression? +is_let :: CoreSyn.CoreExpr -> Bool +is_let (CoreSyn.Let _ _) = True +is_let _ = False + -- Is the given core expression of a function type? is_fun :: CoreSyn.CoreExpr -> Bool -- Treat Type arguments differently, because exprType is not defined for them. @@ -176,10 +227,18 @@ is_simple _ = False has_free_tyvars :: CoreSyn.CoreExpr -> Bool has_free_tyvars = not . VarSet.isEmptyVarSet . (CoreFVs.exprSomeFreeVars Var.isTyVar) +-- Does the given type have any free type vars? +ty_has_free_tyvars :: Type.Type -> Bool +ty_has_free_tyvars = not . VarSet.isEmptyVarSet . Type.tyVarsOfType + -- Does the given CoreExpr have any free local vars? has_free_vars :: CoreSyn.CoreExpr -> Bool has_free_vars = not . VarSet.isEmptyVarSet . CoreFVs.exprFreeVars +-- Does the given expression use any of the given binders? +expr_uses_binders :: [CoreSyn.CoreBndr] -> CoreSyn.CoreExpr -> Bool +expr_uses_binders bndrs = not . VarSet.isEmptyVarSet . (CoreFVs.exprSomeFreeVars (`elem` bndrs)) + -- Turns a Var CoreExpr into the Id inside it. Will of course only work for -- simple Var CoreExprs, not complexer ones. exprToVar :: CoreSyn.CoreExpr -> Var.Id @@ -203,8 +262,234 @@ get_val_args ty args = drop n args -- arguments, to get at the value arguments. n = length tyvars + length predtypes -getLiterals :: CoreSyn.CoreExpr -> [CoreSyn.CoreExpr] -getLiterals app@(CoreSyn.App _ _) = literals +-- Finds out what literal Integer this expression represents. +getIntegerLiteral :: CoreSyn.CoreExpr -> TranslatorSession Integer +getIntegerLiteral expr = + case CoreSyn.collectArgs expr of + (CoreSyn.Var f, [CoreSyn.Lit (Literal.MachInt integer)]) + | getFullString f == "GHC.Integer.smallInteger" -> return integer + (CoreSyn.Var f, [CoreSyn.Lit (Literal.MachInt64 integer)]) + | getFullString f == "GHC.Integer.int64ToInteger" -> return integer + (CoreSyn.Var f, [CoreSyn.Lit (Literal.MachWord integer)]) + | getFullString f == "GHC.Integer.wordToInteger" -> return integer + (CoreSyn.Var f, [CoreSyn.Lit (Literal.MachWord64 integer)]) + | getFullString f == "GHC.Integer.word64ToInteger" -> return integer + -- fromIntegerT returns the integer corresponding to the type of its + -- (third) argument. Since it is polymorphic, the type of that + -- argument is passed as the first argument, so we can just use that + -- one. + (CoreSyn.Var f, [CoreSyn.Type dec_ty, dec_dict, CoreSyn.Type num_ty, num_dict, arg]) + | getFullString f == "Types.Data.Num.Ops.fromIntegerT" -> do + int <- MonadState.lift tsType $ tfp_to_int dec_ty + return $ toInteger int + _ -> error $ "CoreTools.getIntegerLiteral: Unsupported Integer literal: " ++ pprString expr + +reduceCoreListToHsList :: + [HscTypes.CoreModule] -- ^ The modules where parts of the list are hidden + -> CoreSyn.CoreExpr -- ^ The refence to atleast one of the nodes + -> TranslatorSession [CoreSyn.CoreExpr] +reduceCoreListToHsList cores app@(CoreSyn.App _ _) = do { + ; let { (fun, args) = CoreSyn.collectArgs app + ; len = length args + } ; + ; case len of + 3 -> do { + ; let topelem = args!!1 + ; case (args!!2) of + (varz@(CoreSyn.Var id)) -> do { + ; binds <- mapM (findExpr (isVarName id)) cores + ; otherelems <- reduceCoreListToHsList cores (head (Maybe.catMaybes binds)) + ; return (topelem:otherelems) + } + (appz@(CoreSyn.App _ _)) -> do { + ; otherelems <- reduceCoreListToHsList cores appz + ; return (topelem:otherelems) + } + otherwise -> return [topelem] + } + otherwise -> return [] + } + where + isVarName :: Monad m => Var.Var -> Var.Var -> m Bool + isVarName lookfor bind = return $ (Var.varName lookfor) == (Var.varName bind) + +reduceCoreListToHsList _ _ = return [] + +-- Is the given var the State data constructor? +isStateCon :: Var.Var -> Bool +isStateCon var = + -- See if it is a DataConWrapId (not DataConWorkId, since State is a + -- newtype). + case Id.idDetails var of + IdInfo.DataConWrapId dc -> + -- See if the datacon is the State datacon from the State type. + let tycon = DataCon.dataConTyCon dc + tyname = Name.getOccString tycon + dcname = Name.getOccString dc + in case (tyname, dcname) of + ("State", "State") -> True + _ -> False + _ -> False + +-- | Is the given type a State type? +isStateType :: Type.Type -> Bool +-- Resolve any type synonyms remaining +isStateType ty | Just ty' <- Type.tcView ty = isStateType ty' +isStateType ty = Maybe.isJust $ do + -- Split the type. Don't use normal splitAppTy, since that looks through + -- newtypes, and we want to see the State newtype. + (typef, _) <- Type.repSplitAppTy_maybe ty + -- See if the applied type is a type constructor + (tycon, _) <- Type.splitTyConApp_maybe typef + if TyCon.isNewTyCon tycon && Name.getOccString tycon == "State" + then + Just () + else + Nothing + +-- | Does the given TypedThing have a State type? +hasStateType :: (TypedThing t) => t -> Bool +hasStateType expr = case getType expr of + Nothing -> False + Just ty -> isStateType ty + + +-- | Flattens nested lets into a single list of bindings. The expression +-- passed does not have to be a let expression, if it isn't an empty list of +-- bindings is returned. +flattenLets :: + CoreSyn.CoreExpr -- ^ The expression to flatten. + -> ([Binding], CoreSyn.CoreExpr) -- ^ The bindings and resulting expression. +flattenLets (CoreSyn.Let binds expr) = + (bindings ++ bindings', expr') + where + -- Recursively flatten the contained expression + (bindings', expr') =flattenLets expr + -- Flatten our own bindings to remove the Rec / NonRec constructors + bindings = CoreSyn.flattenBinds [binds] +flattenLets expr = ([], expr) + +-- | Create bunch of nested non-recursive let expressions from the given +-- bindings. The first binding is bound at the highest level (and thus +-- available in all other bindings). +mkNonRecLets :: [Binding] -> CoreSyn.CoreExpr -> CoreSyn.CoreExpr +mkNonRecLets bindings expr = MkCore.mkCoreLets binds expr + where + binds = map (uncurry CoreSyn.NonRec) bindings + +-- | A class of things that (optionally) have a core Type. The type is +-- optional, since Type expressions don't have a type themselves. +class TypedThing t where + getType :: t -> Maybe Type.Type + +instance TypedThing CoreSyn.CoreExpr where + getType (CoreSyn.Type _) = Nothing + getType expr = Just $ CoreUtils.exprType expr + +instance TypedThing CoreSyn.CoreBndr where + getType = return . Id.idType + +instance TypedThing Type.Type where + getType = return . id + +-- | Generate new uniques for all binders in the given expression. +-- Does not support making type variables unique, though this could be +-- supported if required (by passing a CoreSubst.Subst instead of VarEnv to +-- genUniques' below). +genUniques :: CoreSyn.CoreExpr -> TranslatorSession CoreSyn.CoreExpr +genUniques = genUniques' VarEnv.emptyVarEnv + +-- | A helper function to generate uniques, that takes a VarEnv containing the +-- substitutions already performed. +genUniques' :: VarEnv.VarEnv CoreSyn.CoreBndr -> CoreSyn.CoreExpr -> TranslatorSession CoreSyn.CoreExpr +genUniques' subst (CoreSyn.Var f) = do + -- Replace the binder with its new value, if applicable. + let f' = VarEnv.lookupWithDefaultVarEnv subst f f + return (CoreSyn.Var f') +-- Leave literals untouched +genUniques' subst (CoreSyn.Lit l) = return $ CoreSyn.Lit l +genUniques' subst (CoreSyn.App f arg) = do + -- Only work on subexpressions + f' <- genUniques' subst f + arg' <- genUniques' subst arg + return (CoreSyn.App f' arg') +-- Don't change type abstractions +genUniques' subst expr@(CoreSyn.Lam bndr res) | CoreSyn.isTyVar bndr = return expr +genUniques' subst (CoreSyn.Lam bndr res) = do + -- Generate a new unique for the bound variable + (subst', bndr') <- genUnique subst bndr + res' <- genUniques' subst' res + return (CoreSyn.Lam bndr' res') +genUniques' subst (CoreSyn.Let (CoreSyn.NonRec bndr bound) res) = do + -- Make the binders unique + (subst', bndr') <- genUnique subst bndr + bound' <- genUniques' subst' bound + res' <- genUniques' subst' res + return $ CoreSyn.Let (CoreSyn.NonRec bndr' bound') res' +genUniques' subst (CoreSyn.Let (CoreSyn.Rec binds) res) = do + -- Make each of the binders unique + (subst', bndrs') <- mapAccumLM genUnique subst (map fst binds) + bounds' <- mapM (genUniques' subst' . snd) binds + res' <- genUniques' subst' res + let binds' = zip bndrs' bounds' + return $ CoreSyn.Let (CoreSyn.Rec binds') res' +genUniques' subst (CoreSyn.Case scrut bndr ty alts) = do + -- Process the scrutinee with the original substitution, since non of the + -- binders bound in the Case statement is in scope in the scrutinee. + scrut' <- genUniques' subst scrut + -- Generate a new binder for the scrutinee + (subst', bndr') <- genUnique subst bndr + -- Process each of the alts + alts' <- mapM (doalt subst') alts + return $ CoreSyn.Case scrut' bndr' ty alts' where - (CoreSyn.Var f, args) = CoreSyn.collectArgs app - literals = filter (is_lit) args + doalt subst (con, bndrs, expr) = do + (subst', bndrs') <- mapAccumLM genUnique subst bndrs + expr' <- genUniques' subst' expr + -- Note that we don't return subst', since bndrs are only in scope in + -- expr. + return (con, bndrs', expr') +genUniques' subst (CoreSyn.Cast expr coercion) = do + expr' <- genUniques' subst expr + -- Just process the casted expression + return $ CoreSyn.Cast expr' coercion +genUniques' subst (CoreSyn.Note note expr) = do + expr' <- genUniques' subst expr + -- Just process the annotated expression + return $ CoreSyn.Note note expr' +-- Leave types untouched +genUniques' subst expr@(CoreSyn.Type _) = return expr + +-- Generate a new unique for the given binder, and extend the given +-- substitution to reflect this. +genUnique :: VarEnv.VarEnv CoreSyn.CoreBndr -> CoreSyn.CoreBndr -> TranslatorSession (VarEnv.VarEnv CoreSyn.CoreBndr, CoreSyn.CoreBndr) +genUnique subst bndr = do + bndr' <- BinderTools.cloneVar bndr + -- Replace all occurences of the old binder with a reference to the new + -- binder. + let subst' = VarEnv.extendVarEnv subst bndr bndr' + return (subst', bndr') + +-- Create a "selector" case that selects the ith field from a datacon +mkSelCase :: CoreSyn.CoreExpr -> Int -> TranslatorSession CoreSyn.CoreExpr +mkSelCase scrut i = do + let scrut_ty = CoreUtils.exprType scrut + case Type.splitTyConApp_maybe scrut_ty of + -- The scrutinee should have a type constructor. We keep the type + -- arguments around so we can instantiate the field types below + Just (tycon, tyargs) -> case TyCon.tyConDataCons tycon of + -- The scrutinee type should have a single dataconstructor, + -- otherwise we can't construct a valid selector case. + [datacon] -> do + let field_tys = DataCon.dataConInstOrigArgTys datacon tyargs + -- Create a list of wild binders for the fields we don't want + let wildbndrs = map MkCore.mkWildBinder field_tys + -- Create a single binder for the field we want + sel_bndr <- mkInternalVar "sel" (field_tys!!i) + -- Create a wild binder for the scrutinee + let scrut_bndr = MkCore.mkWildBinder scrut_ty + -- Create the case expression + let binders = take i wildbndrs ++ [sel_bndr] ++ drop (i+1) wildbndrs + return $ CoreSyn.Case scrut scrut_bndr scrut_ty [(CoreSyn.DataAlt datacon, binders, CoreSyn.Var sel_bndr)] + dcs -> error $ "CoreTools.mkSelCase: Scrutinee type must have exactly one datacon. Extracting element " ++ (show i) ++ " from '" ++ pprString scrut ++ "' Datacons: " ++ (show dcs) ++ " Type: " ++ (pprString scrut_ty) + Nothing -> error $ "CoreTools.mkSelCase: Creating extractor case, but scrutinee has no tycon? Extracting element " ++ (show i) ++ " from '" ++ pprString scrut ++ "'" ++ " Type: " ++ (pprString scrut_ty)