Clean up source files:

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

diff --git a/cλash/CLasH/Normalize.hs b/cλash/CLasH/Normalize.hs
index cce31864c5f2f0878719c6f42cc4b1d0174d7656..17143ffb6d857d555f2f52a30d9d99ab7eb4752b 100644 (file)
--- a/cλash/CLasH/Normalize.hs
+++ b/cλash/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 "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 qualified Data.Monoid as Monoid

-import Data.Accessor

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

-import qualified UniqSupply

 import qualified CoreUtils
 import qualified Type
 import qualified CoreUtils
 import qualified Type

-import qualified TcType
-import qualified Name

 import qualified Id
 import qualified Var
 import qualified VarSet
 import qualified Id
 import qualified Var
 import qualified VarSet

-import qualified NameSet

 import qualified CoreFVs
 import qualified CoreFVs

-import qualified CoreUtils

 import qualified MkCore
 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 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
 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
 -- β-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
 -- 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
 --------------------------------
 -- 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
 -- 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
 --
 -- 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))
 
 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
 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
 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 
       -- 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
         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.
     -- 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')
     (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.
             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)
           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
     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
       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
 
   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
   if is_poly (Var bndr)
     then
       -- This should really only happen at the top level... TODO: Give


@@ -706,7 +720,7 @@ getBinding ::
   CoreBndr -- ^ The binder to get the expression for
   -> TranslatorSession CoreExpr -- ^ The value bound to the binder
 
   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
   -- 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