From: Christiaan Baaij <christiaan.baaij@gmail.com>
Date: Wed, 11 Nov 2009 14:52:33 +0000 (+0100)
Subject: Merge branch 'cλash' of http://git.stderr.nl/matthijs/projects/master-project
X-Git-Url: https://git.stderr.nl/gitweb?a=commitdiff_plain;ds=sidebyside;h=fc16bdb6576ef2c08d3675fdbf74fd61d5d25589;hp=-c;p=matthijs%2Fmaster-project%2Fc%CE%BBash.git

Merge branch 'cλash' of git.stderr.nl/matthijs/projects/master-project

* 'cλash' of http://git.stderr.nl/matthijs/projects/master-project:
  Actually make the scrutinee binder removal not crash.
  Add scrutinee binder removal transformation.
---

fc16bdb6576ef2c08d3675fdbf74fd61d5d25589
diff --combined "c\316\273ash/CLasH/Normalize.hs"
index 17143ff,2c7a95e..ea10516
--- "a/c\316\273ash/CLasH/Normalize.hs"
+++ "b/c\316\273ash/CLasH/Normalize.hs"
@@@ -13,23 -13,32 +13,23 @@@ import qualified Lis
  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
@@@ -226,7 -235,7 +226,7 @@@ letflattop = everywhere ("letflat", let
  --------------------------------
  -- 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
@@@ -389,6 -398,31 +389,31 @@@ scrutsimpl expr = return exp
  -- Perform this transform everywhere
  scrutsimpltop = everywhere ("scrutsimpl", scrutsimpl)
  
+ --------------------------------
+ -- Scrutinee binder removal
+ --------------------------------
+ -- A case expression can have an extra binder, to which the scrutinee is bound
+ -- after bringing it to WHNF. This is used for forcing evaluation of strict
+ -- arguments. Since strictness does not matter for us (rather, everything is
+ -- sort of strict), this binder is ignored when generating VHDL, and must thus
+ -- be wild in the normal form.
+ scrutbndrremove, scrutbndrremovetop :: Transform
+ -- If the scrutinee is already simple, and the bndr is not wild yet, replace
+ -- all occurences of the binder with the scrutinee variable.
+ scrutbndrremove (Case (Var scrut) bndr ty alts) | bndr_used = do
+     alts' <- mapM subs_bndr alts
+     return $ Case (Var scrut) wild ty alts'
+   where
+     is_used (_, _, expr) = expr_uses_binders [bndr] expr
+     bndr_used = or $ map is_used alts
+     subs_bndr (con, bndrs, expr) = do
+       expr' <- substitute bndr (Var scrut) expr
+       return (con, bndrs, expr')
+     wild = MkCore.mkWildBinder (Id.idType bndr)
+ -- Leave all other expressions unchanged
+ scrutbndrremove expr = return expr
+ scrutbndrremovetop = everywhere ("scrutbndrremove", scrutbndrremove)
+ 
  --------------------------------
  -- Case binder wildening
  --------------------------------
@@@ -426,7 -460,7 +451,7 @@@ casesimpl expr@(Case scrut b ty alts) 
      -- 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')
@@@ -477,7 -511,7 +502,7 @@@
              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)
@@@ -575,7 -609,7 +600,7 @@@ argprop expr@(App _ _) | is_var fexpr 
      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
@@@ -683,14 -717,14 +708,14 @@@ simplrestop expr = d
  
  
  -- What transforms to run?
- transforms = [inlinetopleveltop, argproptop, funextracttop, etatop, betatop, castproptop, letremovesimpletop, letderectop, letremovetop, letsimpltop, letflattop, scrutsimpltop, casesimpltop, caseremovetop, inlinenonreptop, appsimpltop, letremoveunusedtop, castsimpltop, lambdasimpltop, simplrestop]
+ transforms = [inlinetopleveltop, argproptop, funextracttop, etatop, betatop, castproptop, letremovesimpletop, letderectop, letremovetop, letsimpltop, letflattop, scrutsimpltop, scrutbndrremovetop, casesimpltop, caseremovetop, inlinenonreptop, appsimpltop, letremoveunusedtop, castsimpltop, lambdasimpltop, simplrestop]
  
  -- | Returns the normalized version of the given function.
  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
@@@ -720,7 -754,7 +745,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