Removed codegen to compile, type seem to work for newly added example
This commit is contained in:
parent
0d23a59f0c
commit
4a6c72fce0
4 changed files with 33 additions and 26 deletions
|
|
@ -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
5
sample-programs/mono.crf
Normal file
|
|
@ -0,0 +1,5 @@
|
||||||
|
const x y = x;
|
||||||
|
|
||||||
|
f x = (const x 'c');
|
||||||
|
|
||||||
|
main = f 5;
|
||||||
28
src/Main.hs
28
src/Main.hs
|
|
@ -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
|
||||||
|
|
|
||||||
|
|
@ -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"
|
||||||
|
|
||||||
|
|
|
||||||
Loading…
Add table
Add a link
Reference in a new issue