From: Matthijs Kooijman Date: Tue, 23 Jun 2009 12:49:08 +0000 (+0200) Subject: Add Cast propagation transform. X-Git-Url: https://git.stderr.nl/gitweb?a=commitdiff_plain;h=019e55a763768d778d0e62b4dc5e49f3c7e06a0f;p=matthijs%2Fmaster-project%2Fc%CE%BBash.git Add Cast propagation transform. This transform tries to push Casts down into the expression as much as possible. --- 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 ::