From 42c8ebc7b6f2ce4351285d182a9bde22d16ea384 Mon Sep 17 00:00:00 2001 From: sebastianselander Date: Thu, 23 Mar 2023 16:49:49 +0100 Subject: [PATCH] Making progress towards finished product --- language.cabal | 7 +- src/LambdaLifter/LambdaLifter.hs | 334 ++++++++++++++++--------------- src/Main.hs | 63 +++--- src/TypeChecker/TypeChecker.hs | 12 ++ tests/Tests.hs | 1 - 5 files changed, 222 insertions(+), 195 deletions(-) diff --git a/language.cabal b/language.cabal index dc436a5..a35b5f0 100644 --- a/language.cabal +++ b/language.cabal @@ -34,9 +34,9 @@ executable language TypeChecker.TypeChecker TypeChecker.TypeCheckerIr Renamer.Renamer - -- LambdaLifter.LambdaLifter - -- Codegen.Codegen - -- Codegen.LlvmIr + LambdaLifter.LambdaLifter + Codegen.Codegen + Codegen.LlvmIr hs-source-dirs: src @@ -49,6 +49,7 @@ executable language , array , hspec , QuickCheck + , directory default-language: GHC2021 diff --git a/src/LambdaLifter/LambdaLifter.hs b/src/LambdaLifter/LambdaLifter.hs index 271cc70..a09f1a7 100644 --- a/src/LambdaLifter/LambdaLifter.hs +++ b/src/LambdaLifter/LambdaLifter.hs @@ -1,192 +1,194 @@ ---{-# LANGUAGE LambdaCase #-} ---{-# LANGUAGE OverloadedStrings #-} - +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} module LambdaLifter.LambdaLifter where ---import Auxiliary (snoc) ---import Control.Applicative (Applicative (liftA2)) ---import Control.Monad.State (MonadState (get, put), State, --- evalState) ---import Data.Set (Set) ---import qualified Data.Set as Set ---import Prelude hiding (exp) ---import Renamer.Renamer ---import TypeChecker.TypeCheckerIr +import Auxiliary (snoc) +import Control.Applicative (Applicative (liftA2)) +import Control.Monad.State (MonadState (get, put), State, evalState) +import Data.Set (Set) +import Data.Set qualified as Set +import Renamer.Renamer +import TypeChecker.TypeChecker (partitionType) +import TypeChecker.TypeCheckerIr +import Prelude hiding (exp) +{- | Lift lambdas and let expression into supercombinators. +Three phases: +@freeVars@ annotates all the free variables. +@abstract@ converts lambdas into let expressions. +@collectScs@ moves every non-constant let expression to a top-level function. +-} +lambdaLift :: Program -> Program +lambdaLift = collectScs . abstract . freeVars ----- | Lift lambdas and let expression into supercombinators. ----- Three phases: ----- @freeVars@ annotatss all the free variables. ----- @abstract@ converts lambdas into let expressions. ----- @collectScs@ moves every non-constant let expression to a top-level function. ---lambdaLift :: Program -> Program ---lambdaLift = collectScs . abstract . freeVars +-- | Annotate free variables +freeVars :: Program -> AnnProgram +freeVars (Program ds) = + [ (n, xs, freeVarsExp (Set.fromList $ map fst xs) e) + | Bind n xs e <- ds + ] +freeVarsExp :: Set Ident -> ExpT -> AnnExpT +freeVarsExp localVars (exp, t) = case exp of + EId n + | Set.member n localVars -> (Set.singleton n, (AId n, t)) + | otherwise -> (mempty, (AId n, t)) + -- EInt i -> (mempty, AInt i) + ELit lit -> (mempty, (ALit lit, t)) + EApp e1 e2 -> (Set.union (freeVarsOf e1') (freeVarsOf e2'), (AApp e1' e2', t)) + where + e1' = freeVarsExp localVars e1 + e2' = freeVarsExp localVars e2 + EAdd e1 e2 -> (Set.union (freeVarsOf e1') (freeVarsOf e2'), (AAdd e1' e2', t)) + where + e1' = freeVarsExp localVars e1 + e2' = freeVarsExp localVars e2 + EAbs par e -> (Set.delete par $ freeVarsOf e', (AAbs par e', t)) + where + e' = freeVarsExp (Set.insert par localVars) e ----- | Annotate free variables ---freeVars :: Program -> AnnProgram ---freeVars (Program ds) = [ (n, xs, freeVarsExp (Set.fromList xs) e) --- | Bind n xs e <- ds --- ] + -- Sum free variables present in bind and the expression + ELet (Bind (name, t_bind) parms rhs) e -> (Set.union binders_frees e_free, (ALet new_bind e', t)) + where + binders_frees = Set.delete name $ freeVarsOf rhs' + e_free = Set.delete name $ freeVarsOf e' ---freeVarsExp :: Set Id -> Exp -> AnnExp ---freeVarsExp localVars = \case --- EId n | Set.member n localVars -> (Set.singleton n, AId n) --- | otherwise -> (mempty, AId n) + rhs' = freeVarsExp e_localVars rhs + new_bind = ABind (name, t_bind) parms rhs' --- ELit _ (LInt i) -> (mempty, AInt i) + e' = freeVarsExp e_localVars e + e_localVars = Set.insert name localVars --- EApp t e1 e2 -> (Set.union (freeVarsOf e1') (freeVarsOf e2'), AApp t e1' e2') --- where --- e1' = freeVarsExp localVars e1 --- e2' = freeVarsExp localVars e2 +freeVarsOf :: AnnExpT -> Set Ident +freeVarsOf = fst --- EAdd t e1 e2 -> (Set.union (freeVarsOf e1') (freeVarsOf e2'), AAdd t e1' e2') --- where --- e1' = freeVarsExp localVars e1 --- e2' = freeVarsExp localVars e2 +-- AST annotated with free variables +type AnnProgram = [(Id, [Id], AnnExpT)] --- EAbs t par e -> (Set.delete par $ freeVarsOf e', AAbs t par e') --- where --- e' = freeVarsExp (Set.insert par localVars) e +type AnnExpT = (Set Ident, AnnExpT') --- -- Sum free variables present in bind and the expression --- ELet (Bind name parms rhs) e -> (Set.union binders_frees e_free, ALet new_bind e') --- where --- binders_frees = Set.delete name $ freeVarsOf rhs' --- e_free = Set.delete name $ freeVarsOf e' +data ABind = ABind Id [Id] AnnExpT deriving (Show) --- rhs' = freeVarsExp e_localVars rhs --- new_bind = ABind name parms rhs' +type AnnExpT' = (AnnExp, Type) --- e' = freeVarsExp e_localVars e --- e_localVars = Set.insert name localVars +data AnnExp + = AId Ident + | ALit Lit + | ALet ABind AnnExpT + | AApp AnnExpT AnnExpT + | AAdd AnnExpT AnnExpT + | AAbs Ident AnnExpT + 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 $ evalState (mapM go prog) 0 + where + go :: (Id, [Id], AnnExpT) -> State Int Bind + go (name, parms, rhs) = Bind name (parms ++ parms1) <$> abstractExp rhs' + where + (rhs', parms1) = flattenLambdasAnn rhs ---freeVarsOf :: AnnExp -> Set Id ---freeVarsOf = fst +{- | Flatten nested lambdas and collect the parameters +@\x.\y.\z. ae → (ae, [x,y,z])@ +-} +flattenLambdasAnn :: AnnExpT -> (AnnExpT, [Id]) +flattenLambdasAnn ae = go (ae, []) + where + go :: (AnnExpT, [Id]) -> (AnnExpT, [Id]) + go ((free, (e, t)), acc) + | AAbs par (free1, e1) <- e + , TFun t_par _ <- t = + go ((Set.delete par free1, e1), snoc (par, t_par) acc) + | otherwise = ((free, (e, t)), acc) ----- AST annotated with free variables ---type AnnProgram = [(Id, [Id], AnnExp)] +abstractExp :: AnnExpT -> State Int ExpT +abstractExp (free, (exp, t)) = case exp of + AId n -> pure (EId n, t) + ALit lit -> pure (ELit lit, t) + AApp e1 e2 -> (,t) <$> liftA2 EApp (abstractExp e1) (abstractExp e2) + AAdd e1 e2 -> (,t) <$> liftA2 EAdd (abstractExp e1) (abstractExp e2) + ALet b e -> (,t) <$> liftA2 ELet (go b) (abstractExp e) + where + go (ABind name parms rhs) = do + (rhs', parms1) <- flattenLambdas <$> skipLambdas abstractExp rhs + pure $ Bind name (parms ++ parms1) rhs' ---type AnnExp = (Set Id, AnnExp') + skipLambdas :: (AnnExpT -> State Int ExpT) -> AnnExpT -> State Int ExpT + skipLambdas f (free, (ae, t)) = case ae of + AAbs par ae1 -> do + ae1' <- skipLambdas f ae1 + pure (EAbs par ae1', t) + _ -> f (free, (ae, t)) ---data ABind = ABind Id [Id] AnnExp deriving Show + -- Lift lambda into let and bind free variables + AAbs parm e -> do + i <- nextNumber + rhs <- abstractExp e ---data AnnExp' = AId Id --- | AInt Integer --- | ALet ABind AnnExp --- | AApp Type AnnExp AnnExp --- | AAdd Type AnnExp AnnExp --- | AAbs Type Id 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 $ evalState (mapM go prog) 0 --- where --- go :: (Id, [Id], AnnExp) -> State Int Bind --- go (name, parms, rhs) = Bind name (parms ++ parms1) <$> abstractExp rhs' --- where --- (rhs', parms1) = flattenLambdasAnn rhs + let sc_name = Ident ("sc_" ++ show i) + sc = (ELet (Bind (sc_name, t) vars rhs) (EId sc_name, t), t) + pure $ foldl applyVars sc freeList + where + freeList = Set.toList free + vars = zip names . fst $ partitionType (length names) t + names = snoc parm freeList + applyVars (e, t) name = (EApp (e, t) (EId name, t_var), t_return) + where + (t_var : _, t_return) = partitionType 1 t +nextNumber :: State Int Int +nextNumber = do + i <- get + put $ succ i + pure i ----- | Flatten nested lambdas and collect the parameters ----- @\x.\y.\z. ae → (ae, [x,y,z])@ ---flattenLambdasAnn :: AnnExp -> (AnnExp, [Id]) ---flattenLambdasAnn ae = go (ae, []) --- where --- go :: (AnnExp, [Id]) -> (AnnExp, [Id]) --- go ((free, e), acc) = --- case e of --- AAbs _ par (free1, e1) -> --- go ((Set.delete par free1, e1), snoc par acc) --- _ -> ((free, e), acc) +-- | Collects supercombinators by lifting non-constant 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 ---abstractExp :: AnnExp -> State Int Exp ---abstractExp (free, exp) = case exp of --- AId n -> pure $ EId n --- AInt i -> pure $ ELit (TMono "Int") (LInt i) --- AApp t e1 e2 -> liftA2 (EApp t) (abstractExp e1) (abstractExp e2) --- AAdd t e1 e2 -> liftA2 (EAdd t) (abstractExp e1) (abstractExp e2) --- ALet b e -> liftA2 ELet (go b) (abstractExp e) --- where --- go (ABind name parms rhs) = do --- (rhs', parms1) <- flattenLambdas <$> skipLambdas abstractExp rhs --- pure $ Bind name (parms ++ parms1) rhs' +collectScsExp :: ExpT -> ([Bind], ExpT) +collectScsExp expT@(exp, typ) = case exp of + EId _ -> ([], expT) + ELit _ -> ([], expT) + EApp e1 e2 -> (scs1 ++ scs2, (EApp e1' e2', typ)) + where + (scs1, e1') = collectScsExp e1 + (scs2, e2') = collectScsExp e2 + EAdd e1 e2 -> (scs1 ++ scs2, (EAdd e1' e2', typ)) + where + (scs1, e1') = collectScsExp e1 + (scs2, e2') = collectScsExp e2 + EAbs par e -> (scs, (EAbs par e', typ)) + where + (scs, e') = collectScsExp e --- skipLambdas :: (AnnExp -> State Int Exp) -> AnnExp -> State Int Exp --- skipLambdas f (free, ae) = case ae of --- AAbs t par ae1 -> EAbs t par <$> skipLambdas f ae1 --- _ -> f (free, ae) - --- -- Lift lambda into let and bind free variables --- AAbs t parm e -> do --- i <- nextNumber --- rhs <- abstractExp e - --- let sc_name = Ident ("sc_" ++ show i) --- sc = ELet (Bind (sc_name, t) parms rhs) $ EId (sc_name, t) - --- pure $ foldl (EApp $ TMono "Int") sc $ map EId freeList --- where --- freeList = Set.toList free --- parms = snoc parm freeList - - ---nextNumber :: State Int Int ---nextNumber = do --- i <- get --- put $ succ i --- pure i - ----- | Collects supercombinators by lifting non-constant 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) --- ELit _ (LInt i) -> ([], ELit (TMono "Int") (LInt i)) - --- EApp t e1 e2 -> (scs1 ++ scs2, EApp t e1' e2') --- where --- (scs1, e1') = collectScsExp e1 --- (scs2, e2') = collectScsExp e2 - --- EAdd t e1 e2 -> (scs1 ++ scs2, EAdd t e1' e2') --- where --- (scs1, e1') = collectScsExp e1 --- (scs2, e2') = collectScsExp e2 - --- EAbs t par e -> (scs, EAbs t par e') --- where --- (scs, e') = collectScsExp e - --- -- Collect supercombinators from bind, the rhss, and the expression. --- -- --- -- > f = let sc x y = rhs in e --- -- --- ELet (Bind name parms rhs) e -> if null parms --- then ( rhs_scs ++ e_scs, ELet bind e') --- else (bind : rhs_scs ++ e_scs, e') --- where --- bind = Bind name parms rhs' --- (rhs_scs, rhs') = collectScsExp rhs --- (e_scs, e') = collectScsExp e - - ----- @\x.\y.\z. e → (e, [x,y,z])@ ---flattenLambdas :: Exp -> (Exp, [Id]) ---flattenLambdas = go . (, []) --- where --- go (e, acc) = case e of --- EAbs _ par e1 -> go (e1, snoc par acc) --- _ -> (e, acc) + -- Collect supercombinators from bind, the rhss, and the expression. + -- + -- > f = let sc x y = rhs in e + -- + ELet (Bind name parms rhs) e -> + if null parms + then (rhs_scs ++ et_scs, (ELet bind et', snd et')) + else (bind : rhs_scs ++ et_scs, et') + where + bind = Bind name parms rhs' + (rhs_scs, rhs') = collectScsExp rhs + (et_scs, et') = collectScsExp e +-- @\x.\y.\z. e → (e, [x,y,z])@ +flattenLambdas :: ExpT -> (ExpT, [Id]) +flattenLambdas = go . (,[]) + where + go ((e, t), acc) = case e of + EAbs name e1 -> go (e1, snoc (name, t_var) acc) + where + t_var : _ = fst $ partitionType 1 t + _ -> ((e, t), acc) diff --git a/src/Main.hs b/src/Main.hs index c82f6a5..edb3eea 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -2,32 +2,36 @@ module Main where ---import Codegen.Codegen (generateCode) -import GHC.IO.Handle.Text (hPutStrLn) -import Grammar.ErrM (Err) -import Grammar.Par (myLexer, pProgram) -import Grammar.Print (printTree) +-- import Codegen.Codegen (generateCode) +import GHC.IO.Handle.Text (hPutStrLn) +import Grammar.ErrM (Err) +import Grammar.Par (myLexer, pProgram) +import Grammar.Print (printTree) -- import Interpreter (interpret) -import Control.Monad (when) -import Data.List.Extra (isSuffixOf) ---import LambdaLifter.LambdaLifter (lambdaLift) -import Renamer.Renamer (rename) -import System.Directory (createDirectory, doesPathExist, - getDirectoryContents, - removeDirectoryRecursive, - setCurrentDirectory) -import System.Environment (getArgs) -import System.Exit (exitFailure, exitSuccess) -import System.IO (stderr) -import System.Process.Extra (spawnCommand, waitForProcess) -import TypeChecker.TypeChecker (typecheck) +import Control.Monad (when) +import Data.List.Extra (isSuffixOf) + +-- import LambdaLifter.LambdaLifter (lambdaLift) +import Renamer.Renamer (rename) +import System.Directory ( + createDirectory, + doesPathExist, + getDirectoryContents, + removeDirectoryRecursive, + setCurrentDirectory, + ) +import System.Environment (getArgs) +import System.Exit (exitFailure, exitSuccess) +import System.IO (stderr) +import System.Process.Extra (spawnCommand, waitForProcess) +import TypeChecker.TypeChecker (typecheck) main :: IO () main = getArgs >>= \case [] -> print "Required file path missing" - ("-d": s : _) -> main' True s + ("-d" : s : _) -> main' True s (s : _) -> main' False s main' :: Bool -> String -> IO () @@ -39,7 +43,7 @@ main' debug s = do printToErr $ printTree parsed printToErr "\n-- Renamer --" - let renamed = rename parsed + renamed <- fromRenamerErr . rename $ parsed printToErr $ printTree renamed printToErr "\n-- TypeChecker --" @@ -49,10 +53,10 @@ main' debug s = do -- printToErr "\n-- Lambda Lifter --" -- let lifted = lambdaLift typechecked -- printToErr $ printTree lifted --- + -- -- printToErr "\n -- Printing compiler output to stdout --" -- compiled <- fromCompilerErr $ generateCode lifted - --putStrLn compiled + -- putStrLn compiled -- check <- doesPathExist "output" -- when check (removeDirectoryRecursive "output") @@ -60,7 +64,6 @@ main' debug s = do -- writeFile "output/llvm.ll" compiled -- if debug then debugDotViz else putStrLn compiled - -- interpred <- fromInterpreterErr $ interpret lifted -- putStrLn "\n-- interpret" -- print interpred @@ -76,8 +79,8 @@ debugDotViz = do mapM_ spawnWait commands setCurrentDirectory ".." return () - where - spawnWait s = spawnCommand s >>= waitForProcess + where + spawnWait s = spawnCommand s >>= waitForProcess printToErr :: String -> IO () printToErr = hPutStrLn stderr @@ -111,6 +114,16 @@ fromTypeCheckerErr = ) pure +fromRenamerErr :: Err a -> IO a +fromRenamerErr = + either + ( \err -> do + putStrLn "\nRENAMER ERROR" + putStrLn err + exitFailure + ) + pure + fromInterpreterErr :: Err a -> IO a fromInterpreterErr = either diff --git a/src/TypeChecker/TypeChecker.hs b/src/TypeChecker/TypeChecker.hs index 2bab6c8..b75f4e1 100644 --- a/src/TypeChecker/TypeChecker.hs +++ b/src/TypeChecker/TypeChecker.hs @@ -517,3 +517,15 @@ litType (LChar _) = char int = T.TLit "Int" char = T.TLit "Char" + +partitionType :: + Int -> -- Number of parameters to apply + Type -> + ([Type], Type) +partitionType = go [] + where + go acc 0 t = (acc, t) + go acc i t = case t of + TAll tvar t' -> second (TAll tvar) $ go acc i t' + TFun t1 t2 -> go (acc ++ [t1]) (i - 1) t2 + _ -> error "Number of parameters and type doesn't match" diff --git a/tests/Tests.hs b/tests/Tests.hs index 27a4eca..9c5649f 100644 --- a/tests/Tests.hs +++ b/tests/Tests.hs @@ -18,7 +18,6 @@ import TypeChecker.TypeCheckerIr ( Env (..), Error, Infer, - Poly (..), ) import TypeChecker.TypeCheckerIr qualified as T