X-Git-Url: https://git.stderr.nl/gitweb?a=blobdiff_plain;f=c%CE%BBash%2FCLasH%2FNormalize.hs;h=17143ffb6d857d555f2f52a30d9d99ab7eb4752b;hb=f3951a1376fc7d7f8addbe9e9fed071320502100;hp=1f5ee427069751c0d7d56d4ecb563c5fad978c8e;hpb=537f5cc89c2a2581b0d7023320e1ade723a01759;p=matthijs%2Fmaster-project%2Fc%CE%BBash.git

diff --git "a/c\316\273ash/CLasH/Normalize.hs" "b/c\316\273ash/CLasH/Normalize.hs"
index 1f5ee42..17143ff 100644
--- "a/c\316\273ash/CLasH/Normalize.hs"
+++ "b/c\316\273ash/CLasH/Normalize.hs"
@@ -13,32 +13,23 @@ import qualified List
 import qualified "transformers" Control.Monad.Trans as Trans
 import qualified Control.Monad as Monad
 import qualified Control.Monad.Trans.Writer as Writer
-import qualified Data.Map as Map
 import qualified Data.Monoid as Monoid
-import Data.Accessor
 
 -- GHC API
 import CoreSyn
-import qualified UniqSupply
 import qualified CoreUtils
 import qualified Type
-import qualified TcType
-import qualified Name
 import qualified Id
 import qualified Var
 import qualified VarSet
-import qualified NameSet
 import qualified CoreFVs
-import qualified CoreUtils
 import qualified MkCore
-import qualified HscTypes
 import Outputable ( showSDoc, ppr, nest )
 
 -- Local imports
 import CLasH.Normalize.NormalizeTypes
 import CLasH.Translator.TranslatorTypes
 import CLasH.Normalize.NormalizeTools
-import CLasH.VHDL.VHDLTypes
 import qualified CLasH.Utils as Utils
 import CLasH.Utils.Core.CoreTools
 import CLasH.Utils.Core.BinderTools
@@ -64,8 +55,10 @@ etatop = notappargs ("eta", eta)
 -- β-reduction
 --------------------------------
 beta, betatop :: Transform
--- Substitute arg for x in expr
-beta (App (Lam x expr) arg) = change $ substitute [(x, arg)] expr
+-- Substitute arg for x in expr. For value lambda's, also clone before
+-- substitution.
+beta (App (Lam x expr) arg) | CoreSyn.isTyVar x = setChanged >> substitute x arg expr
+                            | otherwise      = setChanged >> substitute_clone x arg expr
 -- Propagate the application into the let
 beta (App (Let binds expr) arg) = change $ Let binds (App expr arg)
 -- Propagate the application into each of the alternatives
@@ -233,7 +226,7 @@ letflattop = everywhere ("letflat", letflat)
 --------------------------------
 -- Remove empty (recursive) lets
 letremove, letremovetop :: Transform
-letremove (Let (Rec []) res) = change $ res
+letremove (Let (Rec []) res) = change res
 -- Leave all other expressions unchanged
 letremove expr = return expr
 -- Perform this transform everywhere
@@ -303,26 +296,45 @@ letmergetop = everywhere ("letmerge", letmerge)
 -}
 
 --------------------------------
--- Function inlining
+-- Non-representable binding inlining
 --------------------------------
--- Remove a = B bindings, with B :: a -> b, or B :: forall x . T, from let
--- expressions everywhere. This means that any value that still needs to be
--- applied to something else (polymorphic values need to be applied to a
--- Type) will be inlined, and will eventually be applied to all their
--- arguments.
+-- Remove a = B bindings, with B of a non-representable type, from let
+-- expressions everywhere. This means that any value that we can't generate a
+-- signal for, will be inlined and hopefully turned into something we can
+-- represent.
 --
 -- This is a tricky function, which is prone to create loops in the
 -- transformations. To fix this, we make sure that no transformation will
--- create a new let binding with a function type. These other transformations
--- will just not work on those function-typed values at first, but the other
--- transformations (in particular β-reduction) should make sure that the type
--- of those values eventually becomes primitive.
+-- create a new let binding with a non-representable type. These other
+-- transformations will just not work on those function-typed values at first,
+-- but the other transformations (in particular β-reduction) should make sure
+-- that the type of those values eventually becomes representable.
 inlinenonreptop :: Transform
 inlinenonreptop = everywhere ("inlinenonrep", inlinebind ((Monad.liftM not) . isRepr . snd))
 
