From b83ea5327202d46fc976e369ac303608cbc2330e Mon Sep 17 00:00:00 2001 From: Matthijs Kooijman Date: Wed, 5 Aug 2009 13:59:39 +0200 Subject: [PATCH] Move around some helper functions. This moves some stuff from NormalizeTools and NormalizeTypes into the (new) BinderTools and TranslatorTypes. This also puts most of these function in the TranslatorSession instead of the TransformMonad. --- "c\316\273ash/CLasH/Normalize.hs" | 19 ++-- .../CLasH/Normalize/NormalizeTools.hs" | 86 +----------------- .../CLasH/Normalize/NormalizeTypes.hs" | 16 ---- .../CLasH/Translator/TranslatorTypes.hs" | 20 +++++ .../CLasH/Utils/Core/BinderTools.hs" | 88 +++++++++++++++++++ 5 files changed, 120 insertions(+), 109 deletions(-) create mode 100644 "c\316\273ash/CLasH/Utils/Core/BinderTools.hs" diff --git "a/c\316\273ash/CLasH/Normalize.hs" "b/c\316\273ash/CLasH/Normalize.hs" index 7571a6f..6238b48 100644 --- "a/c\316\273ash/CLasH/Normalize.hs" +++ "b/c\316\273ash/CLasH/Normalize.hs" @@ -39,6 +39,7 @@ import CLasH.Normalize.NormalizeTools import CLasH.VHDL.VHDLTypes import qualified CLasH.Utils as Utils import CLasH.Utils.Core.CoreTools +import CLasH.Utils.Core.BinderTools import CLasH.Utils.Pretty -------------------------------- @@ -51,7 +52,7 @@ import CLasH.Utils.Pretty eta, etatop :: Transform eta expr | is_fun expr && not (is_lam expr) = do let arg_ty = (fst . Type.splitFunTy . CoreUtils.exprType) expr - id <- mkInternalVar "param" arg_ty + id <- Trans.lift $ mkInternalVar "param" arg_ty change (Lam id (App expr (Var id))) -- Leave all other expressions unchanged eta e = return e @@ -112,7 +113,7 @@ letsimpl expr@(Let (Rec binds) res) = do then do -- If the result is not a local var already (to prevent loops with -- ourselves), extract it. - id <- mkInternalVar "foo" (CoreUtils.exprType res) + id <- Trans.lift $ mkInternalVar "foo" (CoreUtils.exprType res) let bind = (id, res) change $ Let (Rec (bind:binds)) (Var id) else @@ -188,7 +189,7 @@ scrutsimpl expr@(Case scrut b ty alts) = do repr <- isRepr scrut if repr then do - id <- mkInternalVar "scrut" (CoreUtils.exprType scrut) + id <- Trans.lift $ mkInternalVar "scrut" (CoreUtils.exprType scrut) change $ Let (Rec [(id, scrut)]) (Case (Var id) b ty alts) else return expr @@ -262,7 +263,7 @@ casesimpl expr@(Case scrut b ty alts) = do -- Create on new binder that will actually capture a value in this -- case statement, and return it. let bty = (Id.idType b) - id <- mkInternalVar "sel" bty + id <- Trans.lift $ mkInternalVar "sel" bty let binders = take i wildbndrs ++ [id] ++ drop (i+1) wildbndrs let caseexpr = Case scrut b bty [(con, binders, Var id)] return (wildbndrs!!i, Just (b, caseexpr)) @@ -282,7 +283,7 @@ casesimpl expr@(Case scrut b ty alts) = do -- prevent loops with inlinenonrep). if (not uses_bndrs) && (not local_var) && repr then do - id <- mkInternalVar "caseval" (CoreUtils.exprType expr) + id <- Trans.lift $ mkInternalVar "caseval" (CoreUtils.exprType expr) -- We don't flag a change here, since casevalsimpl will do that above -- based on Just we return here. return $ (Just (id, expr), Var id) @@ -322,7 +323,7 @@ appsimpl expr@(App f arg) = do local_var <- Trans.lift $ is_local_var arg if repr && not local_var then do -- Extract representable arguments - id <- mkInternalVar "arg" (CoreUtils.exprType arg) + id <- Trans.lift $ mkInternalVar "arg" (CoreUtils.exprType arg) change $ Let (Rec [(id, arg)]) (App f (Var id)) else -- Leave non-representable arguments unchanged return expr @@ -358,7 +359,7 @@ argprop expr@(App _ _) | is_var fexpr = do -- the old body applied to some arguments. let newbody = MkCore.mkCoreLams newparams (MkCore.mkCoreApps body oldargs) -- Create a new function with the same name but a new body - newf <- mkFunction f newbody + newf <- Trans.lift $ mkFunction f newbody -- Replace the original application with one of the new function to the -- new arguments. change $ MkCore.mkCoreApps (Var newf) newargs @@ -404,7 +405,7 @@ argprop expr@(App _ _) | is_var fexpr = do -- Representable types will not be propagated, and arguments with free -- type variables will be propagated later. -- TODO: preserve original naming? - id <- mkBinderFor arg "param" + id <- Trans.lift $ mkBinderFor arg "param" -- Just pass the original argument to the new function, which binds it -- to a new id and just pass that new id to the old function body. return ([arg], [id], mkReferenceTo id) @@ -451,7 +452,7 @@ funextract expr@(App _ _) | is_var fexpr = do -- by the argument expression. let free_vars = VarSet.varSetElems $ CoreFVs.exprFreeVars arg let body = MkCore.mkCoreLams free_vars arg - id <- mkBinderFor body "fun" + id <- Trans.lift $ mkBinderFor body "fun" Trans.lift $ addGlobalBind id body -- Replace the argument with a reference to the new function, applied to -- all vars it uses. diff --git "a/c\316\273ash/CLasH/Normalize/NormalizeTools.hs" "b/c\316\273ash/CLasH/Normalize/NormalizeTools.hs" index 5f0c3fd..b26cb74 100644 --- "a/c\316\273ash/CLasH/Normalize/NormalizeTools.hs" +++ "b/c\316\273ash/CLasH/Normalize/NormalizeTools.hs" @@ -3,6 +3,7 @@ -- This module provides functions for program transformations. -- module CLasH.Normalize.NormalizeTools where + -- Standard modules import Debug.Trace import qualified List @@ -19,18 +20,8 @@ import Data.Accessor.MonadState as MonadState -- GHC API import CoreSyn -import qualified UniqSupply -import qualified Unique -import qualified OccName -import qualified Name -import qualified Var -import qualified SrcLoc -import qualified Type -import qualified IdInfo -import qualified CoreUtils import qualified CoreSubst -import qualified VarSet -import qualified HscTypes +import qualified CoreUtils import Outputable ( showSDoc, ppr, nest ) -- Local imports @@ -40,68 +31,6 @@ import CLasH.Utils.Pretty import CLasH.VHDL.VHDLTypes import qualified CLasH.VHDL.VHDLTools as VHDLTools --- Create a new internal var with the given name and type. A Unique is --- appended to the given name, to ensure uniqueness (not strictly neccesary, --- since the Unique is also stored in the name, but this ensures variable --- names are unique in the output). -mkInternalVar :: String -> Type.Type -> TransformMonad Var.Var -mkInternalVar str ty = Trans.lift (mkInternalVar' str ty) - -mkInternalVar' :: String -> Type.Type -> TranslatorSession Var.Var -mkInternalVar' str ty = do - uniq <- mkUnique' - let occname = OccName.mkVarOcc (str ++ show uniq) - let name = Name.mkInternalName uniq occname SrcLoc.noSrcSpan - return $ Var.mkLocalVar IdInfo.VanillaId name ty IdInfo.vanillaIdInfo - --- Create a new type variable with the given name and kind. A Unique is --- appended to the given name, to ensure uniqueness (not strictly neccesary, --- since the Unique is also stored in the name, but this ensures variable --- names are unique in the output). -mkTypeVar :: String -> Type.Kind -> TransformMonad Var.Var -mkTypeVar str kind = Trans.lift (mkTypeVar' str kind) - -mkTypeVar' :: String -> Type.Kind -> TranslatorSession Var.Var -mkTypeVar' str kind = do - uniq <- mkUnique' - let occname = OccName.mkVarOcc (str ++ show uniq) - let name = Name.mkInternalName uniq occname SrcLoc.noSrcSpan - return $ Var.mkTyVar name kind - --- Creates a binder for the given expression with the given name. This --- works for both value and type level expressions, so it can return a Var or --- TyVar (which is just an alias for Var). -mkBinderFor :: CoreExpr -> String -> TransformMonad Var.Var -mkBinderFor expr string = Trans.lift (mkBinderFor' expr string) - -mkBinderFor' :: CoreExpr -> String -> TranslatorSession Var.Var -mkBinderFor' (Type ty) string = mkTypeVar' string (Type.typeKind ty) -mkBinderFor' expr string = mkInternalVar' string (CoreUtils.exprType expr) - --- Creates a reference to the given variable. This works for both a normal --- variable as well as a type variable -mkReferenceTo :: Var.Var -> CoreExpr -mkReferenceTo var | Var.isTyVar var = (Type $ Type.mkTyVarTy var) - | otherwise = (Var var) - -cloneVar :: Var.Var -> TransformMonad Var.Var -cloneVar v = do - uniq <- mkUnique - -- Swap out the unique, and reset the IdInfo (I'm not 100% sure what it - -- contains, but vannillaIdInfo is always correct, since it means "no info"). - return $ Var.lazySetIdInfo (Var.setVarUnique v uniq) IdInfo.vanillaIdInfo - --- Creates a new function with the same name as the given binder (but with a --- new unique) and with the given function body. Returns the new binder for --- this function. -mkFunction :: CoreBndr -> CoreExpr -> TransformMonad CoreBndr -mkFunction bndr body = do - let ty = CoreUtils.exprType body - id <- cloneVar bndr - let newid = Var.setVarType id ty - Trans.lift $ addGlobalBind newid body - return newid - -- Apply the given transformation to all expressions in the given expression, -- including the expression itself. everywhere :: (String, Transform) -> Transform @@ -229,17 +158,6 @@ change val = do setChanged return val --- Create a new Unique -mkUnique :: TransformMonad Unique.Unique -mkUnique = Trans.lift $ mkUnique' - -mkUnique' :: TranslatorSession Unique.Unique -mkUnique' = do - us <- getA tsUniqSupply - let (us', us'') = UniqSupply.splitUniqSupply us - putA tsUniqSupply us' - return $ UniqSupply.uniqFromSupply us'' - -- Replace each of the binders given with the coresponding expressions in the -- given expression. substitute :: [(CoreBndr, CoreExpr)] -> CoreExpr -> CoreExpr diff --git "a/c\316\273ash/CLasH/Normalize/NormalizeTypes.hs" "b/c\316\273ash/CLasH/Normalize/NormalizeTypes.hs" index 6d9ced8..a13ca0f 100644 --- "a/c\316\273ash/CLasH/Normalize/NormalizeTypes.hs" +++ "b/c\316\273ash/CLasH/Normalize/NormalizeTypes.hs" @@ -27,19 +27,3 @@ type TransformMonad = Writer.WriterT Monoid.Any TranslatorSession -- | Transforms a CoreExpr and keeps track if it has changed. type Transform = CoreExpr -> TransformMonad CoreExpr - --- Finds the value of a global binding, if available -getGlobalBind :: CoreBndr -> TranslatorSession (Maybe CoreExpr) -getGlobalBind bndr = do - bindings <- getA tsBindings - return $ Map.lookup bndr bindings - --- Adds a new global binding with the given value -addGlobalBind :: CoreBndr -> CoreExpr -> TranslatorSession () -addGlobalBind bndr expr = modA tsBindings (Map.insert bndr expr) - --- Returns a list of all global binders -getGlobalBinders :: TranslatorSession [CoreBndr] -getGlobalBinders = do - bindings <- getA tsBindings - return $ Map.keys bindings diff --git "a/c\316\273ash/CLasH/Translator/TranslatorTypes.hs" "b/c\316\273ash/CLasH/Translator/TranslatorTypes.hs" index 6871861..de7ee52 100644 --- "a/c\316\273ash/CLasH/Translator/TranslatorTypes.hs" +++ "b/c\316\273ash/CLasH/Translator/TranslatorTypes.hs" @@ -79,6 +79,10 @@ $( Data.Accessor.Template.deriveAccessors ''TranslatorState ) type TranslatorSession = State.State TranslatorState +----------------------------------------------------------------------------- +-- Some accessors +----------------------------------------------------------------------------- + -- Does the given binder reference a top level binder in the current -- module(s)? isTopLevelBinder :: CoreSyn.CoreBndr -> TranslatorSession Bool @@ -86,4 +90,20 @@ isTopLevelBinder bndr = do bindings <- getA tsBindings return $ Map.member bndr bindings +-- Finds the value of a global binding, if available +getGlobalBind :: CoreSyn.CoreBndr -> TranslatorSession (Maybe CoreSyn.CoreExpr) +getGlobalBind bndr = do + bindings <- getA tsBindings + return $ Map.lookup bndr bindings + +-- Adds a new global binding with the given value +addGlobalBind :: CoreSyn.CoreBndr -> CoreSyn.CoreExpr -> TranslatorSession () +addGlobalBind bndr expr = modA tsBindings (Map.insert bndr expr) + +-- Returns a list of all global binders +getGlobalBinders :: TranslatorSession [CoreSyn.CoreBndr] +getGlobalBinders = do + bindings <- getA tsBindings + return $ Map.keys bindings + -- vim: set ts=8 sw=2 sts=2 expandtab: diff --git "a/c\316\273ash/CLasH/Utils/Core/BinderTools.hs" "b/c\316\273ash/CLasH/Utils/Core/BinderTools.hs" new file mode 100644 index 0000000..a072c45 --- /dev/null +++ "b/c\316\273ash/CLasH/Utils/Core/BinderTools.hs" @@ -0,0 +1,88 @@ +-- +-- This module contains functions that manipulate binders in various ways. +-- +module CLasH.Utils.Core.BinderTools where + +-- Standard modules +import Data.Accessor.MonadState as MonadState + +-- GHC API +import CoreSyn +import qualified Type +import qualified UniqSupply +import qualified Unique +import qualified OccName +import qualified Name +import qualified Var +import qualified SrcLoc +import qualified IdInfo +import qualified CoreUtils +import qualified CoreSubst +import qualified VarSet +import qualified HscTypes + +-- Local imports +import Data.Accessor +import Data.Accessor.MonadState as MonadState +import CLasH.Translator.TranslatorTypes + +-- Create a new Unique +mkUnique :: TranslatorSession Unique.Unique +mkUnique = do + us <- getA tsUniqSupply + let (us', us'') = UniqSupply.splitUniqSupply us + putA tsUniqSupply us' + return $ UniqSupply.uniqFromSupply us'' + +-- Create a new internal var with the given name and type. A Unique is +-- appended to the given name, to ensure uniqueness (not strictly neccesary, +-- since the Unique is also stored in the name, but this ensures variable +-- names are unique in the output). +mkInternalVar :: String -> Type.Type -> TranslatorSession Var.Var +mkInternalVar str ty = do + uniq <- mkUnique + let occname = OccName.mkVarOcc (str ++ show uniq) + let name = Name.mkInternalName uniq occname SrcLoc.noSrcSpan + return $ Var.mkLocalVar IdInfo.VanillaId name ty IdInfo.vanillaIdInfo + +-- Create a new type variable with the given name and kind. A Unique is +-- appended to the given name, to ensure uniqueness (not strictly neccesary, +-- since the Unique is also stored in the name, but this ensures variable +-- names are unique in the output). +mkTypeVar :: String -> Type.Kind -> TranslatorSession Var.Var +mkTypeVar str kind = do + uniq <- mkUnique + let occname = OccName.mkVarOcc (str ++ show uniq) + let name = Name.mkInternalName uniq occname SrcLoc.noSrcSpan + return $ Var.mkTyVar name kind + +-- Creates a binder for the given expression with the given name. This +-- works for both value and type level expressions, so it can return a Var or +-- TyVar (which is just an alias for Var). +mkBinderFor :: CoreExpr -> String -> TranslatorSession Var.Var +mkBinderFor (Type ty) string = mkTypeVar string (Type.typeKind ty) +mkBinderFor expr string = mkInternalVar string (CoreUtils.exprType expr) + +-- Creates a reference to the given variable. This works for both a normal +-- variable as well as a type variable +mkReferenceTo :: Var.Var -> CoreExpr +mkReferenceTo var | Var.isTyVar var = (Type $ Type.mkTyVarTy var) + | otherwise = (Var var) + +cloneVar :: Var.Var -> TranslatorSession Var.Var +cloneVar v = do + uniq <- mkUnique + -- Swap out the unique, and reset the IdInfo (I'm not 100% sure what it + -- contains, but vannillaIdInfo is always correct, since it means "no info"). + return $ Var.lazySetIdInfo (Var.setVarUnique v uniq) IdInfo.vanillaIdInfo + +-- Creates a new function with the same name as the given binder (but with a +-- new unique) and with the given function body. Returns the new binder for +-- this function. +mkFunction :: CoreBndr -> CoreExpr -> TranslatorSession CoreBndr +mkFunction bndr body = do + let ty = CoreUtils.exprType body + id <- cloneVar bndr + let newid = Var.setVarType id ty + addGlobalBind newid body + return newid -- 2.30.2