Let inlinefun inline everything non-representable.

This changes its name to inlinenonrep and makes it inline everything that
is not representable (which helps in particular for dictionary
construction expressions...).

I've not yet changed the conditions in various other transforms, so if
something silly would happen like having a dictionary as the value or
scrutinee of a case of let expression, things might go into an infinite
loop.

Also, since HTypes are generated very often now, things are really
starting to slow down...

diff --git a/Normalize.hs b/Normalize.hs
index 8cb21ea2ab8a0130b851cdcf05150e1208e383dc..2ecf2fa102ba5b56cdc5b9457ac8c792666c06dd 100644 (file)
--- a/Normalize.hs
+++ b/Normalize.hs
@@ -140,7 +140,7 @@ letflattop = everywhere ("letflat", letflat)
 --------------------------------
 -- Remove a = b bindings from let expressions everywhere
 letremovetop :: Transform
-letremovetop = everywhere ("letremove", inlinebind (\(b, e) -> case e of (Var v) | not $ Id.isDataConWorkId v -> True; otherwise -> False))
+letremovetop = everywhere ("letremove", inlinebind (\(b, e) -> case e of (Var v) | not $ Id.isDataConWorkId v -> return True; otherwise -> return False))
 
 --------------------------------
 -- Function inlining
@@ -157,8 +157,8 @@ letremovetop = everywhere ("letremove", inlinebind (\(b, e) -> case e of (Var v)
 -- will just not work on those function-typed values at first, but the other
 -- transformations (in particular β-reduction) should make sure that the type
 -- of those values eventually becomes primitive.
-inlinefuntop :: Transform
-inlinefuntop = everywhere ("inlinefun", inlinebind (is_applicable . snd))
+inlinenonreptop :: Transform
+inlinenonreptop = everywhere ("inlinenonrep", inlinebind ((Monad.liftM not) . isRepr . snd))
 
 --------------------------------
 -- Scrutinee simplification
@@ -448,7 +448,7 @@ funextracttop = everywhere ("funextract", funextract)
 
 
 -- What transforms to run?
-transforms = [argproptop, funextracttop, etatop, betatop, castproptop, letremovetop, letrectop, letsimpltop, letflattop, casewildtop, scrutsimpltop, casevalsimpltop, caseremovetop, inlinefuntop, appsimpltop]
+transforms = [argproptop, funextracttop, etatop, betatop, castproptop, letremovetop, letrectop, letsimpltop, letflattop, casewildtop, scrutsimpltop, casevalsimpltop, caseremovetop, inlinenonreptop, appsimpltop]
 
 -- Turns the given bind into VHDL
 normalizeModule :: 

diff --git a/NormalizeTools.hs b/NormalizeTools.hs
index 5ea3a7db8ab852fce0a7dd8529573e718ff2e7eb..85fae47e8f66a19865f281ee25e642d9dca1f16f 100644 (file)
--- a/NormalizeTools.hs
+++ b/NormalizeTools.hs
@@ -7,6 +7,7 @@ module NormalizeTools where
 import Debug.Trace
 import qualified List
 import qualified Data.Monoid as Monoid
+import qualified Data.Either as Either
 import qualified Control.Arrow as Arrow
 import qualified Control.Monad as Monad
 import qualified Control.Monad.Trans.State as State
@@ -185,14 +186,23 @@ dotransforms transs expr = do
   if Monoid.getAny changed then dotransforms transs expr' else return expr'
 
 -- Inline all let bindings that satisfy the given condition
-inlinebind :: ((CoreBndr, CoreExpr) -> Bool) -> Transform
-inlinebind condition (Let (Rec binds) expr) | not $ null replace =
-    change newexpr
+inlinebind :: ((CoreBndr, CoreExpr) -> TransformMonad Bool) -> Transform
+inlinebind condition expr@(Let (Rec binds) res) = do
+    -- Find all bindings that adhere to the condition
+    res_eithers <- mapM docond binds
+    case Either.partitionEithers res_eithers of
+      -- No replaces? No change
+      ([], _) -> return expr
+      (replace, others) -> do
+        -- Substitute the to be replaced binders with their expression
+        let newexpr = substitute replace (Let (Rec others) res)
+        change newexpr
   where 
-    -- Find all simple bindings
-    (replace, others) = List.partition condition binds
-    -- Substitute the to be replaced binders with their expression
-    newexpr = substitute replace (Let (Rec others) expr)
+    docond :: (CoreBndr, CoreExpr) -> TransformMonad (Either (CoreBndr, CoreExpr) (CoreBndr, CoreExpr))
+    docond b = do
+      res <- condition b
+      return $ case res of True -> Left b; False -> Right b
+
 -- Leave all other expressions unchanged
 inlinebind _ expr = return expr