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 + ] +