X-Git-Url: https://git.stderr.nl/gitweb?a=blobdiff_plain;f=c%CE%BBash%2FCLasH%2FNormalize%2FNormalizeTools.hs;h=ed538cfc455ffc8431b834a0cd768f353b539af0;hb=25b6c1ebc720fda83104b93d4a24ad8dde4d71a5;hp=c9e2f804f55508fd7bbec7c1e624e89ac419bd00;hpb=743f2dcf9a7a37c71fc06ce552f605fac3120e56;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 c9e2f80..ed538cf 100644 --- "a/c\316\273ash/CLasH/Normalize/NormalizeTools.hs" +++ "b/c\316\273ash/CLasH/Normalize/NormalizeTools.hs" @@ -5,35 +5,27 @@ 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, @@ -44,21 +36,21 @@ everywhere trans = applyboth (subeverywhere (everywhere trans)) trans -- 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 @@ -186,14 +178,17 @@ 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 bndrs <- getGlobalBinders - return $ not $ v `elem` bndrs + return $ v `notElem` bndrs is_local_var _ = return False -- Is the given binder defined by the user? @@ -201,22 +196,45 @@ 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 +isUserDefined bndr = str `notElem` (compiler_names ++ builtin_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"] + builtin_names = [ "!", "replace", "head", "last", "tail", "take", "drop" + , "select", "+>", "<+", "++", "map", "zipWith", "foldl" + , "foldr", "zip", "unzip", "shiftl", "shiftr", "rotl" + , "rotr", "concat", "reverse", "iteraten", "iterate" + , "generaten", "generate", "empty", "singleton", "copyn" + , "copy", "lengthT", "null", "hwxor", "hwand", "hwor" + , "hwnot", "not", "+", "*", "-", "fromSizedWord" + , "resizeWord", "resizeInt", "fst", "snd", "blockRAM" + , "split", "==", "/=", "init" + ] + + -- , (ltId , (2, genOperator2 (AST.:<:) ) ) + -- , (lteqId , (2, genOperator2 (AST.:<=:) ) ) + -- , (gtId , (2, genOperator2 (AST.:>:) ) ) + -- , (gteqId , (2, genOperator2 (AST.:>=:) ) ) + -- , (boolOrId , (2, genOperator2 AST.Or ) ) + -- , (boolAndId , (2, genOperator2 AST.And ) ) + -- , (negateId , (1, genNegation ) ) + -- , (sizedIntId , (1, genSizedInt ) ) + -- , (smallIntegerId , (1, genFromInteger ) ) -- 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)