From: Matthijs Kooijman Date: Wed, 19 Aug 2009 15:54:38 +0000 (+0200) Subject: Merge branch 'master' of git://github.com/christiaanb/clash into cλash X-Git-Url: https://git.stderr.nl/gitweb?a=commitdiff_plain;h=743f2dcf9a7a37c71fc06ce552f605fac3120e56;hp=a533335368e252544db4f68ee03e0e7b7255eae5;p=matthijs%2Fmaster-project%2Fc%CE%BBash.git Merge branch 'master' of git://github.com/christiaanb/clash into cλash * 'master' of git://github.com/christiaanb/clash: Work around some bugs in the current clash to make reducer compile correctly Just name the testbench: testbench; don't add the unique No longer allow slashes in extended names, they are now stripped Used unsigned instead of natural as representation of RangedWord Add resetn ports --- diff --git "a/c\316\273ash/CLasH/Normalize.hs" "b/c\316\273ash/CLasH/Normalize.hs" index 7d28473..6fd6a2e 100644 --- "a/c\316\273ash/CLasH/Normalize.hs" +++ "b/c\316\273ash/CLasH/Normalize.hs" @@ -64,8 +64,10 @@ etatop = notappargs ("eta", eta) -- β-reduction -------------------------------- beta, betatop :: Transform --- Substitute arg for x in expr -beta (App (Lam x expr) arg) = change $ substitute [(x, arg)] expr +-- Substitute arg for x in expr. For value lambda's, also clone before +-- substitution. +beta (App (Lam x expr) arg) | CoreSyn.isTyVar x = setChanged >> substitute x arg expr + | otherwise = setChanged >> substitute_clone x arg expr -- Propagate the application into the let beta (App (Let binds expr) arg) = change $ Let binds (App expr arg) -- Propagate the application into each of the alternatives @@ -323,29 +325,36 @@ inlinenonreptop = everywhere ("inlinenonrep", inlinebind ((Monad.liftM not) . is inlinetoplevel, inlinetopleveltop :: Transform -- Any system name is candidate for inlining. Never inline user-defined -- functions, to preserver structure. -inlinetoplevel expr@(Var f) | (Name.isSystemName . Id.idName) f = do +inlinetoplevel expr@(Var f) | not $ isUserDefined f = do + norm <- isNormalizeable f -- See if this is a top level binding for which we have a body body_maybe <- Trans.lift $ getGlobalBind f - case body_maybe of - Just body -> do + if norm && Maybe.isJust body_maybe + then do -- Get the normalized version norm <- Trans.lift $ getNormalized f if needsInline norm - then - change norm + then do + -- Regenerate all uniques in the to-be-inlined expression + norm_uniqued <- Trans.lift $ genUniques norm + change norm_uniqued else return expr - -- No body, this is probably a local variable or builtin or external - -- function. - Nothing -> return expr + else + -- No body or not normalizeable. + return expr -- Leave all other expressions unchanged inlinetoplevel expr = return expr inlinetopleveltop = everywhere ("inlinetoplevel", inlinetoplevel) needsInline :: CoreExpr -> Bool --- Any function that just evaluates to another function, can be inlined ---needsInline (Var f) = True -needsInline _ = False +needsInline expr = case splitNormalized expr of + -- Inline any function that only has a single definition, it is probably + -- simple enough. This might inline some stuff that it shouldn't though it + -- will never inline user-defined functions (inlinetoplevel only tries + -- system names) and inlining should never break things. + (args, [bind], res) -> True + _ -> False -------------------------------- -- Scrutinee simplification @@ -423,7 +432,7 @@ casesimpl expr@(Case scrut b ty alts) = do -- binding containing a case expression. dobndr :: CoreBndr -> Int -> TransformMonad (CoreBndr, Maybe (CoreBndr, CoreExpr)) dobndr b i = do - repr <- isRepr (Var b) + repr <- isRepr b -- Is b wild (e.g., not a free var of expr. Since b is only in scope -- in expr, this means that b is unused if expr does not use it.) let wild = not (VarSet.elemVarSet b free_vars) @@ -647,7 +656,10 @@ simplrestop expr@(Lam _ _) = return expr simplrestop expr@(Let _ _) = return expr simplrestop expr = do local_var <- Trans.lift $ is_local_var expr - if local_var + -- Don't extract values that are not representable, to prevent loops with + -- inlinenonrep + repr <- isRepr expr + if local_var || not repr then return expr else do @@ -685,9 +697,10 @@ normalizeExpr :: -> TranslatorSession CoreSyn.CoreExpr -- ^ The normalized expression normalizeExpr what expr = do + expr_uniqued <- genUniques expr -- Normalize this expression - trace (what ++ " before normalization:\n\n" ++ showSDoc ( ppr expr ) ++ "\n") $ return () - expr' <- dotransforms transforms expr + trace (what ++ " before normalization:\n\n" ++ showSDoc ( ppr expr_uniqued ) ++ "\n") $ return () + expr' <- dotransforms transforms expr_uniqued trace ("\n" ++ what ++ " after normalization:\n\n" ++ showSDoc ( ppr expr')) $ return () return expr' diff --git "a/c\316\273ash/CLasH/Normalize/NormalizeTools.hs" "b/c\316\273ash/CLasH/Normalize/NormalizeTools.hs" index 116c847..c9e2f80 100644 --- "a/c\316\273ash/CLasH/Normalize/NormalizeTools.hs" +++ "b/c\316\273ash/CLasH/Normalize/NormalizeTools.hs" @@ -20,14 +20,19 @@ import Data.Accessor.MonadState as MonadState -- GHC API import CoreSyn +import qualified Name +import qualified Id import qualified CoreSubst import qualified CoreUtils +import qualified Type import Outputable ( showSDoc, ppr, nest ) -- Local imports import CLasH.Normalize.NormalizeTypes import CLasH.Translator.TranslatorTypes +import CLasH.Utils import CLasH.Utils.Pretty +import qualified CLasH.Utils.Core.CoreTools as CoreTools import CLasH.VHDL.VHDLTypes import qualified CLasH.VHDL.VHDLTools as VHDLTools @@ -131,9 +136,10 @@ inlinebind :: ((CoreBndr, CoreExpr) -> TransformMonad Bool) -> Transform inlinebind condition expr@(Let (NonRec bndr expr') res) = do applies <- condition (bndr, expr') if applies - then + then do -- Substitute the binding in res and return that - change $ substitute [(bndr, expr')] res + res' <- substitute_clone bndr expr' res + change res' else -- Don't change this let return expr @@ -157,32 +163,60 @@ changeif :: Bool -> a -> TransformMonad a changeif True val = change val changeif False val = return val --- Replace each of the binders given with the coresponding expressions in the --- given expression. -substitute :: [(CoreBndr, CoreExpr)] -> CoreExpr -> CoreExpr -substitute [] expr = expr --- Apply one substitution on the expression, but also on any remaining --- substitutions. This seems to be the only way to handle substitutions like --- [(b, c), (a, b)]. This means we reuse a substitution, which is not allowed --- according to CoreSubst documentation (but it doesn't seem to be a problem). --- TODO: Find out how this works, exactly. -substitute ((b, e):subss) expr = substitute subss' expr' - where - -- Create the Subst - subs = (CoreSubst.extendSubst CoreSubst.emptySubst b e) - -- Apply this substitution to the main expression - expr' = CoreSubst.substExpr subs expr - -- Apply this substitution on all the expressions in the remaining - -- substitutions - subss' = map (Arrow.second (CoreSubst.substExpr subs)) subss +-- | Creates a transformation that substitutes the given binder with the given +-- expression (This can be a type variable, replace by a Type expression). +-- Does not set the changed flag. +substitute :: CoreBndr -> CoreExpr -> Transform +-- Use CoreSubst to subst a type var in an expression +substitute find repl expr = do + let subst = CoreSubst.extendSubst CoreSubst.emptySubst find repl + return $ CoreSubst.substExpr subst expr + +-- | Creates a transformation that substitutes the given binder with the given +-- expression. This does only work for value expressions! All binders in the +-- expression are cloned before the replacement, to guarantee uniqueness. +substitute_clone :: CoreBndr -> CoreExpr -> Transform +-- If we see the var to find, replace it by a uniqued version of repl +substitute_clone find repl (Var var) | find == var = do + repl' <- Trans.lift $ CoreTools.genUniques repl + change repl' + +-- For all other expressions, just look in subexpressions +substitute_clone find repl expr = subeverywhere (substitute_clone find repl) expr -- Is the given expression representable at runtime, based on the type? -isRepr :: CoreSyn.CoreExpr -> TransformMonad Bool -isRepr (Type ty) = return False -isRepr expr = Trans.lift $ MonadState.lift tsType $ VHDLTools.isReprType (CoreUtils.exprType expr) +isRepr :: (CoreTools.TypedThing t) => t -> TransformMonad Bool +isRepr tything = case CoreTools.getType tything of + Nothing -> return False + Just ty -> Trans.lift $ MonadState.lift tsType $ VHDLTools.isReprType ty is_local_var :: CoreSyn.CoreExpr -> TranslatorSession Bool is_local_var (CoreSyn.Var v) = do bndrs <- getGlobalBinders return $ not $ v `elem` bndrs is_local_var _ = return False + +-- Is the given binder defined by the user? +isUserDefined :: CoreSyn.CoreBndr -> Bool +-- System names are certain to not be user defined +isUserDefined bndr | Name.isSystemName (Id.idName bndr) = False +-- Check a list of typical compiler-defined names +isUserDefined bndr = not $ str `elem` compiler_names + where + str = Name.getOccString bndr + -- These are names of bindings usually generated by the compiler. For some + -- reason these are not marked as system, probably because the name itself + -- is not made up by the compiler, just this particular binding is. + compiler_names = ["fromInteger"] + +-- Is the given binder normalizable? This means that its type signature can be +-- represented in hardware, which should (?) guarantee that it can be made +-- into hardware. Note that if a binder is not normalizable, it might become +-- so using argument propagation. +isNormalizeable :: CoreBndr -> TransformMonad Bool +isNormalizeable bndr = do + let ty = Id.idType bndr + let (arg_tys, res_ty) = Type.splitFunTys ty + -- This function is normalizable if all its arguments and return value are + -- representable. + andM $ mapM isRepr (res_ty:arg_tys) diff --git "a/c\316\273ash/CLasH/Utils.hs" "b/c\316\273ash/CLasH/Utils.hs" index aecbfcf..94da854 100644 --- "a/c\316\273ash/CLasH/Utils.hs" +++ "b/c\316\273ash/CLasH/Utils.hs" @@ -46,3 +46,14 @@ concatM = Monad.liftM concat isJustM :: (Monad m) => m (Maybe a) -> m Bool isJustM = Monad.liftM Maybe.isJust + +andM, orM :: (Monad m) => m [Bool] -> m Bool +andM = Monad.liftM and +orM = Monad.liftM or + +mapAccumLM :: (Monad m) => (acc -> x -> m (acc, y)) -> acc -> [x] -> m (acc, [y]) +mapAccumLM _ s [] = return (s, []) +mapAccumLM f s (x:xs) = do + (s', y ) <- f s x + (s'', ys) <- mapAccumLM f s' xs + return (s'', y:ys) diff --git "a/c\316\273ash/CLasH/Utils/Core/CoreTools.hs" "b/c\316\273ash/CLasH/Utils/Core/CoreTools.hs" index 094b702..bf2ca27 100644 --- "a/c\316\273ash/CLasH/Utils/Core/CoreTools.hs" +++ "b/c\316\273ash/CLasH/Utils/Core/CoreTools.hs" @@ -37,12 +37,15 @@ 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.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) @@ -190,6 +193,10 @@ 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 @@ -336,3 +343,81 @@ instance TypedThing CoreSyn.CoreBndr where 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') (map 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 + 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') diff --git "a/c\316\273ash/CLasH/VHDL/VHDLTools.hs" "b/c\316\273ash/CLasH/VHDL/VHDLTools.hs" index e273da8..cff65a6 100644 --- "a/c\316\273ash/CLasH/VHDL/VHDLTools.hs" +++ "b/c\316\273ash/CLasH/VHDL/VHDLTools.hs" @@ -290,7 +290,8 @@ vhdl_ty_either tything = Just ty -> vhdl_ty_either' ty vhdl_ty_either' :: Type.Type -> TypeSession (Either String (Maybe AST.TypeMark)) -vhdl_ty_either' ty = do +vhdl_ty_either' ty | ty_has_free_tyvars ty = return $ Left $ "VHDLTools.vhdl_ty_either': Cannot create type: type has free type variables: " ++ pprString ty + | otherwise = do typemap <- getA tsTypes htype_either <- mkHType ty case htype_either of