From 514d79bd6ce0759450ac8481f817d66390c1f86e Mon Sep 17 00:00:00 2001 From: Rakarake Date: Wed, 1 Mar 2023 13:50:01 +0100 Subject: [PATCH 01/15] Strucute in place, MonomorpherIr module created --- language.cabal | 4 ++ llvm.ll | 10 +++ src/Monomorpher/Monomorpher.hs | 35 ++++++++++ src/Monomorpher/MonomorpherIr.hs | 112 +++++++++++++++++++++++++++++++ 4 files changed, 161 insertions(+) create mode 100644 llvm.ll create mode 100644 src/Monomorpher/Monomorpher.hs create mode 100644 src/Monomorpher/MonomorpherIr.hs diff --git a/language.cabal b/language.cabal index eb58aa0..322d4ed 100644 --- a/language.cabal +++ b/language.cabal @@ -33,6 +33,8 @@ executable language Auxiliary TypeChecker.TypeChecker TypeChecker.TypeCheckerIr + Monomorpher.Monomorpher + Monomorpher.MonomorpherIr Renamer.Renamer LambdaLifter.LambdaLifter Codegen.Codegen @@ -65,6 +67,8 @@ Test-suite language-testsuite Auxiliary TypeChecker.TypeChecker TypeChecker.TypeCheckerIr + Monomorpher.Monomorpher + Monomorpher.MonomorpherIr Renamer.Renamer hs-source-dirs: src, tests diff --git a/llvm.ll b/llvm.ll new file mode 100644 index 0000000..cd6b190 --- /dev/null +++ b/llvm.ll @@ -0,0 +1,10 @@ +@.str = private unnamed_addr constant [3 x i8] c"%i +", align 1 +declare i32 @printf(ptr noalias nocapture, ...) + +; Ident "main": EAdd (TMono (Ident "Int")) (ELit (TMono (Ident "Int")) (LInt 3)) (ELit (TMono (Ident "Int")) (LInt 3)) +define i64 @main() { + %1 = add i64 3, 3 + call i32 (ptr, ...) @printf(ptr noundef @.str, i64 noundef %1) + ret i64 0 +} diff --git a/src/Monomorpher/Monomorpher.hs b/src/Monomorpher/Monomorpher.hs new file mode 100644 index 0000000..d9e38e1 --- /dev/null +++ b/src/Monomorpher/Monomorpher.hs @@ -0,0 +1,35 @@ +-- | For now, converts polymorphic functions to concrete ones based on usage. +-- Assumes lambdas are lifted. +module Monomorpher.Monomorpher (monomorphize) where + +import qualified TypeChecker.TypeCheckerIr as T +import TypeChecker.TypeCheckerIr (Id) + +import qualified Monomorpher.MonomorpherIr as M +import Control.Monad.State (MonadState (get, put), State) +import qualified Data.Map as Map + +data Env = Env { input :: Map.Map Id T.Bind, output :: Map.Map Id M.Bind } +-- | Monad containing the, outputted +type EnvM a = State Env a + +-- | Creates the environment based on the input binds. +createEnv :: [T.Bind] -> Env +createEnv binds = Env { input = foldl createEnv' Map.empty binds, output = Map.empty } + where + createEnv' ins b@(T.Bind name args exp) = Map.insert name b ins + +-- | Does the monomorphization. +monomorphize :: T.Program -> M.Program +monomorphize = undefined + +-- | Monomorphize an expression. +--morphExp :: T.Exp -> EnvM M.Exp +--morphExp exp = case exp of +-- T.EId id -> return $ M.EId id + + +---- | Add functions (including polymorphic ones) to global environment. +--addBind :: Env -> Def -> Err Env +--addBind env (DDef ident identArgs closure) = envAdd env ident (foldl (flip EAbs) closure identArgs) + diff --git a/src/Monomorpher/MonomorpherIr.hs b/src/Monomorpher/MonomorpherIr.hs new file mode 100644 index 0000000..2b042a1 --- /dev/null +++ b/src/Monomorpher/MonomorpherIr.hs @@ -0,0 +1,112 @@ +{-# LANGUAGE LambdaCase #-} + +module Monomorpher.MonomorpherIr + ( module Grammar.Abs + , module Monomorpher.MonomorpherIr + ) where + +import Grammar.Abs (Ident (..), Literal (..)) +import Grammar.Print +import Prelude +import qualified Prelude as C (Eq, Ord, Read, Show) + +newtype Program = Program [Bind] + deriving (C.Eq, C.Ord, C.Show, C.Read) + +data Exp + = EId Id + | ELit Type Literal + | ELet Bind Exp + | EApp Type Exp Exp + | EAdd Type Exp Exp + | EAbs Type Id Exp + deriving (C.Eq, C.Ord, C.Read, C.Show) + +type Id = (Ident, Type) + +-- Custom version of type which does not include TPol +data Type = TMono Ident | TArr Type Type + deriving (C.Eq, C.Ord, C.Show, C.Read) + +instance Print Type where + prt i = \case + TMono id_ -> prPrec i 1 (concatD [doc (showString "_"), prt 0 id_]) + TArr type_1 type_2 -> prPrec i 0 (concatD [prt 1 type_1, doc (showString "->"), prt 0 type_2]) + +instance Print [Type] where + prt _ [] = concatD [] + prt _ (x:xs) = concatD [prt 0 x, doc (showString " "), prt 0 xs] + + + +data Bind = Bind Id [Id] Exp + deriving (C.Eq, C.Ord, C.Show, C.Read) + +instance Print Program where + prt i (Program sc) = prPrec i 0 $ prt 0 sc + +instance Print Bind where + prt i (Bind (t, name) parms rhs) = prPrec i 0 $ concatD + [ prt 0 name + , doc $ showString ":" + , prt 0 t + , prtIdPs 0 parms + , doc $ showString "=" + , prt 0 rhs + ] + +instance Print [Bind] where + prt _ [] = concatD [] + prt _ [x] = concatD [prt 0 x] + prt _ (x:xs) = concatD [prt 0 x, doc (showString ";"), prt 0 xs] + +prtIdPs :: Int -> [Id] -> Doc +prtIdPs i = prPrec i 0 . concatD . map (prtIdP i) + +prtId :: Int -> Id -> Doc +prtId i (name, t) = prPrec i 0 $ concatD + [ prt 0 name + , doc $ showString ":" + , prt 0 t + ] + +prtIdP :: Int -> Id -> Doc +prtIdP i (name, t) = prPrec i 0 $ concatD + [ doc $ showString "(" + , prt 0 name + , doc $ showString ":" + , prt 0 t + , doc $ showString ")" + ] + + +instance Print Exp where + prt i = \case + EId n -> prPrec i 3 $ concatD [prtId 0 n] + ELit _ (LInt i1) -> prPrec i 3 $ concatD [prt 0 i1] + ELet bs e -> prPrec i 3 $ concatD + [ doc $ showString "let" + , prt 0 bs + , doc $ showString "in" + , prt 0 e + ] + EApp t e1 e2 -> prPrec i 2 $ concatD + [ prt 2 e1 + , prt 3 e2 + ] + EAdd t e1 e2 -> prPrec i 1 $ concatD + [ doc $ showString "@" + , prt 0 t + , prt 1 e1 + , doc $ showString "+" + , prt 2 e2 + ] + EAbs t n e -> prPrec i 0 $ concatD + [ doc $ showString "@" + , prt 0 t + , doc $ showString "\\" + , prtId 0 n + , doc $ showString "." + , prt 0 e + ] + From dbc77ec5f3153fc190f9f63a81d6095f0a9aa619 Mon Sep 17 00:00:00 2001 From: Rakarake Date: Thu, 2 Mar 2023 18:36:50 +0100 Subject: [PATCH 02/15] Progress --- src/Monomorpher/Monomorpher.hs | 94 +++++++++++++++++++++++++++----- src/Monomorpher/MonomorpherIr.hs | 1 - 2 files changed, 79 insertions(+), 16 deletions(-) diff --git a/src/Monomorpher/Monomorpher.hs b/src/Monomorpher/Monomorpher.hs index d9e38e1..9862bab 100644 --- a/src/Monomorpher/Monomorpher.hs +++ b/src/Monomorpher/Monomorpher.hs @@ -1,33 +1,97 @@ -- | For now, converts polymorphic functions to concrete ones based on usage. -- Assumes lambdas are lifted. +-- This step of compilation is as follows: +-- Split all function bindings into monomorphic and polymorphic binds. The +-- monomorphic bindings will be part of this compilation step. +-- Apply the following monomorphization function on all monomorphic binds, with +-- their type as an additional argument. +-- +-- The function that transforms Binds operates on both monomorphic and +-- polymorphic functions, creates a context in which all possible polymorphic types +-- are mapped to concrete types, created using the additional argument. +-- Expressions are then recursively processed. The type of these expressions +-- are changed to using the mapped generic types. The expected type provided +-- in the recursion is changed depending on the different nodes. +-- +-- When an external bind is encountered (EId), it is checked whether it is +-- monomorphic or polymorphic. If monomorphic, nothing further is evaluated. +-- If polymorphic, the bind transformer function is called on this with the +-- expected type in this context. The result of this computation (a monomorphic +-- bind) is added to the resulting set of binds. + module Monomorpher.Monomorpher (monomorphize) where import qualified TypeChecker.TypeCheckerIr as T -import TypeChecker.TypeCheckerIr (Id) - import qualified Monomorpher.MonomorpherIr as M -import Control.Monad.State (MonadState (get, put), State) -import qualified Data.Map as Map -data Env = Env { input :: Map.Map Id T.Bind, output :: Map.Map Id M.Bind } --- | Monad containing the, outputted +import Grammar.Abs (Ident) + +import Control.Monad.State (MonadState (get, put), State, gets, modify) +import qualified Data.Map as Map +import Data.Foldable (find) + +-- | The environment of computations in this module. +data Env = Env { -- | All binds in the program. + input :: Map.Map Ident T.Bind, + -- | The monomorphized binds. + output :: [M.Bind], + -- | Maps polymorphic identifiers with concrete types. + polys :: Map.Map Ident M.Type + } + +-- | State Monad wrapper for "Env". type EnvM a = State Env a +-- TODO: use fromList -- | Creates the environment based on the input binds. createEnv :: [T.Bind] -> Env -createEnv binds = Env { input = foldl createEnv' Map.empty binds, output = Map.empty } +createEnv binds = Env { input = Map.fromList kvPairs } where - createEnv' ins b@(T.Bind name args exp) = Map.insert name b ins + kvPairs :: [(Ident, T.Bind)] + kvPairs = map (\b@(T.Bind (ident, _) _ _) -> (ident, b)) binds + +-- | Gets a polymorphic bind from an id. +getPolymorphic :: T.Id -> EnvM (Maybe T.Bind) +getPolymorphic (ident, _) = gets (Map.lookup ident . input) + +-- | Add monomorphic function derived from a polymorphic one, to env. +addMonomorphic :: M.Bind -> EnvM () +addMonomorphic b = modify (\env -> env { output = b:(output env) }) + +-- | Add polymorphic -> monomorphic type bindings regardless of bind. +addPolyMap :: M.Type -> T.Bind -> EnvM () +addPolyMap = undefined + +--morphBind :: M.Type -> T.Bind -> EnvM M.Bind +--morphBind expectedType (T.Bind (ident, t) _ exp) = do +-- exp' <- morphExp expectedType exp +-- return $ M.Bind (ident, expectedType) [] exp' +-- +---- | Monomorphize an expression. +--morphExp :: M.Type -> T.Exp -> EnvM M.Exp +--morphExp expectedType exp = case exp of +-- T.EApp t e1 e2 -> do +-- e1' <- morphExp expectedType e1 +-- e2' <- morphExp t1 e2 +-- return $ M.EApp expectedType e1' e2' +-- T.EAdd t e1 e2 -> do e1' <- morphExp e1 +-- e2' <- morphExp e2 +-- return $ M.EAdd t e1' e2' +-- T.EId id ->undefined +-- T.ELit t lit ->undefined +-- T.ELet bind e ->undefined +-- -- Special case at bind level +-- T.EAbs t id e -> error "Passing lambda lifter, this is not possible." -- | Does the monomorphization. monomorphize :: T.Program -> M.Program -monomorphize = undefined - --- | Monomorphize an expression. ---morphExp :: T.Exp -> EnvM M.Exp ---morphExp exp = case exp of --- T.EId id -> return $ M.EId id - +monomorphize (T.Program binds) = undefined + where + monomorphize' :: EnvM M.Program + monomorphize' = do + put $ createEnv binds + -- TODO: complete + return $ M.Program [] ---- | Add functions (including polymorphic ones) to global environment. --addBind :: Env -> Def -> Err Env diff --git a/src/Monomorpher/MonomorpherIr.hs b/src/Monomorpher/MonomorpherIr.hs index 2b042a1..14c82ae 100644 --- a/src/Monomorpher/MonomorpherIr.hs +++ b/src/Monomorpher/MonomorpherIr.hs @@ -38,7 +38,6 @@ instance Print [Type] where prt _ (x:xs) = concatD [prt 0 x, doc (showString " "), prt 0 xs] - data Bind = Bind Id [Id] Exp deriving (C.Eq, C.Ord, C.Show, C.Read) From 8ca876a1014955a7ef6842537a722cc2ffe57a28 Mon Sep 17 00:00:00 2001 From: Rakarake Date: Mon, 6 Mar 2023 10:47:52 +0100 Subject: [PATCH 03/15] Most code written, no tests yet --- src/Monomorpher/Monomorpher.hs | 175 +++++++++++++++++++++++++-------- 1 file changed, 135 insertions(+), 40 deletions(-) diff --git a/src/Monomorpher/Monomorpher.hs b/src/Monomorpher/Monomorpher.hs index 9862bab..7a40c7c 100644 --- a/src/Monomorpher/Monomorpher.hs +++ b/src/Monomorpher/Monomorpher.hs @@ -1,6 +1,8 @@ -- | For now, converts polymorphic functions to concrete ones based on usage. -- Assumes lambdas are lifted. +-- -- This step of compilation is as follows: +-- -- Split all function bindings into monomorphic and polymorphic binds. The -- monomorphic bindings will be part of this compilation step. -- Apply the following monomorphization function on all monomorphic binds, with @@ -13,9 +15,9 @@ -- are changed to using the mapped generic types. The expected type provided -- in the recursion is changed depending on the different nodes. -- --- When an external bind is encountered (EId), it is checked whether it is --- monomorphic or polymorphic. If monomorphic, nothing further is evaluated. --- If polymorphic, the bind transformer function is called on this with the +-- When an external bind is encountered (with EId), it is checked whether it +-- exists in outputed binds or not. If it does, nothing further is evaluated. +-- If not, the bind transformer function is called on it with the -- expected type in this context. The result of this computation (a monomorphic -- bind) is added to the resulting set of binds. @@ -26,17 +28,21 @@ import qualified Monomorpher.MonomorpherIr as M import Grammar.Abs (Ident) -import Control.Monad.State (MonadState (get, put), State, gets, modify) +import Control.Monad.State (MonadState (get), State, gets, modify, execState) import qualified Data.Map as Map -import Data.Foldable (find) +import qualified Data.Set as Set +import Data.Maybe (fromJust) -- | The environment of computations in this module. data Env = Env { -- | All binds in the program. input :: Map.Map Ident T.Bind, -- | The monomorphized binds. - output :: [M.Bind], + output :: Map.Map Ident M.Bind, -- | Maps polymorphic identifiers with concrete types. - polys :: Map.Map Ident M.Type + polys :: Map.Map Ident M.Type, + -- | Local variables, not necessary if id's are annotated based + -- on if they are local or global. + locals :: Set.Set Ident } -- | State Monad wrapper for "Env". @@ -45,55 +51,144 @@ type EnvM a = State Env a -- TODO: use fromList -- | Creates the environment based on the input binds. createEnv :: [T.Bind] -> Env -createEnv binds = Env { input = Map.fromList kvPairs } +createEnv binds = Env { input = Map.fromList kvPairs, + output = Map.empty, + polys = Map.empty, + locals = Set.empty } where kvPairs :: [(Ident, T.Bind)] kvPairs = map (\b@(T.Bind (ident, _) _ _) -> (ident, b)) binds +-- | Functions to add, clear and get whether id is a local variable. +addLocal :: Ident -> EnvM () +addLocal ident = modify (\env -> env { locals = Set.insert ident (locals env) }) + +clearLocal :: EnvM () +clearLocal = modify (\env -> env { locals = Set.empty }) + +localExists :: Ident -> EnvM Bool +localExists ident = do env <- get + return $ Set.member ident (locals env) + -- | Gets a polymorphic bind from an id. -getPolymorphic :: T.Id -> EnvM (Maybe T.Bind) -getPolymorphic (ident, _) = gets (Map.lookup ident . input) +getPolymorphic :: Ident -> EnvM (Maybe T.Bind) +getPolymorphic ident = gets (Map.lookup ident . input) -- | Add monomorphic function derived from a polymorphic one, to env. addMonomorphic :: M.Bind -> EnvM () -addMonomorphic b = modify (\env -> env { output = b:(output env) }) +addMonomorphic b@(M.Bind (ident, _) _ _) = modify + (\env -> env { output = Map.insert ident b (output env) }) + +-- | Checks whether or not an ident is added to output binds. +isOutputted :: Ident -> EnvM Bool +isOutputted ident = do env <- get + return $ Map.member ident (output env) + +-- | Finds main bind +getMain :: EnvM T.Bind +getMain = gets (\env -> fromJust $ Map.lookup (T.Ident "main") (input env)) -- | Add polymorphic -> monomorphic type bindings regardless of bind. +-- The structue of the types should be the same, map them. addPolyMap :: M.Type -> T.Bind -> EnvM () -addPolyMap = undefined +addPolyMap t1 (T.Bind (_, t2) _ _) = modify modFunc + where + modFunc env = env { polys = newPolys (polys env) } + newPolys oldPolys = Map.union oldPolys (Map.fromList (mapTypes t2 t1)) ---morphBind :: M.Type -> T.Bind -> EnvM M.Bind ---morphBind expectedType (T.Bind (ident, t) _ exp) = do --- exp' <- morphExp expectedType exp --- return $ M.Bind (ident, expectedType) [] exp' --- ----- | Monomorphize an expression. ---morphExp :: M.Type -> T.Exp -> EnvM M.Exp ---morphExp expectedType exp = case exp of --- T.EApp t e1 e2 -> do --- e1' <- morphExp expectedType e1 --- e2' <- morphExp t1 e2 --- return $ M.EApp expectedType e1' e2' --- T.EAdd t e1 e2 -> do e1' <- morphExp e1 --- e2' <- morphExp e2 --- return $ M.EAdd t e1' e2' --- T.EId id ->undefined --- T.ELit t lit ->undefined --- T.ELet bind e ->undefined --- -- Special case at bind level --- T.EAbs t id e -> error "Passing lambda lifter, this is not possible." +-- | Gets the monomorphic type of a polymorphic type in the current context. +getMono :: T.Type -> EnvM M.Type +getMono t = do env <- get + return $ getMono' (polys env) t + where + getMono' :: Map.Map Ident M.Type -> T.Type -> M.Type + getMono' polys t = case t of + (T.TMono ident) -> M.TMono ident + (T.TArr t1 t2) -> M.TArr + (getMono' polys t1) (getMono' polys t2) + (T.TPol ident) -> case Map.lookup ident polys of + Just concrete -> concrete + Nothing -> error "type not found!" +-- NOTE: could make this function more optimized +-- | Makes a kv pair list of poly to concrete mappings, throws runtime +-- error when encountering different structures between the two arguments. +mapTypes :: T.Type -> M.Type -> [(Ident, M.Type)] +mapTypes (T.TMono _) (M.TMono _) = [] +mapTypes (T.TPol i1) tm = [(i1, tm)] +mapTypes (T.TArr pt1 pt2) (M.TArr mt1 mt2) = mapTypes pt1 mt1 ++ + mapTypes pt2 mt2 +mapTypes _ _ = error "structure of types not the same!" + +-- | If ident not already in env's output, morphed bind to output +-- (and all referenced binds within this bind). +morphBind :: M.Type -> T.Bind -> EnvM () +morphBind expectedType b@(T.Bind (ident, _) _ exp) = do + outputted <- isOutputted ident + if outputted then + -- Don't add anything! + return () + else do + -- Add processed bind! + addPolyMap expectedType b + exp' <- morphExp expectedType exp + addMonomorphic $ M.Bind (ident, expectedType) [] exp' + +-- Get type of expression +getExpType :: T.Exp -> T.Type +getExpType (T.EId (_, t)) = t +getExpType (T.ELit t _) = t +getExpType (T.EApp t _ _) = t +getExpType (T.EAdd t _ _) = t +getExpType (T.EAbs t _ _) = t +getExpType (T.ELet _ _) = error "Lets not allowed🛑👮" + +morphExp :: M.Type -> T.Exp -> EnvM M.Exp +morphExp expectedType exp = case exp of + T.ELit t lit -> do t' <- getMono t -- These steps are abundant + return $ M.ELit t' lit + T.EApp _ e1 e2 -> do t2 <- getMono $ getExpType e2 + e2' <- morphExp t2 e2 + t1 <- getMono $ getExpType e1 + e1' <- morphExp t1 e1 + return $ M.EApp expectedType e1' e2' + T.EAdd _ e1 e2 -> do t2 <- getMono $ getExpType e2 + e2' <- morphExp t2 e2 + t1 <- getMono $ getExpType e1 + e1' <- morphExp t1 e1 + return $ M.EApp expectedType e1' e2' + -- Add local vars to locals + T.EAbs _ (ident, _) e -> do let (M.TArr _ t) = expectedType + addLocal ident + morphExp t e + + T.EId (ident, t) -> do maybeLocal <- localExists ident + if maybeLocal then do + t' <- getMono t + return $ M.EId (ident, t') + else do + clearLocal + bind <- getPolymorphic ident + case bind of + Nothing -> error "Wowzers!" + Just bind' -> do + t' <- getMono t + morphBind t' bind' + return $ M.EId (ident, t') + + T.ELet (T.Bind {}) _ -> error "Lets not possible yet." + +-- TODO: make sure that monomorphic binds are not processed again -- | Does the monomorphization. monomorphize :: T.Program -> M.Program -monomorphize (T.Program binds) = undefined +monomorphize (T.Program binds) = M.Program $ (map snd . Map.toList) outputMap where - monomorphize' :: EnvM M.Program + outputMap :: Map.Map Ident M.Bind + outputMap = output $ execState monomorphize' (createEnv binds) + + monomorphize' :: EnvM () monomorphize' = do - put $ createEnv binds - -- TODO: complete - return $ M.Program [] + main <- getMain + morphBind (M.TMono $ M.Ident "Int") main ----- | Add functions (including polymorphic ones) to global environment. ---addBind :: Env -> Def -> Err Env ---addBind env (DDef ident identArgs closure) = envAdd env ident (foldl (flip EAbs) closure identArgs) From 887c3b83913bf5cf69d5c91f42d56bda239d512c Mon Sep 17 00:00:00 2001 From: Rakarake Date: Tue, 7 Mar 2023 16:42:56 +0100 Subject: [PATCH 04/15] Working on bugs --- language.cabal | 1 + src/Main.hs | 13 +++++--- src/Monomorpher/Monomorpher.hs | 54 ++++++++++++++++++++------------ test_program | 6 +++- tests/Monomorpher/Monomorpher.hs | 0 5 files changed, 49 insertions(+), 25 deletions(-) create mode 100644 tests/Monomorpher/Monomorpher.hs diff --git a/language.cabal b/language.cabal index 322d4ed..12d374b 100644 --- a/language.cabal +++ b/language.cabal @@ -83,3 +83,4 @@ Test-suite language-testsuite , QuickCheck default-language: GHC2021 + diff --git a/src/Main.hs b/src/Main.hs index 3a7bde4..7d8f94f 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -14,6 +14,7 @@ import System.Environment (getArgs) import System.Exit (exitFailure, exitSuccess) import System.IO (stderr) import TypeChecker.TypeChecker (typecheck) +import Monomorpher.Monomorpher (monomorphize) main :: IO () main = @@ -41,10 +42,14 @@ main' s = do 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 -- Monomorphizer --" + let monomorphed = monomorphize lifted + printToErr $ printTree monomorphed + + --printToErr "\n -- Printing compiler output to stdout --" + --compiled <- fromCompilerErr $ compile lifted + --putStrLn compiled + --writeFile "llvm.ll" compiled exitSuccess diff --git a/src/Monomorpher/Monomorpher.hs b/src/Monomorpher/Monomorpher.hs index 7a40c7c..ce42682 100644 --- a/src/Monomorpher/Monomorpher.hs +++ b/src/Monomorpher/Monomorpher.hs @@ -21,7 +21,7 @@ -- expected type in this context. The result of this computation (a monomorphic -- bind) is added to the resulting set of binds. -module Monomorpher.Monomorpher (monomorphize) where +module Monomorpher.Monomorpher (monomorphize, morphExp, morphBind) where import qualified TypeChecker.TypeCheckerIr as T import qualified Monomorpher.MonomorpherIr as M @@ -32,6 +32,7 @@ import Control.Monad.State (MonadState (get), State, gets, modify, execState) import qualified Data.Map as Map import qualified Data.Set as Set import Data.Maybe (fromJust) +import Debug.Trace -- | The environment of computations in this module. data Env = Env { -- | All binds in the program. @@ -43,7 +44,7 @@ data Env = Env { -- | All binds in the program. -- | Local variables, not necessary if id's are annotated based -- on if they are local or global. locals :: Set.Set Ident - } + } deriving (Show) -- | State Monad wrapper for "Env". type EnvM a = State Env a @@ -63,6 +64,10 @@ createEnv binds = Env { input = Map.fromList kvPairs, addLocal :: Ident -> EnvM () addLocal ident = modify (\env -> env { locals = Set.insert ident (locals env) }) +addLocals :: [Ident] -> EnvM () +addLocals idents = modify (\env -> + env { locals = Set.fromList idents `Set.union` locals env }) + clearLocal :: EnvM () clearLocal = modify (\env -> env { locals = Set.empty }) @@ -108,7 +113,7 @@ getMono t = do env <- get (getMono' polys t1) (getMono' polys t2) (T.TPol ident) -> case Map.lookup ident polys of Just concrete -> concrete - Nothing -> error "type not found!" + Nothing -> error $ "type not found! type: " ++ show ident -- NOTE: could make this function more optimized -- | Makes a kv pair list of poly to concrete mappings, throws runtime @@ -120,20 +125,6 @@ mapTypes (T.TArr pt1 pt2) (M.TArr mt1 mt2) = mapTypes pt1 mt1 ++ mapTypes pt2 mt2 mapTypes _ _ = error "structure of types not the same!" --- | If ident not already in env's output, morphed bind to output --- (and all referenced binds within this bind). -morphBind :: M.Type -> T.Bind -> EnvM () -morphBind expectedType b@(T.Bind (ident, _) _ exp) = do - outputted <- isOutputted ident - if outputted then - -- Don't add anything! - return () - else do - -- Add processed bind! - addPolyMap expectedType b - exp' <- morphExp expectedType exp - addMonomorphic $ M.Bind (ident, expectedType) [] exp' - -- Get type of expression getExpType :: T.Exp -> T.Type getExpType (T.EId (_, t)) = t @@ -143,6 +134,21 @@ getExpType (T.EAdd t _ _) = t getExpType (T.EAbs t _ _) = t getExpType (T.ELet _ _) = error "Lets not allowed🛑👮" +-- | If ident not already in env's output, morphed bind to output +-- (and all referenced binds within this bind). +morphBind :: M.Type -> T.Bind -> EnvM () +morphBind expectedType b@(T.Bind (ident, _) args exp) = do + outputted <- isOutputted ident + if outputted then + -- Don't add anything! + return () + else do + -- Add processed bind! + addLocals $ map fst args -- Add all the local variables + addPolyMap expectedType b + exp' <- morphExp expectedType exp + addMonomorphic $ M.Bind (ident, expectedType) [] exp' + morphExp :: M.Type -> T.Exp -> EnvM M.Exp morphExp expectedType exp = case exp of T.ELit t lit -> do t' <- getMono t -- These steps are abundant @@ -156,13 +162,15 @@ morphExp expectedType exp = case exp of e2' <- morphExp t2 e2 t1 <- getMono $ getExpType e1 e1' <- morphExp t1 e1 - return $ M.EApp expectedType e1' e2' - -- Add local vars to locals + return $ M.EAdd expectedType e1' e2' + -- Add local vars to locals, this will never be called after the lambda lifter T.EAbs _ (ident, _) e -> do let (M.TArr _ t) = expectedType + error "should not be able to happen" addLocal ident morphExp t e T.EId (ident, t) -> do maybeLocal <- localExists ident + trace ("Ident: " ++ show ident ++": " ++ show maybeLocal) (return ()) if maybeLocal then do t' <- getMono t return $ M.EId (ident, t') @@ -184,11 +192,17 @@ monomorphize :: T.Program -> M.Program monomorphize (T.Program binds) = M.Program $ (map snd . Map.toList) outputMap where outputMap :: Map.Map Ident M.Bind - outputMap = output $ execState monomorphize' (createEnv binds) + outputMap = output $ execState monomorphize' (trace ("Inital Env: " ++ show (createEnv binds)) $ createEnv binds) monomorphize' :: EnvM () monomorphize' = do main <- getMain morphBind (M.TMono $ M.Ident "Int") main +-- Simple tests +--argX = T.Ident "x" +--funcF = (T.Ident "f", T.TArr ) +--typeInt = T.TMono (T.Ident "Int") +--test1Exp = T.ELit typeInt (T.LInt 8) +--test1 = T.Program [T.Bind funcF [argX] test1Exp] diff --git a/test_program b/test_program index 69a2c20..751a976 100644 --- a/test_program +++ b/test_program @@ -1,2 +1,6 @@ main : _Int ; -main = 3 + 3 ; +main = double 3 ; + +double : _Int -> _Int ; +double x = x + x ; + diff --git a/tests/Monomorpher/Monomorpher.hs b/tests/Monomorpher/Monomorpher.hs new file mode 100644 index 0000000..e69de29 From 63f9689f38cb17f88c1c0a775d851a15d48ec8ad Mon Sep 17 00:00:00 2001 From: Rakarake Date: Tue, 7 Mar 2023 18:49:21 +0100 Subject: [PATCH 05/15] Simple polymorphic and monomorphic functions properly morphed in test demo. --- language.cabal | 1 + tests/Monomorpher/Monomorpher.hs | 0 tests/Tests.hs | 104 ++++++++++++++++++++----------- 3 files changed, 67 insertions(+), 38 deletions(-) delete mode 100644 tests/Monomorpher/Monomorpher.hs diff --git a/language.cabal b/language.cabal index 12d374b..2f00ced 100644 --- a/language.cabal +++ b/language.cabal @@ -81,6 +81,7 @@ Test-suite language-testsuite , extra , array , QuickCheck + , hspec default-language: GHC2021 diff --git a/tests/Monomorpher/Monomorpher.hs b/tests/Monomorpher/Monomorpher.hs deleted file mode 100644 index e69de29..0000000 diff --git a/tests/Tests.hs b/tests/Tests.hs index 46a9a3f..cbe80e7 100644 --- a/tests/Tests.hs +++ b/tests/Tests.hs @@ -1,56 +1,84 @@ -{-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} {-# HLINT ignore "Use <$>" #-} module Main where - -import Control.Monad.Except -import Grammar.Abs -import Test.QuickCheck -import TypeChecker.TypeChecker +import Grammar.Abs (Ident (Ident), Literal (LInt)) import qualified TypeChecker.TypeCheckerIr as T +import Monomorpher.Monomorpher (monomorphize) +import Grammar.Print (printTree) +import System.IO (stderr) +import GHC.IO.Handle.Text (hPutStrLn) +import Test.Hspec + +printToErr :: String -> IO () +printToErr = hPutStrLn stderr + +-- A simple demo +simpleDemo = do + printToErr "# Monomorphic function f" + printToErr "-- Lifted Tree --" + printToErr $ printTree example1 + printToErr "-- Monomorphized Tree --" + printToErr $ printTree (monomorphize example1) + + printToErr "# Polymorphic function p" + printToErr "-- Lifted Tree --" + printToErr $ printTree example2 + printToErr "-- Monomorphized Tree --" + printToErr $ printTree (monomorphize example2) + main :: IO () main = do - quickCheck prop_isInt - quickCheck prop_idAbs_generic + return () -newtype AbsExp = AE Exp deriving Show -newtype EIntExp = EI Exp deriving Show +-- | Reusable test constructs for Monomorpher. +typeInt :: T.Type +typeInt = T.TMono $ Ident "Int" -instance Arbitrary EIntExp where - arbitrary = genInt +typeIntToInt :: T.Type +typeIntToInt = T.TArr typeInt typeInt -instance Arbitrary AbsExp where - arbitrary = genLambda +typeA :: T.Type +typeA = T.TPol $ Ident "a" -getType :: Infer (Type, T.Exp) -> Either Error Type -getType ie = case run ie of - Left err -> Left err - Right (t,e) -> return t +typeAToA :: T.Type +typeAToA = T.TArr typeA typeA -genInt :: Gen EIntExp -genInt = EI . ELit . LInt <$> arbitrary +-- f :: Int -> Int +-- f x = x + x +fName = (Ident "f", typeIntToInt) +fArg1 = (Ident "x", typeInt) +fArgs = [fArg1] +fExp :: T.Exp +fExp = T.EAdd typeInt (T.EId (Ident "x", typeInt)) (T.EId (Ident "x", typeInt)) +f :: T.Bind +f = T.Bind fName fArgs fExp -genLambda :: Gen AbsExp -genLambda = do - str <- arbitrary @String - let str' = Ident str - return $ AE $ EAbs str' (EId str') +-- f :: a -> a +-- f x = x + x +pName = (Ident "p", typeAToA) +pArg1 = (Ident "x", typeA) +pArgs = [pArg1] +pExp :: T.Exp +pExp = T.EAdd typeA (T.EId (Ident "x", typeA)) (T.EId (Ident "x", typeA)) +p :: T.Bind +p = T.Bind pName pArgs pExp -prop_idAbs_generic :: AbsExp -> Bool -prop_idAbs_generic (AE e) = case getType (inferExp e) of - Left _ -> False - Right t -> isGenericArr t -prop_isInt :: EIntExp -> Bool -prop_isInt (EI e) = case getType (inferExp e) of - Left _ -> False - Right t -> t == int +-- | Examples -int :: Type -int = TMono "Int" +-- main = f 5 +example1Name = (Ident "main", typeInt) +example1Exp :: T.Exp +example1Exp = T.EApp typeInt (T.EId (Ident "f", typeIntToInt)) (T.ELit typeInt $ LInt 5) +example1 :: T.Program +example1 = T.Program [T.Bind example1Name [] example1Exp, f] + +-- main = p 5 +example2Name = (Ident "main", typeInt) +example2Exp :: T.Exp +example2Exp = T.EApp typeInt (T.EId (Ident "p", typeIntToInt)) (T.ELit typeInt $ LInt 5) +example2 :: T.Program +example2 = T.Program [T.Bind example2Name [] example2Exp, p] -isGenericArr :: Type -> Bool -isGenericArr (TArr (TPol a) (TPol b)) = a == b -isGenericArr _ = False From d377ded7e10987e89422c70a85b0a20d2e72a712 Mon Sep 17 00:00:00 2001 From: Rakarake Date: Wed, 8 Mar 2023 17:38:50 +0100 Subject: [PATCH 06/15] Deleted bad sample programs, added polymorphic call in polymorphic function test --- language.cabal | 1 + sample-programs/basic-1 | 2 -- sample-programs/basic-2 | 3 --- sample-programs/basic-3 | 2 -- sample-programs/basic-4 | 2 -- sample-programs/basic-5 | 9 -------- sample-programs/good1 | 6 +++++ src/Main.hs | 4 ++++ src/TreeConverter.hs | 13 +++++++++++ tests/Tests.hs | 49 ++++++++++++++++++++++------------------- 10 files changed, 50 insertions(+), 41 deletions(-) delete mode 100644 sample-programs/basic-1 delete mode 100644 sample-programs/basic-2 delete mode 100644 sample-programs/basic-3 delete mode 100644 sample-programs/basic-4 delete mode 100644 sample-programs/basic-5 create mode 100644 sample-programs/good1 create mode 100644 src/TreeConverter.hs diff --git a/language.cabal b/language.cabal index 2f00ced..05860dd 100644 --- a/language.cabal +++ b/language.cabal @@ -39,6 +39,7 @@ executable language LambdaLifter.LambdaLifter Codegen.Codegen Codegen.LlvmIr + TreeConverter hs-source-dirs: src diff --git a/sample-programs/basic-1 b/sample-programs/basic-1 deleted file mode 100644 index f109950..0000000 --- a/sample-programs/basic-1 +++ /dev/null @@ -1,2 +0,0 @@ - -f = \x. x+1; diff --git a/sample-programs/basic-2 b/sample-programs/basic-2 deleted file mode 100644 index f7d0807..0000000 --- a/sample-programs/basic-2 +++ /dev/null @@ -1,3 +0,0 @@ -add x = \y. x+y; - -main = (\z. z+z) ((add 4) 6); diff --git a/sample-programs/basic-3 b/sample-programs/basic-3 deleted file mode 100644 index 9443439..0000000 --- a/sample-programs/basic-3 +++ /dev/null @@ -1,2 +0,0 @@ - -main = (\x. x+x+3) ((\x. x) 2) diff --git a/sample-programs/basic-4 b/sample-programs/basic-4 deleted file mode 100644 index 1de7a8c..0000000 --- a/sample-programs/basic-4 +++ /dev/null @@ -1,2 +0,0 @@ - -f x = let g = (\y. y+1) in g (g x) diff --git a/sample-programs/basic-5 b/sample-programs/basic-5 deleted file mode 100644 index 9984ddd..0000000 --- a/sample-programs/basic-5 +++ /dev/null @@ -1,9 +0,0 @@ -id x = x; - -add x y = x + y; - -double n = n + n; - -apply f x = \y. f x y; - -main = apply (id add) ((\x. x + 1) 1) (double 3); diff --git a/sample-programs/good1 b/sample-programs/good1 new file mode 100644 index 0000000..b7aff4b --- /dev/null +++ b/sample-programs/good1 @@ -0,0 +1,6 @@ +main : _Int ; +main = (id : _Int -> _Int) 5 ; + +id : 'a -> 'a ; +id x = (x : 'a); + diff --git a/src/Main.hs b/src/Main.hs index 7d8f94f..74f6b91 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -38,6 +38,10 @@ main' s = do typechecked <- fromTypeCheckerErr $ typecheck renamed printToErr $ printTree typechecked + --printToErr "\n-- TreeConverter --" + --converted <- fromTypeCheckerErr $ convertToTypecheckerIR renamed + --printToErr $ printTree converted + printToErr "\n-- Lambda Lifter --" let lifted = lambdaLift typechecked printToErr $ printTree lifted diff --git a/src/TreeConverter.hs b/src/TreeConverter.hs new file mode 100644 index 0000000..2dfa7d2 --- /dev/null +++ b/src/TreeConverter.hs @@ -0,0 +1,13 @@ +module TreeConverter where + +--import qualified Grammar.Abs as G +--import qualified TypeChecker.TypeCheckerIr as T +-- +--convertToTypecheckerIR :: G.Program -> Either String T.Program +--convertToTypecheckerIR (G.Program defs) = T.Program (map convertDef defs) +-- +--convertDef :: G.Bind -> T.Bind +--convertDef (G.Bind name t _ args exp) = T.Bind (name, t) (map (\i -> (i, T.TMono "Int"))) (convertExp exp) +-- +-- + diff --git a/tests/Tests.hs b/tests/Tests.hs index cbe80e7..261014c 100644 --- a/tests/Tests.hs +++ b/tests/Tests.hs @@ -9,40 +9,41 @@ import Monomorpher.Monomorpher (monomorphize) import Grammar.Print (printTree) import System.IO (stderr) import GHC.IO.Handle.Text (hPutStrLn) -import Test.Hspec printToErr :: String -> IO () printToErr = hPutStrLn stderr -- A simple demo simpleDemo = do - printToErr "# Monomorphic function f" + printToErr "#### f" printToErr "-- Lifted Tree --" printToErr $ printTree example1 printToErr "-- Monomorphized Tree --" printToErr $ printTree (monomorphize example1) - printToErr "# Polymorphic function p" + printToErr "#### p" printToErr "-- Lifted Tree --" printToErr $ printTree example2 printToErr "-- Monomorphized Tree --" printToErr $ printTree (monomorphize example2) + printToErr "#### g" + printToErr "-- Lifted Tree --" + printToErr $ printTree example3 + printToErr "-- Monomorphized Tree --" + printToErr $ printTree (monomorphize example3) + main :: IO () main = do return () -- | Reusable test constructs for Monomorpher. -typeInt :: T.Type typeInt = T.TMono $ Ident "Int" -typeIntToInt :: T.Type typeIntToInt = T.TArr typeInt typeInt -typeA :: T.Type typeA = T.TPol $ Ident "a" -typeAToA :: T.Type typeAToA = T.TArr typeA typeA -- f :: Int -> Int @@ -50,35 +51,37 @@ typeAToA = T.TArr typeA typeA fName = (Ident "f", typeIntToInt) fArg1 = (Ident "x", typeInt) fArgs = [fArg1] -fExp :: T.Exp fExp = T.EAdd typeInt (T.EId (Ident "x", typeInt)) (T.EId (Ident "x", typeInt)) -f :: T.Bind f = T.Bind fName fArgs fExp --- f :: a -> a --- f x = x + x +-- p :: a -> a +-- p x = x + x pName = (Ident "p", typeAToA) pArg1 = (Ident "x", typeA) pArgs = [pArg1] -pExp :: T.Exp pExp = T.EAdd typeA (T.EId (Ident "x", typeA)) (T.EId (Ident "x", typeA)) -p :: T.Bind p = T.Bind pName pArgs pExp +-- g :: a -> a +-- g x = x + (p x) +gName = (Ident "g", typeAToA) +gArg1 = (Ident "x", typeA) +gArgs = [gArg1] +gExp = T.EAdd typeA (T.EId (Ident "x", typeA)) (T.EApp typeA (T.EId (Ident "p", typeAToA)) (T.EId (Ident "x", typeA))) +g = T.Bind gName gArgs gExp -- | Examples +mainName = (Ident "main", typeInt) +-- func 5 +mainBoilerProg func binds = T.Program (T.Bind mainName [] (mainBoilerExp func) : binds) +mainBoilerExp func = T.EApp typeInt (T.EId (Ident func, typeIntToInt)) (T.ELit typeInt $ LInt 5) -- main = f 5 -example1Name = (Ident "main", typeInt) -example1Exp :: T.Exp -example1Exp = T.EApp typeInt (T.EId (Ident "f", typeIntToInt)) (T.ELit typeInt $ LInt 5) -example1 :: T.Program -example1 = T.Program [T.Bind example1Name [] example1Exp, f] +example1 = mainBoilerProg "f" [f] -- main = p 5 -example2Name = (Ident "main", typeInt) -example2Exp :: T.Exp -example2Exp = T.EApp typeInt (T.EId (Ident "p", typeIntToInt)) (T.ELit typeInt $ LInt 5) -example2 :: T.Program -example2 = T.Program [T.Bind example2Name [] example2Exp, p] +example2 = mainBoilerProg "p" [p] + +-- main = g 5 +example3 = mainBoilerProg "g" [g, p] From 0e20670343d8c2a72f07be30c885624c2706f0fa Mon Sep 17 00:00:00 2001 From: Rakarake Date: Wed, 8 Mar 2023 17:52:41 +0100 Subject: [PATCH 07/15] Added check for recursive calls --- src/Monomorpher/Monomorpher.hs | 19 +++++++++++++++---- 1 file changed, 15 insertions(+), 4 deletions(-) diff --git a/src/Monomorpher/Monomorpher.hs b/src/Monomorpher/Monomorpher.hs index ce42682..e190081 100644 --- a/src/Monomorpher/Monomorpher.hs +++ b/src/Monomorpher/Monomorpher.hs @@ -26,7 +26,7 @@ module Monomorpher.Monomorpher (monomorphize, morphExp, morphBind) where import qualified TypeChecker.TypeCheckerIr as T import qualified Monomorpher.MonomorpherIr as M -import Grammar.Abs (Ident) +import Grammar.Abs (Ident (Ident)) import Control.Monad.State (MonadState (get), State, gets, modify, execState) import qualified Data.Map as Map @@ -43,7 +43,8 @@ data Env = Env { -- | All binds in the program. polys :: Map.Map Ident M.Type, -- | Local variables, not necessary if id's are annotated based -- on if they are local or global. - locals :: Set.Set Ident + locals :: Set.Set Ident, + currentFunc :: Ident } deriving (Show) -- | State Monad wrapper for "Env". @@ -55,7 +56,8 @@ createEnv :: [T.Bind] -> Env createEnv binds = Env { input = Map.fromList kvPairs, output = Map.empty, polys = Map.empty, - locals = Set.empty } + locals = Set.empty, + currentFunc = Ident "main" } where kvPairs :: [(Ident, T.Bind)] kvPairs = map (\b@(T.Bind (ident, _) _ _) -> (ident, b)) binds @@ -75,6 +77,11 @@ localExists :: Ident -> EnvM Bool localExists ident = do env <- get return $ Set.member ident (locals env) +-- | Gets whether ident is current function. +isCurrentFunc :: Ident -> EnvM Bool +isCurrentFunc ident = do env <- get + return $ ident == currentFunc env + -- | Gets a polymorphic bind from an id. getPolymorphic :: Ident -> EnvM (Maybe T.Bind) getPolymorphic ident = gets (Map.lookup ident . input) @@ -180,8 +187,12 @@ morphExp expectedType exp = case exp of case bind of Nothing -> error "Wowzers!" Just bind' -> do + maybeCurrentFunc <- isCurrentFunc ident t' <- getMono t - morphBind t' bind' + if maybeCurrentFunc then + return () + else + morphBind t' bind' return $ M.EId (ident, t') T.ELet (T.Bind {}) _ -> error "Lets not possible yet." From f10919ac206e9add415cca6d6b11fbf42d4cc2af Mon Sep 17 00:00:00 2001 From: Rakarake Date: Thu, 9 Mar 2023 18:32:00 +0100 Subject: [PATCH 08/15] Better tests --- tests/Tests.hs | 100 ++++++++++++++++++++----------------------------- 1 file changed, 40 insertions(+), 60 deletions(-) diff --git a/tests/Tests.hs b/tests/Tests.hs index 261014c..de9ab7c 100644 --- a/tests/Tests.hs +++ b/tests/Tests.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} {-# HLINT ignore "Use <$>" #-} @@ -10,32 +11,50 @@ import Grammar.Print (printTree) import System.IO (stderr) import GHC.IO.Handle.Text (hPutStrLn) + printToErr :: String -> IO () printToErr = hPutStrLn stderr --- A simple demo -simpleDemo = do - printToErr "#### f" - printToErr "-- Lifted Tree --" - printToErr $ printTree example1 - printToErr "-- Monomorphized Tree --" - printToErr $ printTree (monomorphize example1) - - printToErr "#### p" - printToErr "-- Lifted Tree --" - printToErr $ printTree example2 - printToErr "-- Monomorphized Tree --" - printToErr $ printTree (monomorphize example2) - - printToErr "#### g" - printToErr "-- Lifted Tree --" - printToErr $ printTree example3 - printToErr "-- Monomorphized Tree --" - printToErr $ printTree (monomorphize example3) - main :: IO () main = do - return () + -- Only demonstrations for now, will fail if error is thrown. + simpleDemo + +-- A simple demo +simpleDemo = do + demo "main = f 5" $ simpleProgram [f] "f" 5 + demo "main = p 5" $ simpleProgram [p] "p" 5 + demo "main = g 5" $ simpleProgram [g, p] "g" 5 + +-- Nice demo 👍 +demo :: String -> T.Program -> IO () +demo label prg = do + printToErr $ "#### " ++ label ++ " ####" + printToErr " * Lifted Tree * " + printToErr $ printTree prg + printToErr " * Monomorphized Tree * " + printToErr $ printTree (monomorphize prg) + printToErr "##########\n" + +-- Programs in the form of "main = 'func' 'x'" +simpleProgram :: [T.Bind] -> T.Ident -> Int -> T.Program +simpleProgram binds fToCall input = T.Program (T.Bind ("main", typeInt) [] (simpleProgramExp fToCall):binds) +simpleProgramExp func = T.EApp typeInt (T.EId (func, typeIntToInt)) (T.ELit typeInt $ LInt 5) + +-- f :: Int -> Int +-- f x = x + x +f = T.Bind ("f", typeIntToInt) [("x", typeInt)] fExp +fExp = T.EAdd typeInt (T.EId ("x", typeInt)) (T.EId (Ident "x", typeInt)) + +-- p :: a -> a +-- p x = x + x +p = T.Bind (Ident "p", typeAToA) [(Ident "x", typeA)] pExp +pExp = T.EAdd typeA (T.EId (Ident "x", typeA)) (T.EId (Ident "x", typeA)) + +-- g :: a -> a +-- g x = x + (p x) +g = T.Bind (Ident "g", typeAToA) [("x", typeA)] gExp +gExp = T.EAdd typeA (T.EId (Ident "x", typeA)) (T.EApp typeA (T.EId (Ident "p", typeAToA)) (T.EId (Ident "x", typeA))) -- | Reusable test constructs for Monomorpher. typeInt = T.TMono $ Ident "Int" @@ -46,42 +65,3 @@ typeA = T.TPol $ Ident "a" typeAToA = T.TArr typeA typeA --- f :: Int -> Int --- f x = x + x -fName = (Ident "f", typeIntToInt) -fArg1 = (Ident "x", typeInt) -fArgs = [fArg1] -fExp = T.EAdd typeInt (T.EId (Ident "x", typeInt)) (T.EId (Ident "x", typeInt)) -f = T.Bind fName fArgs fExp - --- p :: a -> a --- p x = x + x -pName = (Ident "p", typeAToA) -pArg1 = (Ident "x", typeA) -pArgs = [pArg1] -pExp = T.EAdd typeA (T.EId (Ident "x", typeA)) (T.EId (Ident "x", typeA)) -p = T.Bind pName pArgs pExp - --- g :: a -> a --- g x = x + (p x) -gName = (Ident "g", typeAToA) -gArg1 = (Ident "x", typeA) -gArgs = [gArg1] -gExp = T.EAdd typeA (T.EId (Ident "x", typeA)) (T.EApp typeA (T.EId (Ident "p", typeAToA)) (T.EId (Ident "x", typeA))) -g = T.Bind gName gArgs gExp - --- | Examples -mainName = (Ident "main", typeInt) --- func 5 -mainBoilerProg func binds = T.Program (T.Bind mainName [] (mainBoilerExp func) : binds) -mainBoilerExp func = T.EApp typeInt (T.EId (Ident func, typeIntToInt)) (T.ELit typeInt $ LInt 5) - --- main = f 5 -example1 = mainBoilerProg "f" [f] - --- main = p 5 -example2 = mainBoilerProg "p" [p] - --- main = g 5 -example3 = mainBoilerProg "g" [g, p] - From 224a165715ed8bed548ad7f178af13f17beb42fa Mon Sep 17 00:00:00 2001 From: Rakarake Date: Thu, 9 Mar 2023 18:52:35 +0100 Subject: [PATCH 09/15] Unique names of new binds with different types --- src/Monomorpher/Monomorpher.hs | 25 +++++++++++++------------ 1 file changed, 13 insertions(+), 12 deletions(-) diff --git a/src/Monomorpher/Monomorpher.hs b/src/Monomorpher/Monomorpher.hs index e190081..8067480 100644 --- a/src/Monomorpher/Monomorpher.hs +++ b/src/Monomorpher/Monomorpher.hs @@ -126,7 +126,7 @@ getMono t = do env <- get -- | Makes a kv pair list of poly to concrete mappings, throws runtime -- error when encountering different structures between the two arguments. mapTypes :: T.Type -> M.Type -> [(Ident, M.Type)] -mapTypes (T.TMono _) (M.TMono _) = [] +mapTypes (T.TMono _) (M.TMono _) = [] mapTypes (T.TPol i1) tm = [(i1, tm)] mapTypes (T.TArr pt1 pt2) (M.TArr mt1 mt2) = mapTypes pt1 mt1 ++ mapTypes pt2 mt2 @@ -144,8 +144,8 @@ getExpType (T.ELet _ _) = error "Lets not allowed🛑👮" -- | If ident not already in env's output, morphed bind to output -- (and all referenced binds within this bind). morphBind :: M.Type -> T.Bind -> EnvM () -morphBind expectedType b@(T.Bind (ident, _) args exp) = do - outputted <- isOutputted ident +morphBind expectedType b@(T.Bind (Ident name, _) args exp) = do + outputted <- isOutputted (Ident name) if outputted then -- Don't add anything! return () @@ -154,7 +154,7 @@ morphBind expectedType b@(T.Bind (ident, _) args exp) = do addLocals $ map fst args -- Add all the local variables addPolyMap expectedType b exp' <- morphExp expectedType exp - addMonomorphic $ M.Bind (ident, expectedType) [] exp' + addMonomorphic $ M.Bind (newName expectedType b, expectedType) [] exp' morphExp :: M.Type -> T.Exp -> EnvM M.Exp morphExp expectedType exp = case exp of @@ -189,7 +189,7 @@ morphExp expectedType exp = case exp of Just bind' -> do maybeCurrentFunc <- isCurrentFunc ident t' <- getMono t - if maybeCurrentFunc then + if maybeCurrentFunc then -- Recursive call? return () else morphBind t' bind' @@ -197,6 +197,14 @@ morphExp expectedType exp = case exp of T.ELet (T.Bind {}) _ -> error "Lets not possible yet." +-- Creates a new identifier for a function with an assigned type +newName :: M.Type -> T.Bind -> Ident +newName t (T.Bind (Ident bindName, _) _ _) = Ident (bindName ++ "_" ++ newName' t) + where + newName' :: M.Type -> String + newName' (M.TMono (Ident str)) = str + newName' (M.TArr t1 t2) = newName' t1 ++ "_" ++ newName' t2 + -- TODO: make sure that monomorphic binds are not processed again -- | Does the monomorphization. monomorphize :: T.Program -> M.Program @@ -210,10 +218,3 @@ monomorphize (T.Program binds) = M.Program $ (map snd . Map.toList) outputMap main <- getMain morphBind (M.TMono $ M.Ident "Int") main --- Simple tests ---argX = T.Ident "x" ---funcF = (T.Ident "f", T.TArr ) ---typeInt = T.TMono (T.Ident "Int") ---test1Exp = T.ELit typeInt (T.LInt 8) ---test1 = T.Program [T.Bind funcF [argX] test1Exp] - From 96c4a2bddf183b4e45bdef4e20e081d4c877c1d0 Mon Sep 17 00:00:00 2001 From: Rakarake Date: Fri, 10 Mar 2023 17:20:23 +0100 Subject: [PATCH 10/15] Added test of multiple instanciations of same polymorphic function --- Grammar.cf | 3 +- src/Monomorpher/MonomorpherIr.hs | 1 + src/TypeChecker/TypeCheckerIr.hs | 1 + tests/Tests.hs | 75 +++++++++++++++++++++++++------- 4 files changed, 64 insertions(+), 16 deletions(-) diff --git a/Grammar.cf b/Grammar.cf index 6870367..da285a0 100644 --- a/Grammar.cf +++ b/Grammar.cf @@ -17,7 +17,8 @@ ELet. Exp ::= "let" Ident "=" Exp "in" Exp ; EAbs. Exp ::= "\\" Ident "." Exp ; ECase. Exp ::= "case" Exp "of" "{" [Inj] "}"; -LInt. Literal ::= Integer ; +LInt. Literal ::= Integer ; +LBool. Literal ::= "Ture" ; Inj. Inj ::= Init "=>" Exp ; terminator Inj ";" ; diff --git a/src/Monomorpher/MonomorpherIr.hs b/src/Monomorpher/MonomorpherIr.hs index 14c82ae..01fac01 100644 --- a/src/Monomorpher/MonomorpherIr.hs +++ b/src/Monomorpher/MonomorpherIr.hs @@ -83,6 +83,7 @@ instance Print Exp where prt i = \case EId n -> prPrec i 3 $ concatD [prtId 0 n] ELit _ (LInt i1) -> prPrec i 3 $ concatD [prt 0 i1] + ELit _ LBool -> prPrec i 0 (concatD [doc (showString "Ture")]) ELet bs e -> prPrec i 3 $ concatD [ doc $ showString "let" , prt 0 bs diff --git a/src/TypeChecker/TypeCheckerIr.hs b/src/TypeChecker/TypeCheckerIr.hs index c85ebcc..7b0e445 100644 --- a/src/TypeChecker/TypeCheckerIr.hs +++ b/src/TypeChecker/TypeCheckerIr.hs @@ -69,6 +69,7 @@ instance Print Exp where prt i = \case EId n -> prPrec i 3 $ concatD [prtId 0 n] ELit _ (LInt i1) -> prPrec i 3 $ concatD [prt 0 i1] + ELit _ LBool -> prPrec i 0 (concatD [doc (showString "Ture")]) ELet bs e -> prPrec i 3 $ concatD [ doc $ showString "let" , prt 0 bs diff --git a/tests/Tests.hs b/tests/Tests.hs index de9ab7c..edfd90b 100644 --- a/tests/Tests.hs +++ b/tests/Tests.hs @@ -22,9 +22,25 @@ main = do -- A simple demo simpleDemo = do - demo "main = f 5" $ simpleProgram [f] "f" 5 - demo "main = p 5" $ simpleProgram [p] "p" 5 - demo "main = g 5" $ simpleProgram [g, p] "g" 5 + demo "main = f 5" $ simpleProgram [f] + (mainApp (T.EId ("f", typeIntToInt)) lit5) + demo "main = bigId 5" $ simpleProgram [bigId] + (mainApp (T.EId ("bigId", typeIntToInt)) lit5) + demo "main = g 5" $ simpleProgram [g, bigId] + (mainApp (T.EId ("g", typeIntToInt)) lit5) + demo "main = (bigConst 5) ((bigConst 5) True)" $ simpleProgram [bigConst] + (T.EApp typeInt + -- (bigConst 5) + (T.EApp typeIntToInt (T.EId ("bigConst", typeIntToIntToInt)) lit5) + -- ((bigConst 5) True) + (T.EApp typeInt + (T.EApp typeBoolToInt + (T.EId ("bigConst", typeIntToBoolToInt)) + lit5 + ) + litTrue + ) + ) -- Nice demo 👍 demo :: String -> T.Program -> IO () @@ -37,31 +53,60 @@ demo label prg = do printToErr "##########\n" -- Programs in the form of "main = 'func' 'x'" -simpleProgram :: [T.Bind] -> T.Ident -> Int -> T.Program -simpleProgram binds fToCall input = T.Program (T.Bind ("main", typeInt) [] (simpleProgramExp fToCall):binds) -simpleProgramExp func = T.EApp typeInt (T.EId (func, typeIntToInt)) (T.ELit typeInt $ LInt 5) +simpleProgram :: [T.Bind] -> T.Exp -> T.Program +simpleProgram binds input = T.Program (T.Bind ("main", typeInt) [] input:binds) + +-- Applies two expressions, has type Int +mainApp :: T.Exp -> T.Exp -> T.Exp +mainApp = T.EApp typeInt -- f :: Int -> Int -- f x = x + x f = T.Bind ("f", typeIntToInt) [("x", typeInt)] fExp -fExp = T.EAdd typeInt (T.EId ("x", typeInt)) (T.EId (Ident "x", typeInt)) +fExp = T.EAdd typeInt (T.EId ("x", typeInt)) (T.EId ("x", typeInt)) --- p :: a -> a --- p x = x + x -p = T.Bind (Ident "p", typeAToA) [(Ident "x", typeA)] pExp -pExp = T.EAdd typeA (T.EId (Ident "x", typeA)) (T.EId (Ident "x", typeA)) +-- bigId :: a -> a +-- bigId x = x +bigId = T.Bind (Ident "bigId", typeAToA) [(Ident "x", typeA)] bigIdExp +bigIdExp = T.EAdd typeA (T.EId (Ident "x", typeA)) (T.EId ("x", typeA)) + +-- bigConst :: a -> a -> a +-- bigConst x y = x +bigConst = T.Bind ("bigConst", typeAToAToA) [("x", typeA), ("y", typeA)] bigConstExp +bigConstExp = T.EId ("x", typeA) -- g :: a -> a --- g x = x + (p x) -g = T.Bind (Ident "g", typeAToA) [("x", typeA)] gExp -gExp = T.EAdd typeA (T.EId (Ident "x", typeA)) (T.EApp typeA (T.EId (Ident "p", typeAToA)) (T.EId (Ident "x", typeA))) +-- g x = x + (bigId x) +g = T.Bind ("g", typeAToA) [("x", typeA)] gExp +gExp = T.EAdd typeA (T.EId ("x", typeA)) (T.EApp typeA (T.EId ("bigId", typeAToA)) (T.EId ("x", typeA))) -- | Reusable test constructs for Monomorpher. -typeInt = T.TMono $ Ident "Int" +typeInt = T.TMono "Int" typeIntToInt = T.TArr typeInt typeInt +typeIntToIntToInt = T.TArr typeInt typeIntToInt + + typeA = T.TPol $ Ident "a" typeAToA = T.TArr typeA typeA +typeAToAToA = T.TArr typeA typeAToA + + +typeBool = T.TMono "Bool" + +typeBoolToBool = T.TArr typeBool typeBool + +typeBoolToBoolToBool = T.TArr typeBool typeBoolToBool + + +lit5 = T.ELit typeInt $ T.LInt 5 + +litTrue = T.ELit typeBool T.LBool + + +typeBoolToInt = T.TArr typeBool typeInt +typeIntToBoolToInt = T.TArr typeInt typeBoolToInt + From e2db863c3e016689f478fabf7d4568790d66cb7b Mon Sep 17 00:00:00 2001 From: Rakarake Date: Fri, 10 Mar 2023 17:24:03 +0100 Subject: [PATCH 11/15] Fixed name clashes --- src/Monomorpher/Monomorpher.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Monomorpher/Monomorpher.hs b/src/Monomorpher/Monomorpher.hs index 8067480..63a5b33 100644 --- a/src/Monomorpher/Monomorpher.hs +++ b/src/Monomorpher/Monomorpher.hs @@ -199,7 +199,7 @@ morphExp expectedType exp = case exp of -- Creates a new identifier for a function with an assigned type newName :: M.Type -> T.Bind -> Ident -newName t (T.Bind (Ident bindName, _) _ _) = Ident (bindName ++ "_" ++ newName' t) +newName t (T.Bind (Ident bindName, _) _ _) = Ident (bindName ++ "$" ++ newName' t) where newName' :: M.Type -> String newName' (M.TMono (Ident str)) = str From ec95e0d9ef78ea8461e7ba7bc621580d048d44c1 Mon Sep 17 00:00:00 2001 From: Rakarake Date: Sun, 12 Mar 2023 17:53:46 +0100 Subject: [PATCH 12/15] Monomorphizer cleanup --- src/Monomorpher/Monomorpher.hs | 84 +++++++++++++++++----------------- 1 file changed, 42 insertions(+), 42 deletions(-) diff --git a/src/Monomorpher/Monomorpher.hs b/src/Monomorpher/Monomorpher.hs index 63a5b33..4c8cebf 100644 --- a/src/Monomorpher/Monomorpher.hs +++ b/src/Monomorpher/Monomorpher.hs @@ -44,13 +44,13 @@ data Env = Env { -- | All binds in the program. -- | Local variables, not necessary if id's are annotated based -- on if they are local or global. locals :: Set.Set Ident, + -- | The identifier of the current function. currentFunc :: Ident } deriving (Show) -- | State Monad wrapper for "Env". type EnvM a = State Env a --- TODO: use fromList -- | Creates the environment based on the input binds. createEnv :: [T.Bind] -> Env createEnv binds = Env { input = Map.fromList kvPairs, @@ -70,8 +70,8 @@ addLocals :: [Ident] -> EnvM () addLocals idents = modify (\env -> env { locals = Set.fromList idents `Set.union` locals env }) -clearLocal :: EnvM () -clearLocal = modify (\env -> env { locals = Set.empty }) +clearLocals :: EnvM () +clearLocals = modify (\env -> env { locals = Set.empty }) localExists :: Ident -> EnvM Bool localExists ident = do env <- get @@ -83,47 +83,33 @@ isCurrentFunc ident = do env <- get return $ ident == currentFunc env -- | Gets a polymorphic bind from an id. -getPolymorphic :: Ident -> EnvM (Maybe T.Bind) -getPolymorphic ident = gets (Map.lookup ident . input) +getInputBind :: Ident -> EnvM (Maybe T.Bind) +getInputBind ident = gets (Map.lookup ident . input) -- | Add monomorphic function derived from a polymorphic one, to env. -addMonomorphic :: M.Bind -> EnvM () -addMonomorphic b@(M.Bind (ident, _) _ _) = modify +addOutputBind :: M.Bind -> EnvM () +addOutputBind b@(M.Bind (ident, _) _ _) = modify (\env -> env { output = Map.insert ident b (output env) }) -- | Checks whether or not an ident is added to output binds. -isOutputted :: Ident -> EnvM Bool -isOutputted ident = do env <- get - return $ Map.member ident (output env) +isBindOutputted :: Ident -> EnvM Bool +isBindOutputted ident = do env <- get + return $ Map.member ident (output env) -- | Finds main bind getMain :: EnvM T.Bind getMain = gets (\env -> fromJust $ Map.lookup (T.Ident "main") (input env)) -- | Add polymorphic -> monomorphic type bindings regardless of bind. --- The structue of the types should be the same, map them. -addPolyMap :: M.Type -> T.Bind -> EnvM () -addPolyMap t1 (T.Bind (_, t2) _ _) = modify modFunc +-- The structue of the types should be the same. +mapTypesInBind :: M.Type -> T.Bind -> EnvM () +mapTypesInBind t1 (T.Bind (_, t2) _ _) = modify modFunc where modFunc env = env { polys = newPolys (polys env) } newPolys oldPolys = Map.union oldPolys (Map.fromList (mapTypes t2 t1)) --- | Gets the monomorphic type of a polymorphic type in the current context. -getMono :: T.Type -> EnvM M.Type -getMono t = do env <- get - return $ getMono' (polys env) t - where - getMono' :: Map.Map Ident M.Type -> T.Type -> M.Type - getMono' polys t = case t of - (T.TMono ident) -> M.TMono ident - (T.TArr t1 t2) -> M.TArr - (getMono' polys t1) (getMono' polys t2) - (T.TPol ident) -> case Map.lookup ident polys of - Just concrete -> concrete - Nothing -> error $ "type not found! type: " ++ show ident - -- NOTE: could make this function more optimized --- | Makes a kv pair list of poly to concrete mappings, throws runtime +-- | Makes a kv pair list of polymorphic to monomorphic mappings, throws runtime -- error when encountering different structures between the two arguments. mapTypes :: T.Type -> M.Type -> [(Ident, M.Type)] mapTypes (T.TMono _) (M.TMono _) = [] @@ -132,6 +118,21 @@ mapTypes (T.TArr pt1 pt2) (M.TArr mt1 mt2) = mapTypes pt1 mt1 ++ mapTypes pt2 mt2 mapTypes _ _ = error "structure of types not the same!" +-- | Gets the mapped monomorphic type of a polymorphic type in the current context. +getMonoFromPoly :: T.Type -> EnvM M.Type +getMonoFromPoly t = do env <- get + return $ getMono (polys env) t + where + getMono :: Map.Map Ident M.Type -> T.Type -> M.Type + getMono polys t = case t of + (T.TMono ident) -> M.TMono ident + (T.TArr t1 t2) -> M.TArr + (getMono polys t1) (getMono polys t2) + (T.TPol ident) -> case Map.lookup ident polys of + Just concrete -> concrete + Nothing -> error $ + "type not found! type: " ++ show ident + -- Get type of expression getExpType :: T.Exp -> T.Type getExpType (T.EId (_, t)) = t @@ -145,29 +146,29 @@ getExpType (T.ELet _ _) = error "Lets not allowed🛑👮" -- (and all referenced binds within this bind). morphBind :: M.Type -> T.Bind -> EnvM () morphBind expectedType b@(T.Bind (Ident name, _) args exp) = do - outputted <- isOutputted (Ident name) + outputted <- isBindOutputted (Ident name) if outputted then -- Don't add anything! return () else do -- Add processed bind! addLocals $ map fst args -- Add all the local variables - addPolyMap expectedType b + mapTypesInBind expectedType b exp' <- morphExp expectedType exp - addMonomorphic $ M.Bind (newName expectedType b, expectedType) [] exp' + addOutputBind $ M.Bind (newName expectedType b, expectedType) [] exp' morphExp :: M.Type -> T.Exp -> EnvM M.Exp morphExp expectedType exp = case exp of - T.ELit t lit -> do t' <- getMono t -- These steps are abundant + T.ELit t lit -> do t' <- getMonoFromPoly t -- These steps are abundant return $ M.ELit t' lit - T.EApp _ e1 e2 -> do t2 <- getMono $ getExpType e2 + T.EApp _ e1 e2 -> do t2 <- getMonoFromPoly $ getExpType e2 e2' <- morphExp t2 e2 - t1 <- getMono $ getExpType e1 + t1 <- getMonoFromPoly $ getExpType e1 e1' <- morphExp t1 e1 return $ M.EApp expectedType e1' e2' - T.EAdd _ e1 e2 -> do t2 <- getMono $ getExpType e2 + T.EAdd _ e1 e2 -> do t2 <- getMonoFromPoly $ getExpType e2 e2' <- morphExp t2 e2 - t1 <- getMono $ getExpType e1 + t1 <- getMonoFromPoly $ getExpType e1 e1' <- morphExp t1 e1 return $ M.EAdd expectedType e1' e2' -- Add local vars to locals, this will never be called after the lambda lifter @@ -177,18 +178,17 @@ morphExp expectedType exp = case exp of morphExp t e T.EId (ident, t) -> do maybeLocal <- localExists ident - trace ("Ident: " ++ show ident ++": " ++ show maybeLocal) (return ()) if maybeLocal then do - t' <- getMono t + t' <- getMonoFromPoly t return $ M.EId (ident, t') else do - clearLocal - bind <- getPolymorphic ident + clearLocals + bind <- getInputBind ident case bind of Nothing -> error "Wowzers!" Just bind' -> do maybeCurrentFunc <- isCurrentFunc ident - t' <- getMono t + t' <- getMonoFromPoly t if maybeCurrentFunc then -- Recursive call? return () else @@ -211,7 +211,7 @@ monomorphize :: T.Program -> M.Program monomorphize (T.Program binds) = M.Program $ (map snd . Map.toList) outputMap where outputMap :: Map.Map Ident M.Bind - outputMap = output $ execState monomorphize' (trace ("Inital Env: " ++ show (createEnv binds)) $ createEnv binds) + outputMap = output $ execState monomorphize' (createEnv binds) monomorphize' :: EnvM () monomorphize' = do From 71d07ebf0fbcb97377882eff6f1bdc0ac00a41ad Mon Sep 17 00:00:00 2001 From: Rakarake Date: Tue, 21 Mar 2023 15:59:47 +0100 Subject: [PATCH 13/15] Fixed some internal errors --- src/Monomorpher/Monomorpher.hs | 42 ++++++++++++++++++---------------- 1 file changed, 22 insertions(+), 20 deletions(-) diff --git a/src/Monomorpher/Monomorpher.hs b/src/Monomorpher/Monomorpher.hs index 4c8cebf..816fc71 100644 --- a/src/Monomorpher/Monomorpher.hs +++ b/src/Monomorpher/Monomorpher.hs @@ -140,7 +140,7 @@ getExpType (T.ELit t _) = t getExpType (T.EApp t _ _) = t getExpType (T.EAdd t _ _) = t getExpType (T.EAbs t _ _) = t -getExpType (T.ELet _ _) = error "Lets not allowed🛑👮" +getExpType (T.ELet _ _) = error "lets not allowed🛑👮" -- | If ident not already in env's output, morphed bind to output -- (and all referenced binds within this bind). @@ -173,29 +173,31 @@ morphExp expectedType exp = case exp of return $ M.EAdd expectedType e1' e2' -- Add local vars to locals, this will never be called after the lambda lifter T.EAbs _ (ident, _) e -> do let (M.TArr _ t) = expectedType - error "should not be able to happen" + error "EAbs found in Monomorpher, should not be possible" addLocal ident morphExp t e - T.EId (ident, t) -> do maybeLocal <- localExists ident - if maybeLocal then do - t' <- getMonoFromPoly t - return $ M.EId (ident, t') - else do - clearLocals - bind <- getInputBind ident - case bind of - Nothing -> error "Wowzers!" - Just bind' -> do - maybeCurrentFunc <- isCurrentFunc ident - t' <- getMonoFromPoly t - if maybeCurrentFunc then -- Recursive call? - return () - else - morphBind t' bind' - return $ M.EId (ident, t') + T.EId (ident@(Ident istr), t) -> do + maybeLocal <- localExists ident + if maybeLocal then do + t' <- getMonoFromPoly t + return $ M.EId (ident, t') + else do + clearLocals + bind <- getInputBind ident + case bind of + Nothing -> + error $ "bind of name: " ++ istr ++ " not found" + Just bind' -> do + maybeCurrentFunc <- isCurrentFunc ident + t' <- getMonoFromPoly t + if maybeCurrentFunc then -- Recursive call? + return () + else + morphBind t' bind' + return $ M.EId (ident, t') - T.ELet (T.Bind {}) _ -> error "Lets not possible yet." + T.ELet (T.Bind {}) _ -> error "lets not possible yet" -- Creates a new identifier for a function with an assigned type newName :: M.Type -> T.Bind -> Ident From 8f151b7531eafdf69f25aa6a8abb110068672054 Mon Sep 17 00:00:00 2001 From: Rakarake Date: Tue, 21 Mar 2023 17:15:15 +0100 Subject: [PATCH 14/15] Monomorphization of function applications should work --- src/Monomorpher/Monomorpher.hs | 42 +++++++++++++++++++--------------- 1 file changed, 23 insertions(+), 19 deletions(-) diff --git a/src/Monomorpher/Monomorpher.hs b/src/Monomorpher/Monomorpher.hs index 816fc71..96663f8 100644 --- a/src/Monomorpher/Monomorpher.hs +++ b/src/Monomorpher/Monomorpher.hs @@ -157,27 +157,31 @@ morphBind expectedType b@(T.Bind (Ident name, _) args exp) = do exp' <- morphExp expectedType exp addOutputBind $ M.Bind (newName expectedType b, expectedType) [] exp' +-- Morphs function applications, such as EApp and EAdd +morphApp :: M.Type -> T.Exp -> T.Exp -> EnvM M.Exp +morphApp expectedType e1 e2 = do + t2 <- getMonoFromPoly $ getExpType e2 -- TODO: make better helper + e2' <- morphExp t2 e2 + e1' <- morphExp (M.TArr t2 expectedType) e1 + return $ M.EApp (M.TArr t2 expectedType) e1' e2' + --t2 <- getMonoFromPoly $ getExpType e2 + --e2' <- morphExp t2 e2 + --t1 <- getMonoFromPoly $ getExpType e1 + --e1' <- morphExp t1 e1 + --return $ M.EApp expectedType e1' e2' + morphExp :: M.Type -> T.Exp -> EnvM M.Exp morphExp expectedType exp = case exp of - T.ELit t lit -> do t' <- getMonoFromPoly t -- These steps are abundant - return $ M.ELit t' lit - T.EApp _ e1 e2 -> do t2 <- getMonoFromPoly $ getExpType e2 - e2' <- morphExp t2 e2 - t1 <- getMonoFromPoly $ getExpType e1 - e1' <- morphExp t1 e1 - return $ M.EApp expectedType e1' e2' - T.EAdd _ e1 e2 -> do t2 <- getMonoFromPoly $ getExpType e2 - e2' <- morphExp t2 e2 - t1 <- getMonoFromPoly $ getExpType e1 - e1' <- morphExp t1 e1 - return $ M.EAdd expectedType e1' e2' - -- Add local vars to locals, this will never be called after the lambda lifter - T.EAbs _ (ident, _) e -> do let (M.TArr _ t) = expectedType - error "EAbs found in Monomorpher, should not be possible" - addLocal ident - morphExp t e - - T.EId (ident@(Ident istr), t) -> do + T.ELit t lit -> do + t' <- getMonoFromPoly t -- These steps are abundant + return $ M.ELit t' lit + T.EApp _ e1 e2 -> do + morphApp expectedType e1 e2 + T.EAdd _ e1 e2 -> do + morphApp expectedType e1 e2 + T.EAbs _ (_, _) _ -> do + error "EAbs found in Monomorpher, should not be possible" + T.EId (ident@(Ident istr), t) -> do maybeLocal <- localExists ident if maybeLocal then do t' <- getMonoFromPoly t From bef78217565ccc6583b63ee5e16dafd88c6421cc Mon Sep 17 00:00:00 2001 From: Rakarake Date: Fri, 24 Mar 2023 00:55:05 +0100 Subject: [PATCH 15/15] ReaderT rewrite, recursive and cyclic calls should work --- src/Monomorpher/Monomorpher.hs | 163 ++++++++++++++++----------------- 1 file changed, 77 insertions(+), 86 deletions(-) diff --git a/src/Monomorpher/Monomorpher.hs b/src/Monomorpher/Monomorpher.hs index 96663f8..92851a5 100644 --- a/src/Monomorpher/Monomorpher.hs +++ b/src/Monomorpher/Monomorpher.hs @@ -20,6 +20,8 @@ -- If not, the bind transformer function is called on it with the -- expected type in this context. The result of this computation (a monomorphic -- bind) is added to the resulting set of binds. + +{-# LANGUAGE LambdaCase #-} module Monomorpher.Monomorpher (monomorphize, morphExp, morphBind) where @@ -28,85 +30,69 @@ import qualified Monomorpher.MonomorpherIr as M import Grammar.Abs (Ident (Ident)) -import Control.Monad.State (MonadState (get), State, gets, modify, execState) +import Debug.Trace +import Control.Monad.State (MonadState, gets, modify, StateT (runStateT)) import qualified Data.Map as Map import qualified Data.Set as Set import Data.Maybe (fromJust) -import Debug.Trace - --- | The environment of computations in this module. -data Env = Env { -- | All binds in the program. - input :: Map.Map Ident T.Bind, - -- | The monomorphized binds. - output :: Map.Map Ident M.Bind, - -- | Maps polymorphic identifiers with concrete types. - polys :: Map.Map Ident M.Type, - -- | Local variables, not necessary if id's are annotated based - -- on if they are local or global. - locals :: Set.Set Ident, - -- | The identifier of the current function. - currentFunc :: Ident - } deriving (Show) +import Control.Monad.Reader (Reader, MonadReader (local, ask), asks, runReader) -- | State Monad wrapper for "Env". -type EnvM a = State Env a +newtype EnvM a = EnvM (StateT Output (Reader Env) a) + deriving (Functor, Applicative, Monad, MonadState Output, MonadReader Env) + +type Output = Map.Map Ident Outputted +-- When a bind is being processed, it is Incomplete in the state, also +-- called marked. +data Outputted = Incomplete | Complete M.Bind + +-- Static environment +data Env = Env { + -- | All binds in the program. + input :: Map.Map Ident T.Bind, + -- | Maps polymorphic identifiers with concrete types. + polys :: Map.Map Ident M.Type, + -- | Local variables + locals :: Set.Set Ident +} + +runEnvM :: Output -> Env -> EnvM () -> Output +runEnvM o env (EnvM stateM) = snd $ runReader (runStateT stateM o) env + + -- | Creates the environment based on the input binds. createEnv :: [T.Bind] -> Env createEnv binds = Env { input = Map.fromList kvPairs, - output = Map.empty, polys = Map.empty, - locals = Set.empty, - currentFunc = Ident "main" } + locals = Set.empty } where kvPairs :: [(Ident, T.Bind)] kvPairs = map (\b@(T.Bind (ident, _) _ _) -> (ident, b)) binds --- | Functions to add, clear and get whether id is a local variable. -addLocal :: Ident -> EnvM () -addLocal ident = modify (\env -> env { locals = Set.insert ident (locals env) }) - -addLocals :: [Ident] -> EnvM () -addLocals idents = modify (\env -> - env { locals = Set.fromList idents `Set.union` locals env }) - -clearLocals :: EnvM () -clearLocals = modify (\env -> env { locals = Set.empty }) - localExists :: Ident -> EnvM Bool -localExists ident = do env <- get - return $ Set.member ident (locals env) - --- | Gets whether ident is current function. -isCurrentFunc :: Ident -> EnvM Bool -isCurrentFunc ident = do env <- get - return $ ident == currentFunc env +localExists ident = asks (Set.member ident . locals) -- | Gets a polymorphic bind from an id. getInputBind :: Ident -> EnvM (Maybe T.Bind) -getInputBind ident = gets (Map.lookup ident . input) +getInputBind ident = asks (Map.lookup ident . input) -- | Add monomorphic function derived from a polymorphic one, to env. addOutputBind :: M.Bind -> EnvM () -addOutputBind b@(M.Bind (ident, _) _ _) = modify - (\env -> env { output = Map.insert ident b (output env) }) +addOutputBind b@(M.Bind (ident, _) _ _) = modify (Map.insert ident (Complete b)) --- | Checks whether or not an ident is added to output binds. -isBindOutputted :: Ident -> EnvM Bool -isBindOutputted ident = do env <- get - return $ Map.member ident (output env) +-- | Marks a global bind as being processed, meaning that when encountered again, +-- it should not be recursively processed. +markBind :: Ident -> EnvM () +markBind ident = modify (Map.insert ident Incomplete) + +-- | Check if bind has been touched or not. +isBindMarked :: Ident -> EnvM Bool +isBindMarked ident = gets (Map.member ident) -- | Finds main bind getMain :: EnvM T.Bind -getMain = gets (\env -> fromJust $ Map.lookup (T.Ident "main") (input env)) - --- | Add polymorphic -> monomorphic type bindings regardless of bind. --- The structue of the types should be the same. -mapTypesInBind :: M.Type -> T.Bind -> EnvM () -mapTypesInBind t1 (T.Bind (_, t2) _ _) = modify modFunc - where - modFunc env = env { polys = newPolys (polys env) } - newPolys oldPolys = Map.union oldPolys (Map.fromList (mapTypes t2 t1)) +getMain = asks (\env -> fromJust $ Map.lookup (T.Ident "main") (input env)) -- NOTE: could make this function more optimized -- | Makes a kv pair list of polymorphic to monomorphic mappings, throws runtime @@ -120,7 +106,7 @@ mapTypes _ _ = error "structure of types not the same!" -- | Gets the mapped monomorphic type of a polymorphic type in the current context. getMonoFromPoly :: T.Type -> EnvM M.Type -getMonoFromPoly t = do env <- get +getMonoFromPoly t = do env <- ask return $ getMono (polys env) t where getMono :: Map.Map Ident M.Type -> T.Type -> M.Type @@ -131,7 +117,7 @@ getMonoFromPoly t = do env <- get (T.TPol ident) -> case Map.lookup ident polys of Just concrete -> concrete Nothing -> error $ - "type not found! type: " ++ show ident + "type not found! type: " ++ show ident ++ ", error in previous compilation steps" -- Get type of expression getExpType :: T.Exp -> T.Type @@ -144,18 +130,23 @@ getExpType (T.ELet _ _) = error "lets not allowed🛑👮" -- | If ident not already in env's output, morphed bind to output -- (and all referenced binds within this bind). -morphBind :: M.Type -> T.Bind -> EnvM () -morphBind expectedType b@(T.Bind (Ident name, _) args exp) = do - outputted <- isBindOutputted (Ident name) - if outputted then - -- Don't add anything! - return () - else do - -- Add processed bind! - addLocals $ map fst args -- Add all the local variables - mapTypesInBind expectedType b - exp' <- morphExp expectedType exp - addOutputBind $ M.Bind (newName expectedType b, expectedType) [] exp' +-- Returns the annotated bind name. +morphBind :: M.Type -> T.Bind -> EnvM Ident +morphBind expectedType b@(T.Bind (Ident _, btype) args exp) = + local (\env -> env { locals = Set.fromList (map fst args), + polys = Map.fromList (mapTypes btype expectedType) + }) $ do + -- The "new name" is used to find out if it is already marked or not. + let name' = newName expectedType b + bindMarked <- isBindMarked 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 name' + exp' <- morphExp expectedType exp + addOutputBind $ M.Bind (name', expectedType) [] exp' + return name' -- Morphs function applications, such as EApp and EAdd morphApp :: M.Type -> T.Exp -> T.Exp -> EnvM M.Exp @@ -182,24 +173,19 @@ morphExp expectedType exp = case exp of T.EAbs _ (_, _) _ -> do error "EAbs found in Monomorpher, should not be possible" T.EId (ident@(Ident istr), t) -> do - maybeLocal <- localExists ident - if maybeLocal then do - t' <- getMonoFromPoly t + isLocal <- localExists ident + t' <- getMonoFromPoly t + if isLocal then do return $ M.EId (ident, t') else do - clearLocals bind <- getInputBind ident case bind of Nothing -> - error $ "bind of name: " ++ istr ++ " not found" + error $ "bind of name: " ++ istr ++ " not found, bug in previous compilation steps" Just bind' -> do - maybeCurrentFunc <- isCurrentFunc ident - t' <- getMonoFromPoly t - if maybeCurrentFunc then -- Recursive call? - return () - else - morphBind t' bind' - return $ M.EId (ident, t') + -- New bind to process + newBindName <- morphBind t' bind' + return $ M.EId (newBindName, t') T.ELet (T.Bind {}) _ -> error "lets not possible yet" @@ -211,16 +197,21 @@ newName t (T.Bind (Ident bindName, _) _ _) = Ident (bindName ++ "$" ++ newName' newName' (M.TMono (Ident str)) = str newName' (M.TArr t1 t2) = newName' t1 ++ "_" ++ newName' t2 --- TODO: make sure that monomorphic binds are not processed again --- | Does the monomorphization. +-- Monomorphization step monomorphize :: T.Program -> M.Program -monomorphize (T.Program binds) = M.Program $ (map snd . Map.toList) outputMap +monomorphize (T.Program binds) = M.Program $ getBindsFromOutput + (runEnvM Map.empty (createEnv binds) monomorphize') where - outputMap :: Map.Map Ident M.Bind - outputMap = output $ execState monomorphize' (createEnv binds) - monomorphize' :: EnvM () monomorphize' = do main <- getMain morphBind (M.TMono $ M.Ident "Int") main + return () + +getBindsFromOutput :: Output -> [M.Bind] +getBindsFromOutput outputMap = (map snd . Map.toList) $ fmap + (\case + Incomplete -> error "" + Complete b -> b ) + outputMap