From 2a48b7477e37443a7302bb41f7edec9d390ecd2a Mon Sep 17 00:00:00 2001 From: Martin Fredin Date: Thu, 9 Feb 2023 05:19:51 +0100 Subject: [PATCH] Implement lambda lifting passes: freeVars, abstract, and rename --- Grammar.cf | 28 ++++--- language.cabal | 4 +- src/LambdaLifter.hs | 173 ++++++++++++++++++++++++++++++++++++++++++++ src/Main.hs | 29 ++++---- 4 files changed, 211 insertions(+), 23 deletions(-) create mode 100644 src/LambdaLifter.hs diff --git a/Grammar.cf b/Grammar.cf index d880ed2..9dba2f5 100644 --- a/Grammar.cf +++ b/Grammar.cf @@ -1,15 +1,25 @@ -Program. Program ::= "main" "=" Exp ; +Program. Program ::= [ScDef]; -EId. Exp3 ::= Ident ; -EInt. Exp3 ::= Integer ; -EApp. Exp2 ::= Exp2 Exp3 ; -EAdd. Exp1 ::= Exp1 "+" Exp2 ; -EAbs. Exp ::= "\\" Ident "." Exp ; +ScDef. ScDef ::= Bind; +separator ScDef ";"; -coercions Exp 3 ; +separator Ident " "; -comment "--" ; -comment "{-" "-}" ; + +EId. Exp3 ::= Ident; +EInt. Exp3 ::= Integer; +ELet. Exp3 ::= "let" [Bind] "in" Exp; +EApp. Exp2 ::= Exp2 Exp3; +EAdd. Exp1 ::= Exp1 "+" Exp2; +EAbs. Exp ::= "\\" Ident "." Exp; + +Bind. Bind ::= Ident [Ident] "=" Exp; +separator Bind ";"; + +coercions Exp 3; + +comment "--"; +comment "{-" "-}"; diff --git a/language.cabal b/language.cabal index 5734655..3f4860c 100644 --- a/language.cabal +++ b/language.cabal @@ -30,7 +30,8 @@ executable language Grammar.Par Grammar.Print Grammar.Skel - Interpreter + LambdaLifter + -- Interpreter hs-source-dirs: src @@ -40,5 +41,6 @@ executable language , containers , either , array + , extra default-language: GHC2021 diff --git a/src/LambdaLifter.hs b/src/LambdaLifter.hs new file mode 100644 index 0000000..6e1463d --- /dev/null +++ b/src/LambdaLifter.hs @@ -0,0 +1,173 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} + + +module LambdaLifter (lambdaLift, freeVars, abstract) where + +import Data.List (mapAccumL) +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Maybe (fromJust) +import Data.Set (Set, (\\)) +import qualified Data.Set as Set +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 = rename . abstract . freeVars + + +-- Annotate free variables + +freeVars :: Program -> AnnProgram +freeVars (Program ds) = [ (n, xs, freeVarsExp (Set.fromList xs) e) + | Sc n xs e <- ds + ] + + +freeVarsExp :: Set Ident -> Exp -> AnnExp +freeVarsExp lv = \case + + EId n | Set.member n lv -> (Set.singleton n, AId n) + | otherwise -> (mempty, AId n) + + EInt i -> (mempty, AInt i) + + EApp e1 e2 -> (Set.union (freeVarsOf e1') (freeVarsOf e2'), AApp e1' e2') + where e1' = freeVarsExp lv e1 + e2' = freeVarsExp lv e2 + + EAdd e1 e2 -> (Set.union (freeVarsOf e1') (freeVarsOf e2'), AAdd e1' e2') + where e1' = freeVarsExp lv e1 + e2' = freeVarsExp lv e2 + + EAbs n e -> (Set.delete n $ freeVarsOf e', AAbs n e') + where e' = freeVarsExp (Set.insert n lv) e + + ELet bs e -> (Set.union bsFree eFree, ALet bs' e') + where + bsFree = freeInValues \\ nsSet + eFree = freeVarsOf e' \\ nsSet + bs' = zipWith3 ABind ns xs es' + e' = freeVarsExp e_lv e + (ns, xs, es) = fromBinders bs + nsSet = Set.fromList ns + e_lv = Set.union lv nsSet + es' = map (freeVarsExp e_lv) es + freeInValues = foldr1 Set.union (map freeVarsOf es') + + + +freeVarsOf :: AnnExp -> Set Ident +freeVarsOf = fst + +fromBinders :: [Bind] -> ([Ident], [[Ident]], [Exp]) +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 + ] + + +abstractExp :: AnnExp -> Exp +abstractExp (free, exp) = case exp of + AId n -> EId n + AInt i -> EInt i + AApp e1 e2 -> EApp (abstractExp e1) (abstractExp e2) + AAdd e1 e2 -> EAdd (abstractExp e1) (abstractExp e2) + ALet bs e -> ELet [Bind n xs (abstractExp e1) | ABind n xs e1 <- bs ] $ abstractExp e + AAbs n e -> foldl EApp sc (map EId fvList) + where + fvList = Set.toList free + bind = Bind "sc" [] e' + e' = foldr EAbs (abstractExp e) (fvList ++ [n]) + sc = ELet [bind] (EId (Ident "sc")) + +-- rename pass + +rename :: Program -> Program +rename (Program ds) = Program $ map (uncurry3 Sc) tuples + where + tuples = snd (mapAccumL renameSc 0 ds) + renameSc i (Sc n xs e) = (i2, (n, xs', e')) + where + (i1, xs', env) = newNames i xs + (i2, e') = renameExp env i1 e + +renameExp :: Map Ident Ident -> Int -> Exp -> (Int, Exp) +renameExp env i = \case + + + EId n -> (i, maybe (error "no") EId $ Map.lookup n env) + + + EInt i1 -> (i, EInt i1) + + EApp e1 e2 -> (i2, EApp e1' e2') + where + (i1, e1') = renameExp env i e1 + (i2, e2') = renameExp env i1 e2 + + EAdd e1 e2 -> (i2, EAdd e1' e2') + where + (i1, e1') = renameExp env i e1 + (i2, e2') = renameExp env i1 e2 + + ELet bs e -> (i3, ELet (zipWith3 Bind ns' xs es') e') + where + (i1, e') = renameExp e_env i e + (ns, xs, es) = fromBinders bs + (i2, ns', env') = newNames i1 ns + e_env = Map.union env' env + (i3, es') = mapAccumL (renameExp e_env) i2 es + + + EAbs n e -> (i2, EAbs (head ns) e') + where + (i1, ns, env') = newNames i [n] + (i2, e') = renameExp (Map.union env' env ) i1 e + + +newNames :: Int -> [Ident] -> (Int, [Ident], Map Ident Ident) +newNames i old_names = (i', new_names, env) + where + (i', new_names) = getNames i old_names + env = Map.fromList $ zip old_names new_names + + +getName :: Int -> Ident -> (Int, Ident) +getName i (Ident s) = (i + 1, makeName s i) + +getNames :: Int -> [Ident] -> (Int, [Ident]) +getNames i ns = (i + length ss, zipWith makeName ss [i..]) + where + ss = map (\(Ident s) -> s) ns + +makeName :: String -> Int -> Ident +makeName prefix i = Ident (prefix ++ "_" ++ show i) + +-- Annotated AST + +type AnnProgram = [(Ident, [Ident], AnnExp)] +type AnnExp = (Set Ident, AnnExp') + +data ABind = ABind Ident [Ident] AnnExp deriving Show + +data AnnExp' = AId Ident + | AInt Integer + | AApp AnnExp AnnExp + | AAdd AnnExp AnnExp + | AAbs Ident AnnExp + | ALet [ABind] AnnExp + deriving Show diff --git a/src/Main.hs b/src/Main.hs index ed753f2..58aafe5 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -1,11 +1,11 @@ {-# LANGUAGE LambdaCase #-} module Main where -import Control.Monad.Except (runExcept) -import Grammar.Par (myLexer, pProgram) -import Interpreter (interpret) -import System.Environment (getArgs) -import System.Exit (exitFailure, exitSuccess) +import Grammar.Par (myLexer, pProgram) +import Grammar.Print (printTree) +import LambdaLifter (abstract, freeVars, lambdaLift) +import System.Environment (getArgs) +import System.Exit (exitFailure, exitSuccess) main :: IO () main = getArgs >>= \case @@ -17,14 +17,17 @@ main = getArgs >>= \case putStrLn "SYNTAX ERROR" putStrLn err exitFailure - Right prg -> case runExcept $ interpret prg of - Left err -> do - putStrLn "INTERPRETER ERROR" - putStrLn err - exitFailure - Right i -> do - print i - exitSuccess + Right prg -> do + putStrLn "-- Parser" + putStrLn $ printTree prg + putStrLn "\n--Lamda lifter" + putStrLn "\n--freevars" + print $ freeVars prg + putStrLn "\n--abstract" + putStrLn . printTree $ (abstract . freeVars) prg + putStrLn "\n--renamed" + putStrLn . printTree $ lambdaLift prg + exitSuccess