Removed codegen to compile, type seem to work for newly added example

This commit is contained in:
Rakarake 2023-03-27 20:11:49 +02:00
parent 0d23a59f0c
commit 4a6c72fce0
4 changed files with 33 additions and 26 deletions

View file

@ -36,8 +36,8 @@ executable language
Monomorphizer.Monomorphizer Monomorphizer.Monomorphizer
Monomorphizer.MonomorphizerIr Monomorphizer.MonomorphizerIr
Renamer.Renamer Renamer.Renamer
Codegen.Codegen --Codegen.Codegen
Codegen.LlvmIr --Codegen.LlvmIr
TreeConverter TreeConverter
hs-source-dirs: src hs-source-dirs: src
@ -70,8 +70,8 @@ Test-suite language-testsuite
Auxiliary Auxiliary
TypeChecker.TypeChecker TypeChecker.TypeChecker
TypeChecker.TypeCheckerIr TypeChecker.TypeCheckerIr
Monomorpher.Monomorpher Monomorphizer.Monomorphizer
Monomorpher.MonomorpherIr Monomorphizer.MonomorphizerIr
Renamer.Renamer Renamer.Renamer
Compiler Compiler

5
sample-programs/mono.crf Normal file
View file

@ -0,0 +1,5 @@
const x y = x;
f x = (const x 'c');
main = f 5;

View file

@ -2,7 +2,7 @@
module Main where module Main where
import Codegen.Codegen (generateCode) --import Codegen.Codegen (generateCode)
import Data.Bool (bool) import Data.Bool (bool)
import GHC.IO.Handle.Text (hPutStrLn) import GHC.IO.Handle.Text (hPutStrLn)
import Grammar.ErrM (Err) import Grammar.ErrM (Err)
@ -66,23 +66,27 @@ main' debug s = do
typechecked <- fromTypeCheckerErr $ typecheck renamed typechecked <- fromTypeCheckerErr $ typecheck renamed
bool (printToErr $ printTree typechecked) (printToErr $ show typechecked) debug bool (printToErr $ printTree typechecked) (printToErr $ show typechecked) debug
printToErr "\n -- Compiler --"
let monomorphized = monomorphize typechecked
printToErr $ show monomorphized
-- printToErr "\n-- Lambda Lifter --" -- printToErr "\n-- Lambda Lifter --"
-- let lifted = lambdaLift typechecked -- let lifted = lambdaLift typechecked
-- printToErr $ printTree lifted -- printToErr $ printTree lifted
-- --
printToErr "\n -- Compiler --" --printToErr "\n -- Compiler --"
generatedCode <- fromCompilerErr $ generateCode (monomorphize typechecked) --generatedCode <- fromCompilerErr $ generateCode (monomorphize typechecked)
putStrLn generatedCode --putStrLn generatedCode
check <- doesPathExist "output" --check <- doesPathExist "output"
when check (removeDirectoryRecursive "output") --when check (removeDirectoryRecursive "output")
createDirectory "output" --createDirectory "output"
when debug $ do --when debug $ do
writeFile "output/llvm.ll" generatedCode -- writeFile "output/llvm.ll" generatedCode
debugDotViz -- debugDotViz
compile generatedCode --compile generatedCode
spawnWait "./hello_world" --spawnWait "./hello_world"
-- interpred <- fromInterpreterErr $ interpret lifted -- interpred <- fromInterpreterErr $ interpret lifted
-- putStrLn "\n-- interpret" -- putStrLn "\n-- interpret"
-- print interpred -- print interpred

View file

@ -111,7 +111,7 @@ getMonoFromPoly t = do env <- ask
where where
getMono :: Map.Map Ident M.Type -> T.Type -> M.Type getMono :: Map.Map Ident M.Type -> T.Type -> M.Type
getMono polys t = case t of getMono polys t = case t of
(T.TLit ident) -> M.TLit (convertIdent ident) (T.TLit ident) -> M.TLit (coerce ident)
(T.TFun t1 t2) -> M.TFun (getMono polys t1) (getMono polys t2) (T.TFun t1 t2) -> M.TFun (getMono polys t1) (getMono polys t2)
(T.TVar (T.MkTVar ident)) -> case Map.lookup ident polys of (T.TVar (T.MkTVar ident)) -> case Map.lookup ident polys of
Just concrete -> concrete Just concrete -> concrete
@ -130,14 +130,14 @@ morphBind expectedType b@(T.Bind (Ident _, btype) args (exp, t)) =
}) $ do }) $ do
-- The "new name" is used to find out if it is already marked or not. -- The "new name" is used to find out if it is already marked or not.
let name' = newName expectedType b let name' = newName expectedType b
bindMarked <- isBindMarked (convertIdent name') bindMarked <- isBindMarked (coerce name')
-- Return with right name if already marked -- Return with right name if already marked
if bindMarked then return name' else do if bindMarked then return name' else do
-- Mark so that this bind will not be processed in recursive or cyclic -- Mark so that this bind will not be processed in recursive or cyclic
-- function calls -- function calls
markBind (coerce name') markBind (coerce name')
exp' <- morphExp expectedType exp exp' <- morphExp expectedType exp
addOutputBind $ M.Bind (convertIdent name', expectedType) addOutputBind $ M.Bind (coerce name', expectedType)
[] (exp', expectedType) [] (exp', expectedType)
return name' return name'
@ -155,9 +155,6 @@ morphApp expectedType (e1, t1) (e2, t2)= do
convertLit :: T.Lit -> M.Lit convertLit :: T.Lit -> M.Lit
convertLit (T.LInt v) = M.LInt v convertLit (T.LInt v) = M.LInt v
convertLit (T.LChar v) = M.LChar v convertLit (T.LChar v) = M.LChar v
-- Converts Ident
convertIdent :: T.Ident -> M.Ident
convertIdent (T.Ident str) = M.Ident str
morphExp :: M.Type -> T.Exp -> EnvM M.Exp morphExp :: M.Type -> T.Exp -> EnvM M.Exp
morphExp expectedType exp = case exp of morphExp expectedType exp = case exp of
@ -166,12 +163,13 @@ morphExp expectedType exp = case exp of
morphApp expectedType e1 e2 morphApp expectedType e1 e2
T.EAdd e1 e2 -> do T.EAdd e1 e2 -> do
morphApp expectedType e1 e2 morphApp expectedType e1 e2
T.EAbs _ _ -> do T.EAbs ident (exp, t) -> local (\env -> env { locals = Set.insert ident (locals env) }) $ do
error "EAbs found in Monomorpher, not implemented" t' <- getMonoFromPoly t
morphExp t' exp
T.EId ident@(Ident str) -> do T.EId ident@(Ident str) -> do
isLocal <- localExists ident isLocal <- localExists ident
if isLocal then do if isLocal then do
return $ M.EId (convertIdent ident) return $ M.EId (coerce ident)
else do else do
bind <- getInputBind ident bind <- getInputBind ident
case bind of case bind of
@ -180,7 +178,7 @@ morphExp expectedType exp = case exp of
Just bind' -> do Just bind' -> do
-- New bind to process -- New bind to process
newBindName <- morphBind expectedType bind' newBindName <- morphBind expectedType bind'
return $ M.EId (convertIdent newBindName) return $ M.EId (coerce newBindName)
T.ELet (T.Bind {}) _ -> error "lets not possible yet" T.ELet (T.Bind {}) _ -> error "lets not possible yet"