From 5680334fde2a8bd7aaf1c6814501c72011cdb744 Mon Sep 17 00:00:00 2001 From: Samuel Hammersberg Date: Thu, 16 Feb 2023 10:03:25 +0100 Subject: [PATCH] Fixed some small issues. --- sample-programs/basic-1 | 13 +++- src/Compiler.hs | 86 +++++++++++++------------- src/Main.hs | 133 +++++++++++++++++++++------------------- 3 files changed, 124 insertions(+), 108 deletions(-) diff --git a/sample-programs/basic-1 b/sample-programs/basic-1 index a5d9d9b..f3f4a26 100644 --- a/sample-programs/basic-1 +++ b/sample-programs/basic-1 @@ -1,6 +1,13 @@ -tripplemagic : Int -> Int -> Int -> Int; -tripplemagic x y z = ((\x:Int. x+x) x) + y + z; +--tripplemagic : Int -> Int -> Int -> Int; +--tripplemagic x y z = ((\x:Int. x+x) x) + y + z; + +-- main : Int; +-- main = tripplemagic ((\x:Int. x+x+3) ((\x:Int. x) 2)) 5 3 + +apply : (Int -> Int) -> Int -> Int; +apply f x = f x; main : Int; -main = tripplemagic ((\x:Int. x+x+3) ((\x:Int. x) 2)) 5 3 +main = apply (\x:Int . x + 2) 5; + diff --git a/src/Compiler.hs b/src/Compiler.hs index 7c65cd5..e2bf19b 100644 --- a/src/Compiler.hs +++ b/src/Compiler.hs @@ -1,23 +1,27 @@ -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} module Compiler (compile) where -import Control.Monad.State (StateT, execStateT, gets, modify) -import Data.Map (Map) -import qualified Data.Map as Map -import Data.Tuple.Extra (second) -import Grammar.ErrM (Err) -import Grammar.Print (printTree) -import LlvmIr (LLVMIr (..), LLVMType (..), - LLVMValue (..), llvmIrToString) -import TypeChecker (partitionType) -import TypeCheckerIr +import Control.Monad.State (StateT, execStateT, gets, modify) +import Data.Map (Map) +import Data.Map qualified as Map +import Data.Tuple.Extra (second) +import Grammar.ErrM (Err) +import Grammar.Print (printTree) +import LlvmIr ( + LLVMIr (..), + LLVMType (..), + LLVMValue (..), + llvmIrToString, + ) +import TypeChecker (partitionType) +import TypeCheckerIr -- | The record used as the code generator state data CodeGenerator = CodeGenerator - { instructions :: [LLVMIr] - , functions :: Map Id FunctionInfo + { instructions :: [LLVMIr] + , functions :: Map Id FunctionInfo , variableCount :: Integer } @@ -25,7 +29,7 @@ data CodeGenerator = CodeGenerator type CompilerState a = StateT CodeGenerator Err a data FunctionInfo = FunctionInfo - { numArgs :: Int + { numArgs :: Int , arguments :: [Id] } @@ -118,32 +122,27 @@ compile (Program prg) = do where t_return = snd $ partitionType (length args) t - - go :: Exp -> CompilerState () - go (EInt int) = emitInt int - go (EAdd t e1 e2) = emitAdd e1 e2 + go (EInt int) = emitInt int + go (EAdd t e1 e2) = emitAdd t e1 e2 -- go (ESub e1 e2) = emitSub e1 e2 -- go (EMul e1 e2) = emitMul e1 e2 -- go (EDiv e1 e2) = emitDiv e1 e2 -- go (EMod e1 e2) = emitMod e1 e2 go (EId (name, _)) = emitIdent name - go (EApp t e1 e2) = emitApp e1 e2 + go (EApp t e1 e2) = emitApp t e1 e2 + go (EAbs t ti e) = emitAbs t ti e + go (ELet binds e) = emitLet binds e + go (EAnn _ _) = emitEAnn --- aux functions --- - emitAbs :: Ident -> Exp -> CompilerState () - emitAbs id e = do - emit $ - Comment $ - concat - [ "EAbs (" - , show id - , ", " - , show I64 - , ", " - , show e - , ") is not implemented!" - ] + emitEAnn :: CompilerState () + emitEAnn = emit . UnsafeRaw $ "why?" + + emitAbs :: Type -> Id -> Exp -> CompilerState () + emitAbs _t tid e = do + emit . Comment $ + "Lambda escaped previous stages: \\" <> show tid <> " . " <> show e emitLet :: [Bind] -> Exp -> CompilerState () emitLet xs e = do emit $ @@ -156,18 +155,18 @@ compile (Program prg) = do , ") is not implemented!" ] - emitApp :: Exp -> Exp -> CompilerState () - emitApp e1 e2 = appEmitter e1 e2 [] + emitApp :: Type -> Exp -> Exp -> CompilerState () + emitApp t e1 e2 = appEmitter t e1 e2 [] where - appEmitter :: Exp -> Exp -> [Exp] -> CompilerState () - appEmitter e1 e2 stack = do + appEmitter :: Type -> Exp -> Exp -> [Exp] -> CompilerState () + appEmitter t e1 e2 stack = do let newStack = e2 : stack case e1 of - EApp t e1' e2' -> appEmitter e1' e2' newStack + EApp t' e1' e2' -> appEmitter t' e1' e2' newStack EId (name, _) -> do args <- traverse exprToValue newStack vs <- getNewVar - emit $ SetVariable (Ident $ show vs) (Call I64 name (map (I64,) args)) + emit $ SetVariable (Ident $ show vs) (Call (type2LlvmType t) name (map (I64,) args)) x -> do emit . Comment $ "The unspeakable happened: " emit . Comment $ show x @@ -186,12 +185,12 @@ compile (Program prg) = do emit $ Comment "This should not have happened!" emit $ SetVariable (Ident (show varCount)) (Add I64 (VInteger i) (VInteger 0)) - emitAdd :: Exp -> Exp -> CompilerState () - emitAdd e1 e2 = do + emitAdd :: Type -> Exp -> Exp -> CompilerState () + emitAdd t e1 e2 = do v1 <- exprToValue e1 v2 <- exprToValue e2 v <- getNewVar - emit $ SetVariable (Ident $ show v) (Add I64 v1 v2) + emit $ SetVariable (Ident $ show v) (Add (type2LlvmType t) v1 v2) -- emitMul :: Exp -> Exp -> CompilerState () -- emitMul e1 e2 = do @@ -255,5 +254,6 @@ compile (Program prg) = do type2LlvmType :: Type -> LLVMType type2LlvmType = \case - TInt -> I64 - t -> error $ "missing type case: " ++ show t + TInt -> I64 + TFun t _ -> type2LlvmType t + t -> CustomType $ Ident ("\"" ++ show t ++ "\"") diff --git a/src/Main.hs b/src/Main.hs index c47a3ee..1831428 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -1,88 +1,97 @@ {-# LANGUAGE LambdaCase #-} + module Main where -import Compiler (compile) -import GHC.IO.Handle.Text (hPutStrLn) -import Grammar.ErrM (Err) -import Grammar.Par (myLexer, pProgram) -import Grammar.Print (printTree) ---import Interpreter (interpret) -import LambdaLifter (lambdaLift) -import Renamer (rename) -import System.Environment (getArgs) -import System.Exit (exitFailure, exitSuccess) -import System.IO (stderr) -import TypeChecker (typecheck) +import Compiler (compile) +import GHC.IO.Handle.Text (hPutStrLn) +import Grammar.ErrM (Err) +import Grammar.Par (myLexer, pProgram) +import Grammar.Print (printTree) + +-- import Interpreter (interpret) +import LambdaLifter (lambdaLift) +import Renamer (rename) +import System.Environment (getArgs) +import System.Exit (exitFailure, exitSuccess) +import System.IO (stderr) +import TypeChecker (typecheck) main :: IO () -main = getArgs >>= \case - [] -> print "Required file path missing" - (s:_) -> main' s +main = + getArgs >>= \case + [] -> print "Required file path missing" + (s : _) -> main' s main' :: String -> IO () main' s = do - file <- readFile s + file <- readFile s - printToErr "-- Parse Tree -- " - parsed <- fromSyntaxErr . pProgram $ myLexer file - printToErr $ printTree parsed + printToErr "-- Parse Tree -- " + parsed <- fromSyntaxErr . pProgram $ myLexer file + printToErr $ printTree parsed - putStrLn "\n-- Renamer --" - let renamed = rename parsed - putStrLn $ printTree renamed + printToErr "\n-- Renamer --" + let renamed = rename parsed + printToErr $ printTree renamed - putStrLn "\n-- TypeChecker --" - typechecked <- fromTypeCheckerErr $ typecheck renamed - putStrLn $ printTree typechecked + printToErr "\n-- TypeChecker --" + typechecked <- fromTypeCheckerErr $ typecheck renamed + printToErr $ printTree typechecked - printToErr "\n-- Lambda Lifter --" - let lifted = lambdaLift typechecked - printToErr $ printTree lifted + printToErr "\n-- Lambda Lifter --" + let lifted = lambdaLift typechecked + printToErr $ printTree lifted - printToErr "\n -- Printing compiler output to stdout --" - compiled <- fromCompilerErr $ compile lifted - putStrLn compiled - writeFile "llvm.ll" compiled + printToErr "\n -- Printing compiler output to stdout --" + compiled <- fromCompilerErr $ compile lifted + putStrLn compiled + writeFile "llvm.ll" compiled - -- interpred <- fromInterpreterErr $ interpret lifted - -- putStrLn "\n-- interpret" - -- print interpred + -- interpred <- fromInterpreterErr $ interpret lifted + -- putStrLn "\n-- interpret" + -- print interpred - exitSuccess + exitSuccess printToErr :: String -> IO () printToErr = hPutStrLn stderr fromCompilerErr :: Err a -> IO a -fromCompilerErr = either - (\err -> do - putStrLn "\nCOMPILER ERROR" - putStrLn err - exitFailure) - pure +fromCompilerErr = + either + ( \err -> do + putStrLn "\nCOMPILER ERROR" + putStrLn err + exitFailure + ) + pure fromSyntaxErr :: Err a -> IO a -fromSyntaxErr = either - (\err -> do - putStrLn "\nSYNTAX ERROR" - putStrLn err - exitFailure) - pure +fromSyntaxErr = + either + ( \err -> do + putStrLn "\nSYNTAX ERROR" + putStrLn err + exitFailure + ) + pure fromTypeCheckerErr :: Err a -> IO a -fromTypeCheckerErr = either - (\err -> do - putStrLn "\nTYPECHECKER ERROR" - putStrLn err - exitFailure) - pure +fromTypeCheckerErr = + either + ( \err -> do + putStrLn "\nTYPECHECKER ERROR" + putStrLn err + exitFailure + ) + pure fromInterpreterErr :: Err a -> IO a -fromInterpreterErr = either - (\err -> do - putStrLn "\nINTERPRETER ERROR" - putStrLn err - exitFailure) - pure - - +fromInterpreterErr = + either + ( \err -> do + putStrLn "\nINTERPRETER ERROR" + putStrLn err + exitFailure + ) + pure