More inlining

src/Eucalypt/Core/Eliminate.hs

@@ -14,16 +14,15 @@ import Data.Maybe (fromMaybe)
 import Eucalypt.Core.Syn
 import qualified Data.Set as Set
 
+
 -- | Eliminate unused bindings from let expressions.
---
--- TODO: this but efficiently... at present this is just to cut down
--- on noise while debugging and tidying up after inlining.
 prune :: CoreExp a -> CoreExp a
 prune (CoreLet smid bs b) =
   let prunedB = pruneScope b
       usedInB = foldMapBound Set.singleton prunedB
       prunedBs = map (second pruneScope) bs
-      usedInBs = mconcat $ map (foldMapBound Set.singleton . snd) prunedBs
+      setsBoundByBs = map (foldMapBound Set.singleton . snd) prunedBs
+      usedInBs = mconcat $ removeSelfReferences setsBoundByBs
       used = usedInB <> usedInBs
    in CoreLet smid (blankUnused used prunedBs) prunedB
   where
@@ -44,6 +43,18 @@ prune e = e
 
 
 
+-- | When considering bound variables in each let binding, we need to
+-- discard self-references (for instance in recursive functions) or we
+-- will never prune them
+removeSelfReferences :: [Set.Set Int] -> [Set.Set Int]
+removeSelfReferences boundSets = zipWith f boundSets [0..]
+  where
+    f s i = s Set.\\ Set.singleton i
+
+
+
+-- | Remove let bindings that have been overwritten by CoreEliminated
+-- in the 'prune' step
 compress :: CoreExp a -> CoreExp a
 compress (CoreLet smid bs b) =
   let compressedB = compressScope b
@@ -52,7 +63,12 @@ compress (CoreLet smid bs b) =
       editedBindings =
         map (second $ remapBindings indexRemapping) $
         filter bindingIsNotEliminated compressedBs
-   in CoreLet smid editedBindings $ remapBindings indexRemapping compressedB
+   in
+    if null editedBindings
+    then
+      instantiate (const CoreEliminated) compressedB
+    else
+      CoreLet smid editedBindings $ remapBindings indexRemapping compressedB
   where
     compressScope = toScope . compress . fromScope
     bindingIsNotEliminated = not . isEliminated . unscope . snd

src/Eucalypt/Core/Inliner.hs

@@ -115,21 +115,29 @@ tagInlinables e = e
 
 
 
+transScope ::
+     (Monad f1, Monad f2)
+  => (f2 (Var b1 a1) -> f1 (Var b2 a2))
+  -> Scope b1 f2 a1
+  -> Scope b2 f1 a2
+transScope f = toScope . f . fromScope
+
+
+
 betaReduce :: CoreExp a -> CoreExp a
-betaReduce e@(CoreApply _ (CoreLambda _ True ns body) xs) =
-  if length xs == length ns
-  then
-    instantiate (xs !!) body
-  else
-    e
+betaReduce (CoreApply smid l@(CoreLambda _ inlineFlag ns body) xs) =
+  if inlineFlag && length xs == length ns
+    then betaReduce $ instantiate (map betaReduce xs !!) body
+  else CoreApply smid (betaReduce l) (map betaReduce xs)
+betaReduce (CoreApply smid f xs) =
+  CoreApply smid (betaReduce f) (map betaReduce xs)
 betaReduce (CoreLambda smid i ns body) =
-  CoreLambda smid i ns $ (Scope . betaReduce . unscope) body
-betaReduce (CoreLet smid bs b) =
-  CoreLet smid bs' b'
+  CoreLambda smid i ns $ transScope betaReduce body
+betaReduce (CoreLet smid bs b) = CoreLet smid bs' b'
   where
     b' = betaReduceScope b
     bs' = map (second betaReduceScope) bs
-    betaReduceScope = Scope . betaReduce . unscope
+    betaReduceScope = transScope betaReduce
 betaReduce (CoreMeta smid m e) = CoreMeta smid (betaReduce m) $ betaReduce e
 betaReduce (CoreLookup smid b e) = CoreLookup smid (betaReduce b) e
 betaReduce (CoreList smid xs) = CoreList smid (map betaReduce xs)

src/Eucalypt/Driver/Evaluator.hs

@@ -166,7 +166,7 @@ evaluate opts = do
       (putStrLn (pprint prunedEvaluand) >> exitSuccess)
 
     -- Now some inlining
-    let inlinedEvaluand = {-# SCC "Inlining" #-} prune $ inline $ inline $ inline $ inline $ inline prunedEvaluand
+    let inlinedEvaluand = {-# SCC "Inlining" #-} prune $ prune $ inline prunedEvaluand
     let compressedEvaluand = {-# SCC "Compression" #-} compress inlinedEvaluand
 
     let finalEvaluand = compressedEvaluand

test/Eucalypt/Core/EliminateSpec.hs

@@ -64,6 +64,11 @@ t4equiv =
     ] $
   corelist [var "b0", var "b2"]
 
+t5 :: CoreExpr
+t5 = letexp [("circle", lam ["x"] (app (var "circle") [var "x"]))] $ int 1
+
+t5equiv :: CoreExpr
+t5equiv = int 1
 
 spec :: Spec
 spec = do
@@ -76,6 +81,8 @@ spec = do
     it "renumbers correctly" $
     newBindIndexes [True, False, False, True, True, False] `shouldBe`
     [Just 0, Nothing, Nothing, Just 1, Just 2, Nothing]
-  describe "compresses bindings once eliminated" $
+  describe "compresses bindings once eliminated" $ do
     it "compresses correctly" $
-    compress t4 `shouldBe` t4equiv
+      compress t4 `shouldBe` t4equiv
+    it "prunes self referential bindings with no further references" $
+      (compress . prune) t5 `shouldBe` t5equiv

test/Eucalypt/Core/InlinerSpec.hs

@@ -87,4 +87,4 @@ spec =
     it "inlines transpositions" $
       inline singleTranspositionApplied `shouldBe` singleTransposedResult
     it "inlines sample B" $
-       inline sampleB `shouldBe` sampleBEquiv
+      inline sampleB `shouldBe` sampleBEquiv