X-Git-Url: https://git.stderr.nl/gitweb?a=blobdiff_plain;f=c%CE%BBash%2FCLasH%2FNormalize%2FNormalizeTools.hs;h=cdb7ee01352a85fca6cf080de9019259c359d632;hb=75978cf28a619d14ae27ea2bb4a53246b6a0bcd8;hp=b1ca36900cd5a37220052ac2687e685ce6141814;hpb=3deb1d21f696f8495cd99345c9677210e2a2fc79;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 b1ca369..cdb7ee0 100644 --- "a/c\316\273ash/CLasH/Normalize/NormalizeTools.hs" +++ "b/c\316\273ash/CLasH/Normalize/NormalizeTools.hs" @@ -1,4 +1,3 @@ -{-# LANGUAGE PackageImports #-} -- -- This module provides functions for program transformations. -- @@ -6,11 +5,11 @@ module CLasH.Normalize.NormalizeTools where -- Standard modules import qualified Data.Monoid as Monoid +import qualified Data.Either as Either import qualified Control.Monad as Monad import qualified Control.Monad.Trans.Writer as Writer -import qualified "transformers" Control.Monad.Trans as Trans +import qualified Control.Monad.Trans.Class as Trans import qualified Data.Accessor.Monad.Trans.State as MonadState --- import Debug.Trace -- GHC API import CoreSyn @@ -18,8 +17,8 @@ import qualified Name import qualified Id import qualified CoreSubst import qualified Type --- import qualified CoreUtils --- import Outputable ( showSDoc, ppr, nest ) +import qualified CoreUtils +import Outputable ( showSDoc, ppr, nest ) -- Local imports import CLasH.Normalize.NormalizeTypes @@ -31,53 +30,72 @@ import qualified CLasH.VHDL.VHDLTools as VHDLTools -- Apply the given transformation to all expressions in the given expression, -- including the expression itself. -everywhere :: (String, Transform) -> Transform +everywhere :: Transform -> Transform everywhere trans = applyboth (subeverywhere (everywhere trans)) trans +data NormDbgLevel = + NormDbgNone -- ^ No debugging + | NormDbgFinal -- ^ Print functions before / after normalization + | NormDbgApplied -- ^ Print expressions before / after applying transformations + | NormDbgAll -- ^ Print expressions when a transformation does not apply + deriving (Eq, Ord) +normalize_debug = NormDbgFinal + +-- Applies a transform, optionally showing some debug output. +apply :: (String, Transform) -> Transform +apply (name, trans) ctx expr = do + -- Apply the transformation and find out if it changed anything + (expr', any_changed) <- Writer.listen $ trans ctx expr + let changed = Monoid.getAny any_changed + -- If it changed, increase the transformation counter + Monad.when changed $ Trans.lift (MonadState.modify tsTransformCounter (+1)) + -- Prepare some debug strings + let before = showSDoc (nest 4 $ ppr expr) ++ "\nType: \n" ++ (showSDoc $ nest 4 $ ppr $ CoreUtils.exprType expr) ++ "\n" + let context = "Context: " ++ show ctx ++ "\n" + let after = showSDoc (nest 4 $ ppr expr') ++ "\nType: \n" ++ (showSDoc $ nest 4 $ ppr $ CoreUtils.exprType expr') ++ "\n" + traceIf (normalize_debug >= NormDbgApplied && changed) ("Changes when applying transform " ++ name ++ " to:\n" ++ before ++ context ++ "Result:\n" ++ after) $ + traceIf (normalize_debug >= NormDbgAll && not changed) ("No changes when applying transform " ++ name ++ " to:\n" ++ before ++ context) $ + return expr' + -- 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) context expr = do +applyboth :: Transform -> Transform -> Transform +applyboth first second context expr = do -- Apply the first expr' <- first context expr -- Apply the second (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" - -- ++ "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) context expr'' + if Monoid.getAny $ changed + then + applyboth first second context expr'' else - -- trace ("No changes") $ return expr'' -- Apply the given transformation to all direct subexpressions (only), not the -- expression itself. subeverywhere :: Transform -> Transform subeverywhere trans c (App a b) = do - a' <- trans (Other:c) a - b' <- trans (Other:c) b + a' <- trans (AppFirst:c) a + b' <- trans (AppSecond:c) b return $ App a' b' subeverywhere trans c (Let (NonRec b bexpr) expr) = do - bexpr' <- trans (Other:c) bexpr - expr' <- trans (Other:c) expr + bexpr' <- trans (LetBinding:c) bexpr + expr' <- trans (LetBody:c) expr return $ Let (NonRec b bexpr') expr' subeverywhere trans c (Let (Rec binds) expr) = do - expr' <- trans (Other:c) expr + 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 (Other:c) e + e' <- trans (LetBinding:c) e return (b, e') subeverywhere trans c (Lam x expr) = do - expr' <- trans (Other:c) expr + expr' <- trans (LambdaBody:c) expr return $ Lam x expr' subeverywhere trans c (Case scrut b t alts) = do @@ -100,41 +118,51 @@ subeverywhere trans c (Cast expr ty) = do subeverywhere trans c 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 c (App a b) = do - a' <- subnotappargs trans (Other:c) a - b' <- subnotappargs trans (Other:c) b - return $ App a' b' - --- Let subeverywhere handle all other expressions -subnotappargs trans c expr = subeverywhere (notappargs trans) c expr - -- Runs each of the transforms repeatedly inside the State monad. -dotransforms :: [Transform] -> CoreExpr -> TranslatorSession CoreExpr +dotransforms :: [(String, Transform)] -> CoreExpr -> TranslatorSession CoreExpr dotransforms transs expr = do - (expr', changed) <- Writer.runWriterT $ Monad.foldM (\e trans -> trans [] e) expr transs + (expr', changed) <- Writer.runWriterT $ Monad.foldM (\e trans -> everywhere (apply 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 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' context res - change res' - else - -- Don't change this let - return expr +inlinebind condition context expr@(Let (Rec binds) res) = do + -- Find all bindings that adhere to the condition + res_eithers <- mapM docond binds + case Either.partitionEithers res_eithers of + -- No replaces? No change + ([], _) -> return expr + (replace, others) -> do + -- Substitute the to be replaced binders with their expression + newexpr <- do_substitute replace (Let (Rec others) res) + change newexpr + where + -- Apply the condition to a let binding and return an Either + -- depending on whether it needs to be inlined or not. + docond :: (CoreBndr, CoreExpr) -> TransformMonad (Either (CoreBndr, CoreExpr) (CoreBndr, CoreExpr)) + docond b = do + res <- condition b + return $ case res of True -> Left b; False -> Right b + + -- Apply the given list of substitutions to the the given expression + do_substitute :: [(CoreBndr, CoreExpr)] -> CoreExpr -> TransformMonad CoreExpr + do_substitute [] expr = return expr + do_substitute ((bndr, val):reps) expr = do + -- Perform this substitution in the expression + expr' <- substitute_clone bndr val context expr + -- And in the substitution values we will be using next + reps' <- mapM (subs_bind bndr val) reps + -- And then perform the remaining substitutions + do_substitute reps' expr' + + -- Replace the given binder with the given expression in the + -- expression oft the given let binding + subs_bind :: CoreBndr -> CoreExpr -> (CoreBndr, CoreExpr) -> TransformMonad (CoreBndr, CoreExpr) + subs_bind bndr expr (b, v) = do + v' <- substitute_clone bndr expr (LetBinding:context) v + return (b, v') + + -- Leave all other expressions unchanged inlinebind _ context expr = return expr @@ -201,17 +229,17 @@ isUserDefined bndr = str `notElem` builtinIds where str = Name.getOccString bndr --- Is the given binder normalizable? This means that its type signature can be +-- | 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 = Trans.lift (isNormalizeable' bndr) - -isNormalizeable' :: CoreBndr -> TranslatorSession Bool -isNormalizeable' bndr = do +-- into hardware. This checks whether all the arguments and (optionally) +-- the return value are +-- representable. +isNormalizeable :: + Bool -- ^ Allow the result to be unrepresentable? + -> CoreBndr -- ^ The binder to check + -> TranslatorSession Bool -- ^ Is it normalizeable? +isNormalizeable result_nonrep 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) + let check_tys = if result_nonrep then arg_tys else (res_ty:arg_tys) + andM $ mapM isRepr' check_tys