diff --git a/Grammar.cf b/Grammar.cf index b258446..410d11d 100644 --- a/Grammar.cf +++ b/Grammar.cf @@ -1,15 +1,20 @@ -Program. Program ::= "main" "=" Exp ; +Program. Program ::= [Bind]; -EId. Exp3 ::= Ident ; -EInt. Exp3 ::= Integer ; -EApp. Exp2 ::= Exp2 Exp3 ; -EAdd. Exp1 ::= Exp1 "+" Exp2 ; -EAbs. Exp ::= "\\" Ident "->" Exp ; +EId. Exp3 ::= Ident; +EInt. Exp3 ::= Integer; +ELet. Exp3 ::= "let" [Bind] "in" Exp; +EApp. Exp2 ::= Exp2 Exp3; +EAdd. Exp1 ::= Exp1 "+" Exp2; +EAbs. Exp ::= "\\" Ident "." Exp; -coercions Exp 3 ; +Bind. Bind ::= Ident [Ident] "=" Exp; +separator Bind ";"; +separator Ident " "; -comment "--" ; -comment "{-" "-}" ; +coercions Exp 3; + +comment "--"; +comment "{-" "-}"; diff --git a/Makefile b/Makefile index 16b753d..d9098d1 100644 --- a/Makefile +++ b/Makefile @@ -22,4 +22,16 @@ 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 + ./language ./sample-programs/basic-5 + ./language ./sample-programs/basic-6 + ./language ./sample-programs/basic-7 + ./language ./sample-programs/basic-8 + ./language ./sample-programs/basic-9 + # EOF diff --git a/language.cabal b/language.cabal index 5734655..0577abe 100644 --- a/language.cabal +++ b/language.cabal @@ -30,6 +30,9 @@ executable language Grammar.Par Grammar.Print Grammar.Skel + Grammar.ErrM + LambdaLifter + Auxiliary Interpreter hs-source-dirs: src @@ -40,5 +43,6 @@ executable language , 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/sample-programs/basic-6 b/sample-programs/basic-6 new file mode 100644 index 0000000..511ae10 --- /dev/null +++ b/sample-programs/basic-6 @@ -0,0 +1,3 @@ + + +f = \x.\y. x+y diff --git a/sample-programs/basic-7 b/sample-programs/basic-7 new file mode 100644 index 0000000..b3769b9 --- /dev/null +++ b/sample-programs/basic-7 @@ -0,0 +1,5 @@ +add x y = x + y; + +apply f x = f x; + +main = apply (add 4) 6; diff --git a/sample-programs/basic-8 b/sample-programs/basic-8 new file mode 100644 index 0000000..59abdac --- /dev/null +++ b/sample-programs/basic-8 @@ -0,0 +1,2 @@ + +f x = let double = \y. y+y in (\x. x+y) 4; diff --git a/sample-programs/basic-9 b/sample-programs/basic-9 new file mode 100644 index 0000000..ba9ebdc --- /dev/null +++ b/sample-programs/basic-9 @@ -0,0 +1,4 @@ + + + +main = (\f.\x.\y. f x + f y) (\x. x+x) ((\x. x+1) ((\x. x+3) 2)) 4 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..2de36a7 --- /dev/null +++ b/src/Auxiliary.hs @@ -0,0 +1,11 @@ + +module Auxiliary (module Auxiliary) where +import Control.Monad.Error.Class (liftEither) +import Control.Monad.Except (MonadError) +import Data.Either.Combinators (maybeToRight) + +snoc :: a -> [a] -> [a] +snoc x xs = xs ++ [x] + +maybeToRightM :: MonadError l m => l -> Maybe r -> m r +maybeToRightM err = liftEither . maybeToRight err diff --git a/src/Interpreter.hs b/src/Interpreter.hs index bdbd8d2..3503a7c 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -1,45 +1,79 @@ -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE OverloadedStrings #-} module Interpreter where +import Auxiliary (maybeToRightM) import Control.Applicative (Applicative) import Control.Monad.Except (Except, MonadError (throwError), liftEither) +import Control.Monad.State (MonadState, StateT, evalStateT) import Data.Either.Combinators (maybeToRight) import Data.Map (Map) import qualified Data.Map as Map +import Data.Maybe (maybe) import Grammar.Abs +import Grammar.ErrM (Err) import Grammar.Print (printTree) -interpret :: Program -> Except String Integer -interpret (Program e) = - eval mempty e >>= \case - VClosure {} -> throwError "main evaluated to a function" - VInt i -> pure i +interpret :: Program -> Err Integer +interpret (Program scs) = do + main <- findMain scs + eval (initCxt scs) main >>= + \case + VClosure {} -> throwError "main evaluated to a function" + VInt i -> pure i +initCxt :: [Bind] -> Cxt +initCxt scs = + Cxt { env = mempty + , sig = foldr insert mempty $ map expandLambdas scs + } + where insert (Bind name _ rhs) = Map.insert name rhs + +expandLambdas :: Bind -> Bind +expandLambdas (Bind name parms rhs) = Bind name [] $ foldr EAbs rhs parms + + +findMain :: [Bind] -> Err Exp +findMain [] = throwError "No main!" +findMain (sc:scs) = case sc of + Bind "main" _ rhs -> pure rhs + _ -> findMain scs + data Val = VInt Integer - | VClosure Cxt Ident Exp + | VClosure Env Ident Exp + deriving (Show, Eq) -type Cxt = Map Ident Val +type Env = Map Ident Val +type Sig = Map Ident Exp -eval :: Cxt -> Exp -> Except String Val +data Cxt = Cxt + { env :: Map Ident Val + , sig :: Map Ident Exp + } deriving (Show, Eq) + +eval :: Cxt -> Exp -> Err Val eval cxt = \case - -- ------------ x ∈ γ -- γ ⊢ x ⇓ γ(x) - EId x -> - maybeToRightM - ("Unbound variable:" ++ printTree x) - $ Map.lookup x cxt + EId x -> do + case Map.lookup x cxt.env of + Just e -> pure e + Nothing -> + case Map.lookup x cxt.sig of + Just e -> eval (emptyEnv cxt) e + Nothing -> throwError ("Unbound variable: " ++ printTree x) -- --------- -- γ ⊢ i ⇓ i EInt i -> pure $ VInt i - -- γ ⊢ e ⇓ let δ in λx → f + -- γ ⊢ e ⇓ let δ in λx. f -- γ ⊢ e₁ ⇓ v -- δ,x=v ⊢ f ⇓ v₁ -- ------------------------------ @@ -50,13 +84,15 @@ eval cxt = \case VInt _ -> throwError "Not a function" VClosure delta x f -> do v <- eval cxt e1 - eval (Map.insert x v delta) f + let cxt' = putEnv (Map.insert x v delta) cxt + eval cxt' f + -- -- ----------------------------- - -- γ ⊢ λx → f ⇓ let γ in λx → f + -- γ ⊢ λx. f ⇓ let γ in λx. f - EAbs x e -> pure $ VClosure cxt x e + EAbs par e -> pure $ VClosure cxt.env par e -- γ ⊢ e ⇓ v @@ -71,8 +107,11 @@ eval cxt = \case (VInt i, VInt i1) -> pure $ VInt (i + i1) _ -> throwError "Can't add a function" + ELet _ _ -> throwError "ELet pattern match should never occur!" -maybeToRightM :: MonadError l m => l -> Maybe r -> m r -maybeToRightM err = liftEither . maybeToRight err +emptyEnv :: Cxt -> Cxt +emptyEnv cxt = cxt { env = mempty } +putEnv :: Env -> Cxt -> Cxt +putEnv env cxt = cxt { env = env } diff --git a/src/LambdaLifter.hs b/src/LambdaLifter.hs new file mode 100644 index 0000000..3d9595d --- /dev/null +++ b/src/LambdaLifter.hs @@ -0,0 +1,269 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} + + +module LambdaLifter (lambdaLift, freeVars, abstract, rename, collectScs) where + +import Auxiliary (snoc) +import Data.Foldable.Extra (notNull) +import Data.List (mapAccumL, mapAccumR, partition) +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Maybe (fromMaybe, mapMaybe) +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 localVars = \case + + EId n | Set.member n localVars -> (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 localVars e1 + e2' = freeVarsExp localVars e2 + + EAdd e1 e2 -> (Set.union (freeVarsOf e1') (freeVarsOf e2'), AAdd e1' e2') + where + e1' = freeVarsExp localVars e1 + e2' = freeVarsExp localVars e2 + + EAbs par e -> (Set.delete par $ freeVarsOf e', AAbs par e') + where + e' = freeVarsExp (Set.insert par localVars) e + + -- Sum free variables present in binders and the expression + ELet binders e -> (Set.union binders_frees e_free, ALet binders' e') + where + binders_frees = rhss_frees \\ names_set + e_free = freeVarsOf e' \\ names_set + + rhss_frees = foldr1 Set.union (map freeVarsOf rhss') + names_set = Set.fromList names + + (names, parms, rhss) = fromBinders binders + rhss' = map (freeVarsExp e_localVars) rhss + e_localVars = Set.union localVars names_set + + binders' = zipWith3 ABind names parms rhss' + e' = freeVarsExp e_localVars e + + +freeVarsOf :: AnnExp -> Set Ident +freeVarsOf = fst + +fromBinders :: [Bind] -> ([Ident], [[Ident]], [Exp]) +fromBinders bs = unzip3 [ (name, parms, rhs) | Bind name parms rhs <- 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 = \v₁ x₁ -> e₁@. +-- Free variables are @v₁ v₂ .. vₙ@ are bound. +abstract :: AnnProgram -> Program +abstract prog = Program $ map go prog + where + go :: (Ident, [Ident], AnnExp) -> Bind + go (name, pars, rhs@(_, e)) = + case e of + AAbs par e1 -> Bind name (snoc par pars ++ pars2) $ abstractExp e2 + where + (e2, pars2) = flattenLambdasAnn e1 + _ -> Bind name pars $ abstractExp rhs + + +-- | Flatten nested lambdas and collect the parameters +-- @\x.\y.\z. ae → (ae, [x,y,z])@ +flattenLambdasAnn :: AnnExp -> (AnnExp, [Ident]) +flattenLambdasAnn ae = go (ae, []) + where + go :: (AnnExp, [Ident]) -> (AnnExp, [Ident]) + go ((free, e), acc) = + case e of + AAbs par (free1, e1) -> go ((Set.delete par free1, e1), snoc par acc) + _ -> ((free, e), acc) + + +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 (map go bs) $ abstractExp e + where + go (ABind name parms rhs) = + let + (rhs', parms1) = flattenLambdas $ skipLambdas abstractExp rhs + in + Bind name (parms ++ parms1) rhs' + + skipLambdas :: (AnnExp -> Exp) -> AnnExp -> Exp + skipLambdas f (free, ae) = case ae of + AAbs name ae1 -> EAbs name $ skipLambdas f ae1 + _ -> f (free, ae) + + -- Lift lambda into let and bind free variables + AAbs par e -> foldl EApp sc $ map EId freeList + where + freeList = Set.toList free + sc = ELet [Bind "sc" (snoc par freeList) $ abstractExp e] $ EId "sc" + +-- | 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' pars' es') e') + where + (i1, e') = renameExp e_env i e + (names, pars, rhss) = fromBinders bs + (i2, ns', env') = newNames i1 (names ++ concat pars) + pars' = (map . map) renamePar pars + e_env = Map.union env' env + (i3, es') = mapAccumL (renameExp e_env) i2 rhss + + renamePar p = case Map.lookup p env' of + Just p' -> p' + Nothing -> error ("Can't find name for " ++ show p) + + + EAbs par e -> (i2, EAbs par' e') + where + (i1, par', env') = newName par + (i2, e') = renameExp (Map.union env' env ) i1 e + + +newName :: Ident -> (Int, Ident, Map Ident Ident) +newName old_name = (i, head names, env) + where (i, names, env) = newNames 1 [old_name] + +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 + +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 scs) = Program $ concatMap collectFromRhs scs + where + collectFromRhs (Bind name parms rhs) = + let (rhs_scs, rhs') = collectScsExp rhs + in Bind name parms rhs' : rhs_scs + + +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 + + -- Collect supercombinators from binds, the rhss, and the expression. + -- + -- > f = let + -- > sc = rhs + -- > sc1 = rhs1 + -- > ... + -- > in e + -- + ELet binds e -> (binds_scs ++ rhss_scs ++ e_scs, mkEAbs non_scs' e') + where + binds_scs = [ let (rhs', parms1) = flattenLambdas rhs in + Bind n (parms ++ parms1) rhs' + | Bind n parms rhs <- scs' + ] + (rhss_scs, binds') = mapAccumL collectScsRhs [] binds + (e_scs, e') = collectScsExp e + + (scs', non_scs') = partition (\(Bind _ pars _) -> notNull pars) binds' + + collectScsRhs acc (Bind n xs rhs) = (acc ++ rhs_scs, Bind n xs rhs') + where + (rhs_scs, rhs') = collectScsExp rhs + +-- @\x.\y.\z. e → (e, [x,y,z])@ +flattenLambdas :: Exp -> (Exp, [Ident]) +flattenLambdas e = go (e, []) + where + go (e, acc) = case e of + EAbs par e1 -> go (e1, snoc par acc) + _ -> (e, acc) + +mkEAbs :: [Bind] -> Exp -> Exp +mkEAbs [] e = e +mkEAbs bs e = ELet bs e diff --git a/src/Main.hs b/src/Main.hs index ed753f2..41379fc 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -1,30 +1,52 @@ {-# 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.ErrM (Err) +import Grammar.Par (myLexer, pProgram) +import Grammar.Print (printTree) +import Interpreter (interpret) +import LambdaLifter (abstract, freeVars, lambdaLift) +import System.Environment (getArgs) +import System.Exit (exitFailure, exitSuccess) main :: IO () main = getArgs >>= \case [] -> print "Required file path missing" - (x:_) -> do - file <- readFile x - case pProgram (myLexer file) of - Left err -> do - 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 + (s:_) -> main' s + +main' :: String -> IO () +main' s = do + file <- readFile s + + putStrLn "\n-- parse" + parsed <- fromSyntaxErr . pProgram $ myLexer file + putStrLn $ printTree parsed + + putStrLn "\n-- Lambda Lifter" + let lifted = lambdaLift parsed + putStrLn $ printTree lifted + + -- interpred <- fromInterpreterErr $ interpret lifted + -- putStrLn "\n-- interpret" + -- print interpred + + exitSuccess +fromSyntaxErr :: Err a -> IO a +fromSyntaxErr = either + (\err -> do + putStrLn "\nSYNTAX ERROR" + putStrLn err + exitFailure) + pure + +fromInterpreterErr :: Err a -> IO a +fromInterpreterErr = either + (\err -> do + putStrLn "\nINTERPRETER ERROR" + putStrLn err + exitFailure) + pure + diff --git a/test_program b/test_program deleted file mode 100644 index 83f3e9a..0000000 --- a/test_program +++ /dev/null @@ -1,5 +0,0 @@ - - - - -main = (\x -> x + x + 3) ((\x -> x) 2)