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 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;

60
src/Compiler.hs
View file

@ -5,12 +5,16 @@ module Compiler (compile) where
import Control.Monad.State (StateT, execStateT, gets, modify)
import Data.Map (Map)
import qualified Data.Map as 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 LlvmIr (
LLVMIr (..),
LLVMType (..),
LLVMValue (..),
llvmIrToString,
)
import TypeChecker (partitionType)
import TypeCheckerIr
@ -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 (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
@ -256,4 +255,5 @@ compile (Program prg) = do
type2LlvmType :: Type -> LLVMType
type2LlvmType = \case
TInt -> I64
t -> error $ "missing type case: " ++ show t
TFun t _ -> type2LlvmType t
t -> CustomType $ Ident ("\"" ++ show t ++ "\"")

39
src/Main.hs
View file

@ -1,4 +1,5 @@
{-# LANGUAGE LambdaCase #-}
module Main where
import Compiler (compile)
@ -6,6 +7,7 @@ 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)
@ -15,7 +17,8 @@ import System.IO (stderr)
import TypeChecker (typecheck)
main :: IO ()
main = getArgs >>= \case
main =
getArgs >>= \case
[] -> print "Required file path missing"
(s : _) -> main' s
@ -27,13 +30,13 @@ main' s = do
parsed <- fromSyntaxErr . pProgram $ myLexer file
printToErr $ printTree parsed
putStrLn "\n-- Renamer --"
printToErr "\n-- Renamer --"
let renamed = rename parsed
putStrLn $ printTree renamed
printToErr $ printTree renamed
putStrLn "\n-- TypeChecker --"
printToErr "\n-- TypeChecker --"
typechecked <- fromTypeCheckerErr $ typecheck renamed
putStrLn $ printTree typechecked
printToErr $ printTree typechecked
printToErr "\n-- Lambda Lifter --"
let lifted = lambdaLift typechecked
@ -54,35 +57,41 @@ printToErr :: String -> IO ()
printToErr = hPutStrLn stderr
fromCompilerErr :: Err a -> IO a
fromCompilerErr = either
fromCompilerErr =
either
( \err -> do
putStrLn "\nCOMPILER ERROR"
putStrLn err
exitFailure)
exitFailure
)
pure
fromSyntaxErr :: Err a -> IO a
fromSyntaxErr = either
fromSyntaxErr =
either
( \err -> do
putStrLn "\nSYNTAX ERROR"
putStrLn err
exitFailure)
exitFailure
)
pure
fromTypeCheckerErr :: Err a -> IO a
fromTypeCheckerErr = either
fromTypeCheckerErr =
either
( \err -> do
putStrLn "\nTYPECHECKER ERROR"
putStrLn err
exitFailure)
exitFailure
)
pure
fromInterpreterErr :: Err a -> IO a
fromInterpreterErr = either
fromInterpreterErr =
either
( \err -> do
putStrLn "\nINTERPRETER ERROR"
putStrLn err
exitFailure)
exitFailure
)
pure