+--------------------------------
+-- Top level function inlining
+--------------------------------
+-- This transformation inlines top level bindings that have been generated by
+-- the compiler and are really simple. Really simple currently means that the
+-- normalized form only contains a single binding, which catches most of the
+-- cases where a top level function is created that simply calls a type class
+-- method with a type and dictionary argument, e.g.
+--   fromInteger = GHC.Num.fromInteger (SizedWord D8) $dNum
+-- which is later called using simply
+--   fromInteger (smallInteger 10)
+-- By inlining such calls to simple, compiler generated functions, we prevent
+-- huge amounts of trivial components in the VHDL output, which the user never
+-- wanted. We never inline user-defined functions, since we want to preserve
+-- all structure defined by the user. Currently this includes all functions
+-- that were created by funextract, since we would get loops otherwise.
+--
+-- Note that "defined by the compiler" isn't completely watertight, since GHC
+-- doesn't seem to set all those names as "system names", we apply some
+-- guessing here.
 inlinetoplevel, inlinetopleveltop :: Transform
 -- Any system name is candidate for inlining. Never inline user-defined
--- functions, to preserver structure.
+-- functions, to preserve structure.
 inlinetoplevel expr@(Var f) | not $ isUserDefined f = do
   norm <- isNormalizeable f
   -- See if this is a top level binding for which we have a body
@@ -332,8 +344,10 @@ inlinetoplevel expr@(Var f) | not $ isUserDefined f = do
       -- Get the normalized version
       norm <- Trans.lift $ getNormalized f
       if needsInline norm 
-        then
-          change norm
+        then do
+          -- Regenerate all uniques in the to-be-inlined expression
+          norm_uniqued <- Trans.lift $ genUniques norm
+          change norm_uniqued
         else
           return expr
     else
@@ -412,7 +426,7 @@ casesimpl expr@(Case scrut b ty alts) = do
     -- Extract a complex expression, if possible. For this we check if any of
     -- the new list of bndrs are used by expr. We can't use free_vars here,
     -- since that looks at the old bndrs.
-    let uses_bndrs = not $ VarSet.isEmptyVarSet $ CoreFVs.exprSomeFreeVars (`elem` newbndrs) $ expr
+    let uses_bndrs = not $ VarSet.isEmptyVarSet $ CoreFVs.exprSomeFreeVars (`elem` newbndrs) expr
     (exprbinding_maybe, expr') <- doexpr expr uses_bndrs
     -- Create a new alternative
     let newalt = (con, newbndrs, expr')
@@ -463,7 +477,7 @@ casesimpl expr@(Case scrut b ty alts) = do
             id <- Trans.lift $ mkBinderFor expr "caseval"
             -- We don't flag a change here, since casevalsimpl will do that above
             -- based on Just we return here.
-            return $ (Just (id, expr), Var id)
+            return (Just (id, expr), Var id)
           else
             -- Don't simplify anything else
             return (Nothing, expr)
@@ -561,7 +575,7 @@ argprop expr@(App _ _) | is_var fexpr = do
     doarg arg = do
       repr <- isRepr arg
       bndrs <- Trans.lift getGlobalBinders
-      let interesting var = Var.isLocalVar var && (not $ var `elem` bndrs)
+      let interesting var = Var.isLocalVar var && (var `notElem` bndrs)
       if not repr && not (is_var arg && interesting (exprToVar arg)) && not (has_free_tyvars arg) 
         then do
           -- Propagate all complex arguments that are not representable, but not
@@ -676,7 +690,7 @@ getNormalized ::
   CoreBndr -- ^ The function to get
   -> TranslatorSession CoreExpr -- The normalized function body
 
-getNormalized bndr = Utils.makeCached bndr tsNormalized $ do
+getNormalized bndr = Utils.makeCached bndr tsNormalized $
   if is_poly (Var bndr)
     then
       -- This should really only happen at the top level... TODO: Give
@@ -693,9 +707,10 @@ normalizeExpr ::
   -> TranslatorSession CoreSyn.CoreExpr -- ^ The normalized expression
 
 normalizeExpr what expr = do
+      expr_uniqued <- genUniques expr
       -- Normalize this expression
-      trace (what ++ " before normalization:\n\n" ++ showSDoc ( ppr expr ) ++ "\n") $ return ()
-      expr' <- dotransforms transforms expr
+      trace (what ++ " before normalization:\n\n" ++ showSDoc ( ppr expr_uniqued ) ++ "\n") $ return ()
+      expr' <- dotransforms transforms expr_uniqued
       trace ("\n" ++ what ++ " after normalization:\n\n" ++ showSDoc ( ppr expr')) $ return ()
       return expr'
 
@@ -705,7 +720,7 @@ getBinding ::
   CoreBndr -- ^ The binder to get the expression for
   -> TranslatorSession CoreExpr -- ^ The value bound to the binder
 
-getBinding bndr = Utils.makeCached bndr tsBindings $ do
+getBinding bndr = Utils.makeCached bndr tsBindings $
   -- If the binding isn't in the "cache" (bindings map), then we can't create
   -- it out of thin air, so return an error.
   error $ "Normalize.getBinding: Unknown function requested: " ++ show bndr