Merge branch 'cλash' of http://git.stderr.nl/matthijs/projects/master-project

* 'cλash' of http://git.stderr.nl/matthijs/projects/master-project:
  Ignore cast expressions when generating VHDL.
  Add Cast propagation transform.
  Make subeverywhere support Cast expressions.
  Remove a double line introduced a few commits back.
  Make subeverywhere complain for unknown expressions.

diff --git a/Normalize.hs b/Normalize.hs
index cceefc0cf7baf76c4135da6ef12cc7f9c5922988..747a95b0c6eccd898bfbd12e0bec80f33a0910ae 100644 (file)
--- a/Normalize.hs
+++ b/Normalize.hs
@@ -43,7 +43,6 @@ import Pretty
 -- η abstraction
 --------------------------------
 eta, etatop :: Transform
-eta expr | is_fun expr && not (is_lam expr) = do
 eta expr | is_fun expr && not (is_lam expr) = do
   let arg_ty = (fst . Type.splitFunTy . CoreUtils.exprType) expr
   id <- mkInternalVar "param" arg_ty
@@ -70,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
 --------------------------------
@@ -408,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 :: 

diff --git a/NormalizeTools.hs b/NormalizeTools.hs
index 400bf88bfa503e12232ef5ddac1ff8868b01c20b..8e57ba8f2ec2446301ebcf22ec83e03f577470b7 100644 (file)
--- a/NormalizeTools.hs
+++ b/NormalizeTools.hs
@@ -142,9 +142,16 @@ subeverywhere trans (Case scrut b t alts) = do
     transalt (con, binders, expr) = do
       expr' <- trans expr
       return (con, binders, expr')
-      
 
-subeverywhere trans expr = return expr
+subeverywhere trans (Var x) = return $ Var x
+subeverywhere trans (Lit x) = return $ Lit x
+subeverywhere trans (Type x) = return $ Type x
+
+subeverywhere trans (Cast expr ty) = do
+  expr' <- trans expr
+  return $ Cast expr' ty
+
+subeverywhere trans expr = error $ "NormalizeTools.subeverywhere Unsupported expression: " ++ show expr
 
 -- Apply the given transformation to all expressions, except for direct
 -- arguments of an application

diff --git a/VHDL.hs b/VHDL.hs
index 24c4eb0f1fc788b9cebfdcb28332a5eb9d8bf0fe..99aa08907f33f1153a773b1bbdd9e6e558167812 100644 (file)
--- a/VHDL.hs
+++ b/VHDL.hs
@@ -264,6 +264,11 @@ mkConcSm ::
   (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -- ^ The binding to process
   -> VHDLState [AST.ConcSm] -- ^ The corresponding VHDL component instantiations.
 
+
+-- Ignore Cast expressions, they should not longer have any meaning as long as
+-- the type works out.
+mkConcSm (bndr, Cast expr ty) = mkConcSm (bndr, expr)
+
 mkConcSm (bndr, app@(CoreSyn.App _ _))= do
   let (CoreSyn.Var f, args) = CoreSyn.collectArgs app
   let valargs' = filter isValArg args