projects
/
matthijs
/
master-project
/
cλash.git
/ blobdiff
commit
grep
author
committer
pickaxe
?
search:
re
summary
|
shortlog
|
log
|
commit
|
commitdiff
|
tree
raw
|
inline
| side by side
Move a part of β-reduction to application propagation.
[matthijs/master-project/cλash.git]
/
cλash
/
CLasH
/
Normalize.hs
diff --git
a/cλash/CLasH/Normalize.hs
b/cλash/CLasH/Normalize.hs
index dc3c0c2052141045c09b53f6af5af42012a50d6d..dc9606c756238d312ae2f8888b57efe660d38dbe 100644
(file)
--- a/
cλash/CLasH/Normalize.hs
+++ b/
cλash/CLasH/Normalize.hs
@@
-72,15
+72,22
@@
beta :: Transform
-- substitution.
beta c (App (Lam x expr) arg) | CoreSyn.isTyVar x = setChanged >> substitute x arg c expr
| otherwise = setChanged >> substitute_clone x arg c expr
-- substitution.
beta c (App (Lam x expr) arg) | CoreSyn.isTyVar x = setChanged >> substitute x arg c expr
| otherwise = setChanged >> substitute_clone x arg c expr
+-- Leave all other expressions unchanged
+beta c expr = return expr
+
+--------------------------------
+-- Application propagation
+--------------------------------
+appprop :: Transform
-- Propagate the application into the let
-- Propagate the application into the let
-
beta
c (App (Let binds expr) arg) = change $ Let binds (App expr arg)
+
appprop
c (App (Let binds expr) arg) = change $ Let binds (App expr arg)
-- Propagate the application into each of the alternatives
-- Propagate the application into each of the alternatives
-
beta
c (App (Case scrut b ty alts) arg) = change $ Case scrut b ty' alts'
+
appprop
c (App (Case scrut b ty alts) arg) = change $ Case scrut b ty' alts'
where
alts' = map (\(con, bndrs, expr) -> (con, bndrs, (App expr arg))) alts
ty' = CoreUtils.applyTypeToArg ty arg
-- Leave all other expressions unchanged
where
alts' = map (\(con, bndrs, expr) -> (con, bndrs, (App expr arg))) alts
ty' = CoreUtils.applyTypeToArg ty arg
-- Leave all other expressions unchanged
-
beta
c expr = return expr
+
appprop
c expr = return expr
--------------------------------
-- Case of known constructor simplification
--------------------------------
-- Case of known constructor simplification
@@
-910,6
+917,7
@@
transforms = [ ("inlinedict", inlinedict)
, ("funextract", funextract)
, ("eta", eta)
, ("beta", beta)
, ("funextract", funextract)
, ("eta", eta)
, ("beta", beta)
+ , ("appprop", appprop)
, ("castprop", castprop)
, ("letremovesimple", letremovesimple)
, ("letrec", letrec)
, ("castprop", castprop)
, ("letremovesimple", letremovesimple)
, ("letrec", letrec)
@@
-968,13
+976,14
@@
normalizeExpr ::
normalizeExpr what expr = do
startcount <- MonadState.get tsTransformCounter
expr_uniqued <- genUniques expr
normalizeExpr what expr = do
startcount <- MonadState.get tsTransformCounter
expr_uniqued <- genUniques expr
+ -- Do a debug print, if requested
+ let expr_uniqued' = Utils.traceIf (normalize_debug >= NormDbgFinal) (what ++ " before normalization:\n\n" ++ showSDoc ( ppr expr_uniqued ) ++ "\n") expr_uniqued
-- Normalize this expression
-- Normalize this expression
- trace (what ++ " before normalization:\n\n" ++ showSDoc ( ppr expr_uniqued ) ++ "\n") $ return ()
- expr' <- dotransforms transforms expr_uniqued
+ expr' <- dotransforms transforms expr_uniqued'
endcount <- MonadState.get tsTransformCounter
endcount <- MonadState.get tsTransformCounter
- trace ("\n" ++ what ++ " after normalization:\n\n" ++ showSDoc ( ppr expr')
-
++ "\nNeeded " ++ show (endcount - startcount) ++ " transformations to normalize " ++ what) $
- return expr'
+ -- Do a debug print, if requested
+
Utils.traceIf (normalize_debug >= NormDbgFinal) (what ++ " after normalization:\n\n" ++ showSDoc ( ppr expr')
++ "\nNeeded " ++ show (endcount - startcount) ++ " transformations to normalize " ++ what) $
+
return expr'
-- | Split a normalized expression into the argument binders, top level
-- bindings and the result binder. This function returns an error if
-- | Split a normalized expression into the argument binders, top level
-- bindings and the result binder. This function returns an error if