X-Git-Url: https://git.stderr.nl/gitweb?a=blobdiff_plain;f=c%CE%BBash%2FCLasH%2FNormalize%2FNormalizeTools.hs;h=803fd958cec82637d8177194da570e89ecf40f2b;hb=0223b461a043e42d3fc5442904b73ce0bd537472;hp=ed538cfc455ffc8431b834a0cd768f353b539af0;hpb=25b6c1ebc720fda83104b93d4a24ad8dde4d71a5;p=matthijs%2Fmaster-project%2Fc%CE%BBash.git diff --git "a/c\316\273ash/CLasH/Normalize/NormalizeTools.hs" "b/c\316\273ash/CLasH/Normalize/NormalizeTools.hs" index ed538cf..803fd95 100644 --- "a/c\316\273ash/CLasH/Normalize/NormalizeTools.hs" +++ "b/c\316\273ash/CLasH/Normalize/NormalizeTools.hs" @@ -24,6 +24,7 @@ import qualified Type -- Local imports import CLasH.Normalize.NormalizeTypes import CLasH.Translator.TranslatorTypes +import CLasH.VHDL.Constants (builtinIds) import CLasH.Utils import qualified CLasH.Utils.Core.CoreTools as CoreTools import qualified CLasH.VHDL.VHDLTools as VHDLTools @@ -36,19 +37,20 @@ everywhere trans = applyboth (subeverywhere (everywhere trans)) trans -- Apply the first transformation, followed by the second transformation, and -- keep applying both for as long as expression still changes. applyboth :: Transform -> (String, Transform) -> Transform -applyboth first (name, second) expr = do +applyboth first (name, second) context expr = do -- Apply the first - expr' <- first expr + expr' <- first context expr -- Apply the second - (expr'', changed) <- Writer.listen $ second expr' + (expr'', changed) <- Writer.listen $ second context expr' if Monoid.getAny $ -- trace ("Trying to apply transform " ++ name ++ " to:\n" ++ showSDoc (nest 4 $ ppr expr') ++ "\nType: \n" ++ (showSDoc $ nest 4 $ ppr $ CoreUtils.exprType expr') ++ "\n") changed - then - -- trace ("Applying transform " ++ name ++ " to:\n" ++ showSDoc (nest 4 $ ppr expr') ++ "\nType: \n" ++ (showSDoc $ nest 4 $ ppr $ CoreUtils.exprType expr') ++ "\n") $ - -- trace ("Result of applying " ++ name ++ ":\n" ++ showSDoc (nest 4 $ ppr expr'') ++ "\n" ++ "Type: \n" ++ (showSDoc $ nest 4 $ ppr $ CoreUtils.exprType expr'') ++ "\n" ) $ - applyboth first (name, second) - expr'' + then do + -- trace ("Applying transform " ++ name ++ " to:\n" ++ showSDoc (nest 4 $ ppr expr') ++ "\nType: \n" ++ (showSDoc $ nest 4 $ ppr $ CoreUtils.exprType expr') ++ "\n" + -- ++ "Context: " ++ show context ++ "\n" + -- ++ "Result of applying " ++ name ++ ":\n" ++ showSDoc (nest 4 $ ppr expr'') ++ "\n" ++ "Type: \n" ++ (showSDoc $ nest 4 $ ppr $ CoreUtils.exprType expr'') ++ "\n" ) $ + Trans.lift $ MonadState.modify tsTransformCounter (+1) + applyboth first (name, second) context expr'' else -- trace ("No changes") $ return expr'' @@ -56,87 +58,70 @@ applyboth first (name, second) expr = do -- Apply the given transformation to all direct subexpressions (only), not the -- expression itself. subeverywhere :: Transform -> Transform -subeverywhere trans (App a b) = do - a' <- trans a - b' <- trans b +subeverywhere trans c (App a b) = do + a' <- trans (AppFirst:c) a + b' <- trans (AppSecond:c) b return $ App a' b' -subeverywhere trans (Let (NonRec b bexpr) expr) = do - bexpr' <- trans bexpr - expr' <- trans expr +subeverywhere trans c (Let (NonRec b bexpr) expr) = do + bexpr' <- trans (LetBinding:c) bexpr + expr' <- trans (LetBody:c) expr return $ Let (NonRec b bexpr') expr' -subeverywhere trans (Let (Rec binds) expr) = do - expr' <- trans expr +subeverywhere trans c (Let (Rec binds) expr) = do + expr' <- trans (LetBody:c) expr binds' <- mapM transbind binds return $ Let (Rec binds') expr' where transbind :: (CoreBndr, CoreExpr) -> TransformMonad (CoreBndr, CoreExpr) transbind (b, e) = do - e' <- trans e + e' <- trans (LetBinding:c) e return (b, e') -subeverywhere trans (Lam x expr) = do - expr' <- trans expr +subeverywhere trans c (Lam x expr) = do + expr' <- trans (LambdaBody:c) expr return $ Lam x expr' -subeverywhere trans (Case scrut b t alts) = do - scrut' <- trans scrut +subeverywhere trans c (Case scrut b t alts) = do + scrut' <- trans (Other:c) scrut alts' <- mapM transalt alts return $ Case scrut' b t alts' where transalt :: CoreAlt -> TransformMonad CoreAlt transalt (con, binders, expr) = do - expr' <- trans expr + expr' <- trans (Other:c) expr return (con, binders, expr') -subeverywhere trans (Var x) = return $ Var x -subeverywhere trans (Lit x) = return $ Lit x -subeverywhere trans (Type x) = return $ Type x +subeverywhere trans c (Var x) = return $ Var x +subeverywhere trans c (Lit x) = return $ Lit x +subeverywhere trans c (Type x) = return $ Type x -subeverywhere trans (Cast expr ty) = do - expr' <- trans expr +subeverywhere trans c (Cast expr ty) = do + expr' <- trans (Other:c) expr return $ Cast expr' ty -subeverywhere trans expr = error $ "\nNormalizeTools.subeverywhere: Unsupported expression: " ++ show expr - --- Apply the given transformation to all expressions, except for direct --- arguments of an application -notappargs :: (String, Transform) -> Transform -notappargs trans = applyboth (subnotappargs trans) trans - --- Apply the given transformation to all (direct and indirect) subexpressions --- (but not the expression itself), except for direct arguments of an --- application -subnotappargs :: (String, Transform) -> Transform -subnotappargs trans (App a b) = do - a' <- subnotappargs trans a - b' <- subnotappargs trans b - return $ App a' b' - --- Let subeverywhere handle all other expressions -subnotappargs trans expr = subeverywhere (notappargs trans) expr +subeverywhere trans c expr = error $ "\nNormalizeTools.subeverywhere: Unsupported expression: " ++ show expr -- Runs each of the transforms repeatedly inside the State monad. dotransforms :: [Transform] -> CoreExpr -> TranslatorSession CoreExpr dotransforms transs expr = do - (expr', changed) <- Writer.runWriterT $ Monad.foldM (flip ($)) expr transs + (expr', changed) <- Writer.runWriterT $ Monad.foldM (\e trans -> trans [] e) expr transs if Monoid.getAny changed then dotransforms transs expr' else return expr' -- Inline all let bindings that satisfy the given condition inlinebind :: ((CoreBndr, CoreExpr) -> TransformMonad Bool) -> Transform -inlinebind condition expr@(Let (NonRec bndr expr') res) = do +inlinebind condition context expr@(Let (NonRec bndr expr') res) = do applies <- condition (bndr, expr') if applies then do -- Substitute the binding in res and return that - res' <- substitute_clone bndr expr' res + res' <- substitute_clone bndr expr' context res change res' else -- Don't change this let return expr -- Leave all other expressions unchanged -inlinebind _ expr = return expr +inlinebind _ context expr = return expr -- Sets the changed flag in the TransformMonad, to signify that some -- transform has changed the result @@ -160,7 +145,7 @@ changeif False val = return val -- 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 +substitute find repl context expr = do let subst = CoreSubst.extendSubst CoreSubst.emptySubst find repl return $ CoreSubst.substExpr subst expr @@ -169,12 +154,12 @@ substitute find repl expr = do -- 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 +substitute_clone find repl context (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 +substitute_clone find repl context expr = subeverywhere (substitute_clone find repl) context expr -- Is the given expression representable at runtime, based on the type? isRepr :: (CoreTools.TypedThing t) => t -> TransformMonad Bool @@ -195,34 +180,11 @@ is_local_var _ = return False 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 = str `notElem` (compiler_names ++ builtin_names) +-- Builtin functions are usually not user-defined either (and would +-- break currently if they are...) +isUserDefined bndr = str `notElem` builtinIds 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"] - builtin_names = [ "!", "replace", "head", "last", "tail", "take", "drop" - , "select", "+>", "<+", "++", "map", "zipWith", "foldl" - , "foldr", "zip", "unzip", "shiftl", "shiftr", "rotl" - , "rotr", "concat", "reverse", "iteraten", "iterate" - , "generaten", "generate", "empty", "singleton", "copyn" - , "copy", "lengthT", "null", "hwxor", "hwand", "hwor" - , "hwnot", "not", "+", "*", "-", "fromSizedWord" - , "resizeWord", "resizeInt", "fst", "snd", "blockRAM" - , "split", "==", "/=", "init" - ] - - -- , (ltId , (2, genOperator2 (AST.:<:) ) ) - -- , (lteqId , (2, genOperator2 (AST.:<=:) ) ) - -- , (gtId , (2, genOperator2 (AST.:>:) ) ) - -- , (gteqId , (2, genOperator2 (AST.:>=:) ) ) - -- , (boolOrId , (2, genOperator2 AST.Or ) ) - -- , (boolAndId , (2, genOperator2 AST.And ) ) - -- , (negateId , (1, genNegation ) ) - -- , (sizedIntId , (1, genSizedInt ) ) - -- , (smallIntegerId , (1, genFromInteger ) ) -- Is the given binder normalizable? This means that its type signature can be -- represented in hardware, which should (?) guarantee that it can be made