module CLasH.Normalize.NormalizeTools where
-- Standard modules
-import Debug.Trace
-import qualified List
import qualified Data.Monoid as Monoid
-import qualified Data.Either as Either
-import qualified Control.Arrow as Arrow
import qualified Control.Monad as Monad
-import qualified Control.Monad.Trans.State as State
import qualified Control.Monad.Trans.Writer as Writer
import qualified "transformers" Control.Monad.Trans as Trans
-import qualified Data.Map as Map
-import Data.Accessor
-import Data.Accessor.MonadState as MonadState
+import qualified Data.Accessor.Monad.Trans.State as MonadState
+-- import Debug.Trace
-- GHC API
import CoreSyn
import qualified Name
import qualified Id
import qualified CoreSubst
-import qualified CoreUtils
import qualified Type
-import Outputable ( showSDoc, ppr, nest )
+-- import qualified CoreUtils
+-- 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
-- Apply the given transformation to all expressions in the given expression,
-- 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) expr = do
-- Apply the first
expr' <- first expr
-- Apply the second
(expr'', changed) <- Writer.listen $ second 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") $
+ -- 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) $
+ -- 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''
else
--- trace ("No changes") $
+ -- trace ("No changes") $
return expr''
-- Apply the given transformation to all direct subexpressions (only), not the
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
- setChanged >> substitute bndr expr' res
+ res' <- substitute_clone bndr expr' res
+ change res'
else
-- Don't change this let
return expr
changeif True val = change val
changeif False val = return val
--- Creates a transformation that substitutes the given binder with the given
--- expression (This can be a type variable, replace by a Type expression). All
--- value binders in the expression are cloned before the replacement, to
--- guarantee uniqueness.
+-- | 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 a type
-substitute find (Type repl_ty) (Type ty) = do
- let subst = CoreSubst.extendTvSubst CoreSubst.emptySubst find repl_ty
- let ty' = CoreSubst.substTy subst ty
- return (Type ty')
--- Use CoreSubst to subst a type var in the type annotation of a case
-substitute find repl@(Type repl_ty) (Case scrut bndr ty alts) = do
- let subst = CoreSubst.extendTvSubst CoreSubst.emptySubst find repl_ty
- let ty' = CoreSubst.substTy subst ty
- -- And continue with substituting on all subexpressions of the case
- subeverywhere (substitute find repl) (Case scrut bndr ty' alts)
+-- 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 find repl (Var var) | find == var = do
- setChanged >> (Trans.lift $ CoreTools.genUniques 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 find repl expr = subeverywhere (substitute find repl) expr
+substitute_clone find repl expr = subeverywhere (substitute_clone find repl) expr
-- Is the given expression representable at runtime, based on the type?
isRepr :: (CoreTools.TypedThing t) => t -> TransformMonad Bool
is_local_var :: CoreSyn.CoreExpr -> TranslatorSession Bool
is_local_var (CoreSyn.Var v) = do
bndrs <- getGlobalBinders
- return $ not $ v `elem` bndrs
+ return $ v `notElem` bndrs
is_local_var _ = return False
-- Is the given binder defined by the user?
-- 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 `elem` compiler_names
+isUserDefined bndr = str `notElem` 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"]
+ compiler_names = ["fromInteger", "head", "tail", "init", "last", "+", "*", "-", "!"]
-- Is the given binder normalizable? This means that its type signature can be
-- represented in hardware, which should (?) guarantee that it can be made