diff --git a/.gitignore b/.gitignore index 5aa7a08..5112877 100644 --- a/.gitignore +++ b/.gitignore @@ -3,3 +3,4 @@ dist-newstyle *.x *.bak src/Grammar +/language diff --git a/Grammar.cf b/Grammar.cf index e072d5e..4446eaf 100644 --- a/Grammar.cf +++ b/Grammar.cf @@ -3,21 +3,21 @@ Program. Program ::= [Def] ; DExp. Def ::= Ident ":" Type Ident [Ident] "=" Exp ; -separator Def ""; -separator Ident ""; -separator Type "->"; +Program. Program ::= [Bind]; -EId. Exp3 ::= Ident ; -EInt. Exp3 ::= Integer ; -EApp. Exp2 ::= Exp2 Exp3 ; -EAdd. Exp1 ::= Exp1 "+" Exp2 ; -EAbs. Exp ::= "\\" Ident ":" Type "." Exp ; -coercions Exp 3 ; +EId. Exp3 ::= Ident; +EInt. Exp3 ::= Integer; +ELet. Exp3 ::= "let" [Bind] "in" Exp; +EApp. Exp2 ::= Exp2 Exp3; +EAdd. Exp1 ::= Exp1 "+" Exp2; +EAbs. Exp ::= "\\" Ident "." Exp; -TInt. Type1 ::= "Int" ; -TPol. Type1 ::= Ident ; -TFun. Type ::= [Type] ; -coercions Type 1 ; +Bind. Bind ::= Ident [Ident] "=" Exp; +separator Bind ";"; +separator Ident " "; + +coercions Exp 3; + +comment "--"; +comment "{-" "-}"; -comment "--" ; -comment "{-" "-}" ; diff --git a/Makefile b/Makefile index 35736a1..ad830b5 100644 --- a/Makefile +++ b/Makefile @@ -22,4 +22,11 @@ clean : rm -r src/Grammar rm language +test : + ./language ./sample-programs/basic-1 + ./language ./sample-programs/basic-2 + ./language ./sample-programs/basic-3 + ./language ./sample-programs/basic-4 + ./language ./sample-programs/basic-5 + # EOF diff --git a/language.cabal b/language.cabal index bb35f1f..f95d1dd 100644 --- a/language.cabal +++ b/language.cabal @@ -12,7 +12,7 @@ build-type: Simple extra-doc-files: CHANGELOG.md -extra-source-fiels: +extra-source-files: Grammar.cf @@ -30,18 +30,18 @@ executable language Grammar.Par Grammar.Print Grammar.Skel - Grammar.ErrM - Interpreter - TypeChecker - NewAbs + LambdaLifter + Auxiliary + -- Interpreter hs-source-dirs: src build-depends: - base >= 4.16.3.0 + base >=4.16 , mtl , containers , either , array + , extra default-language: GHC2021 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..9984ddd --- /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/shell.nix b/shell.nix index 0c7624a..2eaf1cd 100644 --- a/shell.nix +++ b/shell.nix @@ -6,7 +6,7 @@ pkgs.haskellPackages.developPackage { withHoogle = true; modifier = drv: pkgs.haskell.lib.addBuildTools drv ( - (with pkgs; [ hlint haskell-language-server ghc jasmin ]) + (with pkgs; [ hlint haskell-language-server ghc jasmin llvmPackages_15.libllvm]) ++ (with pkgs.haskellPackages; [ cabal-install diff --git a/src/Auxiliary.hs b/src/Auxiliary.hs new file mode 100644 index 0000000..cd844d7 --- /dev/null +++ b/src/Auxiliary.hs @@ -0,0 +1,5 @@ + +module Auxiliary (module Auxiliary) where + +snoc :: a -> [a] -> [a] +snoc x xs = xs ++ [x] diff --git a/src/Interpreter.hs b/src/Interpreter.hs index dc34d49..b7d83a5 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -7,4 +7,68 @@ import Control.Monad.Except (Except, MonadError (throwError)) import Grammar.Abs interpret :: Program -> Except String Integer -interpret (Program _) = throwError "Can not interpret program yet" +interpret (Program e) = + eval mempty e >>= \case + VClosure {} -> throwError "main evaluated to a function" + VInt i -> pure i + + +data Val = VInt Integer + | VClosure Cxt Ident Exp + +type Cxt = Map Ident Val + +eval :: Cxt -> Exp -> Except String Val +eval cxt = \case + + + -- ------------ x ∈ γ + -- γ ⊢ x ⇓ γ(x) + + EId x -> + maybeToRightM + ("Unbound variable:" ++ printTree x) + $ Map.lookup x cxt + + -- --------- + -- γ ⊢ i ⇓ i + + EInt i -> pure $ VInt i + + -- γ ⊢ e ⇓ let δ in λx. f + -- γ ⊢ e₁ ⇓ v + -- δ,x=v ⊢ f ⇓ v₁ + -- ------------------------------ + -- γ ⊢ e e₁ ⇓ v₁ + + EApp e e1 -> + eval cxt e >>= \case + VInt _ -> throwError "Not a function" + VClosure delta x f -> do + v <- eval cxt e1 + eval (Map.insert x v delta) f + + -- + -- ----------------------------- + -- γ ⊢ λx. f ⇓ let γ in λx. f + + EAbs x e -> pure $ VClosure cxt x e + + + -- γ ⊢ e ⇓ v + -- γ ⊢ e₁ ⇓ v₁ + -- ------------------ + -- γ ⊢ e e₁ ⇓ v + v₁ + + EAdd e e1 -> do + v <- eval cxt e + v1 <- eval cxt e1 + case (v, v1) of + (VInt i, VInt i1) -> pure $ VInt (i + i1) + _ -> throwError "Can't add a function" + + + +maybeToRightM :: MonadError l m => l -> Maybe r -> m r +maybeToRightM err = liftEither . maybeToRight err + diff --git a/src/LambdaLifter.hs b/src/LambdaLifter.hs new file mode 100644 index 0000000..ac9cee0 --- /dev/null +++ b/src/LambdaLifter.hs @@ -0,0 +1,221 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} + + +module LambdaLifter (lambdaLift, freeVars, abstract, rename, collectScs) where + +import Data.List (mapAccumL) +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Maybe (fromMaybe) +import Data.Set (Set, (\\)) +import qualified Data.Set as Set +import Data.Tuple.Extra (uncurry3) +import Grammar.Abs +import Prelude hiding (exp) + + + +-- | Lift lambdas and let expression into supercombinators. +lambdaLift :: Program -> Program +lambdaLift = collectScs . rename . abstract . freeVars + + +-- | Annotate free variables +freeVars :: Program -> AnnProgram +freeVars (Program ds) = [ (n, xs, freeVarsExp (Set.fromList xs) e) + | Bind 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 ] + +-- AST annotated with free variables +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 + +-- | Lift lambdas to let expression of the form @let sc = \x -> rhs@ +abstract :: AnnProgram -> Program +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 + +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")) + + +snoc :: a -> [a] -> [a] +snoc x xs = xs ++ [x] + +-- | Rename all supercombinators and variables +rename :: Program -> Program +rename (Program ds) = Program $ map (uncurry3 Bind) tuples + where + tuples = snd (mapAccumL renameSc 0 ds) + renameSc i (Bind 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, EId . fromMaybe n $ 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) + + +-- | Collects supercombinators by lifting appropriate let expressions +collectScs :: Program -> Program +collectScs (Program ds) = Program $ concatMap collectOneSc ds + where + collectOneSc (Bind name args rhs) = Bind name args rhs' : scs + where (scs, rhs') = collectScsExp rhs + +collectScsExp :: Exp -> ([Bind], Exp) +collectScsExp = \case + + EId n -> ([], EId n) + + EInt i -> ([], EInt i) + + EApp e1 e2 -> (scs1 ++ scs2, EApp e1' e2') + where + (scs1, e1') = collectScsExp e1 + (scs2, e2') = collectScsExp e2 + + EAdd e1 e2 -> (scs1 ++ scs2, EAdd e1' e2') + where + (scs1, e1') = collectScsExp e1 + (scs2, e2') = collectScsExp e2 + + EAbs x e -> (scs, EAbs x e') + where + (scs, e') = collectScsExp e + + ELet bs e -> (rhss_scs ++ e_scs ++ local_scs, mkEAbs non_scs' e') + where + (rhss_scs, bs') = mapAccumL collectScs_d [] bs + 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, Bind n xs rhs') + where + (rhs_scs1, rhs') = collectScsExp rhs + +isEAbs :: Exp -> Bool +isEAbs = \case + EAbs {} -> True + _ -> False + +mkEAbs :: [Bind] -> Exp -> Exp +mkEAbs [] e = e +mkEAbs bs e = ELet bs e + + diff --git a/src/Main.hs b/src/Main.hs index ab2bd24..9af1753 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -1,12 +1,11 @@ {-# LANGUAGE LambdaCase #-} module Main where -import Control.Monad.Except (runExcept) -import Grammar.Par (myLexer, pProgram) -import Interpreter (interpret) -import TypeChecker (typecheck) -import System.Environment (getArgs) -import System.Exit (exitFailure, exitSuccess) +import Grammar.Par (myLexer, pProgram) +import Grammar.Print (printTree) +import LambdaLifter (abstract, freeVars, lambdaLift, rename) +import System.Environment (getArgs) +import System.Exit (exitFailure, exitSuccess) main :: IO () main = getArgs >>= \case @@ -14,23 +13,21 @@ main = getArgs >>= \case (x:_) -> do file <- readFile x case pProgram (myLexer file) of - Left err -> do - putStrLn "SYNTAX ERROR" - putStrLn err - exitFailure - Right p -> case typecheck p of - Left err -> do - putStrLn "TYPECHECKING 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 + Left err -> do + putStrLn "SYNTAX ERROR" + putStrLn err + exitFailure + Right prg -> do + putStrLn "-- Parse" + putStrLn $ printTree prg + -- 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 + putStrLn "" + exitSuccess