From 019e55a763768d778d0e62b4dc5e49f3c7e06a0f Mon Sep 17 00:00:00 2001 From: Matthijs Kooijman Date: Tue, 23 Jun 2009 14:49:08 +0200 Subject: [PATCH] Add Cast propagation transform. This transform tries to push Casts down into the expression as much as possible. --- Normalize.hs | 16 +++++++++++++++- 1 file changed, 15 insertions(+), 1 deletion(-) diff --git a/Normalize.hs b/Normalize.hs index 208a8fa..747a95b 100644 --- a/Normalize.hs +++ b/Normalize.hs @@ -69,6 +69,20 @@ beta expr = return expr -- Perform this transform everywhere betatop = everywhere ("beta", beta) +-------------------------------- +-- Cast propagation +-------------------------------- +-- Try to move casts as much downward as possible. +castprop, castproptop :: Transform +castprop (Cast (Let binds expr) ty) = change $ Let binds (Cast expr ty) +castprop expr@(Cast (Case scrut b _ alts) ty) = change (Case scrut b ty alts') + where + alts' = map (\(con, bndrs, expr) -> (con, bndrs, (Cast expr ty))) alts +-- Leave all other expressions unchanged +castprop expr = return expr +-- Perform this transform everywhere +castproptop = everywhere ("castprop", castprop) + -------------------------------- -- let recursification -------------------------------- @@ -407,7 +421,7 @@ funproptop = everywhere ("funprop", funprop) -- What transforms to run? -transforms = [typeproptop, funproptop, etatop, betatop, letremovetop, letrectop, letsimpltop, letflattop, casewildtop, scrutsimpltop, casevalsimpltop, caseremovetop, inlinefuntop, appsimpltop] +transforms = [typeproptop, funproptop, etatop, betatop, castproptop, letremovetop, letrectop, letsimpltop, letflattop, casewildtop, scrutsimpltop, casevalsimpltop, caseremovetop, inlinefuntop, appsimpltop] -- Turns the given bind into VHDL normalizeModule :: -- 2.30.2