Rakarake/churf
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Fixed some small issues.

Browse source
This commit is contained in:
Samuel Hammersberg 2023-02-16 10:03:25 +01:00
parent 7ef7090aa5
commit 5680334fde
3 changed files with 124 additions and 108 deletions
Download patch file Download diff file Expand all files Collapse all files

13
sample-programs/basic-1
View file

@ -1,6 +1,13 @@
tripplemagic : Int -> Int -> Int -> Int; --tripplemagic : Int -> Int -> Int -> Int;
tripplemagic x y z = ((\x:Int. x+x) x) + y + z; --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 : Int;
main = tripplemagic ((\x:Int. x+x+3) ((\x:Int. x) 2)) 5 3 main = apply (\x:Int . x + 2) 5;

86
src/Compiler.hs
View file

@ -1,23 +1,27 @@
{-# LANGUAGE LambdaCase #-} {-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
module Compiler (compile) where module Compiler (compile) where
import Control.Monad.State (StateT, execStateT, gets, modify) import Control.Monad.State (StateT, execStateT, gets, modify)
import Data.Map (Map) import Data.Map (Map)
import qualified Data.Map as Map import Data.Map qualified as Map
import Data.Tuple.Extra (second) import Data.Tuple.Extra (second)
import Grammar.ErrM (Err) import Grammar.ErrM (Err)
import Grammar.Print (printTree) import Grammar.Print (printTree)
import LlvmIr (LLVMIr (..), LLVMType (..), import LlvmIr (
LLVMValue (..), llvmIrToString) LLVMIr (..),
import TypeChecker (partitionType) LLVMType (..),
import TypeCheckerIr LLVMValue (..),
llvmIrToString,
)
import TypeChecker (partitionType)
import TypeCheckerIr
-- | The record used as the code generator state -- | The record used as the code generator state
data CodeGenerator = CodeGenerator data CodeGenerator = CodeGenerator
{ instructions :: [LLVMIr] { instructions :: [LLVMIr]
, functions :: Map Id FunctionInfo , functions :: Map Id FunctionInfo
, variableCount :: Integer , variableCount :: Integer
} }
@ -25,7 +29,7 @@ data CodeGenerator = CodeGenerator
type CompilerState a = StateT CodeGenerator Err a type CompilerState a = StateT CodeGenerator Err a
data FunctionInfo = FunctionInfo data FunctionInfo = FunctionInfo
{ numArgs :: Int { numArgs :: Int
, arguments :: [Id] , arguments :: [Id]
} }
@ -118,32 +122,27 @@ compile (Program prg) = do
where where
t_return = snd $ partitionType (length args) t t_return = snd $ partitionType (length args) t
go :: Exp -> CompilerState () go :: Exp -> CompilerState ()
go (EInt int) = emitInt int go (EInt int) = emitInt int
go (EAdd t e1 e2) = emitAdd e1 e2 go (EAdd t e1 e2) = emitAdd t e1 e2
-- go (ESub e1 e2) = emitSub e1 e2 -- go (ESub e1 e2) = emitSub e1 e2
-- go (EMul e1 e2) = emitMul e1 e2 -- go (EMul e1 e2) = emitMul e1 e2
-- go (EDiv e1 e2) = emitDiv e1 e2 -- go (EDiv e1 e2) = emitDiv e1 e2
-- go (EMod e1 e2) = emitMod e1 e2 -- go (EMod e1 e2) = emitMod e1 e2
go (EId (name, _)) = emitIdent name 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 --- --- aux functions ---
emitAbs :: Ident -> Exp -> CompilerState () emitEAnn :: CompilerState ()
emitAbs id e = do emitEAnn = emit . UnsafeRaw $ "why?"
emit $
Comment $ emitAbs :: Type -> Id -> Exp -> CompilerState ()
concat emitAbs _t tid e = do
[ "EAbs (" emit . Comment $
, show id "Lambda escaped previous stages: \\" <> show tid <> " . " <> show e
, ", "
, show I64
, ", "
, show e
, ") is not implemented!"
]
emitLet :: [Bind] -> Exp -> CompilerState () emitLet :: [Bind] -> Exp -> CompilerState ()
emitLet xs e = do emitLet xs e = do
emit $ emit $
@ -156,18 +155,18 @@ compile (Program prg) = do
, ") is not implemented!" , ") is not implemented!"
] ]
emitApp :: Exp -> Exp -> CompilerState () emitApp :: Type -> Exp -> Exp -> CompilerState ()
emitApp e1 e2 = appEmitter e1 e2 [] emitApp t e1 e2 = appEmitter t e1 e2 []
where where
appEmitter :: Exp -> Exp -> [Exp] -> CompilerState () appEmitter :: Type -> Exp -> Exp -> [Exp] -> CompilerState ()
appEmitter e1 e2 stack = do appEmitter t e1 e2 stack = do
let newStack = e2 : stack let newStack = e2 : stack
case e1 of case e1 of
EApp t e1' e2' -> appEmitter e1' e2' newStack EApp t' e1' e2' -> appEmitter t' e1' e2' newStack
EId (name, _) -> do EId (name, _) -> do
args <- traverse exprToValue newStack args <- traverse exprToValue newStack
vs <- getNewVar 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 x -> do
emit . Comment $ "The unspeakable happened: " emit . Comment $ "The unspeakable happened: "
emit . Comment $ show x emit . Comment $ show x
@ -186,12 +185,12 @@ compile (Program prg) = do
emit $ Comment "This should not have happened!" emit $ Comment "This should not have happened!"
emit $ SetVariable (Ident (show varCount)) (Add I64 (VInteger i) (VInteger 0)) emit $ SetVariable (Ident (show varCount)) (Add I64 (VInteger i) (VInteger 0))
emitAdd :: Exp -> Exp -> CompilerState () emitAdd :: Type -> Exp -> Exp -> CompilerState ()
emitAdd e1 e2 = do emitAdd t e1 e2 = do
v1 <- exprToValue e1 v1 <- exprToValue e1
v2 <- exprToValue e2 v2 <- exprToValue e2
v <- getNewVar 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 :: Exp -> Exp -> CompilerState ()
-- emitMul e1 e2 = do -- emitMul e1 e2 = do
@ -255,5 +254,6 @@ compile (Program prg) = do
type2LlvmType :: Type -> LLVMType type2LlvmType :: Type -> LLVMType
type2LlvmType = \case type2LlvmType = \case
TInt -> I64 TInt -> I64
t -> error $ "missing type case: " ++ show t TFun t _ -> type2LlvmType t
t -> CustomType $ Ident ("\"" ++ show t ++ "\"")

