Apply optimization recursively

Author: Ailrun

lambdacomp.cabal

@@ -77,11 +77,11 @@ library
     LambdaComp.AM.Eval
     LambdaComp.AM.Syntax
     LambdaComp.CBPV.ArityAnalysis
+    LambdaComp.CBPV.Optimization.BetaReduction
     LambdaComp.CBPV.Optimization.BindingConversion
     LambdaComp.CBPV.Optimization.DeadBindingElimination
     LambdaComp.CBPV.Optimization.InlineBinding
     LambdaComp.CBPV.Optimization.Local
-    LambdaComp.CBPV.Optimization.SkipReturn
     LambdaComp.CBPV.Syntax
     LambdaComp.CBPV.ToAM
     LambdaComp.CBPV.ToC

src/LambdaComp/CBPV/Optimization/BetaReduction.hs

@@ -0,0 +1,46 @@
+module LambdaComp.CBPV.Optimization.BetaReduction
+  ( runBetaReduction
+  ) where
+
+import LambdaComp.CBPV.Syntax
+
+runBetaReduction :: Tm Com -> Tm Com
+runBetaReduction = betaReduction
+
+betaReduction :: Tm c -> Tm c
+betaReduction tm@(TmVar _)             = tm
+betaReduction tm@(TmGlobal _)          = tm
+betaReduction tm@TmUnit                = tm
+betaReduction tm@TmTrue                = tm
+betaReduction tm@TmFalse               = tm
+betaReduction tm@(TmInt _)             = tm
+betaReduction tm@(TmDouble _)          = tm
+betaReduction (TmThunk tm)             = TmThunk $ betaReduction tm
+betaReduction (TmIf tm0 tm1 tm2)       =
+  case betaReduction tm0 of
+    TmTrue  -> tm1'
+    TmFalse -> tm2'
+    tm0'    -> TmIf tm0' tm1' tm2'
+  where
+    tm1' = betaReduction tm1
+    tm2' = betaReduction tm2
+betaReduction (TmLam p tm)             = TmLam p $ betaReduction tm
+betaReduction (tmf `TmApp` tma)        =
+  case betaReduction tmf of
+    TmLam Param{..} tmf' -> TmLet paramName (betaReduction tma) tmf'
+    tmf'                 -> tmf' `TmApp` betaReduction tma
+betaReduction (TmForce tm)             =
+  case betaReduction tm of
+    TmThunk tm' -> tm'
+    tm'         -> TmForce tm'
+betaReduction (TmReturn tm)            = TmReturn $ betaReduction tm
+betaReduction (TmTo tm0 x tm1)         =
+  case betaReduction tm0 of
+    TmReturn tm0' -> TmLet x tm0' (betaReduction tm1)
+    tm0'          -> TmTo tm0' x (betaReduction tm1)
+betaReduction (TmLet x tm0 tm1)        = TmLet x (betaReduction tm0) (betaReduction tm1)
+betaReduction (TmPrimBinOp op tm0 tm1) = TmPrimBinOp op (betaReduction tm0) (betaReduction tm1)
+betaReduction (TmPrimUnOp op tm)       = TmPrimUnOp op $ betaReduction tm
+betaReduction (TmPrintInt tm0 tm1)     = TmPrintInt (betaReduction tm0) (betaReduction tm1)
+betaReduction (TmPrintDouble tm0 tm1)  = TmPrintDouble (betaReduction tm0) (betaReduction tm1)
+betaReduction (TmRec p tm)             = TmRec p (betaReduction tm)

src/LambdaComp/CBPV/Optimization/Local.hs

@@ -2,10 +2,12 @@ module LambdaComp.CBPV.Optimization.Local
   ( runLocalOptDefault
   ) where
 
+import Control.Monad.Identity (Identity (Identity, runIdentity))
+
+import LambdaComp.CBPV.Optimization.BetaReduction          (runBetaReduction)
 import LambdaComp.CBPV.Optimization.BindingConversion      (runCommutingTo, runLiftingLet)
 import LambdaComp.CBPV.Optimization.DeadBindingElimination (runDeadLetElimination)
 import LambdaComp.CBPV.Optimization.InlineBinding          (runInlineSimpleLet)
-import LambdaComp.CBPV.Optimization.SkipReturn             (runSkipReturn)
 import LambdaComp.CBPV.Syntax
 
 runLocalOptDefault :: Program -> Program
@@ -15,4 +17,11 @@ runLocalOptDefaultTop :: Top -> Top
 runLocalOptDefaultTop m = m{ tmDefBody = runLocalOptDefaultTm $ tmDefBody m }
 
 runLocalOptDefaultTm :: Tm Com -> Tm Com
-runLocalOptDefaultTm = runDeadLetElimination . runInlineSimpleLet . runLiftingLet . runSkipReturn . runCommutingTo
+runLocalOptDefaultTm = runIdentity . repeatUntilFix (Identity . runDeadLetElimination . runInlineSimpleLet . runLiftingLet . runBetaReduction . runCommutingTo)
+
+repeatUntilFix :: (Monad m, Eq a) => (a -> m a) -> a -> m a
+repeatUntilFix f a = do
+  a' <- f a
+  if a == a'
+    then pure a'
+    else repeatUntilFix f a'

src/LambdaComp/CBPV/Optimization/SkipReturn.hs

@@ -106,7 +106,12 @@
 , ThunkCodeSection
     { thunkCodeSectionName = "sys_thunk_4"
     , thunkCode =
-        [ IScope
+        [ IAssign
+            ( AIdent "var_c_f0_6" )
+            ( VaThunk "sys_thunk_3"
+                [ ALocalEnv 2 ]
+            )
+        , IScope
         , IPush
             ( VaAddr
                 ( ALocalEnv 1 )
@@ -121,11 +126,6 @@
             ( AIdent "var_c_c_1" )
         , IPop
             ( AIdent "var_e_y" )
-        , IAssign
-            ( AIdent "var_c_f0_6" )
-            ( VaThunk "sys_thunk_3"
-                [ ALocalEnv 2 ]
-            )
         , ICondJump
             ( VaAddr
                 ( AIdent "var_c_c_1" )
@@ -555,11 +555,11 @@
 , ThunkCodeSection
     { thunkCodeSectionName = "sys_thunk_19"
     , thunkCode =
-        [ IPop
-            ( AIdent "var_e_n" )
-        , IAssign
+        [ IAssign
             ( AIdent "var_c_f0_8" )
             ( VaThunk "sys_thunk_18" [] )
+        , IPop
+            ( AIdent "var_e_n" )
         , IScope
         , IPush
             ( VaAddr