From 08917be1c6890bd2a760b15713d7d9c6600916d2 Mon Sep 17 00:00:00 2001 From: Martin Fredin Date: Thu, 9 Feb 2023 17:53:39 +0100 Subject: [PATCH] Fix first unnecessary supercombinator --- Grammar.cf | 9 ++---- basic-2 | 4 --- sample-programs/basic-1 | 2 ++ sample-programs/basic-2 | 4 +++ sample-programs/basic-3 | 2 ++ sample-programs/basic-4 | 2 ++ sample-programs/basic-5 | 9 ++++++ src/LambdaLifter.hs | 72 ++++++++++++++++++++++------------------- src/Main.hs | 8 +++-- test_program | 5 --- 10 files changed, 66 insertions(+), 51 deletions(-) delete mode 100644 basic-2 create mode 100644 sample-programs/basic-1 create mode 100644 sample-programs/basic-2 create mode 100644 sample-programs/basic-3 create mode 100644 sample-programs/basic-4 create mode 100644 sample-programs/basic-5 delete mode 100644 test_program diff --git a/Grammar.cf b/Grammar.cf index 9dba2f5..410d11d 100644 --- a/Grammar.cf +++ b/Grammar.cf @@ -1,12 +1,6 @@ -Program. Program ::= [ScDef]; - -ScDef. ScDef ::= Bind; -separator ScDef ";"; - -separator Ident " "; - +Program. Program ::= [Bind]; EId. Exp3 ::= Ident; EInt. Exp3 ::= Integer; @@ -17,6 +11,7 @@ EAbs. Exp ::= "\\" Ident "." Exp; Bind. Bind ::= Ident [Ident] "=" Exp; separator Bind ";"; +separator Ident " "; coercions Exp 3; diff --git a/basic-2 b/basic-2 deleted file mode 100644 index 8afd060..0000000 --- a/basic-2 +++ /dev/null @@ -1,4 +0,0 @@ -add x = \y. x + y; - -main = (\z. z + z) ((add 4) 6); - diff --git a/sample-programs/basic-1 b/sample-programs/basic-1 new file mode 100644 index 0000000..f109950 --- /dev/null +++ b/sample-programs/basic-1 @@ -0,0 +1,2 @@ + +f = \x. x+1; diff --git a/sample-programs/basic-2 b/sample-programs/basic-2 new file mode 100644 index 0000000..4b8ead0 --- /dev/null +++ b/sample-programs/basic-2 @@ -0,0 +1,4 @@ +add x = \y. x+y; + +main = (\z. z+z) ((add 4) 6); + diff --git a/sample-programs/basic-3 b/sample-programs/basic-3 new file mode 100644 index 0000000..9443439 --- /dev/null +++ b/sample-programs/basic-3 @@ -0,0 +1,2 @@ + +main = (\x. x+x+3) ((\x. x) 2) diff --git a/sample-programs/basic-4 b/sample-programs/basic-4 new file mode 100644 index 0000000..1de7a8c --- /dev/null +++ b/sample-programs/basic-4 @@ -0,0 +1,2 @@ + +f x = let g = (\y. y+1) in g (g x) diff --git a/sample-programs/basic-5 b/sample-programs/basic-5 new file mode 100644 index 0000000..3168484 --- /dev/null +++ b/sample-programs/basic-5 @@ -0,0 +1,9 @@ +id x = x; + +add x y = x + y; + +double n = n + n; + +apply f x = \y -> f x y; + +main = apply (id add) ((\x. x + 1) 1) (double 3); diff --git a/src/LambdaLifter.hs b/src/LambdaLifter.hs index 512155d..c9253b6 100644 --- a/src/LambdaLifter.hs +++ b/src/LambdaLifter.hs @@ -1,6 +1,5 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PatternSynonyms #-} module LambdaLifter (lambdaLift, freeVars, abstract, rename, collectScs) where @@ -15,20 +14,14 @@ import Data.Tuple.Extra (uncurry3) import Grammar.Abs import Prelude hiding (exp) -pattern Sc :: Ident -> [Ident] -> Exp -> ScDef -pattern Sc n xs e = ScDef (Bind n xs e) - - - lambdaLift :: Program -> Program lambdaLift = collectScs . rename . abstract . freeVars - -- Annotate free variables freeVars :: Program -> AnnProgram freeVars (Program ds) = [ (n, xs, freeVarsExp (Set.fromList xs) e) - | Sc n xs e <- ds + | Bind n xs e <- ds ] @@ -64,7 +57,6 @@ freeVarsExp lv = \case freeInValues = foldr1 Set.union (map freeVarsOf es') - freeVarsOf :: AnnExp -> Set Ident freeVarsOf = fst @@ -74,10 +66,21 @@ fromBinders bs = unzip3 [ (n, xs, e) | Bind n xs e <- bs ] -- Lift lambda expression into let with binder "sc" abstract :: AnnProgram -> Program -abstract p = Program - [ Sc sc_name xs $ abstractExp rhs - | (sc_name, xs, rhs) <- p - ] +abstract prog = Program $ map f prog + where + f :: (Ident, [Ident], AnnExp) -> Bind + f (name, pars, rhs@(_, e)) = + case e of + AAbs par body -> Bind name (snoc par pars) $ abstractExp body + _ -> Bind name pars $ abstractExp rhs + + + +-- [ case rhs of +-- EAbs par body -> Bind name (snoc par pars) body +-- _ -> Bind name pars rhs +-- +-- | (name, pars, rhs) <- prog abstractExp :: AnnExp -> Exp @@ -94,13 +97,17 @@ abstractExp (free, exp) = case exp of e' = foldr EAbs (abstractExp e) (fvList ++ [n]) sc = ELet [bind] (EId (Ident "sc")) + +snoc :: a -> [a] -> [a] +snoc x xs = xs ++ [x] + -- Rename rename :: Program -> Program -rename (Program ds) = Program $ map (uncurry3 Sc) tuples +rename (Program ds) = Program $ map (uncurry3 Bind) tuples where tuples = snd (mapAccumL renameSc 0 ds) - renameSc i (Sc n xs e) = (i2, (n, xs', e')) + renameSc i (Bind n xs e) = (i2, (n, xs', e')) where (i1, xs', env) = newNames i xs (i2, e') = renameExp env i1 e @@ -159,14 +166,23 @@ makeName prefix i = Ident (prefix ++ "_" ++ show i) -- Collect supercombinators collectScs :: Program -> Program -collectScs (Program ds) = Program $ concatMap collect_one_sc ds +collectScs (Program ds) = Program $ concatMap collectOneSc ds where - collect_one_sc (Sc n xs e) = Sc n xs e' : scs - where (scs, e') = collectScsExp e + collectOneSc (Bind name args rhs) = Bind name args rhs' : scs + where (scs, rhs') = collectScsExp rhs + {- -collectScsExp :: Exp -> ([ScDef], Exp) +Bind (Ident "f") [] + + (ELet [Bind (Ident "sc") [] (EAbs (Ident "x") (EAdd (EId (Ident "x")) (EInt 1)))] (EId (Ident "sc"))) + + + -} + + +collectScsExp :: Exp -> ([Bind], Exp) collectScsExp = \case EId n -> ([], EId n) @@ -190,25 +206,15 @@ collectScsExp = \case ELet bs e -> (rhss_scs ++ e_scs ++ local_scs, mkEAbs non_scs' e') where (rhss_scs, bs') = mapAccumL collectScs_d [] bs - scs' = [ Sc n xs rhs | Sc n xs rhs <- bs', isEAbs rhs] - non_scs' = [ Bind n xs rhs | Sc n xs rhs <- bs', not $ isEAbs rhs] - local_scs = map peelLambda scs' - -- local_scs = [ Sc n (xs ++ [x]) e1 | Sc n xs (EAbs x e1) <- scs'] + scs' = [ Bind n xs rhs | Bind n xs rhs <- bs', isEAbs rhs] + non_scs' = [ Bind n xs rhs | Bind n xs rhs <- bs', not $ isEAbs rhs] + local_scs = [ Bind n (xs ++ [x]) e1 | Bind n xs (EAbs x e1) <- scs'] (e_scs, e') = collectScsExp e - collectScs_d scs (Bind n xs rhs) = (scs ++ rhs_scs1, Sc n xs rhs') + collectScs_d scs (Bind n xs rhs) = (scs ++ rhs_scs1, Bind n xs rhs') where (rhs_scs1, rhs') = collectScsExp rhs - - -peelLambda :: ScDef -> ScDef -peelLambda sc@(Sc n xs e) = case e of - EAbs x e1 -> peelLambda (Sc n (xs ++ [x]) e1) - _ -> sc - - - isEAbs :: Exp -> Bool isEAbs = \case EAbs {} -> True diff --git a/src/Main.hs b/src/Main.hs index ee5a0a1..211bf3a 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -18,9 +18,13 @@ main = getArgs >>= \case putStrLn err exitFailure Right prg -> do - putStrLn "-- Parser" + putStrLn "-- Parse" putStrLn $ printTree prg - putStrLn "\n--Lamda lifter" + putStrLn "\n-- Abstract" + putStrLn . printTree $ (abstract . freeVars) prg + putStrLn "\n-- Rename" + putStrLn . printTree $ (rename . abstract . freeVars) prg + putStrLn "\n-- Lamda lifter" putStrLn . printTree $ lambdaLift prg exitSuccess diff --git a/test_program b/test_program deleted file mode 100644 index 95235e4..0000000 --- a/test_program +++ /dev/null @@ -1,5 +0,0 @@ - - - - -main = (\x. x + x + 3) ((\x. x) 2)