diff --git a/language.cabal b/language.cabal index 38f5ef5..b7ff72d 100644 --- a/language.cabal +++ b/language.cabal @@ -36,8 +36,8 @@ executable language Monomorphizer.Monomorphizer Monomorphizer.MonomorphizerIr Renamer.Renamer - Codegen.Codegen - Codegen.LlvmIr + --Codegen.Codegen + --Codegen.LlvmIr TreeConverter hs-source-dirs: src @@ -70,8 +70,8 @@ Test-suite language-testsuite Auxiliary TypeChecker.TypeChecker TypeChecker.TypeCheckerIr - Monomorpher.Monomorpher - Monomorpher.MonomorpherIr + Monomorphizer.Monomorphizer + Monomorphizer.MonomorphizerIr Renamer.Renamer Compiler diff --git a/sample-programs/mono.crf b/sample-programs/mono.crf new file mode 100644 index 0000000..e682b7d --- /dev/null +++ b/sample-programs/mono.crf @@ -0,0 +1,5 @@ +const x y = x; + +f x = (const x 'c'); + +main = f 5; diff --git a/src/Main.hs b/src/Main.hs index 3bb12d4..b7b2bc6 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -2,7 +2,7 @@ module Main where -import Codegen.Codegen (generateCode) +--import Codegen.Codegen (generateCode) import Data.Bool (bool) import GHC.IO.Handle.Text (hPutStrLn) import Grammar.ErrM (Err) @@ -66,23 +66,27 @@ main' debug s = do typechecked <- fromTypeCheckerErr $ typecheck renamed bool (printToErr $ printTree typechecked) (printToErr $ show typechecked) debug + printToErr "\n -- Compiler --" + let monomorphized = monomorphize typechecked + printToErr $ show monomorphized + -- printToErr "\n-- Lambda Lifter --" -- let lifted = lambdaLift typechecked -- printToErr $ printTree lifted -- - printToErr "\n -- Compiler --" - generatedCode <- fromCompilerErr $ generateCode (monomorphize typechecked) - putStrLn generatedCode + --printToErr "\n -- Compiler --" + --generatedCode <- fromCompilerErr $ generateCode (monomorphize typechecked) + --putStrLn generatedCode - check <- doesPathExist "output" - when check (removeDirectoryRecursive "output") - createDirectory "output" - when debug $ do - writeFile "output/llvm.ll" generatedCode - debugDotViz + --check <- doesPathExist "output" + --when check (removeDirectoryRecursive "output") + --createDirectory "output" + --when debug $ do + -- writeFile "output/llvm.ll" generatedCode + -- debugDotViz - compile generatedCode - spawnWait "./hello_world" + --compile generatedCode + --spawnWait "./hello_world" -- interpred <- fromInterpreterErr $ interpret lifted -- putStrLn "\n-- interpret" -- print interpred diff --git a/src/Monomorphizer/Monomorphizer.hs b/src/Monomorphizer/Monomorphizer.hs index 6267f39..f0026c4 100644 --- a/src/Monomorphizer/Monomorphizer.hs +++ b/src/Monomorphizer/Monomorphizer.hs @@ -111,7 +111,7 @@ getMonoFromPoly t = do env <- ask where getMono :: Map.Map Ident M.Type -> T.Type -> M.Type 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.TVar (T.MkTVar ident)) -> case Map.lookup ident polys of Just concrete -> concrete @@ -130,14 +130,14 @@ morphBind expectedType b@(T.Bind (Ident _, btype) args (exp, t)) = }) $ do -- The "new name" is used to find out if it is already marked or not. let name' = newName expectedType b - bindMarked <- isBindMarked (convertIdent name') + bindMarked <- isBindMarked (coerce name') -- Return with right name if already marked if bindMarked then return name' else do -- Mark so that this bind will not be processed in recursive or cyclic -- function calls markBind (coerce name') exp' <- morphExp expectedType exp - addOutputBind $ M.Bind (convertIdent name', expectedType) + addOutputBind $ M.Bind (coerce name', expectedType) [] (exp', expectedType) return name' @@ -155,9 +155,6 @@ morphApp expectedType (e1, t1) (e2, t2)= do convertLit :: T.Lit -> M.Lit convertLit (T.LInt v) = M.LInt 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 expectedType exp = case exp of @@ -166,12 +163,13 @@ morphExp expectedType exp = case exp of morphApp expectedType e1 e2 T.EAdd e1 e2 -> do morphApp expectedType e1 e2 - T.EAbs _ _ -> do - error "EAbs found in Monomorpher, not implemented" + T.EAbs ident (exp, t) -> local (\env -> env { locals = Set.insert ident (locals env) }) $ do + t' <- getMonoFromPoly t + morphExp t' exp T.EId ident@(Ident str) -> do isLocal <- localExists ident if isLocal then do - return $ M.EId (convertIdent ident) + return $ M.EId (coerce ident) else do bind <- getInputBind ident case bind of @@ -180,7 +178,7 @@ morphExp expectedType exp = case exp of Just bind' -> do -- New bind to process newBindName <- morphBind expectedType bind' - return $ M.EId (convertIdent newBindName) + return $ M.EId (coerce newBindName) T.ELet (T.Bind {}) _ -> error "lets not possible yet"