change (Lam id (App expr (Var id)))
-- Leave all other expressions unchanged
eta e = return e
-etatop = notapplied ("eta", eta)
+etatop = notappargs ("eta", eta)
--------------------------------
-- β-reduction
-- 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
--------------------------------
--------------------------------
-- Remove a = b bindings from let expressions everywhere
letremovetop :: Transform
-letremovetop = everywhere ("letremove", inlinebind (\(b, e) -> case e of (Var v) -> True; otherwise -> False))
+letremovetop = everywhere ("letremove", inlinebind (\(b, e) -> case e of (Var v) | not $ Id.isDataConWorkId v -> True; otherwise -> False))
--------------------------------
-- Function inlining
--------------------------------
-- Make sure that all arguments in an application are simple variables.
appsimpl, appsimpltop :: Transform
--- Don't simplify arguments that are already simple
-appsimpl expr@(App f (Var _)) = return expr
+-- Don't simplify arguments that are already simple. Do simplify datacons,
+-- however, since we can't portmap literals.
+appsimpl expr@(App f (Var v)) | not $ Id.isDataConWorkId v = return expr
-- Simplify all non-applicable (to prevent loops with inlinefun) arguments,
-- except for type arguments (since a let can't bind type vars, only a lambda
-- can). Do this by introducing a new Let that binds the argument and passing
-- 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 ::