From: Matthijs Kooijman <matthijs@stdin.nl>
Date: Wed, 11 Nov 2009 11:12:48 +0000 (+0100)
Subject: Add scrutinee binder removal transformation.
X-Git-Url: https://git.stderr.nl/gitweb?a=commitdiff_plain;h=b79c61e1dd119d18a0d00a05127c785c143281e1;p=matthijs%2Fmaster-project%2Fc%CE%BBash.git

Add scrutinee binder removal transformation.

This code is untested, for I have been unable to produce Haskell code to
which it applies...
---

diff --git "a/c\316\273ash/CLasH/Normalize.hs" "b/c\316\273ash/CLasH/Normalize.hs"
index 40eab93..4f02800 100644
--- "a/c\316\273ash/CLasH/Normalize.hs"
+++ "b/c\316\273ash/CLasH/Normalize.hs"
@@ -398,6 +398,29 @@ scrutsimpl expr = return expr
 -- 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)
+scrutbndrremovetop = everywhere ("scrutbndrremove", scrutbndrremove)
+
 --------------------------------
 -- Case binder wildening
 --------------------------------
@@ -692,7 +715,7 @@ simplrestop expr = do
 
 
 -- 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 ::