133
src/Main.hs
View file

@ -1,88 +1,97 @@
{-# LANGUAGE LambdaCase #-} {-# LANGUAGE LambdaCase #-}
module Main where module Main where
import Compiler (compile) import Compiler (compile)
import GHC.IO.Handle.Text (hPutStrLn) import GHC.IO.Handle.Text (hPutStrLn)
import Grammar.ErrM (Err) import Grammar.ErrM (Err)
import Grammar.Par (myLexer, pProgram) import Grammar.Par (myLexer, pProgram)
import Grammar.Print (printTree) import Grammar.Print (printTree)
--import Interpreter (interpret)
import LambdaLifter (lambdaLift) -- import Interpreter (interpret)
import Renamer (rename) import LambdaLifter (lambdaLift)
import System.Environment (getArgs) import Renamer (rename)
import System.Exit (exitFailure, exitSuccess) import System.Environment (getArgs)
import System.IO (stderr) import System.Exit (exitFailure, exitSuccess)
import TypeChecker (typecheck) import System.IO (stderr)
import TypeChecker (typecheck)
main :: IO () main :: IO ()
main = getArgs >>= \case main =
[] -> print "Required file path missing" getArgs >>= \case
(s:_) -> main' s [] -> print "Required file path missing"
(s : _) -> main' s
main' :: String -> IO () main' :: String -> IO ()
main' s = do main' s = do
file <- readFile s file <- readFile s
printToErr "-- Parse Tree -- " printToErr "-- Parse Tree -- "
parsed <- fromSyntaxErr . pProgram $ myLexer file parsed <- fromSyntaxErr . pProgram $ myLexer file
printToErr $ printTree parsed printToErr $ printTree parsed
putStrLn "\n-- Renamer --" printToErr "\n-- Renamer --"
let renamed = rename parsed let renamed = rename parsed
putStrLn $ printTree renamed printToErr $ printTree renamed
putStrLn "\n-- TypeChecker --" printToErr "\n-- TypeChecker --"
typechecked <- fromTypeCheckerErr $ typecheck renamed typechecked <- fromTypeCheckerErr $ typecheck renamed
putStrLn $ printTree typechecked printToErr $ printTree typechecked
printToErr "\n-- Lambda Lifter --" printToErr "\n-- Lambda Lifter --"
let lifted = lambdaLift typechecked let lifted = lambdaLift typechecked
printToErr $ printTree lifted printToErr $ printTree lifted
printToErr "\n -- Printing compiler output to stdout --" printToErr "\n -- Printing compiler output to stdout --"
compiled <- fromCompilerErr $ compile lifted compiled <- fromCompilerErr $ compile lifted
putStrLn compiled putStrLn compiled
writeFile "llvm.ll" compiled writeFile "llvm.ll" compiled
-- interpred <- fromInterpreterErr $ interpret lifted -- interpred <- fromInterpreterErr $ interpret lifted
-- putStrLn "\n-- interpret" -- putStrLn "\n-- interpret"
-- print interpred -- print interpred
exitSuccess exitSuccess
printToErr :: String -> IO () printToErr :: String -> IO ()
printToErr = hPutStrLn stderr printToErr = hPutStrLn stderr
fromCompilerErr :: Err a -> IO a fromCompilerErr :: Err a -> IO a
fromCompilerErr = either fromCompilerErr =
(\err -> do either
putStrLn "\nCOMPILER ERROR" ( \err -> do
putStrLn err putStrLn "\nCOMPILER ERROR"
exitFailure) putStrLn err
pure exitFailure
)
pure
fromSyntaxErr :: Err a -> IO a fromSyntaxErr :: Err a -> IO a
fromSyntaxErr = either fromSyntaxErr =
(\err -> do either
putStrLn "\nSYNTAX ERROR" ( \err -> do
putStrLn err putStrLn "\nSYNTAX ERROR"
exitFailure) putStrLn err
pure exitFailure
)
pure
fromTypeCheckerErr :: Err a -> IO a fromTypeCheckerErr :: Err a -> IO a
fromTypeCheckerErr = either fromTypeCheckerErr =
(\err -> do either
putStrLn "\nTYPECHECKER ERROR" ( \err -> do
putStrLn err putStrLn "\nTYPECHECKER ERROR"
exitFailure) putStrLn err
pure exitFailure
)
pure
fromInterpreterErr :: Err a -> IO a fromInterpreterErr :: Err a -> IO a
fromInterpreterErr = either fromInterpreterErr =
(\err -> do either
putStrLn "\nINTERPRETER ERROR" ( \err -> do
putStrLn err putStrLn "\nINTERPRETER ERROR"
exitFailure) putStrLn err
pure exitFailure
)
pure