Use data-accessor-transformers package to remove deprecation warnings

[matthijs/master-project/cλash.git] / cλash / CLasH / Normalize / NormalizeTools.hs

diff --git a/cλash/CLasH/Normalize/NormalizeTools.hs b/cλash/CLasH/Normalize/NormalizeTools.hs
index 5f0c3fd6e75164a0f74737355089205947d30715..936a4ec1e834ec59c6cc49002f50f1878c544d6e 100644 (file)
--- a/cλash/CLasH/Normalize/NormalizeTools.hs
+++ b/cλash/CLasH/Normalize/NormalizeTools.hs
@@ -3,6 +3,7 @@
 -- This module provides functions for program transformations.
 --
 module CLasH.Normalize.NormalizeTools where
 -- This module provides functions for program transformations.
 --
 module CLasH.Normalize.NormalizeTools where

+

 -- Standard modules
 import Debug.Trace
 import qualified List
 -- Standard modules
 import Debug.Trace
 import qualified List


@@ -15,93 +16,26 @@ 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 qualified "transformers" Control.Monad.Trans as Trans
 import qualified Data.Map as Map
 import Data.Accessor

-import Data.Accessor.MonadState as MonadState
+import Data.Accessor.Monad.Trans.State as MonadState

 
 -- GHC API
 import CoreSyn
 
 -- GHC API
 import CoreSyn

-import qualified UniqSupply
-import qualified Unique
-import qualified OccName

 import qualified Name
 import qualified Name

-import qualified Var
-import qualified SrcLoc
-import qualified Type
-import qualified IdInfo
-import qualified CoreUtils
+import qualified Id

 import qualified CoreSubst
 import qualified CoreSubst

-import qualified VarSet
-import qualified HscTypes
+import qualified CoreUtils
+import qualified Type

 import Outputable ( showSDoc, ppr, nest )
 
 -- Local imports
 import CLasH.Normalize.NormalizeTypes
 import CLasH.Translator.TranslatorTypes
 import Outputable ( showSDoc, ppr, nest )
 
 -- Local imports
 import CLasH.Normalize.NormalizeTypes
 import CLasH.Translator.TranslatorTypes

+import CLasH.Utils

 import CLasH.Utils.Pretty
 import CLasH.Utils.Pretty

+import qualified CLasH.Utils.Core.CoreTools as CoreTools

 import CLasH.VHDL.VHDLTypes
 import qualified CLasH.VHDL.VHDLTools as VHDLTools
 
 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
 -- Apply the given transformation to all expressions in the given expression,
 -- including the expression itself.
 everywhere :: (String, Transform) -> Transform


@@ -199,22 +133,16 @@ dotransforms transs expr = do
 
 -- Inline all let bindings that satisfy the given condition
 inlinebind :: ((CoreBndr, CoreExpr) -> TransformMonad Bool) -> Transform
 
 -- Inline all let bindings that satisfy the given condition
 inlinebind :: ((CoreBndr, CoreExpr) -> TransformMonad Bool) -> Transform

-inlinebind condition 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
-        let newexpr = substitute replace (Let (Rec others) res)
-        change newexpr
-  where 
-    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
-
+inlinebind condition 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
+        change res'
+      else
+        -- Don't change this let
+        return expr

 -- Leave all other expressions unchanged
 inlinebind _ expr = return expr
 
 -- Leave all other expressions unchanged
 inlinebind _ expr = return expr
 


@@ -229,43 +157,66 @@ change val = do
   setChanged
   return val
 
   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
-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
+-- Returns the given value and sets the changed flag if the bool given is
+-- True. Note that this will not unset the changed flag if the bool is False.
+changeif :: Bool -> a -> TransformMonad a
+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).
+-- 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?
 
 -- 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_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)