X-Git-Url: https://git.stderr.nl/gitweb?a=blobdiff_plain;f=c%CE%BBash%2FCLasH%2FNormalize%2FNormalizeTools.hs;h=e32bd341470489020363478fe5198972fcb23559;hb=5eb86d4e07de5c2a31e0862314d100f72bfaa46e;hp=116c84742f45f7953b7fcea588820c8d7e305da3;hpb=a45d964ffb9ab3691e84975d6fd7a40935532069;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 116c847..e32bd34 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
 
@@ -133,7 +138,7 @@ inlinebind condition expr@(Let (NonRec bndr expr') res) = do
     if applies
       then
         -- Substitute the binding in res and return that
-        change $ substitute [(bndr, expr')] res
+        setChanged >> substitute bndr expr' res
       else
         -- Don't change this let
         return expr
@@ -157,32 +162,62 @@ 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). All
+-- value binders in the expression are cloned before the replacement, to
+-- guarantee uniqueness.
+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)
+-- 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)
+
+-- For all other expressions, just look in subexpressions
+substitute find repl expr = subeverywhere (substitute 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 = 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)