X-Git-Url: https://git.stderr.nl/gitweb?a=blobdiff_plain;f=c%CE%BBash%2FCLasH%2FNormalize%2FNormalizeTools.hs;h=b9f4544c2e768c0873302006d2efd2e7e9f9cd0a;hb=85bbc8126e1a7c8703d99afe3678ad067ca773a8;hp=6acaa86a5286ed347c6c2dccd3ab57c0e768fbf1;hpb=3fc90df84f37ade227d663a21852a3c4e4d0a727;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 6acaa86..b9f4544 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
@@ -45,8 +46,8 @@ applyboth first (name, second) expr = do
         -- 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" ) $
+     -- 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)
         expr'' 
     else 
@@ -178,9 +179,12 @@ substitute_clone find repl expr = subeverywhere (substitute_clone find repl) exp
 
 -- Is the given expression representable at runtime, based on the type?
 isRepr :: (CoreTools.TypedThing t) => t -> TransformMonad Bool
-isRepr tything = case CoreTools.getType tything of
+isRepr tything = Trans.lift (isRepr' tything)
+
+isRepr' :: (CoreTools.TypedThing t) => t -> TranslatorSession Bool
+isRepr' tything = case CoreTools.getType tything of
   Nothing -> return False
-  Just ty -> Trans.lift $ MonadState.lift tsType $ VHDLTools.isReprType ty 
+  Just ty -> MonadState.lift tsType $ VHDLTools.isReprType ty 
 
 is_local_var :: CoreSyn.CoreExpr -> TranslatorSession Bool
 is_local_var (CoreSyn.Var v) = do
@@ -192,23 +196,23 @@ 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 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"]
 
 -- 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
+isNormalizeable bndr = Trans.lift (isNormalizeable' bndr)
+
+isNormalizeable' :: CoreBndr -> TranslatorSession 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)
+  andM $ mapM isRepr' (res_ty:arg_tys)