From: Matthijs Kooijman 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 ::