Fixed some small issues.
This commit is contained in:
Samuel Hammersberg
parent
7ef7090aa5
commit
5680334fde
3 changed files with 124 additions and 108 deletions
|
|
@ -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 ++ "\"")
|
||||
|
|
|
|||
133
src/Main.hs
133
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
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue