From 43e0f67fe2dceb87a8669c2d412be9c5e445dd3a Mon Sep 17 00:00:00 2001 From: Martin Fredin Date: Sun, 22 Jan 2023 20:16:03 +0100 Subject: [PATCH 001/372] Fix conflict --- Grammar.cf | 2 +- src/Grammar/Doc.txt | 56 ++++++++++++++++ src/Grammar/Print.hs | 153 +++++++++++++++++++++++++++++++++++++++++++ src/Interpreter.hs | 4 +- test_program | 2 +- 5 files changed, 213 insertions(+), 4 deletions(-) create mode 100644 src/Grammar/Doc.txt create mode 100644 src/Grammar/Print.hs diff --git a/Grammar.cf b/Grammar.cf index b258446..d880ed2 100644 --- a/Grammar.cf +++ b/Grammar.cf @@ -6,7 +6,7 @@ EId. Exp3 ::= Ident ; EInt. Exp3 ::= Integer ; EApp. Exp2 ::= Exp2 Exp3 ; EAdd. Exp1 ::= Exp1 "+" Exp2 ; -EAbs. Exp ::= "\\" Ident "->" Exp ; +EAbs. Exp ::= "\\" Ident "." Exp ; coercions Exp 3 ; diff --git a/src/Grammar/Doc.txt b/src/Grammar/Doc.txt new file mode 100644 index 0000000..18a68c9 --- /dev/null +++ b/src/Grammar/Doc.txt @@ -0,0 +1,56 @@ +The Language Grammar +BNF Converter + + +%Process by txt2tags to generate html or latex + + + +This document was automatically generated by the //BNF-Converter//. It was generated together with the lexer, the parser, and the abstract syntax module, which guarantees that the document matches with the implementation of the language (provided no hand-hacking has taken place). + +==The lexical structure of Grammar== +===Identifiers=== +Identifiers //Ident// are unquoted strings beginning with a letter, +followed by any combination of letters, digits, and the characters ``_ '`` +reserved words excluded. + + +===Literals=== +Integer literals //Integer// are nonempty sequences of digits. + + + + +===Reserved words and symbols=== +The set of reserved words is the set of terminals appearing in the grammar. Those reserved words that consist of non-letter characters are called symbols, and they are treated in a different way from those that are similar to identifiers. The lexer follows rules familiar from languages like Haskell, C, and Java, including longest match and spacing conventions. + +The reserved words used in Grammar are the following: + | ``main`` | | | + +The symbols used in Grammar are the following: + | = | + | \ | . + | ( | ) | | + +===Comments=== +Single-line comments begin with --.Multiple-line comments are enclosed with {- and -}. + +==The syntactic structure of Grammar== +Non-terminals are enclosed between < and >. +The symbols -> (production), **|** (union) +and **eps** (empty rule) belong to the BNF notation. +All other symbols are terminals. + + | //Program// | -> | ``main`` ``=`` //Exp// + | //Exp3// | -> | //Ident// + | | **|** | //Integer// + | | **|** | ``(`` //Exp// ``)`` + | //Exp2// | -> | //Exp2// //Exp3// + | | **|** | //Exp3// + | //Exp1// | -> | //Exp1// ``+`` //Exp2// + | | **|** | //Exp2// + | //Exp// | -> | ``\`` //Ident// ``.`` //Exp// + | | **|** | //Exp1// + + + +%% File generated by the BNF Converter (bnfc 2.9.4.1). diff --git a/src/Grammar/Print.hs b/src/Grammar/Print.hs new file mode 100644 index 0000000..377a3cf --- /dev/null +++ b/src/Grammar/Print.hs @@ -0,0 +1,153 @@ +-- File generated by the BNF Converter (bnfc 2.9.4.1). + +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +#if __GLASGOW_HASKELL__ <= 708 +{-# LANGUAGE OverlappingInstances #-} +#endif + +-- | Pretty-printer for Grammar. + +module Grammar.Print where + +import Prelude + ( ($), (.) + , Bool(..), (==), (<) + , Int, Integer, Double, (+), (-), (*) + , String, (++) + , ShowS, showChar, showString + , all, elem, foldr, id, map, null, replicate, shows, span + ) +import Data.Char ( Char, isSpace ) +import qualified Grammar.Abs + +-- | The top-level printing method. + +printTree :: Print a => a -> String +printTree = render . prt 0 + +type Doc = [ShowS] -> [ShowS] + +doc :: ShowS -> Doc +doc = (:) + +render :: Doc -> String +render d = rend 0 False (map ($ "") $ d []) "" + where + rend + :: Int -- ^ Indentation level. + -> Bool -- ^ Pending indentation to be output before next character? + -> [String] + -> ShowS + rend i p = \case + "[" :ts -> char '[' . rend i False ts + "(" :ts -> char '(' . rend i False ts + "{" :ts -> onNewLine i p . showChar '{' . new (i+1) ts + "}" : ";":ts -> onNewLine (i-1) p . showString "};" . new (i-1) ts + "}" :ts -> onNewLine (i-1) p . showChar '}' . new (i-1) ts + [";"] -> char ';' + ";" :ts -> char ';' . new i ts + t : ts@(s:_) | closingOrPunctuation s + -> pending . showString t . rend i False ts + t :ts -> pending . space t . rend i False ts + [] -> id + where + -- Output character after pending indentation. + char :: Char -> ShowS + char c = pending . showChar c + + -- Output pending indentation. + pending :: ShowS + pending = if p then indent i else id + + -- Indentation (spaces) for given indentation level. + indent :: Int -> ShowS + indent i = replicateS (2*i) (showChar ' ') + + -- Continue rendering in new line with new indentation. + new :: Int -> [String] -> ShowS + new j ts = showChar '\n' . rend j True ts + + -- Make sure we are on a fresh line. + onNewLine :: Int -> Bool -> ShowS + onNewLine i p = (if p then id else showChar '\n') . indent i + + -- Separate given string from following text by a space (if needed). + space :: String -> ShowS + space t s = + case (all isSpace t', null spc, null rest) of + (True , _ , True ) -> [] -- remove trailing space + (False, _ , True ) -> t' -- remove trailing space + (False, True, False) -> t' ++ ' ' : s -- add space if none + _ -> t' ++ s + where + t' = showString t [] + (spc, rest) = span isSpace s + + closingOrPunctuation :: String -> Bool + closingOrPunctuation [c] = c `elem` closerOrPunct + closingOrPunctuation _ = False + + closerOrPunct :: String + closerOrPunct = ")],;" + +parenth :: Doc -> Doc +parenth ss = doc (showChar '(') . ss . doc (showChar ')') + +concatS :: [ShowS] -> ShowS +concatS = foldr (.) id + +concatD :: [Doc] -> Doc +concatD = foldr (.) id + +replicateS :: Int -> ShowS -> ShowS +replicateS n f = concatS (replicate n f) + +-- | The printer class does the job. + +class Print a where + prt :: Int -> a -> Doc + +instance {-# OVERLAPPABLE #-} Print a => Print [a] where + prt i = concatD . map (prt i) + +instance Print Char where + prt _ c = doc (showChar '\'' . mkEsc '\'' c . showChar '\'') + +instance Print String where + prt _ = printString + +printString :: String -> Doc +printString s = doc (showChar '"' . concatS (map (mkEsc '"') s) . showChar '"') + +mkEsc :: Char -> Char -> ShowS +mkEsc q = \case + s | s == q -> showChar '\\' . showChar s + '\\' -> showString "\\\\" + '\n' -> showString "\\n" + '\t' -> showString "\\t" + s -> showChar s + +prPrec :: Int -> Int -> Doc -> Doc +prPrec i j = if j < i then parenth else id + +instance Print Integer where + prt _ x = doc (shows x) + +instance Print Double where + prt _ x = doc (shows x) + +instance Print Grammar.Abs.Ident where + prt _ (Grammar.Abs.Ident i) = doc $ showString i +instance Print Grammar.Abs.Program where + prt i = \case + Grammar.Abs.Program exp -> prPrec i 0 (concatD [doc (showString "main"), doc (showString "="), prt 0 exp]) + +instance Print Grammar.Abs.Exp where + prt i = \case + Grammar.Abs.EId id_ -> prPrec i 3 (concatD [prt 0 id_]) + Grammar.Abs.EInt n -> prPrec i 3 (concatD [prt 0 n]) + Grammar.Abs.EApp exp1 exp2 -> prPrec i 2 (concatD [prt 2 exp1, prt 3 exp2]) + Grammar.Abs.EAdd exp1 exp2 -> prPrec i 1 (concatD [prt 1 exp1, doc (showString "+"), prt 2 exp2]) + Grammar.Abs.EAbs id_ exp -> prPrec i 0 (concatD [doc (showString "\\"), prt 0 id_, doc (showString "."), prt 0 exp]) diff --git a/src/Interpreter.hs b/src/Interpreter.hs index bdbd8d2..378c95b 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -39,7 +39,7 @@ eval cxt = \case EInt i -> pure $ VInt i - -- γ ⊢ e ⇓ let δ in λx → f + -- γ ⊢ e ⇓ let δ in λx. f -- γ ⊢ e₁ ⇓ v -- δ,x=v ⊢ f ⇓ v₁ -- ------------------------------ @@ -54,7 +54,7 @@ eval cxt = \case -- -- ----------------------------- - -- γ ⊢ λx → f ⇓ let γ in λx → f + -- γ ⊢ λx. f ⇓ let γ in λx. f EAbs x e -> pure $ VClosure cxt x e diff --git a/test_program b/test_program index 83f3e9a..95235e4 100644 --- a/test_program +++ b/test_program @@ -2,4 +2,4 @@ -main = (\x -> x + x + 3) ((\x -> x) 2) +main = (\x. x + x + 3) ((\x. x) 2) From b6b2dfa25f40c2416503dfc3518a05b34d8ad878 Mon Sep 17 00:00:00 2001 From: sebastianselander Date: Mon, 23 Jan 2023 17:17:06 +0100 Subject: [PATCH 002/372] Some work on a typechecker --- Grammar.cf | 18 ++++++++--- Makefile | 2 +- language.cabal | 3 +- src/Interpreter.hs | 76 +++------------------------------------------- src/TypeChecker.hs | 76 ++++++++++++++++++++++++++++++++++++++++++++++ test_program | 7 ++--- 6 files changed, 98 insertions(+), 84 deletions(-) diff --git a/Grammar.cf b/Grammar.cf index b258446..fb80ea1 100644 --- a/Grammar.cf +++ b/Grammar.cf @@ -1,15 +1,23 @@ +Program. Program ::= [Def] ; +DExp. Def ::= Ident ":" Type + Ident [Ident] "=" Exp ; -Program. Program ::= "main" "=" Exp ; +separator Def ""; +separator Ident ""; +separator Type "->"; EId. Exp3 ::= Ident ; EInt. Exp3 ::= Integer ; -EApp. Exp2 ::= Exp2 Exp3 ; +-- EApp. Exp2 ::= Exp2 Exp3 ; EAdd. Exp1 ::= Exp1 "+" Exp2 ; -EAbs. Exp ::= "\\" Ident "->" Exp ; - +-- EAbs. Exp ::= "\\" Ident ":" Type "." Exp ; coercions Exp 3 ; +TInt. Type1 ::= "Int" ; +TPol. Type1 ::= Ident ; +TFun. Type ::= [Type] ; +coercions Type 1 ; + comment "--" ; comment "{-" "-}" ; - diff --git a/Makefile b/Makefile index 16b753d..35736a1 100644 --- a/Makefile +++ b/Makefile @@ -1,7 +1,7 @@ .PHONY : sdist clean language : src/Grammar/Test - cabal install --installdir=. + cabal install --installdir=. --overwrite-policy=always src/Grammar/Test.hs src/Grammar/Lex.x src/Grammar/Par.y : Grammar.cf bnfc -o src -d $< diff --git a/language.cabal b/language.cabal index fc1c2fe..0f1a53c 100644 --- a/language.cabal +++ b/language.cabal @@ -31,11 +31,12 @@ executable language Grammar.Print Grammar.Skel Interpreter + TypeChecker hs-source-dirs: src build-depends: - base ^>=4.16.3.0 + base >= 4.16.3.0 , mtl , containers , either diff --git a/src/Interpreter.hs b/src/Interpreter.hs index bdbd8d2..dc34d49 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -1,78 +1,10 @@ {-# LANGUAGE LambdaCase #-} + module Interpreter where -import Control.Applicative (Applicative) -import Control.Monad.Except (Except, MonadError (throwError), - liftEither) -import Data.Either.Combinators (maybeToRight) -import Data.Map (Map) -import qualified Data.Map as Map +import Control.Monad.Except (Except, MonadError (throwError)) + import Grammar.Abs -import Grammar.Print (printTree) interpret :: Program -> Except String Integer -interpret (Program e) = - eval mempty e >>= \case - VClosure {} -> throwError "main evaluated to a function" - VInt i -> pure i - - -data Val = VInt Integer - | VClosure Cxt Ident Exp - -type Cxt = Map Ident Val - -eval :: Cxt -> Exp -> Except String Val -eval cxt = \case - - - -- ------------ x ∈ γ - -- γ ⊢ x ⇓ γ(x) - - EId x -> - maybeToRightM - ("Unbound variable:" ++ printTree x) - $ Map.lookup x cxt - - -- --------- - -- γ ⊢ i ⇓ i - - EInt i -> pure $ VInt i - - -- γ ⊢ e ⇓ let δ in λx → f - -- γ ⊢ e₁ ⇓ v - -- δ,x=v ⊢ f ⇓ v₁ - -- ------------------------------ - -- γ ⊢ e e₁ ⇓ v₁ - - EApp e e1 -> - eval cxt e >>= \case - VInt _ -> throwError "Not a function" - VClosure delta x f -> do - v <- eval cxt e1 - eval (Map.insert x v delta) f - - -- - -- ----------------------------- - -- γ ⊢ λx → f ⇓ let γ in λx → f - - EAbs x e -> pure $ VClosure cxt x e - - - -- γ ⊢ e ⇓ v - -- γ ⊢ e₁ ⇓ v₁ - -- ------------------ - -- γ ⊢ e e₁ ⇓ v + v₁ - - EAdd e e1 -> do - v <- eval cxt e - v1 <- eval cxt e1 - case (v, v1) of - (VInt i, VInt i1) -> pure $ VInt (i + i1) - _ -> throwError "Can't add a function" - - - -maybeToRightM :: MonadError l m => l -> Maybe r -> m r -maybeToRightM err = liftEither . maybeToRight err - +interpret (Program _) = throwError "Can not interpret program yet" diff --git a/src/TypeChecker.hs b/src/TypeChecker.hs index e69de29..d4bf673 100644 --- a/src/TypeChecker.hs +++ b/src/TypeChecker.hs @@ -0,0 +1,76 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeApplications #-} + +module TypeChecker where + +import Grammar.Abs +import Grammar.ErrM +import Data.Kind qualified as T +import Data.String qualified +import Data.Map (Map) +import Data.Map qualified as Map +import Control.Monad.Reader +import Control.Monad.Except + +newtype Env = Env { signature :: Map Ident CType } + +type Check a = ReaderT Env Err a + +initEnv :: Env +initEnv = Env { signature = mempty } + +run :: Check a -> Either String a +run = flip runReaderT initEnv + +checkProg :: Program -> Check Program +checkProg (Program ds) = Program <$> mapM checkDef ds + +checkDef :: Def -> Check Def +checkDef = \case + (DExp n1 TInt n2 params e) -> undefined + (DExp n1 (TPol (Ident t)) n2 params e) -> undefined + (DExp n1 ts n2 params e) -> undefined + +class Typecheck a where + checkExp :: Exp -> Check (CExp a) + +instance Typecheck Int where + checkExp = \case + EInt i -> pure $ CInt (fromIntegral i) + EAdd e1 e2 -> do + e1' <- checkExp @Int e1 + e2' <- checkExp @Int e2 + return $ CAdd e1' e2' + EId (Ident i) -> asks (lookupSig (Ident i)) >>= liftEither >>= \case + TCInt -> pure (CId (CIdent i)) + _ -> throwError $ "Unbound variable " <> show i + +data CExp :: T.Type -> T.Type where + CId :: CIdent -> CExp a + CInt :: Int -> CExp Int + CAdd :: Num a => CExp a -> CExp a -> CExp a + +instance Show (CExp a) where + show = \case + CId (CIdent a) -> show a + CInt i -> show i + CAdd e1 e2 -> show e1 <> " + " <> show e2 + +data CDef a = CDef CIdent CType CIdent [CIdent] (CExp a) + deriving Show + +newtype CProgram = CProgram [Def] + +data CType = TCInt | TCPol Ident | TCFun Type Type + deriving (Eq, Ord, Show, Read) + +newtype CIdent = CIdent String + deriving (Eq, Ord, Show, Read, Data.String.IsString) + +lookupSig :: Ident -> Env -> Err CType +lookupSig i (Env m) = case Map.lookup i m of + Nothing -> throwError $ "Unbound variable: " <> show i + Just x -> pure x + + diff --git a/test_program b/test_program index 83f3e9a..77bf0ad 100644 --- a/test_program +++ b/test_program @@ -1,5 +1,2 @@ - - - - -main = (\x -> x + x + 3) ((\x -> x) 2) +main : Int +main = (\x : Int. x + x + 3) ((\x : Int. x) 2) From be3fcfc9e3c2394e5d6517cbeabbd19b38088420 Mon Sep 17 00:00:00 2001 From: sebastianselander Date: Tue, 24 Jan 2023 16:39:22 +0100 Subject: [PATCH 003/372] Typeinference/checking on expressions done. Simplified the typechecker a bit, removed GADT solution for now. Still not fully working --- Grammar.cf | 4 +- language.cabal | 4 +- src/Main.hs | 30 +++++---- src/NewAbs.hs | 29 +++++++++ src/TypeChecker.hs | 149 ++++++++++++++++++++++++++++++--------------- 5 files changed, 153 insertions(+), 63 deletions(-) create mode 100644 src/NewAbs.hs diff --git a/Grammar.cf b/Grammar.cf index fb80ea1..e072d5e 100644 --- a/Grammar.cf +++ b/Grammar.cf @@ -9,9 +9,9 @@ separator Type "->"; EId. Exp3 ::= Ident ; EInt. Exp3 ::= Integer ; --- EApp. Exp2 ::= Exp2 Exp3 ; +EApp. Exp2 ::= Exp2 Exp3 ; EAdd. Exp1 ::= Exp1 "+" Exp2 ; --- EAbs. Exp ::= "\\" Ident ":" Type "." Exp ; +EAbs. Exp ::= "\\" Ident ":" Type "." Exp ; coercions Exp 3 ; TInt. Type1 ::= "Int" ; diff --git a/language.cabal b/language.cabal index 0f1a53c..bb35f1f 100644 --- a/language.cabal +++ b/language.cabal @@ -17,7 +17,7 @@ extra-source-fiels: common warnings - ghc-options: -Wall + ghc-options: -W executable language import: warnings @@ -30,8 +30,10 @@ executable language Grammar.Par Grammar.Print Grammar.Skel + Grammar.ErrM Interpreter TypeChecker + NewAbs hs-source-dirs: src diff --git a/src/Main.hs b/src/Main.hs index ed753f2..ab2bd24 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -4,6 +4,7 @@ module Main where import Control.Monad.Except (runExcept) import Grammar.Par (myLexer, pProgram) import Interpreter (interpret) +import TypeChecker (typecheck) import System.Environment (getArgs) import System.Exit (exitFailure, exitSuccess) @@ -13,18 +14,23 @@ main = getArgs >>= \case (x:_) -> do file <- readFile x case pProgram (myLexer file) of - Left err -> do - putStrLn "SYNTAX ERROR" - putStrLn err - exitFailure - Right prg -> case runExcept $ interpret prg of - Left err -> do - putStrLn "INTERPRETER ERROR" - putStrLn err - exitFailure - Right i -> do - print i - exitSuccess + Left err -> do + putStrLn "SYNTAX ERROR" + putStrLn err + exitFailure + Right p -> case typecheck p of + Left err -> do + putStrLn "TYPECHECKING ERROR" + putStrLn err + exitFailure + Right prg -> case runExcept $ interpret prg of + Left err -> do + putStrLn "INTERPRETER ERROR" + putStrLn err + exitFailure + Right i -> do + print i + exitSuccess diff --git a/src/NewAbs.hs b/src/NewAbs.hs new file mode 100644 index 0000000..9a0296d --- /dev/null +++ b/src/NewAbs.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE GADTs, LambdaCase #-} + +module NewAbs where + +import Grammar.Abs ( Ident(..), Type ) + +data CExp where + CId :: Type -> Ident -> CExp + CInt :: Type -> Int -> CExp + CAdd :: Type -> CExp -> CExp -> CExp + CAbs :: Type -> Ident -> Type -> CExp -> CExp + CApp :: Type -> CExp -> CExp -> CExp + +instance Show CExp where + show :: CExp -> String + show = \case + CId _ (Ident a) -> show a + CInt _ i -> show i + CAdd _ e1 e2 -> show e1 <> " + " <> show e2 + CAbs t1 i t2 e -> appendType t1 $ show "\\" <> show i <> " : " <> show t2 <> ". " <> show e + CApp _ e1 e2 -> show e1 <> " " <> show e2 + +appendType :: Type -> String -> String +appendType t s = s <> " : " <> show t + +data CDef = CDef Ident Type Ident [Ident] CExp + deriving Show + +newtype CProgram = CProgram [CDef] diff --git a/src/TypeChecker.hs b/src/TypeChecker.hs index d4bf673..8e233bb 100644 --- a/src/TypeChecker.hs +++ b/src/TypeChecker.hs @@ -1,76 +1,129 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE GADTs #-} -{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE OverloadedRecordDot #-} -module TypeChecker where +module TypeChecker (typecheck) where import Grammar.Abs -import Grammar.ErrM -import Data.Kind qualified as T -import Data.String qualified +import Grammar.ErrM ( Err ) +import NewAbs import Data.Map (Map) import Data.Map qualified as Map import Control.Monad.Reader import Control.Monad.Except +import Data.List (isPrefixOf) +import Control.Applicative ((<|>)) -newtype Env = Env { signature :: Map Ident CType } +type Check a = ReaderT Context Err a -type Check a = ReaderT Env Err a +data Context = Ctx { sig :: Map Ident Type + , env :: [Map Ident Type] + } -initEnv :: Env -initEnv = Env { signature = mempty } +initEnv :: Context +initEnv = Ctx { sig = mempty + , env = mempty + } run :: Check a -> Either String a run = flip runReaderT initEnv -checkProg :: Program -> Check Program -checkProg (Program ds) = Program <$> mapM checkDef ds +typecheck :: Program -> Err Program +typecheck prg = case run $ checkProg prg of + Left err -> fail err + Right _ -> pure prg + + +checkProg :: Program -> Check CProgram +checkProg (Program ds) = undefined -checkDef :: Def -> Check Def -checkDef = \case - (DExp n1 TInt n2 params e) -> undefined - (DExp n1 (TPol (Ident t)) n2 params e) -> undefined - (DExp n1 ts n2 params e) -> undefined +checkDef :: Def -> Check CDef +checkDef (DExp i1 TInt i2 args e) = undefined +checkDef (DExp i1 (TPol i) i2 args e) = undefined +checkDef (DExp i1 (TFun xs) i2 args e) = do + when (i1 /= i2) (fail $ "Mismatched names: " <> show i1 <> " != " <> show i2) + case compare (length xs - 1) (length args) of + LT -> fail $ "Too many arguments, got " <> show (length args) <> " expected " <> show (length xs) + _ -> do + let vars = Map.fromList $ zip args xs + e' <- local (\r -> r { env = [vars] }) (checkExp e) + return $ CDef i1 (TFun xs) i2 args e' -class Typecheck a where - checkExp :: Exp -> Check (CExp a) +checkExp :: Exp -> Check CExp +checkExp = \case -instance Typecheck Int where - checkExp = \case - EInt i -> pure $ CInt (fromIntegral i) - EAdd e1 e2 -> do - e1' <- checkExp @Int e1 - e2' <- checkExp @Int e2 - return $ CAdd e1' e2' - EId (Ident i) -> asks (lookupSig (Ident i)) >>= liftEither >>= \case - TCInt -> pure (CId (CIdent i)) - _ -> throwError $ "Unbound variable " <> show i + EInt i -> pure $ CInt TInt (fromIntegral i) -data CExp :: T.Type -> T.Type where - CId :: CIdent -> CExp a - CInt :: Int -> CExp Int - CAdd :: Num a => CExp a -> CExp a -> CExp a + EAdd e1 e2 -> do + e1' <- checkExp e1 + e2' <- checkExp e2 + let t1 = getType e1' + let t2 = getType e2' + when (t1 /= t2) (fail $ "Different types occured, got " <> show t1 <> " and " <> show t2) + return $ CAdd t1 e1' e2' -instance Show (CExp a) where - show = \case - CId (CIdent a) -> show a - CInt i -> show i - CAdd e1 e2 -> show e1 <> " + " <> show e2 + EId i -> do + asks (lookupEnv i) >>= \case + Right t -> return $ CId t i + Left _ -> asks (lookupSig i) >>= \case + Right t -> return $ CId t i + Left x -> fail x -data CDef a = CDef CIdent CType CIdent [CIdent] (CExp a) - deriving Show + EAbs i t e -> do + e' <- local (\r -> r { env = Map.singleton i t : r.env }) (checkExp e) + return $ CAbs (TFun [t, getType e']) i t e' -newtype CProgram = CProgram [Def] + EApp e1 e2 -> do + e1' <- checkExp e1 + e2' <- checkExp e2 + let retT = applyType (getType e1') (getType e2') + case retT of + Left x -> fail x + Right t -> return $ CApp t e1' e2' -data CType = TCInt | TCPol Ident | TCFun Type Type - deriving (Eq, Ord, Show, Read) +lookupSig :: Ident -> Context -> Err Type +lookupSig i (Ctx s _) = case Map.lookup i s of + Nothing -> throwError $ "Undefined function: " <> show i + Just x -> pure x -newtype CIdent = CIdent String - deriving (Eq, Ord, Show, Read, Data.String.IsString) - -lookupSig :: Ident -> Env -> Err CType -lookupSig i (Env m) = case Map.lookup i m of - Nothing -> throwError $ "Unbound variable: " <> show i +lookupEnv :: Ident -> Context -> Err Type +lookupEnv i (Ctx _ []) = throwError $ "Unbound variable: " <> show i +lookupEnv i (Ctx s (e:es)) = case Map.lookup i e of + Nothing -> lookupEnv i (Ctx s es) Just x -> pure x +applyType :: Type -> Type -> Err Type +applyType (TFun (x:xs)) t = case t of + (TFun ys) -> if ys `isPrefixOf` (x:xs) + then return . TFun $ drop (length ys) (x:xs) + else fail $ "Mismatched types, expected " <> show x <> " got " <> show TInt +applyType t1 t2 = fail $ "Can not apply " <> show t1 <> " to " <> show t2 + +class ExtractType a where + getType :: a -> Type + +instance ExtractType CExp where + getType = \case + CId t _ -> t + CInt t _ -> t + CAdd t _ _ -> t + CAbs t _ _ _ -> t + CApp t _ _ -> t + +-- | λx : Int. x + 3 + 5 +customLambda1 :: Exp +customLambda1 = EAbs (Ident "x") TInt (EAdd (EId (Ident "x")) (EAdd (EInt 3) (EInt 5))) + +customLambda2 :: Exp +customLambda2 = EAbs (Ident "x") (TFun [TInt, TInt]) (EId (Ident "f")) + +-- | main : Int +-- main = λx : Int. x + 3 + 5 +customPrg1 :: Program +customPrg1 = Program [DExp (Ident "main") TInt (Ident "main") [] customLambda1] + +-- | main : Int -> Int +-- main = λx : Int. x + 3 + 5 +customPrg2 :: Program +customPrg2 = Program [DExp (Ident "main") (TFun [TInt, TInt]) (Ident "main") [] customLambda2] From 6607173b9353c8458967c097ea5bf4053ef5ba05 Mon Sep 17 00:00:00 2001 From: Patrik Jansson Date: Fri, 3 Feb 2023 11:12:44 +0100 Subject: [PATCH 004/372] Typo fix (to check access). --- .gitignore | 1 + language.cabal | 2 +- 2 files changed, 2 insertions(+), 1 deletion(-) diff --git a/.gitignore b/.gitignore index 5aa7a08..5112877 100644 --- a/.gitignore +++ b/.gitignore @@ -3,3 +3,4 @@ dist-newstyle *.x *.bak src/Grammar +/language diff --git a/language.cabal b/language.cabal index fc1c2fe..aac5d02 100644 --- a/language.cabal +++ b/language.cabal @@ -12,7 +12,7 @@ build-type: Simple extra-doc-files: CHANGELOG.md -extra-source-fiels: +extra-source-files: Grammar.cf From 84eb430c41c8abd8a14e7d25197c600ee1b4ec37 Mon Sep 17 00:00:00 2001 From: sebastianselander Date: Fri, 3 Feb 2023 11:29:42 +0100 Subject: [PATCH 005/372] relaxed base dependency and added overwrite --- language.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/language.cabal b/language.cabal index aac5d02..5734655 100644 --- a/language.cabal +++ b/language.cabal @@ -35,7 +35,7 @@ executable language hs-source-dirs: src build-depends: - base ^>=4.16.3.0 + base >=4.16 , mtl , containers , either From b6693815726c08192d4a80761bfe8c1f0f4e3785 Mon Sep 17 00:00:00 2001 From: Martin Fredin Date: Thu, 9 Feb 2023 05:18:49 +0100 Subject: [PATCH 006/372] Remove files from git --- src/Grammar/Doc.txt | 56 ---------------- src/Grammar/Print.hs | 153 ------------------------------------------- 2 files changed, 209 deletions(-) delete mode 100644 src/Grammar/Doc.txt delete mode 100644 src/Grammar/Print.hs diff --git a/src/Grammar/Doc.txt b/src/Grammar/Doc.txt deleted file mode 100644 index 18a68c9..0000000 --- a/src/Grammar/Doc.txt +++ /dev/null @@ -1,56 +0,0 @@ -The Language Grammar -BNF Converter - - -%Process by txt2tags to generate html or latex - - - -This document was automatically generated by the //BNF-Converter//. It was generated together with the lexer, the parser, and the abstract syntax module, which guarantees that the document matches with the implementation of the language (provided no hand-hacking has taken place). - -==The lexical structure of Grammar== -===Identifiers=== -Identifiers //Ident// are unquoted strings beginning with a letter, -followed by any combination of letters, digits, and the characters ``_ '`` -reserved words excluded. - - -===Literals=== -Integer literals //Integer// are nonempty sequences of digits. - - - - -===Reserved words and symbols=== -The set of reserved words is the set of terminals appearing in the grammar. Those reserved words that consist of non-letter characters are called symbols, and they are treated in a different way from those that are similar to identifiers. The lexer follows rules familiar from languages like Haskell, C, and Java, including longest match and spacing conventions. - -The reserved words used in Grammar are the following: - | ``main`` | | | - -The symbols used in Grammar are the following: - | = | + | \ | . - | ( | ) | | - -===Comments=== -Single-line comments begin with --.Multiple-line comments are enclosed with {- and -}. - -==The syntactic structure of Grammar== -Non-terminals are enclosed between < and >. -The symbols -> (production), **|** (union) -and **eps** (empty rule) belong to the BNF notation. -All other symbols are terminals. - - | //Program// | -> | ``main`` ``=`` //Exp// - | //Exp3// | -> | //Ident// - | | **|** | //Integer// - | | **|** | ``(`` //Exp// ``)`` - | //Exp2// | -> | //Exp2// //Exp3// - | | **|** | //Exp3// - | //Exp1// | -> | //Exp1// ``+`` //Exp2// - | | **|** | //Exp2// - | //Exp// | -> | ``\`` //Ident// ``.`` //Exp// - | | **|** | //Exp1// - - - -%% File generated by the BNF Converter (bnfc 2.9.4.1). diff --git a/src/Grammar/Print.hs b/src/Grammar/Print.hs deleted file mode 100644 index 377a3cf..0000000 --- a/src/Grammar/Print.hs +++ /dev/null @@ -1,153 +0,0 @@ --- File generated by the BNF Converter (bnfc 2.9.4.1). - -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE LambdaCase #-} -#if __GLASGOW_HASKELL__ <= 708 -{-# LANGUAGE OverlappingInstances #-} -#endif - --- | Pretty-printer for Grammar. - -module Grammar.Print where - -import Prelude - ( ($), (.) - , Bool(..), (==), (<) - , Int, Integer, Double, (+), (-), (*) - , String, (++) - , ShowS, showChar, showString - , all, elem, foldr, id, map, null, replicate, shows, span - ) -import Data.Char ( Char, isSpace ) -import qualified Grammar.Abs - --- | The top-level printing method. - -printTree :: Print a => a -> String -printTree = render . prt 0 - -type Doc = [ShowS] -> [ShowS] - -doc :: ShowS -> Doc -doc = (:) - -render :: Doc -> String -render d = rend 0 False (map ($ "") $ d []) "" - where - rend - :: Int -- ^ Indentation level. - -> Bool -- ^ Pending indentation to be output before next character? - -> [String] - -> ShowS - rend i p = \case - "[" :ts -> char '[' . rend i False ts - "(" :ts -> char '(' . rend i False ts - "{" :ts -> onNewLine i p . showChar '{' . new (i+1) ts - "}" : ";":ts -> onNewLine (i-1) p . showString "};" . new (i-1) ts - "}" :ts -> onNewLine (i-1) p . showChar '}' . new (i-1) ts - [";"] -> char ';' - ";" :ts -> char ';' . new i ts - t : ts@(s:_) | closingOrPunctuation s - -> pending . showString t . rend i False ts - t :ts -> pending . space t . rend i False ts - [] -> id - where - -- Output character after pending indentation. - char :: Char -> ShowS - char c = pending . showChar c - - -- Output pending indentation. - pending :: ShowS - pending = if p then indent i else id - - -- Indentation (spaces) for given indentation level. - indent :: Int -> ShowS - indent i = replicateS (2*i) (showChar ' ') - - -- Continue rendering in new line with new indentation. - new :: Int -> [String] -> ShowS - new j ts = showChar '\n' . rend j True ts - - -- Make sure we are on a fresh line. - onNewLine :: Int -> Bool -> ShowS - onNewLine i p = (if p then id else showChar '\n') . indent i - - -- Separate given string from following text by a space (if needed). - space :: String -> ShowS - space t s = - case (all isSpace t', null spc, null rest) of - (True , _ , True ) -> [] -- remove trailing space - (False, _ , True ) -> t' -- remove trailing space - (False, True, False) -> t' ++ ' ' : s -- add space if none - _ -> t' ++ s - where - t' = showString t [] - (spc, rest) = span isSpace s - - closingOrPunctuation :: String -> Bool - closingOrPunctuation [c] = c `elem` closerOrPunct - closingOrPunctuation _ = False - - closerOrPunct :: String - closerOrPunct = ")],;" - -parenth :: Doc -> Doc -parenth ss = doc (showChar '(') . ss . doc (showChar ')') - -concatS :: [ShowS] -> ShowS -concatS = foldr (.) id - -concatD :: [Doc] -> Doc -concatD = foldr (.) id - -replicateS :: Int -> ShowS -> ShowS -replicateS n f = concatS (replicate n f) - --- | The printer class does the job. - -class Print a where - prt :: Int -> a -> Doc - -instance {-# OVERLAPPABLE #-} Print a => Print [a] where - prt i = concatD . map (prt i) - -instance Print Char where - prt _ c = doc (showChar '\'' . mkEsc '\'' c . showChar '\'') - -instance Print String where - prt _ = printString - -printString :: String -> Doc -printString s = doc (showChar '"' . concatS (map (mkEsc '"') s) . showChar '"') - -mkEsc :: Char -> Char -> ShowS -mkEsc q = \case - s | s == q -> showChar '\\' . showChar s - '\\' -> showString "\\\\" - '\n' -> showString "\\n" - '\t' -> showString "\\t" - s -> showChar s - -prPrec :: Int -> Int -> Doc -> Doc -prPrec i j = if j < i then parenth else id - -instance Print Integer where - prt _ x = doc (shows x) - -instance Print Double where - prt _ x = doc (shows x) - -instance Print Grammar.Abs.Ident where - prt _ (Grammar.Abs.Ident i) = doc $ showString i -instance Print Grammar.Abs.Program where - prt i = \case - Grammar.Abs.Program exp -> prPrec i 0 (concatD [doc (showString "main"), doc (showString "="), prt 0 exp]) - -instance Print Grammar.Abs.Exp where - prt i = \case - Grammar.Abs.EId id_ -> prPrec i 3 (concatD [prt 0 id_]) - Grammar.Abs.EInt n -> prPrec i 3 (concatD [prt 0 n]) - Grammar.Abs.EApp exp1 exp2 -> prPrec i 2 (concatD [prt 2 exp1, prt 3 exp2]) - Grammar.Abs.EAdd exp1 exp2 -> prPrec i 1 (concatD [prt 1 exp1, doc (showString "+"), prt 2 exp2]) - Grammar.Abs.EAbs id_ exp -> prPrec i 0 (concatD [doc (showString "\\"), prt 0 id_, doc (showString "."), prt 0 exp]) From 1f47288fcffde023ee23d84aa188762246a57771 Mon Sep 17 00:00:00 2001 From: Martin Fredin Date: Thu, 9 Feb 2023 05:19:51 +0100 Subject: [PATCH 007/372] Implement lambda lifting passes: freeVars, abstract, and rename --- Grammar.cf | 28 ++++--- language.cabal | 4 +- src/LambdaLifter.hs | 173 ++++++++++++++++++++++++++++++++++++++++++++ src/Main.hs | 29 ++++---- 4 files changed, 211 insertions(+), 23 deletions(-) create mode 100644 src/LambdaLifter.hs diff --git a/Grammar.cf b/Grammar.cf index d880ed2..9dba2f5 100644 --- a/Grammar.cf +++ b/Grammar.cf @@ -1,15 +1,25 @@ -Program. Program ::= "main" "=" Exp ; +Program. Program ::= [ScDef]; -EId. Exp3 ::= Ident ; -EInt. Exp3 ::= Integer ; -EApp. Exp2 ::= Exp2 Exp3 ; -EAdd. Exp1 ::= Exp1 "+" Exp2 ; -EAbs. Exp ::= "\\" Ident "." Exp ; +ScDef. ScDef ::= Bind; +separator ScDef ";"; -coercions Exp 3 ; +separator Ident " "; -comment "--" ; -comment "{-" "-}" ; + +EId. Exp3 ::= Ident; +EInt. Exp3 ::= Integer; +ELet. Exp3 ::= "let" [Bind] "in" Exp; +EApp. Exp2 ::= Exp2 Exp3; +EAdd. Exp1 ::= Exp1 "+" Exp2; +EAbs. Exp ::= "\\" Ident "." Exp; + +Bind. Bind ::= Ident [Ident] "=" Exp; +separator Bind ";"; + +coercions Exp 3; + +comment "--"; +comment "{-" "-}"; diff --git a/language.cabal b/language.cabal index 5734655..3f4860c 100644 --- a/language.cabal +++ b/language.cabal @@ -30,7 +30,8 @@ executable language Grammar.Par Grammar.Print Grammar.Skel - Interpreter + LambdaLifter + -- Interpreter hs-source-dirs: src @@ -40,5 +41,6 @@ executable language , containers , either , array + , extra default-language: GHC2021 diff --git a/src/LambdaLifter.hs b/src/LambdaLifter.hs new file mode 100644 index 0000000..6e1463d --- /dev/null +++ b/src/LambdaLifter.hs @@ -0,0 +1,173 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} + + +module LambdaLifter (lambdaLift, freeVars, abstract) where + +import Data.List (mapAccumL) +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Maybe (fromJust) +import Data.Set (Set, (\\)) +import qualified Data.Set as Set +import Data.Tuple.Extra (uncurry3) +import Grammar.Abs +import Prelude hiding (exp) + +pattern Sc :: Ident -> [Ident] -> Exp -> ScDef +pattern Sc n xs e = ScDef (Bind n xs e) + + + +lambdaLift :: Program -> Program +lambdaLift = rename . abstract . freeVars + + +-- Annotate free variables + +freeVars :: Program -> AnnProgram +freeVars (Program ds) = [ (n, xs, freeVarsExp (Set.fromList xs) e) + | Sc n xs e <- ds + ] + + +freeVarsExp :: Set Ident -> Exp -> AnnExp +freeVarsExp lv = \case + + EId n | Set.member n lv -> (Set.singleton n, AId n) + | otherwise -> (mempty, AId n) + + EInt i -> (mempty, AInt i) + + EApp e1 e2 -> (Set.union (freeVarsOf e1') (freeVarsOf e2'), AApp e1' e2') + where e1' = freeVarsExp lv e1 + e2' = freeVarsExp lv e2 + + EAdd e1 e2 -> (Set.union (freeVarsOf e1') (freeVarsOf e2'), AAdd e1' e2') + where e1' = freeVarsExp lv e1 + e2' = freeVarsExp lv e2 + + EAbs n e -> (Set.delete n $ freeVarsOf e', AAbs n e') + where e' = freeVarsExp (Set.insert n lv) e + + ELet bs e -> (Set.union bsFree eFree, ALet bs' e') + where + bsFree = freeInValues \\ nsSet + eFree = freeVarsOf e' \\ nsSet + bs' = zipWith3 ABind ns xs es' + e' = freeVarsExp e_lv e + (ns, xs, es) = fromBinders bs + nsSet = Set.fromList ns + e_lv = Set.union lv nsSet + es' = map (freeVarsExp e_lv) es + freeInValues = foldr1 Set.union (map freeVarsOf es') + + + +freeVarsOf :: AnnExp -> Set Ident +freeVarsOf = fst + +fromBinders :: [Bind] -> ([Ident], [[Ident]], [Exp]) +fromBinders bs = unzip3 [ (n, xs, e) | Bind n xs e <- bs ] + +-- Lift lambda expression into let with binder "sc" + +abstract :: AnnProgram -> Program +abstract p = Program + [ Sc sc_name xs $ abstractExp rhs + | (sc_name, xs, rhs) <- p + ] + + +abstractExp :: AnnExp -> Exp +abstractExp (free, exp) = case exp of + AId n -> EId n + AInt i -> EInt i + AApp e1 e2 -> EApp (abstractExp e1) (abstractExp e2) + AAdd e1 e2 -> EAdd (abstractExp e1) (abstractExp e2) + ALet bs e -> ELet [Bind n xs (abstractExp e1) | ABind n xs e1 <- bs ] $ abstractExp e + AAbs n e -> foldl EApp sc (map EId fvList) + where + fvList = Set.toList free + bind = Bind "sc" [] e' + e' = foldr EAbs (abstractExp e) (fvList ++ [n]) + sc = ELet [bind] (EId (Ident "sc")) + +-- rename pass + +rename :: Program -> Program +rename (Program ds) = Program $ map (uncurry3 Sc) tuples + where + tuples = snd (mapAccumL renameSc 0 ds) + renameSc i (Sc n xs e) = (i2, (n, xs', e')) + where + (i1, xs', env) = newNames i xs + (i2, e') = renameExp env i1 e + +renameExp :: Map Ident Ident -> Int -> Exp -> (Int, Exp) +renameExp env i = \case + + + EId n -> (i, maybe (error "no") EId $ Map.lookup n env) + + + EInt i1 -> (i, EInt i1) + + EApp e1 e2 -> (i2, EApp e1' e2') + where + (i1, e1') = renameExp env i e1 + (i2, e2') = renameExp env i1 e2 + + EAdd e1 e2 -> (i2, EAdd e1' e2') + where + (i1, e1') = renameExp env i e1 + (i2, e2') = renameExp env i1 e2 + + ELet bs e -> (i3, ELet (zipWith3 Bind ns' xs es') e') + where + (i1, e') = renameExp e_env i e + (ns, xs, es) = fromBinders bs + (i2, ns', env') = newNames i1 ns + e_env = Map.union env' env + (i3, es') = mapAccumL (renameExp e_env) i2 es + + + EAbs n e -> (i2, EAbs (head ns) e') + where + (i1, ns, env') = newNames i [n] + (i2, e') = renameExp (Map.union env' env ) i1 e + + +newNames :: Int -> [Ident] -> (Int, [Ident], Map Ident Ident) +newNames i old_names = (i', new_names, env) + where + (i', new_names) = getNames i old_names + env = Map.fromList $ zip old_names new_names + + +getName :: Int -> Ident -> (Int, Ident) +getName i (Ident s) = (i + 1, makeName s i) + +getNames :: Int -> [Ident] -> (Int, [Ident]) +getNames i ns = (i + length ss, zipWith makeName ss [i..]) + where + ss = map (\(Ident s) -> s) ns + +makeName :: String -> Int -> Ident +makeName prefix i = Ident (prefix ++ "_" ++ show i) + +-- Annotated AST + +type AnnProgram = [(Ident, [Ident], AnnExp)] +type AnnExp = (Set Ident, AnnExp') + +data ABind = ABind Ident [Ident] AnnExp deriving Show + +data AnnExp' = AId Ident + | AInt Integer + | AApp AnnExp AnnExp + | AAdd AnnExp AnnExp + | AAbs Ident AnnExp + | ALet [ABind] AnnExp + deriving Show diff --git a/src/Main.hs b/src/Main.hs index ed753f2..58aafe5 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -1,11 +1,11 @@ {-# LANGUAGE LambdaCase #-} module Main where -import Control.Monad.Except (runExcept) -import Grammar.Par (myLexer, pProgram) -import Interpreter (interpret) -import System.Environment (getArgs) -import System.Exit (exitFailure, exitSuccess) +import Grammar.Par (myLexer, pProgram) +import Grammar.Print (printTree) +import LambdaLifter (abstract, freeVars, lambdaLift) +import System.Environment (getArgs) +import System.Exit (exitFailure, exitSuccess) main :: IO () main = getArgs >>= \case @@ -17,14 +17,17 @@ main = getArgs >>= \case putStrLn "SYNTAX ERROR" putStrLn err exitFailure - Right prg -> case runExcept $ interpret prg of - Left err -> do - putStrLn "INTERPRETER ERROR" - putStrLn err - exitFailure - Right i -> do - print i - exitSuccess + Right prg -> do + putStrLn "-- Parser" + putStrLn $ printTree prg + putStrLn "\n--Lamda lifter" + putStrLn "\n--freevars" + print $ freeVars prg + putStrLn "\n--abstract" + putStrLn . printTree $ (abstract . freeVars) prg + putStrLn "\n--renamed" + putStrLn . printTree $ lambdaLift prg + exitSuccess From 7a2404cf74b4fffcd649fab330c61b7158b5034e Mon Sep 17 00:00:00 2001 From: Martin Fredin Date: Thu, 9 Feb 2023 06:19:58 +0100 Subject: [PATCH 008/372] Finish Lambda Lifter --- basic-2 | 4 +++ src/LambdaLifter.hs | 76 ++++++++++++++++++++++++++++++++++++++++----- src/Main.hs | 7 +---- 3 files changed, 74 insertions(+), 13 deletions(-) create mode 100644 basic-2 diff --git a/basic-2 b/basic-2 new file mode 100644 index 0000000..8afd060 --- /dev/null +++ b/basic-2 @@ -0,0 +1,4 @@ +add x = \y. x + y; + +main = (\z. z + z) ((add 4) 6); + diff --git a/src/LambdaLifter.hs b/src/LambdaLifter.hs index 6e1463d..512155d 100644 --- a/src/LambdaLifter.hs +++ b/src/LambdaLifter.hs @@ -3,12 +3,12 @@ {-# LANGUAGE PatternSynonyms #-} -module LambdaLifter (lambdaLift, freeVars, abstract) where +module LambdaLifter (lambdaLift, freeVars, abstract, rename, collectScs) where import Data.List (mapAccumL) import Data.Map (Map) import qualified Data.Map as Map -import Data.Maybe (fromJust) +import Data.Maybe (fromMaybe) import Data.Set (Set, (\\)) import qualified Data.Set as Set import Data.Tuple.Extra (uncurry3) @@ -21,7 +21,7 @@ pattern Sc n xs e = ScDef (Bind n xs e) lambdaLift :: Program -> Program -lambdaLift = rename . abstract . freeVars +lambdaLift = collectScs . rename . abstract . freeVars -- Annotate free variables @@ -94,7 +94,7 @@ abstractExp (free, exp) = case exp of e' = foldr EAbs (abstractExp e) (fvList ++ [n]) sc = ELet [bind] (EId (Ident "sc")) --- rename pass +-- Rename rename :: Program -> Program rename (Program ds) = Program $ map (uncurry3 Sc) tuples @@ -108,9 +108,7 @@ rename (Program ds) = Program $ map (uncurry3 Sc) tuples renameExp :: Map Ident Ident -> Int -> Exp -> (Int, Exp) renameExp env i = \case - - EId n -> (i, maybe (error "no") EId $ Map.lookup n env) - + EId n -> (i, EId . fromMaybe n $ Map.lookup n env) EInt i1 -> (i, EInt i1) @@ -157,6 +155,70 @@ getNames i ns = (i + length ss, zipWith makeName ss [i..]) makeName :: String -> Int -> Ident makeName prefix i = Ident (prefix ++ "_" ++ show i) + +-- Collect supercombinators + +collectScs :: Program -> Program +collectScs (Program ds) = Program $ concatMap collect_one_sc ds + where + collect_one_sc (Sc n xs e) = Sc n xs e' : scs + where (scs, e') = collectScsExp e + + + +collectScsExp :: Exp -> ([ScDef], Exp) +collectScsExp = \case + + EId n -> ([], EId n) + + EInt i -> ([], EInt i) + + EApp e1 e2 -> (scs1 ++ scs2, EApp e1' e2') + where + (scs1, e1') = collectScsExp e1 + (scs2, e2') = collectScsExp e2 + + EAdd e1 e2 -> (scs1 ++ scs2, EAdd e1' e2') + where + (scs1, e1') = collectScsExp e1 + (scs2, e2') = collectScsExp e2 + + EAbs x e -> (scs, EAbs x e') + where + (scs, e') = collectScsExp e + + ELet bs e -> (rhss_scs ++ e_scs ++ local_scs, mkEAbs non_scs' e') + where + (rhss_scs, bs') = mapAccumL collectScs_d [] bs + scs' = [ Sc n xs rhs | Sc n xs rhs <- bs', isEAbs rhs] + non_scs' = [ Bind n xs rhs | Sc n xs rhs <- bs', not $ isEAbs rhs] + local_scs = map peelLambda scs' + -- local_scs = [ Sc n (xs ++ [x]) e1 | Sc n xs (EAbs x e1) <- scs'] + (e_scs, e') = collectScsExp e + + collectScs_d scs (Bind n xs rhs) = (scs ++ rhs_scs1, Sc n xs rhs') + where + (rhs_scs1, rhs') = collectScsExp rhs + + + +peelLambda :: ScDef -> ScDef +peelLambda sc@(Sc n xs e) = case e of + EAbs x e1 -> peelLambda (Sc n (xs ++ [x]) e1) + _ -> sc + + + +isEAbs :: Exp -> Bool +isEAbs = \case + EAbs {} -> True + _ -> False + +mkEAbs :: [Bind] -> Exp -> Exp +mkEAbs [] e = e +mkEAbs bs e = ELet bs e + + -- Annotated AST type AnnProgram = [(Ident, [Ident], AnnExp)] diff --git a/src/Main.hs b/src/Main.hs index 58aafe5..ee5a0a1 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -3,7 +3,7 @@ module Main where import Grammar.Par (myLexer, pProgram) import Grammar.Print (printTree) -import LambdaLifter (abstract, freeVars, lambdaLift) +import LambdaLifter (abstract, freeVars, lambdaLift, rename) import System.Environment (getArgs) import System.Exit (exitFailure, exitSuccess) @@ -21,11 +21,6 @@ main = getArgs >>= \case putStrLn "-- Parser" putStrLn $ printTree prg putStrLn "\n--Lamda lifter" - putStrLn "\n--freevars" - print $ freeVars prg - putStrLn "\n--abstract" - putStrLn . printTree $ (abstract . freeVars) prg - putStrLn "\n--renamed" putStrLn . printTree $ lambdaLift prg exitSuccess From b6f03e953ba007f17c2f766ef0a1f2dee72a2474 Mon Sep 17 00:00:00 2001 From: sebastianselander Date: Thu, 9 Feb 2023 09:42:44 +0100 Subject: [PATCH 009/372] deprecated branch --- language | 1 + src/Abs.hs | 20 +++++++++ src/Rename/Renamer.hs | 96 +++++++++++++++++++++++++++++++++++++++++++ 3 files changed, 117 insertions(+) create mode 120000 language create mode 100644 src/Abs.hs create mode 100644 src/Rename/Renamer.hs diff --git a/language b/language new file mode 120000 index 0000000..29e6f1c --- /dev/null +++ b/language @@ -0,0 +1 @@ +/home/sebastian/.cabal/store/ghc-9.4.4/language-0.1.0.0-e-language-b98a5580bec9e5cee0ea5d675b3788bf6eec0b9eb955374c9ba250c1d3b935fc/bin/language \ No newline at end of file diff --git a/src/Abs.hs b/src/Abs.hs new file mode 100644 index 0000000..35e2904 --- /dev/null +++ b/src/Abs.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE TypeFamilies, StandaloneDeriving #-} + +module Abs where + +data Exp eps + = EInt (XInt eps) Integer + | EId (XId eps) String + | EAdd (XAdd eps) (Exp eps) (Exp eps) + | EApp (XApp eps) (Exp eps) (Exp eps) + | EAbs (XAbs eps) String (Exp eps) + | EExp (XExp eps) + +newtype Ident = Ident String + +type family XInt eps +type family XId eps +type family XAdd eps +type family XApp eps +type family XAbs eps +type family XExp eps diff --git a/src/Rename/Renamer.hs b/src/Rename/Renamer.hs new file mode 100644 index 0000000..a6cf12d --- /dev/null +++ b/src/Rename/Renamer.hs @@ -0,0 +1,96 @@ +{-# LANGUAGE OverloadedRecordDot, LambdaCase, TypeFamilies, PatternSynonyms #-} + +module Rename.Renamer where + +import Abs + +import qualified Grammar.Abs as A +import Grammar.ErrM (Err) +import Control.Monad.Except (throwError) +import Grammar.Print (printTree) +import Control.Monad.State +import qualified Data.Map as M +import Data.Map (Map) +import qualified Data.Set as S +import Data.Set (Set) + +------------------ DATA TYPES ------------------ + +type Rn a = StateT Env Err a + +data Env = Env { uniques :: Map String Unique + , nextUnique :: Unique + , sig :: Set String + } + +newtype Unique = Unique Int + deriving Enum + +data Name = Nu Unique | Ni String + +initEnv :: Env +initEnv = Env + { uniques = mempty + , nextUnique = Unique 0 + , sig = mempty + } + +findBind :: String -> Rn Name +findBind x = lookupUnique x >>= \case + Just u -> pure $ Nu u + Nothing -> gets (S.member x . sig) >>= \case + False -> throwError ("Unbound variable " ++ printTree x) + True -> pure $ Ni x + +newUnique :: String -> Rn Unique +newUnique x = do + u <- gets nextUnique + modify $ \env -> env { nextUnique = succ u + , uniques = M.insert x u env.uniques } + return u + +lookupUnique :: String -> Rn (Maybe Unique) +lookupUnique x = gets (M.lookup x . uniques) + +renameDef :: Def -> Rn Def +renameDef = \case + DExp x t _ xs e -> do + newSig x + xs' <- mapM newUnique xs + e' <- renameExp e + let e'' = foldr ($) e' . zipWith R.EAbs xs' $ fromTree t + pure . R.DBind $ R.Bind x t e'' + +renameExp :: A.Exp -> Rn ExpRE +renameExp e = + case e of + A.EInt i -> pure (EIntR i) + A.EId (A.Ident str) -> flip EIdR str <$> findBind str + A.EAdd e1 e2 -> EAppR <$> renameExp e1 <*> renameExp e2 + A.EApp e1 e2 -> EAppR <$> renameExp e1 <*> renameExp e2 + A.EAbs (A.Ident x) e -> do + x' <- newUnique x + e' <- renameExp e + pure $ EAbsR x' x e' + +data R +type ExpRE = Exp R + +type instance XInt R = () +type instance XId R = Name +type instance XAdd R = () +type instance XApp R = () +type instance XAbs R = Unique +type instance XExp R = () + +pattern EIntR :: Integer -> ExpRE +pattern EIntR i = EInt () i + +pattern EIdR :: Name -> String -> ExpRE +pattern EIdR n s = EId n s + +pattern EAppR :: ExpRE -> ExpRE -> ExpRE +pattern EAppR e1 e2 = EApp () e1 e2 + +pattern EAbsR :: Unique -> String -> ExpRE -> ExpRE +pattern EAbsR u n e = EAbs u n e From ce31e4d49056c252d9295c07bf267a81de6a6882 Mon Sep 17 00:00:00 2001 From: Martin Fredin Date: Thu, 9 Feb 2023 17:53:39 +0100 Subject: [PATCH 010/372] Fix first unnecessary supercombinator --- Grammar.cf | 9 ++---- basic-2 | 4 --- sample-programs/basic-1 | 2 ++ sample-programs/basic-2 | 4 +++ sample-programs/basic-3 | 2 ++ sample-programs/basic-4 | 2 ++ sample-programs/basic-5 | 9 ++++++ src/LambdaLifter.hs | 72 ++++++++++++++++++++++------------------- src/Main.hs | 8 +++-- test_program | 5 --- 10 files changed, 66 insertions(+), 51 deletions(-) delete mode 100644 basic-2 create mode 100644 sample-programs/basic-1 create mode 100644 sample-programs/basic-2 create mode 100644 sample-programs/basic-3 create mode 100644 sample-programs/basic-4 create mode 100644 sample-programs/basic-5 delete mode 100644 test_program diff --git a/Grammar.cf b/Grammar.cf index 9dba2f5..410d11d 100644 --- a/Grammar.cf +++ b/Grammar.cf @@ -1,12 +1,6 @@ -Program. Program ::= [ScDef]; - -ScDef. ScDef ::= Bind; -separator ScDef ";"; - -separator Ident " "; - +Program. Program ::= [Bind]; EId. Exp3 ::= Ident; EInt. Exp3 ::= Integer; @@ -17,6 +11,7 @@ EAbs. Exp ::= "\\" Ident "." Exp; Bind. Bind ::= Ident [Ident] "=" Exp; separator Bind ";"; +separator Ident " "; coercions Exp 3; diff --git a/basic-2 b/basic-2 deleted file mode 100644 index 8afd060..0000000 --- a/basic-2 +++ /dev/null @@ -1,4 +0,0 @@ -add x = \y. x + y; - -main = (\z. z + z) ((add 4) 6); - diff --git a/sample-programs/basic-1 b/sample-programs/basic-1 new file mode 100644 index 0000000..f109950 --- /dev/null +++ b/sample-programs/basic-1 @@ -0,0 +1,2 @@ + +f = \x. x+1; diff --git a/sample-programs/basic-2 b/sample-programs/basic-2 new file mode 100644 index 0000000..4b8ead0 --- /dev/null +++ b/sample-programs/basic-2 @@ -0,0 +1,4 @@ +add x = \y. x+y; + +main = (\z. z+z) ((add 4) 6); + diff --git a/sample-programs/basic-3 b/sample-programs/basic-3 new file mode 100644 index 0000000..9443439 --- /dev/null +++ b/sample-programs/basic-3 @@ -0,0 +1,2 @@ + +main = (\x. x+x+3) ((\x. x) 2) diff --git a/sample-programs/basic-4 b/sample-programs/basic-4 new file mode 100644 index 0000000..1de7a8c --- /dev/null +++ b/sample-programs/basic-4 @@ -0,0 +1,2 @@ + +f x = let g = (\y. y+1) in g (g x) diff --git a/sample-programs/basic-5 b/sample-programs/basic-5 new file mode 100644 index 0000000..3168484 --- /dev/null +++ b/sample-programs/basic-5 @@ -0,0 +1,9 @@ +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/src/LambdaLifter.hs b/src/LambdaLifter.hs index 512155d..c9253b6 100644 --- a/src/LambdaLifter.hs +++ b/src/LambdaLifter.hs @@ -1,6 +1,5 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PatternSynonyms #-} module LambdaLifter (lambdaLift, freeVars, abstract, rename, collectScs) where @@ -15,20 +14,14 @@ import Data.Tuple.Extra (uncurry3) import Grammar.Abs import Prelude hiding (exp) -pattern Sc :: Ident -> [Ident] -> Exp -> ScDef -pattern Sc n xs e = ScDef (Bind n xs e) - - - lambdaLift :: Program -> Program lambdaLift = collectScs . rename . abstract . freeVars - -- Annotate free variables freeVars :: Program -> AnnProgram freeVars (Program ds) = [ (n, xs, freeVarsExp (Set.fromList xs) e) - | Sc n xs e <- ds + | Bind n xs e <- ds ] @@ -64,7 +57,6 @@ freeVarsExp lv = \case freeInValues = foldr1 Set.union (map freeVarsOf es') - freeVarsOf :: AnnExp -> Set Ident freeVarsOf = fst @@ -74,10 +66,21 @@ fromBinders bs = unzip3 [ (n, xs, e) | Bind n xs e <- bs ] -- Lift lambda expression into let with binder "sc" abstract :: AnnProgram -> Program -abstract p = Program - [ Sc sc_name xs $ abstractExp rhs - | (sc_name, xs, rhs) <- p - ] +abstract prog = Program $ map f prog + where + f :: (Ident, [Ident], AnnExp) -> Bind + f (name, pars, rhs@(_, e)) = + case e of + AAbs par body -> Bind name (snoc par pars) $ abstractExp body + _ -> Bind name pars $ abstractExp rhs + + + +-- [ case rhs of +-- EAbs par body -> Bind name (snoc par pars) body +-- _ -> Bind name pars rhs +-- +-- | (name, pars, rhs) <- prog abstractExp :: AnnExp -> Exp @@ -94,13 +97,17 @@ abstractExp (free, exp) = case exp of e' = foldr EAbs (abstractExp e) (fvList ++ [n]) sc = ELet [bind] (EId (Ident "sc")) + +snoc :: a -> [a] -> [a] +snoc x xs = xs ++ [x] + -- Rename rename :: Program -> Program -rename (Program ds) = Program $ map (uncurry3 Sc) tuples +rename (Program ds) = Program $ map (uncurry3 Bind) tuples where tuples = snd (mapAccumL renameSc 0 ds) - renameSc i (Sc n xs e) = (i2, (n, xs', e')) + renameSc i (Bind n xs e) = (i2, (n, xs', e')) where (i1, xs', env) = newNames i xs (i2, e') = renameExp env i1 e @@ -159,14 +166,23 @@ makeName prefix i = Ident (prefix ++ "_" ++ show i) -- Collect supercombinators collectScs :: Program -> Program -collectScs (Program ds) = Program $ concatMap collect_one_sc ds +collectScs (Program ds) = Program $ concatMap collectOneSc ds where - collect_one_sc (Sc n xs e) = Sc n xs e' : scs - where (scs, e') = collectScsExp e + collectOneSc (Bind name args rhs) = Bind name args rhs' : scs + where (scs, rhs') = collectScsExp rhs + {- -collectScsExp :: Exp -> ([ScDef], Exp) +Bind (Ident "f") [] + + (ELet [Bind (Ident "sc") [] (EAbs (Ident "x") (EAdd (EId (Ident "x")) (EInt 1)))] (EId (Ident "sc"))) + + + -} + + +collectScsExp :: Exp -> ([Bind], Exp) collectScsExp = \case EId n -> ([], EId n) @@ -190,25 +206,15 @@ collectScsExp = \case ELet bs e -> (rhss_scs ++ e_scs ++ local_scs, mkEAbs non_scs' e') where (rhss_scs, bs') = mapAccumL collectScs_d [] bs - scs' = [ Sc n xs rhs | Sc n xs rhs <- bs', isEAbs rhs] - non_scs' = [ Bind n xs rhs | Sc n xs rhs <- bs', not $ isEAbs rhs] - local_scs = map peelLambda scs' - -- local_scs = [ Sc n (xs ++ [x]) e1 | Sc n xs (EAbs x e1) <- scs'] + scs' = [ Bind n xs rhs | Bind n xs rhs <- bs', isEAbs rhs] + non_scs' = [ Bind n xs rhs | Bind n xs rhs <- bs', not $ isEAbs rhs] + local_scs = [ Bind n (xs ++ [x]) e1 | Bind n xs (EAbs x e1) <- scs'] (e_scs, e') = collectScsExp e - collectScs_d scs (Bind n xs rhs) = (scs ++ rhs_scs1, Sc n xs rhs') + collectScs_d scs (Bind n xs rhs) = (scs ++ rhs_scs1, Bind n xs rhs') where (rhs_scs1, rhs') = collectScsExp rhs - - -peelLambda :: ScDef -> ScDef -peelLambda sc@(Sc n xs e) = case e of - EAbs x e1 -> peelLambda (Sc n (xs ++ [x]) e1) - _ -> sc - - - isEAbs :: Exp -> Bool isEAbs = \case EAbs {} -> True diff --git a/src/Main.hs b/src/Main.hs index ee5a0a1..211bf3a 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -18,9 +18,13 @@ main = getArgs >>= \case putStrLn err exitFailure Right prg -> do - putStrLn "-- Parser" + putStrLn "-- Parse" putStrLn $ printTree prg - putStrLn "\n--Lamda lifter" + putStrLn "\n-- Abstract" + putStrLn . printTree $ (abstract . freeVars) prg + putStrLn "\n-- Rename" + putStrLn . printTree $ (rename . abstract . freeVars) prg + putStrLn "\n-- Lamda lifter" putStrLn . printTree $ lambdaLift prg exitSuccess diff --git a/test_program b/test_program deleted file mode 100644 index 95235e4..0000000 --- a/test_program +++ /dev/null @@ -1,5 +0,0 @@ - - - - -main = (\x. x + x + 3) ((\x. x) 2) From 23261ec380040a198eb9df626debfe23bc26fa85 Mon Sep 17 00:00:00 2001 From: Martin Fredin Date: Thu, 9 Feb 2023 20:23:20 +0100 Subject: [PATCH 011/372] Add llvm dep --- shell.nix | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/shell.nix b/shell.nix index 0c7624a..2eaf1cd 100644 --- a/shell.nix +++ b/shell.nix @@ -6,7 +6,7 @@ pkgs.haskellPackages.developPackage { withHoogle = true; modifier = drv: pkgs.haskell.lib.addBuildTools drv ( - (with pkgs; [ hlint haskell-language-server ghc jasmin ]) + (with pkgs; [ hlint haskell-language-server ghc jasmin llvmPackages_15.libllvm]) ++ (with pkgs.haskellPackages; [ cabal-install From 7c313b3faad5bb5b3a4439300c736e81c8140645 Mon Sep 17 00:00:00 2001 From: Martin Fredin Date: Thu, 9 Feb 2023 20:23:49 +0100 Subject: [PATCH 012/372] Fix basic tests --- Makefile | 7 +++++++ sample-programs/basic-5 | 2 +- 2 files changed, 8 insertions(+), 1 deletion(-) diff --git a/Makefile b/Makefile index 16b753d..6e8a54d 100644 --- a/Makefile +++ b/Makefile @@ -22,4 +22,11 @@ clean : rm -r src/Grammar rm language +test : + ./language ./sample-programs/basic-1 + ./language ./sample-programs/basic-2 + ./language ./sample-programs/basic-3 + ./language ./sample-programs/basic-4 + ./language ./sample-programs/basic-5 + # EOF diff --git a/sample-programs/basic-5 b/sample-programs/basic-5 index 3168484..9984ddd 100644 --- a/sample-programs/basic-5 +++ b/sample-programs/basic-5 @@ -4,6 +4,6 @@ add x y = x + y; double n = n + n; -apply f x = \y -> f x y; +apply f x = \y. f x y; main = apply (id add) ((\x. x + 1) 1) (double 3); From 07bec3e7ef6111960e96c5ac8695624ee68bffa8 Mon Sep 17 00:00:00 2001 From: Martin Fredin Date: Thu, 9 Feb 2023 20:24:06 +0100 Subject: [PATCH 013/372] Add auxiliary module --- Auxiliary.hs | 5 +++++ language.cabal | 1 + 2 files changed, 6 insertions(+) create mode 100644 Auxiliary.hs diff --git a/Auxiliary.hs b/Auxiliary.hs new file mode 100644 index 0000000..cd844d7 --- /dev/null +++ b/Auxiliary.hs @@ -0,0 +1,5 @@ + +module Auxiliary (module Auxiliary) where + +snoc :: a -> [a] -> [a] +snoc x xs = xs ++ [x] diff --git a/language.cabal b/language.cabal index 3f4860c..52b2577 100644 --- a/language.cabal +++ b/language.cabal @@ -31,6 +31,7 @@ executable language Grammar.Print Grammar.Skel LambdaLifter + Auxiliary -- Interpreter hs-source-dirs: src From 59fb773bc1cc3d8d37531a08df223a706d2dc7a2 Mon Sep 17 00:00:00 2001 From: Martin Fredin Date: Thu, 9 Feb 2023 20:24:25 +0100 Subject: [PATCH 014/372] Some clean up and documenting --- src/LambdaLifter.hs | 62 +++++++++++++++------------------------------ src/Main.hs | 9 ++++--- 2 files changed, 26 insertions(+), 45 deletions(-) diff --git a/src/LambdaLifter.hs b/src/LambdaLifter.hs index c9253b6..ac9cee0 100644 --- a/src/LambdaLifter.hs +++ b/src/LambdaLifter.hs @@ -14,17 +14,19 @@ import Data.Tuple.Extra (uncurry3) import Grammar.Abs import Prelude hiding (exp) + + +-- | Lift lambdas and let expression into supercombinators. lambdaLift :: Program -> Program lambdaLift = collectScs . rename . abstract . freeVars --- Annotate free variables +-- | Annotate free variables freeVars :: Program -> AnnProgram freeVars (Program ds) = [ (n, xs, freeVarsExp (Set.fromList xs) e) | Bind n xs e <- ds ] - freeVarsExp :: Set Ident -> Exp -> AnnExp freeVarsExp lv = \case @@ -63,8 +65,22 @@ freeVarsOf = fst fromBinders :: [Bind] -> ([Ident], [[Ident]], [Exp]) fromBinders bs = unzip3 [ (n, xs, e) | Bind n xs e <- bs ] --- Lift lambda expression into let with binder "sc" +-- AST annotated with free variables +type AnnProgram = [(Ident, [Ident], AnnExp)] +type AnnExp = (Set Ident, AnnExp') + +data ABind = ABind Ident [Ident] AnnExp deriving Show + +data AnnExp' = AId Ident + | AInt Integer + | AApp AnnExp AnnExp + | AAdd AnnExp AnnExp + | AAbs Ident AnnExp + | ALet [ABind] AnnExp + deriving Show + +-- | Lift lambdas to let expression of the form @let sc = \x -> rhs@ abstract :: AnnProgram -> Program abstract prog = Program $ map f prog where @@ -74,15 +90,6 @@ abstract prog = Program $ map f prog AAbs par body -> Bind name (snoc par pars) $ abstractExp body _ -> Bind name pars $ abstractExp rhs - - --- [ case rhs of --- EAbs par body -> Bind name (snoc par pars) body --- _ -> Bind name pars rhs --- --- | (name, pars, rhs) <- prog - - abstractExp :: AnnExp -> Exp abstractExp (free, exp) = case exp of AId n -> EId n @@ -101,8 +108,7 @@ abstractExp (free, exp) = case exp of snoc :: a -> [a] -> [a] snoc x xs = xs ++ [x] --- Rename - +-- | Rename all supercombinators and variables rename :: Program -> Program rename (Program ds) = Program $ map (uncurry3 Bind) tuples where @@ -163,24 +169,12 @@ makeName :: String -> Int -> Ident makeName prefix i = Ident (prefix ++ "_" ++ show i) --- Collect supercombinators - +-- | Collects supercombinators by lifting appropriate let expressions collectScs :: Program -> Program collectScs (Program ds) = Program $ concatMap collectOneSc ds where collectOneSc (Bind name args rhs) = Bind name args rhs' : scs where (scs, rhs') = collectScsExp rhs - {- - - - -Bind (Ident "f") [] - - (ELet [Bind (Ident "sc") [] (EAbs (Ident "x") (EAdd (EId (Ident "x")) (EInt 1)))] (EId (Ident "sc"))) - - - -} - collectScsExp :: Exp -> ([Bind], Exp) collectScsExp = \case @@ -225,17 +219,3 @@ mkEAbs [] e = e mkEAbs bs e = ELet bs e --- Annotated AST - -type AnnProgram = [(Ident, [Ident], AnnExp)] -type AnnExp = (Set Ident, AnnExp') - -data ABind = ABind Ident [Ident] AnnExp deriving Show - -data AnnExp' = AId Ident - | AInt Integer - | AApp AnnExp AnnExp - | AAdd AnnExp AnnExp - | AAbs Ident AnnExp - | ALet [ABind] AnnExp - deriving Show diff --git a/src/Main.hs b/src/Main.hs index 211bf3a..9af1753 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -20,12 +20,13 @@ main = getArgs >>= \case Right prg -> do putStrLn "-- Parse" putStrLn $ printTree prg - putStrLn "\n-- Abstract" - putStrLn . printTree $ (abstract . freeVars) prg - putStrLn "\n-- Rename" - putStrLn . printTree $ (rename . abstract . freeVars) prg + -- putStrLn "\n-- Abstract" + -- putStrLn . printTree $ (abstract . freeVars) prg + -- putStrLn "\n-- Rename" + -- putStrLn . printTree $ (rename . abstract . freeVars) prg putStrLn "\n-- Lamda lifter" putStrLn . printTree $ lambdaLift prg + putStrLn "" exitSuccess From 3ac8377fa01259f91986d5833693c6911bd0e8ca Mon Sep 17 00:00:00 2001 From: Martin Fredin Date: Thu, 9 Feb 2023 20:25:00 +0100 Subject: [PATCH 015/372] Fix auxiliary path --- Auxiliary.hs => src/Auxiliary.hs | 0 1 file changed, 0 insertions(+), 0 deletions(-) rename Auxiliary.hs => src/Auxiliary.hs (100%) diff --git a/Auxiliary.hs b/src/Auxiliary.hs similarity index 100% rename from Auxiliary.hs rename to src/Auxiliary.hs From f4f1786be3e84dc0b5bf1a6099aec45bf1b61550 Mon Sep 17 00:00:00 2001 From: sebastianselander Date: Fri, 10 Feb 2023 10:41:16 +0100 Subject: [PATCH 016/372] Revert "Merge branch 'typechecking' into codegen-martin-3" This reverts commit e000e5159f12f3ba8140ed372c7aa647fd62d506, reversing changes made to 3ac8377fa01259f91986d5833693c6911bd0e8ca. --- Grammar.cf | 3 - Makefile | 2 +- language | 1 - language.cabal | 2 +- src/Abs.hs | 20 ------- src/Interpreter.hs | 10 +++- src/NewAbs.hs | 29 ---------- src/Rename/Renamer.hs | 96 ------------------------------- src/TypeChecker.hs | 129 ------------------------------------------ test_program | 2 - 10 files changed, 9 insertions(+), 285 deletions(-) delete mode 120000 language delete mode 100644 src/Abs.hs delete mode 100644 src/NewAbs.hs delete mode 100644 src/Rename/Renamer.hs delete mode 100644 test_program diff --git a/Grammar.cf b/Grammar.cf index 4446eaf..410d11d 100644 --- a/Grammar.cf +++ b/Grammar.cf @@ -1,7 +1,4 @@ -Program. Program ::= [Def] ; -DExp. Def ::= Ident ":" Type - Ident [Ident] "=" Exp ; Program. Program ::= [Bind]; diff --git a/Makefile b/Makefile index ad830b5..6e8a54d 100644 --- a/Makefile +++ b/Makefile @@ -1,7 +1,7 @@ .PHONY : sdist clean language : src/Grammar/Test - cabal install --installdir=. --overwrite-policy=always + cabal install --installdir=. src/Grammar/Test.hs src/Grammar/Lex.x src/Grammar/Par.y : Grammar.cf bnfc -o src -d $< diff --git a/language b/language deleted file mode 120000 index 29e6f1c..0000000 --- a/language +++ /dev/null @@ -1 +0,0 @@ -/home/sebastian/.cabal/store/ghc-9.4.4/language-0.1.0.0-e-language-b98a5580bec9e5cee0ea5d675b3788bf6eec0b9eb955374c9ba250c1d3b935fc/bin/language \ No newline at end of file diff --git a/language.cabal b/language.cabal index f95d1dd..52b2577 100644 --- a/language.cabal +++ b/language.cabal @@ -17,7 +17,7 @@ extra-source-files: common warnings - ghc-options: -W + ghc-options: -Wall executable language import: warnings diff --git a/src/Abs.hs b/src/Abs.hs deleted file mode 100644 index 35e2904..0000000 --- a/src/Abs.hs +++ /dev/null @@ -1,20 +0,0 @@ -{-# LANGUAGE TypeFamilies, StandaloneDeriving #-} - -module Abs where - -data Exp eps - = EInt (XInt eps) Integer - | EId (XId eps) String - | EAdd (XAdd eps) (Exp eps) (Exp eps) - | EApp (XApp eps) (Exp eps) (Exp eps) - | EAbs (XAbs eps) String (Exp eps) - | EExp (XExp eps) - -newtype Ident = Ident String - -type family XInt eps -type family XId eps -type family XAdd eps -type family XApp eps -type family XAbs eps -type family XExp eps diff --git a/src/Interpreter.hs b/src/Interpreter.hs index b7d83a5..378c95b 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -1,10 +1,14 @@ {-# LANGUAGE LambdaCase #-} - module Interpreter where -import Control.Monad.Except (Except, MonadError (throwError)) - +import Control.Applicative (Applicative) +import Control.Monad.Except (Except, MonadError (throwError), + liftEither) +import Data.Either.Combinators (maybeToRight) +import Data.Map (Map) +import qualified Data.Map as Map import Grammar.Abs +import Grammar.Print (printTree) interpret :: Program -> Except String Integer interpret (Program e) = diff --git a/src/NewAbs.hs b/src/NewAbs.hs deleted file mode 100644 index 9a0296d..0000000 --- a/src/NewAbs.hs +++ /dev/null @@ -1,29 +0,0 @@ -{-# LANGUAGE GADTs, LambdaCase #-} - -module NewAbs where - -import Grammar.Abs ( Ident(..), Type ) - -data CExp where - CId :: Type -> Ident -> CExp - CInt :: Type -> Int -> CExp - CAdd :: Type -> CExp -> CExp -> CExp - CAbs :: Type -> Ident -> Type -> CExp -> CExp - CApp :: Type -> CExp -> CExp -> CExp - -instance Show CExp where - show :: CExp -> String - show = \case - CId _ (Ident a) -> show a - CInt _ i -> show i - CAdd _ e1 e2 -> show e1 <> " + " <> show e2 - CAbs t1 i t2 e -> appendType t1 $ show "\\" <> show i <> " : " <> show t2 <> ". " <> show e - CApp _ e1 e2 -> show e1 <> " " <> show e2 - -appendType :: Type -> String -> String -appendType t s = s <> " : " <> show t - -data CDef = CDef Ident Type Ident [Ident] CExp - deriving Show - -newtype CProgram = CProgram [CDef] diff --git a/src/Rename/Renamer.hs b/src/Rename/Renamer.hs deleted file mode 100644 index a6cf12d..0000000 --- a/src/Rename/Renamer.hs +++ /dev/null @@ -1,96 +0,0 @@ -{-# LANGUAGE OverloadedRecordDot, LambdaCase, TypeFamilies, PatternSynonyms #-} - -module Rename.Renamer where - -import Abs - -import qualified Grammar.Abs as A -import Grammar.ErrM (Err) -import Control.Monad.Except (throwError) -import Grammar.Print (printTree) -import Control.Monad.State -import qualified Data.Map as M -import Data.Map (Map) -import qualified Data.Set as S -import Data.Set (Set) - ------------------- DATA TYPES ------------------ - -type Rn a = StateT Env Err a - -data Env = Env { uniques :: Map String Unique - , nextUnique :: Unique - , sig :: Set String - } - -newtype Unique = Unique Int - deriving Enum - -data Name = Nu Unique | Ni String - -initEnv :: Env -initEnv = Env - { uniques = mempty - , nextUnique = Unique 0 - , sig = mempty - } - -findBind :: String -> Rn Name -findBind x = lookupUnique x >>= \case - Just u -> pure $ Nu u - Nothing -> gets (S.member x . sig) >>= \case - False -> throwError ("Unbound variable " ++ printTree x) - True -> pure $ Ni x - -newUnique :: String -> Rn Unique -newUnique x = do - u <- gets nextUnique - modify $ \env -> env { nextUnique = succ u - , uniques = M.insert x u env.uniques } - return u - -lookupUnique :: String -> Rn (Maybe Unique) -lookupUnique x = gets (M.lookup x . uniques) - -renameDef :: Def -> Rn Def -renameDef = \case - DExp x t _ xs e -> do - newSig x - xs' <- mapM newUnique xs - e' <- renameExp e - let e'' = foldr ($) e' . zipWith R.EAbs xs' $ fromTree t - pure . R.DBind $ R.Bind x t e'' - -renameExp :: A.Exp -> Rn ExpRE -renameExp e = - case e of - A.EInt i -> pure (EIntR i) - A.EId (A.Ident str) -> flip EIdR str <$> findBind str - A.EAdd e1 e2 -> EAppR <$> renameExp e1 <*> renameExp e2 - A.EApp e1 e2 -> EAppR <$> renameExp e1 <*> renameExp e2 - A.EAbs (A.Ident x) e -> do - x' <- newUnique x - e' <- renameExp e - pure $ EAbsR x' x e' - -data R -type ExpRE = Exp R - -type instance XInt R = () -type instance XId R = Name -type instance XAdd R = () -type instance XApp R = () -type instance XAbs R = Unique -type instance XExp R = () - -pattern EIntR :: Integer -> ExpRE -pattern EIntR i = EInt () i - -pattern EIdR :: Name -> String -> ExpRE -pattern EIdR n s = EId n s - -pattern EAppR :: ExpRE -> ExpRE -> ExpRE -pattern EAppR e1 e2 = EApp () e1 e2 - -pattern EAbsR :: Unique -> String -> ExpRE -> ExpRE -pattern EAbsR u n e = EAbs u n e diff --git a/src/TypeChecker.hs b/src/TypeChecker.hs index 8e233bb..e69de29 100644 --- a/src/TypeChecker.hs +++ b/src/TypeChecker.hs @@ -1,129 +0,0 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE OverloadedRecordDot #-} - -module TypeChecker (typecheck) where - -import Grammar.Abs -import Grammar.ErrM ( Err ) -import NewAbs -import Data.Map (Map) -import Data.Map qualified as Map -import Control.Monad.Reader -import Control.Monad.Except -import Data.List (isPrefixOf) -import Control.Applicative ((<|>)) - -type Check a = ReaderT Context Err a - -data Context = Ctx { sig :: Map Ident Type - , env :: [Map Ident Type] - } - -initEnv :: Context -initEnv = Ctx { sig = mempty - , env = mempty - } - -run :: Check a -> Either String a -run = flip runReaderT initEnv - -typecheck :: Program -> Err Program -typecheck prg = case run $ checkProg prg of - Left err -> fail err - Right _ -> pure prg - - -checkProg :: Program -> Check CProgram -checkProg (Program ds) = undefined - -checkDef :: Def -> Check CDef -checkDef (DExp i1 TInt i2 args e) = undefined -checkDef (DExp i1 (TPol i) i2 args e) = undefined -checkDef (DExp i1 (TFun xs) i2 args e) = do - when (i1 /= i2) (fail $ "Mismatched names: " <> show i1 <> " != " <> show i2) - case compare (length xs - 1) (length args) of - LT -> fail $ "Too many arguments, got " <> show (length args) <> " expected " <> show (length xs) - _ -> do - let vars = Map.fromList $ zip args xs - e' <- local (\r -> r { env = [vars] }) (checkExp e) - return $ CDef i1 (TFun xs) i2 args e' - -checkExp :: Exp -> Check CExp -checkExp = \case - - EInt i -> pure $ CInt TInt (fromIntegral i) - - EAdd e1 e2 -> do - e1' <- checkExp e1 - e2' <- checkExp e2 - let t1 = getType e1' - let t2 = getType e2' - when (t1 /= t2) (fail $ "Different types occured, got " <> show t1 <> " and " <> show t2) - return $ CAdd t1 e1' e2' - - EId i -> do - asks (lookupEnv i) >>= \case - Right t -> return $ CId t i - Left _ -> asks (lookupSig i) >>= \case - Right t -> return $ CId t i - Left x -> fail x - - EAbs i t e -> do - e' <- local (\r -> r { env = Map.singleton i t : r.env }) (checkExp e) - return $ CAbs (TFun [t, getType e']) i t e' - - EApp e1 e2 -> do - e1' <- checkExp e1 - e2' <- checkExp e2 - let retT = applyType (getType e1') (getType e2') - case retT of - Left x -> fail x - Right t -> return $ CApp t e1' e2' - -lookupSig :: Ident -> Context -> Err Type -lookupSig i (Ctx s _) = case Map.lookup i s of - Nothing -> throwError $ "Undefined function: " <> show i - Just x -> pure x - -lookupEnv :: Ident -> Context -> Err Type -lookupEnv i (Ctx _ []) = throwError $ "Unbound variable: " <> show i -lookupEnv i (Ctx s (e:es)) = case Map.lookup i e of - Nothing -> lookupEnv i (Ctx s es) - Just x -> pure x - - -applyType :: Type -> Type -> Err Type -applyType (TFun (x:xs)) t = case t of - (TFun ys) -> if ys `isPrefixOf` (x:xs) - then return . TFun $ drop (length ys) (x:xs) - else fail $ "Mismatched types, expected " <> show x <> " got " <> show TInt -applyType t1 t2 = fail $ "Can not apply " <> show t1 <> " to " <> show t2 - -class ExtractType a where - getType :: a -> Type - -instance ExtractType CExp where - getType = \case - CId t _ -> t - CInt t _ -> t - CAdd t _ _ -> t - CAbs t _ _ _ -> t - CApp t _ _ -> t - --- | λx : Int. x + 3 + 5 -customLambda1 :: Exp -customLambda1 = EAbs (Ident "x") TInt (EAdd (EId (Ident "x")) (EAdd (EInt 3) (EInt 5))) - -customLambda2 :: Exp -customLambda2 = EAbs (Ident "x") (TFun [TInt, TInt]) (EId (Ident "f")) - --- | main : Int --- main = λx : Int. x + 3 + 5 -customPrg1 :: Program -customPrg1 = Program [DExp (Ident "main") TInt (Ident "main") [] customLambda1] - --- | main : Int -> Int --- main = λx : Int. x + 3 + 5 -customPrg2 :: Program -customPrg2 = Program [DExp (Ident "main") (TFun [TInt, TInt]) (Ident "main") [] customLambda2] diff --git a/test_program b/test_program deleted file mode 100644 index 77bf0ad..0000000 --- a/test_program +++ /dev/null @@ -1,2 +0,0 @@ -main : Int -main = (\x : Int. x + x + 3) ((\x : Int. x) 2) From a1e9624d5ee896fe0314591ad539db995bd3b21e Mon Sep 17 00:00:00 2001 From: sebastianselander Date: Fri, 10 Feb 2023 12:09:08 +0100 Subject: [PATCH 017/372] TTGing the lambda lifter --- language.cabal | 1 - src/Abs.hs | 28 ++++++++++++++++++++++++++++ src/Auxiliary.hs | 5 ----- src/LambdaLifter.hs | 44 ++++++++++++++++++++++++++++++++++++++------ src/Main.hs | 2 +- 5 files changed, 67 insertions(+), 13 deletions(-) create mode 100644 src/Abs.hs delete mode 100644 src/Auxiliary.hs diff --git a/language.cabal b/language.cabal index 52b2577..3f4860c 100644 --- a/language.cabal +++ b/language.cabal @@ -31,7 +31,6 @@ executable language Grammar.Print Grammar.Skel LambdaLifter - Auxiliary -- Interpreter hs-source-dirs: src diff --git a/src/Abs.hs b/src/Abs.hs new file mode 100644 index 0000000..7cc3064 --- /dev/null +++ b/src/Abs.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE TypeFamilies, PatternSynonyms, StandaloneDeriving #-} + +module Abs where + +import Data.String + +data Program a = Program [Bind a] + +data Bind a = Bind Ident [Ident] (Exp a) + +newtype Ident = Ident String + deriving (Eq, Ord, Show, Data.String.IsString) + +data Exp a = EId (IdFamily a) Ident + | EInt (IntFamily a) Integer + | EAdd (AddFamily a) (Exp a) (Exp a) + | EApp (AppFamily a) (Exp a) (Exp a) + | EAbs (AbsFamily a) Ident (Exp a) + | ELet (LetFamily a) [Bind a] (Exp a) + | EExp (ExpFamily a) (Exp a) + +type family IdFamily a +type family IntFamily a +type family AddFamily a +type family AppFamily a +type family AbsFamily a +type family LetFamily a +type family ExpFamily a diff --git a/src/Auxiliary.hs b/src/Auxiliary.hs deleted file mode 100644 index cd844d7..0000000 --- a/src/Auxiliary.hs +++ /dev/null @@ -1,5 +0,0 @@ - -module Auxiliary (module Auxiliary) where - -snoc :: a -> [a] -> [a] -snoc x xs = xs ++ [x] diff --git a/src/LambdaLifter.hs b/src/LambdaLifter.hs index ac9cee0..79d5b8a 100644 --- a/src/LambdaLifter.hs +++ b/src/LambdaLifter.hs @@ -1,5 +1,4 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE LambdaCase, OverloadedStrings, TypeFamilies, PatternSynonyms #-} module LambdaLifter (lambdaLift, freeVars, abstract, rename, collectScs) where @@ -13,6 +12,8 @@ import qualified Data.Set as Set import Data.Tuple.Extra (uncurry3) import Grammar.Abs import Prelude hiding (exp) +import qualified Abs as A +import Data.Void @@ -74,10 +75,10 @@ data ABind = ABind Ident [Ident] AnnExp deriving Show data AnnExp' = AId Ident | AInt Integer - | AApp AnnExp AnnExp - | AAdd AnnExp AnnExp - | AAbs Ident AnnExp - | ALet [ABind] AnnExp + | AApp (Set Ident, AnnExp') (Set Ident, AnnExp') + | AAdd (Set Ident, AnnExp') (Set Ident, AnnExp') + | AAbs Ident (Set Ident, AnnExp') + | ALet [ABind] (Set Ident, AnnExp') deriving Show -- | Lift lambdas to let expression of the form @let sc = \x -> rhs@ @@ -219,3 +220,34 @@ mkEAbs [] e = e mkEAbs bs e = ELet bs e +{----------- BOILERPLATE -----------} + +data LL + +type instance A.IdFamily LL = () +type instance A.IntFamily LL = () +type instance A.AddFamily LL = (Set Ident, Set Ident) +type instance A.AppFamily LL = (Set Ident, Set Ident) +type instance A.AbsFamily LL = Set Ident +type instance A.LetFamily LL = Set Ident +type instance A.ExpFamily LL = Void + +pattern LLId ident = A.EId () ident +pattern LLInt int = A.EInt () int +pattern LLAdd s1 s2 e1 e2 = A.EAdd (s1,s2) e1 e2 +pattern LLApp s1 s2 e1 e2 = A.EApp (s1,s2) e1 e2 +pattern LLAbs s i e = A.EAbs s i e +pattern LLLet s binds e = A.ELet s binds e +pattern LLExp v e = A.EExp v e + +{- + +data AnnExp' = AId Ident + | AInt Integer + | AApp (Set Ident, AnnExp') (Set Ident, AnnExp') + | AAdd (Set Ident, AnnExp') (Set Ident, AnnExp') + | AAbs Ident (Set Ident, AnnExp') + | ALet [ABind] (Set Ident, AnnExp') + deriving Show + +-} diff --git a/src/Main.hs b/src/Main.hs index 9af1753..d367bc1 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -3,7 +3,7 @@ module Main where import Grammar.Par (myLexer, pProgram) import Grammar.Print (printTree) -import LambdaLifter (abstract, freeVars, lambdaLift, rename) +import LambdaLifter (lambdaLift) import System.Environment (getArgs) import System.Exit (exitFailure, exitSuccess) From 73dc2e4b6a28c20b21fac8bee958733fc67507eb Mon Sep 17 00:00:00 2001 From: sebastianselander Date: Mon, 13 Feb 2023 12:17:49 +0100 Subject: [PATCH 018/372] Inference on most expressions. HM based. Still have to figure out how to infer type of lambda variables, as well as how function application on polymorphic should work --- Grammar.cf | 28 ++-- Makefile | 2 +- language.cabal | 11 +- src/Abs.hs | 28 ---- src/LambdaLifter.hs | 253 ------------------------------- src/Main.hs | 16 +- src/Renamer/Renamer.hs | 90 +++++++++++ src/Renamer/RenamerIr.hs | 84 ++++++++++ src/TypeChecker.hs | 0 src/TypeChecker/TypeChecker.hs | 122 +++++++++++++++ src/TypeChecker/TypeCheckerIr.hs | 22 +++ test_program | 1 + 12 files changed, 347 insertions(+), 310 deletions(-) delete mode 100644 src/Abs.hs delete mode 100644 src/LambdaLifter.hs create mode 100644 src/Renamer/Renamer.hs create mode 100644 src/Renamer/RenamerIr.hs delete mode 100644 src/TypeChecker.hs create mode 100644 src/TypeChecker/TypeChecker.hs create mode 100644 src/TypeChecker/TypeCheckerIr.hs create mode 100644 test_program diff --git a/Grammar.cf b/Grammar.cf index 410d11d..b58dbea 100644 --- a/Grammar.cf +++ b/Grammar.cf @@ -1,20 +1,28 @@ - Program. Program ::= [Bind]; -EId. Exp3 ::= Ident; -EInt. Exp3 ::= Integer; -ELet. Exp3 ::= "let" [Bind] "in" Exp; -EApp. Exp2 ::= Exp2 Exp3; -EAdd. Exp1 ::= Exp1 "+" Exp2; -EAbs. Exp ::= "\\" Ident "." Exp; - Bind. Bind ::= Ident [Ident] "=" Exp; + +EAnn. Exp5 ::= Exp5 ":" Type ; +EId. Exp4 ::= Ident; +EConst. Exp4 ::= Const; +EApp. Exp3 ::= Exp3 Exp4; +ELet. Exp2 ::= "let" Bind "in" Exp; +EAdd. Exp1 ::= Exp1 "+" Exp2; +EAbs. Exp ::= "\\" Ident "." Exp; + +CInt. Const ::= Integer ; +CStr. Const ::= String ; + +TMono. Type1 ::= Ident ; +TPoly. Type1 ::= Ident ; +TFun. Type ::= Type1 "->" Type ; + separator Bind ";"; separator Ident " "; -coercions Exp 3; +coercions Type 1 ; +coercions Exp 5; comment "--"; comment "{-" "-}"; - diff --git a/Makefile b/Makefile index 6e8a54d..ad830b5 100644 --- a/Makefile +++ b/Makefile @@ -1,7 +1,7 @@ .PHONY : sdist clean language : src/Grammar/Test - cabal install --installdir=. + cabal install --installdir=. --overwrite-policy=always src/Grammar/Test.hs src/Grammar/Lex.x src/Grammar/Par.y : Grammar.cf bnfc -o src -d $< diff --git a/language.cabal b/language.cabal index 3f4860c..d254e3e 100644 --- a/language.cabal +++ b/language.cabal @@ -17,7 +17,7 @@ extra-source-files: common warnings - ghc-options: -Wall + ghc-options: -W executable language import: warnings @@ -30,7 +30,12 @@ executable language Grammar.Par Grammar.Print Grammar.Skel - LambdaLifter + Grammar.ErrM + -- LambdaLifter + TypeChecker.TypeChecker + TypeChecker.TypeCheckerIr + -- Renamer.Renamer + -- Renamer.RenamerIr -- Interpreter hs-source-dirs: src @@ -40,7 +45,7 @@ executable language , mtl , containers , either - , array , extra + , array default-language: GHC2021 diff --git a/src/Abs.hs b/src/Abs.hs deleted file mode 100644 index 7cc3064..0000000 --- a/src/Abs.hs +++ /dev/null @@ -1,28 +0,0 @@ -{-# LANGUAGE TypeFamilies, PatternSynonyms, StandaloneDeriving #-} - -module Abs where - -import Data.String - -data Program a = Program [Bind a] - -data Bind a = Bind Ident [Ident] (Exp a) - -newtype Ident = Ident String - deriving (Eq, Ord, Show, Data.String.IsString) - -data Exp a = EId (IdFamily a) Ident - | EInt (IntFamily a) Integer - | EAdd (AddFamily a) (Exp a) (Exp a) - | EApp (AppFamily a) (Exp a) (Exp a) - | EAbs (AbsFamily a) Ident (Exp a) - | ELet (LetFamily a) [Bind a] (Exp a) - | EExp (ExpFamily a) (Exp a) - -type family IdFamily a -type family IntFamily a -type family AddFamily a -type family AppFamily a -type family AbsFamily a -type family LetFamily a -type family ExpFamily a diff --git a/src/LambdaLifter.hs b/src/LambdaLifter.hs deleted file mode 100644 index 79d5b8a..0000000 --- a/src/LambdaLifter.hs +++ /dev/null @@ -1,253 +0,0 @@ -{-# LANGUAGE LambdaCase, OverloadedStrings, TypeFamilies, PatternSynonyms #-} - - -module LambdaLifter (lambdaLift, freeVars, abstract, rename, collectScs) where - -import Data.List (mapAccumL) -import Data.Map (Map) -import qualified Data.Map as Map -import Data.Maybe (fromMaybe) -import Data.Set (Set, (\\)) -import qualified Data.Set as Set -import Data.Tuple.Extra (uncurry3) -import Grammar.Abs -import Prelude hiding (exp) -import qualified Abs as A -import Data.Void - - - --- | Lift lambdas and let expression into supercombinators. -lambdaLift :: Program -> Program -lambdaLift = collectScs . rename . abstract . freeVars - - --- | Annotate free variables -freeVars :: Program -> AnnProgram -freeVars (Program ds) = [ (n, xs, freeVarsExp (Set.fromList xs) e) - | Bind n xs e <- ds - ] - -freeVarsExp :: Set Ident -> Exp -> AnnExp -freeVarsExp lv = \case - - EId n | Set.member n lv -> (Set.singleton n, AId n) - | otherwise -> (mempty, AId n) - - EInt i -> (mempty, AInt i) - - EApp e1 e2 -> (Set.union (freeVarsOf e1') (freeVarsOf e2'), AApp e1' e2') - where e1' = freeVarsExp lv e1 - e2' = freeVarsExp lv e2 - - EAdd e1 e2 -> (Set.union (freeVarsOf e1') (freeVarsOf e2'), AAdd e1' e2') - where e1' = freeVarsExp lv e1 - e2' = freeVarsExp lv e2 - - EAbs n e -> (Set.delete n $ freeVarsOf e', AAbs n e') - where e' = freeVarsExp (Set.insert n lv) e - - ELet bs e -> (Set.union bsFree eFree, ALet bs' e') - where - bsFree = freeInValues \\ nsSet - eFree = freeVarsOf e' \\ nsSet - bs' = zipWith3 ABind ns xs es' - e' = freeVarsExp e_lv e - (ns, xs, es) = fromBinders bs - nsSet = Set.fromList ns - e_lv = Set.union lv nsSet - es' = map (freeVarsExp e_lv) es - freeInValues = foldr1 Set.union (map freeVarsOf es') - - -freeVarsOf :: AnnExp -> Set Ident -freeVarsOf = fst - -fromBinders :: [Bind] -> ([Ident], [[Ident]], [Exp]) -fromBinders bs = unzip3 [ (n, xs, e) | Bind n xs e <- bs ] - --- AST annotated with free variables -type AnnProgram = [(Ident, [Ident], AnnExp)] - -type AnnExp = (Set Ident, AnnExp') - -data ABind = ABind Ident [Ident] AnnExp deriving Show - -data AnnExp' = AId Ident - | AInt Integer - | AApp (Set Ident, AnnExp') (Set Ident, AnnExp') - | AAdd (Set Ident, AnnExp') (Set Ident, AnnExp') - | AAbs Ident (Set Ident, AnnExp') - | ALet [ABind] (Set Ident, AnnExp') - deriving Show - --- | Lift lambdas to let expression of the form @let sc = \x -> rhs@ -abstract :: AnnProgram -> Program -abstract prog = Program $ map f prog - where - f :: (Ident, [Ident], AnnExp) -> Bind - f (name, pars, rhs@(_, e)) = - case e of - AAbs par body -> Bind name (snoc par pars) $ abstractExp body - _ -> Bind name pars $ abstractExp rhs - -abstractExp :: AnnExp -> Exp -abstractExp (free, exp) = case exp of - AId n -> EId n - AInt i -> EInt i - AApp e1 e2 -> EApp (abstractExp e1) (abstractExp e2) - AAdd e1 e2 -> EAdd (abstractExp e1) (abstractExp e2) - ALet bs e -> ELet [Bind n xs (abstractExp e1) | ABind n xs e1 <- bs ] $ abstractExp e - AAbs n e -> foldl EApp sc (map EId fvList) - where - fvList = Set.toList free - bind = Bind "sc" [] e' - e' = foldr EAbs (abstractExp e) (fvList ++ [n]) - sc = ELet [bind] (EId (Ident "sc")) - - -snoc :: a -> [a] -> [a] -snoc x xs = xs ++ [x] - --- | Rename all supercombinators and variables -rename :: Program -> Program -rename (Program ds) = Program $ map (uncurry3 Bind) tuples - where - tuples = snd (mapAccumL renameSc 0 ds) - renameSc i (Bind n xs e) = (i2, (n, xs', e')) - where - (i1, xs', env) = newNames i xs - (i2, e') = renameExp env i1 e - -renameExp :: Map Ident Ident -> Int -> Exp -> (Int, Exp) -renameExp env i = \case - - EId n -> (i, EId . fromMaybe n $ Map.lookup n env) - - EInt i1 -> (i, EInt i1) - - EApp e1 e2 -> (i2, EApp e1' e2') - where - (i1, e1') = renameExp env i e1 - (i2, e2') = renameExp env i1 e2 - - EAdd e1 e2 -> (i2, EAdd e1' e2') - where - (i1, e1') = renameExp env i e1 - (i2, e2') = renameExp env i1 e2 - - ELet bs e -> (i3, ELet (zipWith3 Bind ns' xs es') e') - where - (i1, e') = renameExp e_env i e - (ns, xs, es) = fromBinders bs - (i2, ns', env') = newNames i1 ns - e_env = Map.union env' env - (i3, es') = mapAccumL (renameExp e_env) i2 es - - - EAbs n e -> (i2, EAbs (head ns) e') - where - (i1, ns, env') = newNames i [n] - (i2, e') = renameExp (Map.union env' env ) i1 e - - -newNames :: Int -> [Ident] -> (Int, [Ident], Map Ident Ident) -newNames i old_names = (i', new_names, env) - where - (i', new_names) = getNames i old_names - env = Map.fromList $ zip old_names new_names - - -getName :: Int -> Ident -> (Int, Ident) -getName i (Ident s) = (i + 1, makeName s i) - -getNames :: Int -> [Ident] -> (Int, [Ident]) -getNames i ns = (i + length ss, zipWith makeName ss [i..]) - where - ss = map (\(Ident s) -> s) ns - -makeName :: String -> Int -> Ident -makeName prefix i = Ident (prefix ++ "_" ++ show i) - - --- | Collects supercombinators by lifting appropriate let expressions -collectScs :: Program -> Program -collectScs (Program ds) = Program $ concatMap collectOneSc ds - where - collectOneSc (Bind name args rhs) = Bind name args rhs' : scs - where (scs, rhs') = collectScsExp rhs - -collectScsExp :: Exp -> ([Bind], Exp) -collectScsExp = \case - - EId n -> ([], EId n) - - EInt i -> ([], EInt i) - - EApp e1 e2 -> (scs1 ++ scs2, EApp e1' e2') - where - (scs1, e1') = collectScsExp e1 - (scs2, e2') = collectScsExp e2 - - EAdd e1 e2 -> (scs1 ++ scs2, EAdd e1' e2') - where - (scs1, e1') = collectScsExp e1 - (scs2, e2') = collectScsExp e2 - - EAbs x e -> (scs, EAbs x e') - where - (scs, e') = collectScsExp e - - ELet bs e -> (rhss_scs ++ e_scs ++ local_scs, mkEAbs non_scs' e') - where - (rhss_scs, bs') = mapAccumL collectScs_d [] bs - scs' = [ Bind n xs rhs | Bind n xs rhs <- bs', isEAbs rhs] - non_scs' = [ Bind n xs rhs | Bind n xs rhs <- bs', not $ isEAbs rhs] - local_scs = [ Bind n (xs ++ [x]) e1 | Bind n xs (EAbs x e1) <- scs'] - (e_scs, e') = collectScsExp e - - collectScs_d scs (Bind n xs rhs) = (scs ++ rhs_scs1, Bind n xs rhs') - where - (rhs_scs1, rhs') = collectScsExp rhs - -isEAbs :: Exp -> Bool -isEAbs = \case - EAbs {} -> True - _ -> False - -mkEAbs :: [Bind] -> Exp -> Exp -mkEAbs [] e = e -mkEAbs bs e = ELet bs e - - -{----------- BOILERPLATE -----------} - -data LL - -type instance A.IdFamily LL = () -type instance A.IntFamily LL = () -type instance A.AddFamily LL = (Set Ident, Set Ident) -type instance A.AppFamily LL = (Set Ident, Set Ident) -type instance A.AbsFamily LL = Set Ident -type instance A.LetFamily LL = Set Ident -type instance A.ExpFamily LL = Void - -pattern LLId ident = A.EId () ident -pattern LLInt int = A.EInt () int -pattern LLAdd s1 s2 e1 e2 = A.EAdd (s1,s2) e1 e2 -pattern LLApp s1 s2 e1 e2 = A.EApp (s1,s2) e1 e2 -pattern LLAbs s i e = A.EAbs s i e -pattern LLLet s binds e = A.ELet s binds e -pattern LLExp v e = A.EExp v e - -{- - -data AnnExp' = AId Ident - | AInt Integer - | AApp (Set Ident, AnnExp') (Set Ident, AnnExp') - | AAdd (Set Ident, AnnExp') (Set Ident, AnnExp') - | AAbs Ident (Set Ident, AnnExp') - | ALet [ABind] (Set Ident, AnnExp') - deriving Show - --} diff --git a/src/Main.hs b/src/Main.hs index d367bc1..e55afe9 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -3,7 +3,6 @@ module Main where import Grammar.Par (myLexer, pProgram) import Grammar.Print (printTree) -import LambdaLifter (lambdaLift) import System.Environment (getArgs) import System.Exit (exitFailure, exitSuccess) @@ -17,17 +16,4 @@ main = getArgs >>= \case putStrLn "SYNTAX ERROR" putStrLn err exitFailure - Right prg -> do - putStrLn "-- Parse" - putStrLn $ printTree prg - -- putStrLn "\n-- Abstract" - -- putStrLn . printTree $ (abstract . freeVars) prg - -- putStrLn "\n-- Rename" - -- putStrLn . printTree $ (rename . abstract . freeVars) prg - putStrLn "\n-- Lamda lifter" - putStrLn . printTree $ lambdaLift prg - putStrLn "" - exitSuccess - - - + Right prg -> putStrLn "NO SYNTAX ERROR" diff --git a/src/Renamer/Renamer.hs b/src/Renamer/Renamer.hs new file mode 100644 index 0000000..8d3fa1c --- /dev/null +++ b/src/Renamer/Renamer.hs @@ -0,0 +1,90 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedRecordDot #-} + +module Renamer.Renamer (rename) where + +import Control.Applicative (Applicative (liftA2)) +import Control.Monad.Except (MonadError (throwError)) +import Control.Monad.RWS (MonadState, gets, modify) +import Control.Monad.State (StateT, evalStateT) +import Data.Set (Set) +import qualified Data.Set as Set +import Grammar.Abs +import Grammar.ErrM (Err) +import Grammar.Print (printTree) +import qualified Renamer.RenamerIr as R + + +data Cxt = Cxt + { uniques :: [(Ident, R.Unique)] + , nextUnique :: R.Unique + , sig :: Set Ident + } + +initCxt :: Cxt +initCxt = Cxt + { uniques = [] + , nextUnique = R.Unique 0 + , sig = mempty + } + +newtype Rn a = Rn { runRn :: StateT Cxt Err a } + deriving (Functor, Applicative, Monad, MonadState Cxt, MonadError String) + +rename :: Program -> Err R.Program +rename p = evalStateT (runRn $ renameProgram p) initCxt + +renameProgram :: Program -> Rn R.Program +renameProgram (Program ds (Main e)) = do + ds' <- mapM renameDef ds + e' <- renameExp e + pure $ R.Program ds' (R.Main e') + +renameDef :: Def -> Rn R.Def +renameDef = \case + DExp x t _ xs e -> do + newSig x + xs' <- mapM newUnique xs + e' <- renameExp e + let e'' = foldr ($) e' . zipWith R.EAbs xs' $ fromTree t + pure . R.DBind $ R.Bind x t e'' + +renameExp :: Exp -> Rn R.Exp +renameExp = \case + EId x -> R.EId <$> findBind x + EInt i -> pure $ R.EInt i + EApp e e1 -> liftA2 R.EApp (renameExp e) $ renameExp e1 + EAdd e e1 -> liftA2 R.EAdd (renameExp e) $ renameExp e1 + EAbs x t e -> do + x' <- newUnique x + e' <- renameExp e + pure $ R.EAbs x' t e' + +findBind :: Ident -> Rn R.Name +findBind x = lookupUnique x >>= \case + Just u -> pure $ R.Nu u + Nothing -> gets (Set.member x . sig) >>= \case + False -> throwError ("Unbound variable " ++ printTree x) + True -> pure $ R.Ni x + +newUnique :: Ident -> Rn R.Unique +newUnique x = do + u <- gets nextUnique + modify $ \env -> env { nextUnique = succ u + , uniques = (x, u) : env.uniques + } + pure u + +newSig :: Ident -> Rn () +newSig x = modify $ \cxt -> cxt { sig = Set.insert x cxt.sig} + +lookupUnique :: Ident -> Rn (Maybe R.Unique) +lookupUnique x = lookup x <$> gets uniques + +fromTree :: Type -> [Type] +fromTree = fromTree' [] + +fromTree' :: [Type] -> Type -> [Type] +fromTree' acc = \case + TFun t t1 -> acc ++ [t] ++ fromTree t1 + other -> other : acc diff --git a/src/Renamer/RenamerIr.hs b/src/Renamer/RenamerIr.hs new file mode 100644 index 0000000..e3c4cce --- /dev/null +++ b/src/Renamer/RenamerIr.hs @@ -0,0 +1,84 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} + +module Renamer.RenamerIr where + +import Grammar.Abs (Ident, Type (..)) +import Grammar.Print + + +data Program = Program [Def] Main + deriving (Eq, Ord, Show, Read) + +newtype Main = Main Exp + deriving (Eq, Ord, Show, Read) + + +newtype Def = DBind Bind + deriving (Eq, Ord, Show, Read) + +data Name = Nu Unique | Ni Ident deriving (Ord, Show, Eq, Read) + +newtype Unique = Unique Int deriving (Enum, Eq, Read, Ord) +instance Show Unique where show (Unique i) = "x" ++ show i + +data Exp + = EId Name + | EInt Integer + | EApp Exp Exp + | EAdd Exp Exp + | EAbs Unique Type Exp + deriving (Eq, Ord, Show, Read) + + +data Bind = Bind Ident Type Exp + deriving (Eq, Ord, Show, Read) + + +instance Print Program where + prt i = \case + Program defs main -> prPrec i 0 (concatD [prt 0 defs, prt 0 main]) + + +instance Print Def where + prt i (DBind b) = prPrec i 0 $ concatD [prt 0 b, doc (showString ";")] + +instance Print Bind where + prt i = \case + Bind x t e -> prPrec i 0 $ concatD + [ prt 0 x + , doc (showString ":") + , prt 0 t + , doc (showString "=") + , prt 0 e] + +instance Print [Def] where + prt _ [] = concatD [] + prt _ (x:xs) = concatD [prt 0 x, prt 0 xs] + + +instance Print Main where + prt i = \case + Main exp -> prPrec i 0 $ concatD + [ doc (showString "main") + , doc (showString "=") + , prt 0 exp + , doc (showString ";") + ] + +instance Print Exp where + prt i = \case + EId u -> prPrec i 3 (concatD [prt 0 u]) + EInt n -> prPrec i 3 (concatD [prt 0 n]) + EApp e e1 -> prPrec i 2 (concatD [prt 2 e, prt 3 e1]) + EAdd e e1 -> prPrec i 1 (concatD [prt 1 e, doc (showString "+"), prt 2 e1]) + EAbs u t e -> prPrec i 0 (concatD [doc (showString "\\"), prt 0 u, doc (showString ":"), prt 0 t, doc (showString "."), prt 0 e]) + + +instance Print Name where + prt _ = \case + Ni i -> prt 0 i + Nu u -> prt 0 u + +instance Print Unique where + prt _ = doc . showString . show diff --git a/src/TypeChecker.hs b/src/TypeChecker.hs deleted file mode 100644 index e69de29..0000000 diff --git a/src/TypeChecker/TypeChecker.hs b/src/TypeChecker/TypeChecker.hs new file mode 100644 index 0000000..c98ad66 --- /dev/null +++ b/src/TypeChecker/TypeChecker.hs @@ -0,0 +1,122 @@ +{-# LANGUAGE LambdaCase #-} + +module TypeChecker.TypeChecker where + +import Control.Monad (when) +import Control.Monad.Except (throwError) +import Control.Monad.Reader (ReaderT) +import qualified Control.Monad.Reader as R +import Control.Monad.Writer (WriterT) +import qualified Control.Monad.Writer as W + +import Data.Map (Map) +import qualified Data.Map as M +import Data.Set (Set) +import qualified Data.Set as S + +import qualified Grammar.Abs as Old +import Grammar.ErrM (Err) + +import TypeChecker.TypeCheckerIr + +data Ctx = Ctx + { env :: [Map Ident Type] + , sig :: Map Ident Bind + , typs :: Set Ident + } + +type Check a = WriterT String (ReaderT Ctx Err) a + +inferExp :: Old.Exp -> Check Type +inferExp = \case + Old.EAnn e t -> do + infT <- inferExp e + when (t /= infT) (throwError $ show (AnnotatedMismatch (show e) (show t) (show infT))) + return infT + Old.EConst c -> case c of + (CInt i) -> return (TMono $ Old.Ident "Int") + (CStr s) -> return (TMono $ Old.Ident "String") + Old.EId i -> lookupEnv i + Old.EAdd e1 e2 -> do + t1 <- inferExp e1 + t2 <- inferExp e2 + case (t1, t2) of + (TMono (Old.Ident "Int"), TMono (Old.Ident "Int")) -> return t1 + _ -> throwError $ show (NotNumber (show t1)) + return t1 + + -- This is wrong currently. (a -> b) should be able to take String + Old.EApp e1 e2 -> do + inferExp e1 >>= \case + TFun mono@(TMono i) t2 -> do + t <- inferExp e2 + when (t /= mono) (throwError $ show $ TypeMismatch (show t) (show mono)) + return t + + -- Not entirely correct. Should sometimes be able to provide mono types where poly expected. + -- i.e id : a -> a; id "string" + TFun poly@(TPoly f) t2 -> do + t <- inferExp e2 + when (t /= poly) (throwError $ show (TypeMismatch (show t) (show poly))) + return t + t -> throwError $ show (NotFunction "Expected a function, but got:" (show t)) + + Old.EAbs i e -> undefined + + Old.ELet b e -> undefined + +-- Aux + +lookupEnv :: Ident -> Check Type +lookupEnv i = + R.asks env >>= \case + [] -> throwError $ show (UnboundVar "Variable not found" (show i)) + xs -> lookupEnv' i xs + where + lookupEnv' :: Ident -> [Map Ident Type] -> Check Type + lookupEnv' i [] = throwError $ show (UnboundVar "Variable not found" (show i)) + lookupEnv' i (x : xs) = case M.lookup i x of + Just t -> return t + Nothing -> lookupEnv' i xs + +lookupSig :: Ident -> Check Bind +lookupSig b = + R.asks sig >>= \m -> case M.lookup b m of + Nothing -> undefined + Just b -> return b + +insertEnv :: Ident -> Type -> Ctx -> Ctx +insertEnv i t c = + case env c of + [] -> Ctx{env = [M.insert i t mempty]} + (x : xs) -> Ctx{env = M.insert i t x : xs} + +data Error + = TypeMismatch String String + | NotNumber String + | FunctionTypeMismatch String String String + | NotFunction String String + | UnboundVar String String + | AnnotatedMismatch String String String + | Default String + +showErr :: Error -> String +showErr = \case + TypeMismatch expected found -> unwords ["Expected type:", show expected, "but got", show found] + NotNumber mess -> "Expected a number, but got: " <> mess + NotFunction mess func -> mess <> ": " <> func + FunctionTypeMismatch func expected found -> unwords ["Function:", show func, "expected:", show expected, "but got:", show found] + UnboundVar mess var -> mess <> ": " <> var + AnnotatedMismatch expression expected found -> + unwords + [ "Expression" + , expression + , "expected type" + , expected + , "but was inferred as type" + , found + ] + Default mess -> mess + +instance Show Error where + show = showErr diff --git a/src/TypeChecker/TypeCheckerIr.hs b/src/TypeChecker/TypeCheckerIr.hs new file mode 100644 index 0000000..3bca405 --- /dev/null +++ b/src/TypeChecker/TypeCheckerIr.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE LambdaCase #-} + +module TypeChecker.TypeCheckerIr + ( Program(..) + , Bind(..) + , Ident + , Type(..) + , Const(..) + , Exp(..) + ) + where + +import Grammar.Abs (Program(..), Bind(..), Ident, Type(..), Const(..)) + +data Exp + = EAnn Exp Type + | EId Ident Type + | EConst Const Type + | EApp Exp Exp Type + | EAdd Exp Exp Type + | EAbs Ident Exp Type + deriving (Eq, Ord, Show, Read) diff --git a/test_program b/test_program new file mode 100644 index 0000000..4a7b634 --- /dev/null +++ b/test_program @@ -0,0 +1 @@ +main = \x. x + (3 : Int) From c10d7703ad8e5bb3634b51f8aaf018b01dd5e85c Mon Sep 17 00:00:00 2001 From: sebastianselander Date: Mon, 13 Feb 2023 19:03:06 +0100 Subject: [PATCH 019/372] Progression on type checker ;) --- Grammar.cf | 11 +- src/Main.hs | 11 +- src/TypeChecker/TypeChecker.hs | 172 +++++++++++++++++++------------ src/TypeChecker/TypeCheckerIr.hs | 12 +-- test_program | 2 +- 5 files changed, 126 insertions(+), 82 deletions(-) diff --git a/Grammar.cf b/Grammar.cf index b58dbea..45021c1 100644 --- a/Grammar.cf +++ b/Grammar.cf @@ -7,16 +7,19 @@ EAnn. Exp5 ::= Exp5 ":" Type ; EId. Exp4 ::= Ident; EConst. Exp4 ::= Const; EApp. Exp3 ::= Exp3 Exp4; -ELet. Exp2 ::= "let" Bind "in" Exp; EAdd. Exp1 ::= Exp1 "+" Exp2; +ELet. Exp ::= "let" Ident "=" Exp "in" Exp; EAbs. Exp ::= "\\" Ident "." Exp; CInt. Const ::= Integer ; CStr. Const ::= String ; -TMono. Type1 ::= Ident ; -TPoly. Type1 ::= Ident ; -TFun. Type ::= Type1 "->" Type ; +TMono. Type1 ::= UIdent ; +TPoly. Type1 ::= LIdent ; +TArrow. Type ::= Type "->" Type1 ; + +token UIdent (upper (letter | digit | '_')*) ; +token LIdent (lower (letter | digit | '_')*) ; separator Bind ";"; separator Ident " "; diff --git a/src/Main.hs b/src/Main.hs index e55afe9..27802b7 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -5,6 +5,7 @@ import Grammar.Par (myLexer, pProgram) import Grammar.Print (printTree) import System.Environment (getArgs) import System.Exit (exitFailure, exitSuccess) +import TypeChecker.TypeChecker (typecheck) main :: IO () main = getArgs >>= \case @@ -16,4 +17,12 @@ main = getArgs >>= \case putStrLn "SYNTAX ERROR" putStrLn err exitFailure - Right prg -> putStrLn "NO SYNTAX ERROR" + Right prg -> case typecheck prg of + Right prg -> do + putStrLn "TYPE CHECK SUCCESSFUL" + putStrLn . show $ prg + Left err -> do + putStrLn "TYPE CHECK ERROR" + putStrLn . show $ err + exitFailure + diff --git a/src/TypeChecker/TypeChecker.hs b/src/TypeChecker/TypeChecker.hs index c98ad66..9c3ac70 100644 --- a/src/TypeChecker/TypeChecker.hs +++ b/src/TypeChecker/TypeChecker.hs @@ -1,14 +1,18 @@ -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE LambdaCase, OverloadedStrings #-} -module TypeChecker.TypeChecker where +module TypeChecker.TypeChecker (typecheck) where + +import Control.Monad (when, void) +import Control.Monad.Except (ExceptT, throwError, runExceptT) -import Control.Monad (when) -import Control.Monad.Except (throwError) import Control.Monad.Reader (ReaderT) import qualified Control.Monad.Reader as R + import Control.Monad.Writer (WriterT) import qualified Control.Monad.Writer as W +import Data.Functor.Identity (Identity, runIdentity) + import Data.Map (Map) import qualified Data.Map as M import Data.Set (Set) @@ -24,66 +28,88 @@ data Ctx = Ctx , sig :: Map Ident Bind , typs :: Set Ident } + deriving Show -type Check a = WriterT String (ReaderT Ctx Err) a +type Check = ReaderT Ctx (ExceptT Error Identity) + +initEnv :: Ctx +initEnv = + Ctx { env = mempty + , sig = mempty + , typs = mempty + } + +run :: Check Type -> Either Error Type +run = runIdentity . runExceptT . flip R.runReaderT initEnv + +typecheck :: Old.Program -> Either Error () +typecheck = runIdentity . runExceptT . flip R.runReaderT initEnv . inferPrg + +inferPrg :: Old.Program -> Check () +inferPrg (Program [x]) = void $ inferBind x + +inferBind :: Old.Bind -> Check () +inferBind (Bind _ _ e) = void $ inferExp e inferExp :: Old.Exp -> Check Type inferExp = \case + + Old.EId i -> undefined + Old.EAnn e t -> do infT <- inferExp e - when (t /= infT) (throwError $ show (AnnotatedMismatch (show e) (show t) (show infT))) + when (t /= infT) (throwError AnnotatedMismatch) return infT + Old.EConst c -> case c of - (CInt i) -> return (TMono $ Old.Ident "Int") - (CStr s) -> return (TMono $ Old.Ident "String") - Old.EId i -> lookupEnv i + (Old.CInt i) -> return (TMono $ UIdent "Int") + (Old.CStr s) -> return (TMono $ UIdent "String") + Old.EAdd e1 e2 -> do t1 <- inferExp e1 t2 <- inferExp e2 case (t1, t2) of - (TMono (Old.Ident "Int"), TMono (Old.Ident "Int")) -> return t1 - _ -> throwError $ show (NotNumber (show t1)) + (TMono (UIdent "Int"), TMono (UIdent "Int")) -> return t1 + _ -> throwError NotNumber return t1 - -- This is wrong currently. (a -> b) should be able to take String Old.EApp e1 e2 -> do inferExp e1 >>= \case - TFun mono@(TMono i) t2 -> do + TArrow mono@(TMono i) t2 -> do t <- inferExp e2 - when (t /= mono) (throwError $ show $ TypeMismatch (show t) (show mono)) - return t + when (t /= mono) (throwError TypeMismatch) + return t2 - -- Not entirely correct. Should sometimes be able to provide mono types where poly expected. - -- i.e id : a -> a; id "string" - TFun poly@(TPoly f) t2 -> do - t <- inferExp e2 - when (t /= poly) (throwError $ show (TypeMismatch (show t) (show poly))) - return t - t -> throwError $ show (NotFunction "Expected a function, but got:" (show t)) + TArrow poly@(TPoly f) t2 -> do + t <- inferExp e2 + when (not $ t `subtype` t) (throwError TypeMismatch) + return t2 - Old.EAbs i e -> undefined +-- This is not entirely correct. The assumed type can change. + Old.EAbs i e -> do + let assume = (TPoly "a") + infT <- R.local (insertEnv i assume) (inferExp e) + return (TArrow assume infT) - Old.ELet b e -> undefined + Old.ELet i e1 e2 -> undefined -- Aux -lookupEnv :: Ident -> Check Type -lookupEnv i = - R.asks env >>= \case - [] -> throwError $ show (UnboundVar "Variable not found" (show i)) - xs -> lookupEnv' i xs - where - lookupEnv' :: Ident -> [Map Ident Type] -> Check Type - lookupEnv' i [] = throwError $ show (UnboundVar "Variable not found" (show i)) - lookupEnv' i (x : xs) = case M.lookup i x of - Just t -> return t - Nothing -> lookupEnv' i xs +subtype :: Type -> Type -> Bool +subtype (TMono t1) (TMono t2) = t1 == t2 +subtype (TMono t1) (TPoly t2) = True +subtype (TPoly t2) (TMono t1) = False +subtype (TArrow t1 t2) (TArrow t3 t4) = t1 `subtype` t3 && t2 `subtype` t4 -lookupSig :: Ident -> Check Bind -lookupSig b = - R.asks sig >>= \m -> case M.lookup b m of - Nothing -> undefined - Just b -> return b +lookupEnv :: Ident -> Ctx -> Maybe Type +lookupEnv i c = case env c of + [] -> Nothing + x : xs -> case M.lookup i x of + Nothing -> lookupEnv i (Ctx { env = xs }) + Just x -> Just x + +lookupSig :: Ident -> Ctx -> Maybe Bind +lookupSig i = M.lookup i . sig insertEnv :: Ident -> Type -> Ctx -> Ctx insertEnv i t c = @@ -92,31 +118,45 @@ insertEnv i t c = (x : xs) -> Ctx{env = M.insert i t x : xs} data Error - = TypeMismatch String String - | NotNumber String - | FunctionTypeMismatch String String String - | NotFunction String String - | UnboundVar String String - | AnnotatedMismatch String String String - | Default String + = TypeMismatch + | NotNumber + | FunctionTypeMismatch + | NotFunction + | UnboundVar + | AnnotatedMismatch + | Default + deriving Show -showErr :: Error -> String -showErr = \case - TypeMismatch expected found -> unwords ["Expected type:", show expected, "but got", show found] - NotNumber mess -> "Expected a number, but got: " <> mess - NotFunction mess func -> mess <> ": " <> func - FunctionTypeMismatch func expected found -> unwords ["Function:", show func, "expected:", show expected, "but got:", show found] - UnboundVar mess var -> mess <> ": " <> var - AnnotatedMismatch expression expected found -> - unwords - [ "Expression" - , expression - , "expected type" - , expected - , "but was inferred as type" - , found - ] - Default mess -> mess +-- showErr :: Error -> String +-- showErr = \case +-- TypeMismatch expected found -> unwords ["Expected type:", show expected, "but got", show found] +-- NotNumber mess -> "Expected a number, but got: " <> mess +-- NotFunction mess func -> mess <> ": " <> func +-- FunctionTypeMismatch func expected found -> unwords ["Function:", show func, "expected:", show expected, "but got:", show found] +-- UnboundVar mess var -> mess <> ": " <> var +-- AnnotatedMismatch expression expected found -> +-- unwords +-- [ "Expression" +-- , expression +-- , "expected type" +-- , expected +-- , "but was inferred as type" +-- , found +-- ] +-- Default mess -> mess -instance Show Error where - show = showErr + +-- Tests + +number :: Old.Exp +number = Old.EConst (CInt 3) + +lambda :: Old.Exp +lambda = Old.EAbs (Old.Ident "x") (Old.EAdd (Old.EConst (Old.CInt 3)) (Old.EConst (Old.CInt 3))) + +apply :: Old.Exp +apply = Old.EApp lambda (Old.EConst (Old.CInt 3)) + +{-# WARNING todo "TODO IN CODE" #-} +todo :: a +todo = error "TODO in code" diff --git a/src/TypeChecker/TypeCheckerIr.hs b/src/TypeChecker/TypeCheckerIr.hs index 3bca405..7fb93fe 100644 --- a/src/TypeChecker/TypeCheckerIr.hs +++ b/src/TypeChecker/TypeCheckerIr.hs @@ -1,16 +1,8 @@ {-# LANGUAGE LambdaCase #-} -module TypeChecker.TypeCheckerIr - ( Program(..) - , Bind(..) - , Ident - , Type(..) - , Const(..) - , Exp(..) - ) - where +module TypeChecker.TypeCheckerIr (module Grammar.Abs, Exp) where -import Grammar.Abs (Program(..), Bind(..), Ident, Type(..), Const(..)) +import Grammar.Abs (Program(..), Ident(..), Bind(..), Const(..), Type(..), UIdent(..), LIdent(..)) data Exp = EAnn Exp Type diff --git a/test_program b/test_program index 4a7b634..14077bd 100644 --- a/test_program +++ b/test_program @@ -1 +1 @@ -main = \x. x + (3 : Int) +test y = y From 200a9e57ed5d8fb8f2d019fc0e218a0b480172cd Mon Sep 17 00:00:00 2001 From: sebastianselander Date: Tue, 14 Feb 2023 10:12:38 +0100 Subject: [PATCH 020/372] Fixed EId, more work on other expressions needed --- Grammar.cf | 24 +++++++-------- language.cabal | 2 +- src/TypeChecker/TypeChecker.hs | 55 +++++++++++++++++++++++++--------- test_program | 2 +- 4 files changed, 55 insertions(+), 28 deletions(-) diff --git a/Grammar.cf b/Grammar.cf index 45021c1..a570950 100644 --- a/Grammar.cf +++ b/Grammar.cf @@ -1,15 +1,15 @@ -Program. Program ::= [Bind]; +Program. Program ::= [Bind] ; -Bind. Bind ::= Ident [Ident] "=" Exp; +Bind. Bind ::= Ident [Ident] "=" Exp ; EAnn. Exp5 ::= Exp5 ":" Type ; -EId. Exp4 ::= Ident; -EConst. Exp4 ::= Const; -EApp. Exp3 ::= Exp3 Exp4; -EAdd. Exp1 ::= Exp1 "+" Exp2; -ELet. Exp ::= "let" Ident "=" Exp "in" Exp; -EAbs. Exp ::= "\\" Ident "." Exp; +EId. Exp4 ::= Ident ; +EConst. Exp4 ::= Const ; +EApp. Exp3 ::= Exp3 Exp4 ; +EAdd. Exp1 ::= Exp1 "+" Exp2 ; +ELet. Exp ::= "let" Ident "=" Exp "in" Exp ; +EAbs. Exp ::= "\\" Ident "." Exp ; CInt. Const ::= Integer ; CStr. Const ::= String ; @@ -21,11 +21,11 @@ TArrow. Type ::= Type "->" Type1 ; token UIdent (upper (letter | digit | '_')*) ; token LIdent (lower (letter | digit | '_')*) ; -separator Bind ";"; +separator Bind ";" ; separator Ident " "; coercions Type 1 ; -coercions Exp 5; +coercions Exp 5 ; -comment "--"; -comment "{-" "-}"; +comment "--" ; +comment "{-" "-}" ; diff --git a/language.cabal b/language.cabal index d254e3e..0f5aec2 100644 --- a/language.cabal +++ b/language.cabal @@ -17,7 +17,7 @@ extra-source-files: common warnings - ghc-options: -W + ghc-options: -Wdefault executable language import: warnings diff --git a/src/TypeChecker/TypeChecker.hs b/src/TypeChecker/TypeChecker.hs index 9c3ac70..36ec739 100644 --- a/src/TypeChecker/TypeChecker.hs +++ b/src/TypeChecker/TypeChecker.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE LambdaCase, OverloadedStrings #-} +{-# LANGUAGE LambdaCase, OverloadedStrings, OverloadedRecordDot #-} module TypeChecker.TypeChecker (typecheck) where @@ -18,6 +18,8 @@ import qualified Data.Map as M import Data.Set (Set) import qualified Data.Set as S +import Data.Bool (bool) + import qualified Grammar.Abs as Old import Grammar.ErrM (Err) @@ -25,7 +27,7 @@ import TypeChecker.TypeCheckerIr data Ctx = Ctx { env :: [Map Ident Type] - , sig :: Map Ident Bind + , sigs :: Map Ident Type , typs :: Set Ident } deriving Show @@ -35,7 +37,7 @@ type Check = ReaderT Ctx (ExceptT Error Identity) initEnv :: Ctx initEnv = Ctx { env = mempty - , sig = mempty + , sigs = mempty , typs = mempty } @@ -54,7 +56,14 @@ inferBind (Bind _ _ e) = void $ inferExp e inferExp :: Old.Exp -> Check Type inferExp = \case - Old.EId i -> undefined + Old.EId i -> do + ctx <- R.ask + case lookupEnv i ctx of + Just t -> return t + Nothing -> case lookupSigs i ctx of + Just t -> return t + Nothing -> throwError UnboundVar + Old.EAnn e t -> do infT <- inferExp e @@ -68,8 +77,12 @@ inferExp = \case Old.EAdd e1 e2 -> do t1 <- inferExp e1 t2 <- inferExp e2 + let int = TMono (UIdent "Int") case (t1, t2) of - (TMono (UIdent "Int"), TMono (UIdent "Int")) -> return t1 + (TMono (UIdent "Int"), TMono (UIdent "Int")) -> return int + (_, TMono (UIdent "Int")) -> return int + (TMono (UIdent "Int"), _) -> return int + (TPoly (LIdent x), TPoly (LIdent y)) -> bool (throwError TypeMismatch) (return int) (x==y) _ -> throwError NotNumber return t1 @@ -95,27 +108,39 @@ inferExp = \case -- Aux +-- Double check this function. It's bad and maybe wrong subtype :: Type -> Type -> Bool subtype (TMono t1) (TMono t2) = t1 == t2 subtype (TMono t1) (TPoly t2) = True subtype (TPoly t2) (TMono t1) = False subtype (TArrow t1 t2) (TArrow t3 t4) = t1 `subtype` t3 && t2 `subtype` t4 +subtype _ _ = False lookupEnv :: Ident -> Ctx -> Maybe Type lookupEnv i c = case env c of [] -> Nothing x : xs -> case M.lookup i x of - Nothing -> lookupEnv i (Ctx { env = xs }) + Nothing -> lookupEnv i (Ctx { env = xs + , sigs = c.sigs + , typs = c.typs + }) Just x -> Just x -lookupSig :: Ident -> Ctx -> Maybe Bind -lookupSig i = M.lookup i . sig +lookupSigs :: Ident -> Ctx -> Maybe Type +lookupSigs i = M.lookup i . sigs insertEnv :: Ident -> Type -> Ctx -> Ctx insertEnv i t c = case env c of - [] -> Ctx{env = [M.insert i t mempty]} - (x : xs) -> Ctx{env = M.insert i t x : xs} + [] -> Ctx { env = [M.insert i t mempty] + , sigs = c.sigs + , typs = c.typs + } + + (x : xs) -> Ctx { env = M.insert i t x : xs + , sigs = c.sigs + , typs = c.typs + } data Error = TypeMismatch @@ -145,17 +170,19 @@ data Error -- ] -- Default mess -> mess - -- Tests number :: Old.Exp number = Old.EConst (CInt 3) -lambda :: Old.Exp -lambda = Old.EAbs (Old.Ident "x") (Old.EAdd (Old.EConst (Old.CInt 3)) (Old.EConst (Old.CInt 3))) +aToInt :: Old.Exp +aToInt = Old.EAbs (Old.Ident "x") (Old.EAdd (Old.EConst (Old.CInt 3)) (Old.EConst (Old.CInt 3))) + +intToInt :: Old.Exp +intToInt = Old.EAbs (Old.Ident "x") (Old.EAdd (Old.EId $ Ident "x") (Old.EConst (Old.CInt 3))) apply :: Old.Exp -apply = Old.EApp lambda (Old.EConst (Old.CInt 3)) +apply = Old.EApp aToInt (Old.EConst (Old.CInt 3)) {-# WARNING todo "TODO IN CODE" #-} todo :: a diff --git a/test_program b/test_program index 14077bd..a17b924 100644 --- a/test_program +++ b/test_program @@ -1 +1 @@ -test y = y +main = 3; From 53314551f53c4fbd647cd6970465425dfa1087b3 Mon Sep 17 00:00:00 2001 From: sebastianselander Date: Tue, 14 Feb 2023 12:56:07 +0100 Subject: [PATCH 021/372] A bit cleaner code. A renamer is the focus to make the tc simpler --- .gitignore | 2 +- src/TypeChecker/TypeChecker.hs | 133 +++++++++++++++------------------ 2 files changed, 62 insertions(+), 73 deletions(-) diff --git a/.gitignore b/.gitignore index 5112877..193a11d 100644 --- a/.gitignore +++ b/.gitignore @@ -3,4 +3,4 @@ dist-newstyle *.x *.bak src/Grammar -/language +language diff --git a/src/TypeChecker/TypeChecker.hs b/src/TypeChecker/TypeChecker.hs index 36ec739..0704832 100644 --- a/src/TypeChecker/TypeChecker.hs +++ b/src/TypeChecker/TypeChecker.hs @@ -4,48 +4,49 @@ module TypeChecker.TypeChecker (typecheck) where import Control.Monad (when, void) import Control.Monad.Except (ExceptT, throwError, runExceptT) - import Control.Monad.Reader (ReaderT) import qualified Control.Monad.Reader as R - import Control.Monad.Writer (WriterT) import qualified Control.Monad.Writer as W - +import Control.Monad.State (StateT) +import qualified Control.Monad.State as St import Data.Functor.Identity (Identity, runIdentity) - import Data.Map (Map) import qualified Data.Map as M import Data.Set (Set) import qualified Data.Set as S - import Data.Bool (bool) - import qualified Grammar.Abs as Old import Grammar.ErrM (Err) import TypeChecker.TypeCheckerIr -data Ctx = Ctx - { env :: [Map Ident Type] - , sigs :: Map Ident Type - , typs :: Set Ident - } +data Ctx = Ctx { env :: Map Ident Type + , sigs :: Map Ident Type + } deriving Show -type Check = ReaderT Ctx (ExceptT Error Identity) +{- + +The type checker will assume we first rename all variables to unique name, as to not +have to care about scoping. It significantly improves the quality of life of the +programmer. + +-} + +type Check = StateT (Map Ident Type) (ReaderT Ctx (ExceptT Error Identity)) initEnv :: Ctx initEnv = Ctx { env = mempty , sigs = mempty - , typs = mempty } run :: Check Type -> Either Error Type -run = runIdentity . runExceptT . flip R.runReaderT initEnv +run = runIdentity . runExceptT . flip R.runReaderT initEnv . flip St.evalStateT mempty typecheck :: Old.Program -> Either Error () -typecheck = runIdentity . runExceptT . flip R.runReaderT initEnv . inferPrg +typecheck = todo inferPrg :: Old.Program -> Check () inferPrg (Program [x]) = void $ inferBind x @@ -56,15 +57,19 @@ inferBind (Bind _ _ e) = void $ inferExp e inferExp :: Old.Exp -> Check Type inferExp = \case + -- TODO: Fix bound variable lookup Old.EId i -> do - ctx <- R.ask - case lookupEnv i ctx of + st <- St.get + case lookupBound i st of Just t -> return t - Nothing -> case lookupSigs i ctx of - Just t -> return t - Nothing -> throwError UnboundVar + Nothing -> do + ctx <- R.ask + case lookupEnv i ctx of + Just t -> return t + Nothing -> case lookupSigs i ctx of + Just t -> return t + Nothing -> throwError UnboundVar - Old.EAnn e t -> do infT <- inferExp e when (t /= infT) (throwError AnnotatedMismatch) @@ -75,17 +80,15 @@ inferExp = \case (Old.CStr s) -> return (TMono $ UIdent "String") Old.EAdd e1 e2 -> do - t1 <- inferExp e1 - t2 <- inferExp e2 - let int = TMono (UIdent "Int") - case (t1, t2) of - (TMono (UIdent "Int"), TMono (UIdent "Int")) -> return int - (_, TMono (UIdent "Int")) -> return int - (TMono (UIdent "Int"), _) -> return int - (TPoly (LIdent x), TPoly (LIdent y)) -> bool (throwError TypeMismatch) (return int) (x==y) - _ -> throwError NotNumber - return t1 + let int = TMono "Int" + updateBound e1 int + updateBound e2 int + inf1 <- inferExp e1 + inf2 <- inferExp e2 + when (not $ isInt inf1 && isInt inf2) (throwError TypeMismatch) + return int + -- Incomplete and probably wrong Old.EApp e1 e2 -> do inferExp e1 >>= \case TArrow mono@(TMono i) t2 -> do @@ -98,13 +101,16 @@ inferExp = \case when (not $ t `subtype` t) (throwError TypeMismatch) return t2 --- This is not entirely correct. The assumed type can change. + -- This is not entirely correct. The assumed type can change. Old.EAbs i e -> do let assume = (TPoly "a") + St.modify (M.insert i assume) infT <- R.local (insertEnv i assume) (inferExp e) - return (TArrow assume infT) + St.gets (M.lookup i) >>= \case + Nothing -> todo + Just x -> return (TArrow x infT) - Old.ELet i e1 e2 -> undefined + Old.ELet i e1 e2 -> todo -- Aux @@ -117,30 +123,31 @@ subtype (TArrow t1 t2) (TArrow t3 t4) = t1 `subtype` t3 && t2 `subtype` t4 subtype _ _ = False lookupEnv :: Ident -> Ctx -> Maybe Type -lookupEnv i c = case env c of - [] -> Nothing - x : xs -> case M.lookup i x of - Nothing -> lookupEnv i (Ctx { env = xs - , sigs = c.sigs - , typs = c.typs - }) - Just x -> Just x +lookupEnv i = M.lookup i . env lookupSigs :: Ident -> Ctx -> Maybe Type lookupSigs i = M.lookup i . sigs insertEnv :: Ident -> Type -> Ctx -> Ctx -insertEnv i t c = - case env c of - [] -> Ctx { env = [M.insert i t mempty] - , sigs = c.sigs - , typs = c.typs - } +insertEnv i t c = Ctx { env = M.insert i t c.env + , sigs = c.sigs + } - (x : xs) -> Ctx { env = M.insert i t x : xs - , sigs = c.sigs - , typs = c.typs - } +updateBound :: Old.Exp -> Type -> Check () +updateBound (Old.EId i) t = St.modify (M.insert i t) +updateBound _ _ = return () + +isBound :: Old.Exp -> Check Bool +isBound (Old.EId i) = (M.member i) <$> St.get +isBound _ = return False + +lookupBound :: Ident -> Map Ident Type -> Maybe Type +lookupBound = M.lookup + +isInt :: Type -> Bool +isInt (TMono "Int") = True +isInt (TPoly _) = True +isInt _ = False data Error = TypeMismatch @@ -152,24 +159,6 @@ data Error | Default deriving Show --- showErr :: Error -> String --- showErr = \case --- TypeMismatch expected found -> unwords ["Expected type:", show expected, "but got", show found] --- NotNumber mess -> "Expected a number, but got: " <> mess --- NotFunction mess func -> mess <> ": " <> func --- FunctionTypeMismatch func expected found -> unwords ["Function:", show func, "expected:", show expected, "but got:", show found] --- UnboundVar mess var -> mess <> ": " <> var --- AnnotatedMismatch expression expected found -> --- unwords --- [ "Expression" --- , expression --- , "expected type" --- , expected --- , "but was inferred as type" --- , found --- ] --- Default mess -> mess - -- Tests number :: Old.Exp @@ -181,8 +170,8 @@ aToInt = Old.EAbs (Old.Ident "x") (Old.EAdd (Old.EConst (Old.CInt 3)) (Old.ECons intToInt :: Old.Exp intToInt = Old.EAbs (Old.Ident "x") (Old.EAdd (Old.EId $ Ident "x") (Old.EConst (Old.CInt 3))) -apply :: Old.Exp -apply = Old.EApp aToInt (Old.EConst (Old.CInt 3)) +addLambda :: Old.Exp +addLambda = Old.EAbs (Old.Ident "x") (Old.EAdd (Old.EId $ Ident "x") (Old.EId $ Ident "x")) {-# WARNING todo "TODO IN CODE" #-} todo :: a From 6218efac20481e794925bbd933eb4daa657b53cb Mon Sep 17 00:00:00 2001 From: sebastianselander Date: Tue, 14 Feb 2023 16:44:38 +0100 Subject: [PATCH 022/372] Renamer done. It renames bound variables to numbers, converts let to lambda, and removes all variables from binds --- Grammar.cf | 8 +- language.cabal | 6 +- sample-programs/basic-2 | 1 - src/Main.hs | 10 +- src/Renamer/Renamer.hs | 155 +++++++++++++++++-------------- src/Renamer/RenamerIr.hs | 119 +++++++++--------------- src/TypeChecker/TypeChecker.hs | 4 +- src/TypeChecker/TypeCheckerIr.hs | 25 +++-- test_program | 5 +- 9 files changed, 158 insertions(+), 175 deletions(-) diff --git a/Grammar.cf b/Grammar.cf index a570950..21b563b 100644 --- a/Grammar.cf +++ b/Grammar.cf @@ -14,12 +14,12 @@ EAbs. Exp ::= "\\" Ident "." Exp ; CInt. Const ::= Integer ; CStr. Const ::= String ; -TMono. Type1 ::= UIdent ; -TPoly. Type1 ::= LIdent ; +TMono. Type ::= "Mono" Ident ; +TPoly. Type ::= "Poly" Ident ; TArrow. Type ::= Type "->" Type1 ; -token UIdent (upper (letter | digit | '_')*) ; -token LIdent (lower (letter | digit | '_')*) ; +-- token Upper (upper (letter | digit | '_')*) ; +-- token Lower (lower (letter | digit | '_')*) ; separator Bind ";" ; separator Ident " "; diff --git a/language.cabal b/language.cabal index 0f5aec2..0701df6 100644 --- a/language.cabal +++ b/language.cabal @@ -31,12 +31,10 @@ executable language Grammar.Print Grammar.Skel Grammar.ErrM - -- LambdaLifter TypeChecker.TypeChecker TypeChecker.TypeCheckerIr - -- Renamer.Renamer - -- Renamer.RenamerIr - -- Interpreter + Renamer.Renamer + Renamer.RenamerIr hs-source-dirs: src diff --git a/sample-programs/basic-2 b/sample-programs/basic-2 index 4b8ead0..f7d0807 100644 --- a/sample-programs/basic-2 +++ b/sample-programs/basic-2 @@ -1,4 +1,3 @@ add x = \y. x+y; main = (\z. z+z) ((add 4) 6); - diff --git a/src/Main.hs b/src/Main.hs index 27802b7..93b3edd 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -6,6 +6,7 @@ import Grammar.Print (printTree) import System.Environment (getArgs) import System.Exit (exitFailure, exitSuccess) import TypeChecker.TypeChecker (typecheck) +import Renamer.Renamer (rename) main :: IO () main = getArgs >>= \case @@ -17,12 +18,11 @@ main = getArgs >>= \case putStrLn "SYNTAX ERROR" putStrLn err exitFailure - Right prg -> case typecheck prg of + Right prg -> case rename prg of Right prg -> do - putStrLn "TYPE CHECK SUCCESSFUL" - putStrLn . show $ prg + putStrLn "RENAME SUCCESSFUL" + putStrLn $ printTree prg Left err -> do - putStrLn "TYPE CHECK ERROR" + putStrLn "FAILED RENAMING" putStrLn . show $ err exitFailure - diff --git a/src/Renamer/Renamer.hs b/src/Renamer/Renamer.hs index 8d3fa1c..8f09a51 100644 --- a/src/Renamer/Renamer.hs +++ b/src/Renamer/Renamer.hs @@ -1,90 +1,101 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE LambdaCase, OverloadedRecordDot, OverloadedStrings #-} module Renamer.Renamer (rename) where -import Control.Applicative (Applicative (liftA2)) -import Control.Monad.Except (MonadError (throwError)) -import Control.Monad.RWS (MonadState, gets, modify) -import Control.Monad.State (StateT, evalStateT) -import Data.Set (Set) -import qualified Data.Set as Set -import Grammar.Abs -import Grammar.ErrM (Err) -import Grammar.Print (printTree) -import qualified Renamer.RenamerIr as R +import Renamer.RenamerIr +import Control.Monad.State +import Control.Monad.Except +import Control.Monad.Reader +import Data.Functor.Identity (Identity, runIdentity) +import Data.Set (Set) +import qualified Data.Set as S +import Data.Map (Map) +import qualified Data.Map as M +import Renamer.RenamerIr +import qualified Grammar.Abs as Old -data Cxt = Cxt - { uniques :: [(Ident, R.Unique)] - , nextUnique :: R.Unique - , sig :: Set Ident - } +type Rename = StateT Ctx (ExceptT Error Identity) -initCxt :: Cxt -initCxt = Cxt - { uniques = [] - , nextUnique = R.Unique 0 - , sig = mempty - } +data Ctx = Ctx { count :: Integer + , sig :: Set Ident + , env :: Map Ident Integer} -newtype Rn a = Rn { runRn :: StateT Cxt Err a } - deriving (Functor, Applicative, Monad, MonadState Cxt, MonadError String) +run :: Rename a -> Either Error a +run = runIdentity . runExceptT . flip evalStateT initCtx -rename :: Program -> Err R.Program -rename p = evalStateT (runRn $ renameProgram p) initCxt +initCtx :: Ctx +initCtx = Ctx { count = 0 + , sig = mempty + , env = mempty } -renameProgram :: Program -> Rn R.Program -renameProgram (Program ds (Main e)) = do - ds' <- mapM renameDef ds - e' <- renameExp e - pure $ R.Program ds' (R.Main e') +rename :: Old.Program -> Either Error RProgram +rename = run . renamePrg -renameDef :: Def -> Rn R.Def -renameDef = \case - DExp x t _ xs e -> do - newSig x - xs' <- mapM newUnique xs - e' <- renameExp e - let e'' = foldr ($) e' . zipWith R.EAbs xs' $ fromTree t - pure . R.DBind $ R.Bind x t e'' +renamePrg :: Old.Program -> Rename RProgram +renamePrg (Old.Program xs) = do + xs' <- mapM renameBind xs + return $ RProgram xs' -renameExp :: Exp -> Rn R.Exp +renameBind :: Old.Bind -> Rename RBind +renameBind (Old.Bind i args e) = do + insertSig i + e' <- renameExp (makeLambda (reverse args) e) + return $ RBind i e' + where + makeLambda :: [Ident] -> Old.Exp -> Old.Exp + makeLambda [] e = e + makeLambda (x:xs) e = makeLambda xs (Old.EAbs x e) + +renameExp :: Old.Exp -> Rename RExp renameExp = \case - EId x -> R.EId <$> findBind x - EInt i -> pure $ R.EInt i - EApp e e1 -> liftA2 R.EApp (renameExp e) $ renameExp e1 - EAdd e e1 -> liftA2 R.EAdd (renameExp e) $ renameExp e1 - EAbs x t e -> do - x' <- newUnique x - e' <- renameExp e - pure $ R.EAbs x' t e' -findBind :: Ident -> Rn R.Name -findBind x = lookupUnique x >>= \case - Just u -> pure $ R.Nu u - Nothing -> gets (Set.member x . sig) >>= \case - False -> throwError ("Unbound variable " ++ printTree x) - True -> pure $ R.Ni x + Old.EId i -> do + st <- get + case M.lookup i st.env of + Just n -> return $ RBound n i + Nothing -> case S.member i st.sig of + True -> return $ RFree i + False -> throwError $ UnboundVar (show i) -newUnique :: Ident -> Rn R.Unique -newUnique x = do - u <- gets nextUnique - modify $ \env -> env { nextUnique = succ u - , uniques = (x, u) : env.uniques - } - pure u + Old.EConst c -> return $ RConst c -newSig :: Ident -> Rn () -newSig x = modify $ \cxt -> cxt { sig = Set.insert x cxt.sig} + Old.EAnn e t -> flip RAnn t <$> renameExp e -lookupUnique :: Ident -> Rn (Maybe R.Unique) -lookupUnique x = lookup x <$> gets uniques + Old.EApp e1 e2 -> RApp <$> renameExp e1 <*> renameExp e2 -fromTree :: Type -> [Type] -fromTree = fromTree' [] + Old.EAdd e1 e2 -> RAdd <$> renameExp e1 <*> renameExp e2 -fromTree' :: [Type] -> Type -> [Type] -fromTree' acc = \case - TFun t t1 -> acc ++ [t] ++ fromTree t1 - other -> other : acc + -- Convert let-expressions to lambdas + Old.ELet i e1 e2 -> renameExp (Old.EApp (Old.EAbs i e2) e1) + + Old.EAbs i e -> do + n <- cnt + ctx <- get + insertEnv i n + re <- renameExp e + return $ RAbs n i re + +-- | Get current count and increase it by one +cnt :: Rename Integer +cnt = do + st <- get + put (Ctx { count = succ st.count + , sig = st.sig + , env = st.env }) + return st.count + +insertEnv :: Ident -> Integer -> Rename () +insertEnv i n = do + c <- get + put ( Ctx { env = M.insert i n c.env , sig = c.sig , count = c.count} ) + +insertSig :: Ident -> Rename () +insertSig i = do + c <- get + put ( Ctx { sig = S.insert i c.sig , env = c.env , count = c.count } ) + +data Error = UnboundVar String + +instance Show Error where + show (UnboundVar str) = "Unbound variable: " <> str diff --git a/src/Renamer/RenamerIr.hs b/src/Renamer/RenamerIr.hs index e3c4cce..882129c 100644 --- a/src/Renamer/RenamerIr.hs +++ b/src/Renamer/RenamerIr.hs @@ -1,84 +1,51 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE LambdaCase #-} -module Renamer.RenamerIr where +module Renamer.RenamerIr (module Grammar.Abs, RExp (..), RBind (..), RProgram (..)) where -import Grammar.Abs (Ident, Type (..)) -import Grammar.Print +import Grammar.Abs ( + Bind (..), + Const (..), + Ident (..), + Program (..), + Type (..), + ) +import Grammar.Print +data RProgram = RProgram [RBind] + deriving (Eq, Show, Read, Ord) -data Program = Program [Def] Main - deriving (Eq, Ord, Show, Read) +data RBind = RBind Ident RExp + deriving (Eq, Show, Read, Ord) -newtype Main = Main Exp - deriving (Eq, Ord, Show, Read) +data RExp + = RAnn RExp Type + | RBound Integer Ident + | RFree Ident + | RConst Const + | RApp RExp RExp + | RAdd RExp RExp + | RAbs Integer Ident RExp + deriving (Eq, Ord, Show, Read) +instance Print RProgram where + prt i = \case + RProgram defs -> prPrec i 0 (concatD [prt 0 defs]) -newtype Def = DBind Bind - deriving (Eq, Ord, Show, Read) +instance Print RBind where + prt i = \case + RBind x e -> + prPrec i 0 $ + concatD + [ prt 0 x + , doc (showString "=") + , prt 0 e + ] -data Name = Nu Unique | Ni Ident deriving (Ord, Show, Eq, Read) - -newtype Unique = Unique Int deriving (Enum, Eq, Read, Ord) -instance Show Unique where show (Unique i) = "x" ++ show i - -data Exp - = EId Name - | EInt Integer - | EApp Exp Exp - | EAdd Exp Exp - | EAbs Unique Type Exp - deriving (Eq, Ord, Show, Read) - - -data Bind = Bind Ident Type Exp - deriving (Eq, Ord, Show, Read) - - -instance Print Program where - prt i = \case - Program defs main -> prPrec i 0 (concatD [prt 0 defs, prt 0 main]) - - -instance Print Def where - prt i (DBind b) = prPrec i 0 $ concatD [prt 0 b, doc (showString ";")] - -instance Print Bind where - prt i = \case - Bind x t e -> prPrec i 0 $ concatD - [ prt 0 x - , doc (showString ":") - , prt 0 t - , doc (showString "=") - , prt 0 e] - -instance Print [Def] where - prt _ [] = concatD [] - prt _ (x:xs) = concatD [prt 0 x, prt 0 xs] - - -instance Print Main where - prt i = \case - Main exp -> prPrec i 0 $ concatD - [ doc (showString "main") - , doc (showString "=") - , prt 0 exp - , doc (showString ";") - ] - -instance Print Exp where - prt i = \case - EId u -> prPrec i 3 (concatD [prt 0 u]) - EInt n -> prPrec i 3 (concatD [prt 0 n]) - EApp e e1 -> prPrec i 2 (concatD [prt 2 e, prt 3 e1]) - EAdd e e1 -> prPrec i 1 (concatD [prt 1 e, doc (showString "+"), prt 2 e1]) - EAbs u t e -> prPrec i 0 (concatD [doc (showString "\\"), prt 0 u, doc (showString ":"), prt 0 t, doc (showString "."), prt 0 e]) - - -instance Print Name where - prt _ = \case - Ni i -> prt 0 i - Nu u -> prt 0 u - -instance Print Unique where - prt _ = doc . showString . show +instance Print RExp where + prt i = \case + RBound n _ -> prPrec i 3 (concatD [prt 0 ("var" ++ show n)]) + RFree id -> prPrec i 3 (concatD [prt 0 id]) + RConst n -> prPrec i 3 (concatD [prt 0 n]) + RApp e e1 -> prPrec i 2 (concatD [prt 2 e, prt 3 e1]) + RAdd e e1 -> prPrec i 1 (concatD [prt 1 e, doc (showString "+"), prt 2 e1]) + RAbs u id e -> prPrec i 0 (concatD [doc (showString "\\"), prt 0 ("var" ++ show u), doc (showString "."), prt 0 e]) diff --git a/src/TypeChecker/TypeChecker.hs b/src/TypeChecker/TypeChecker.hs index 0704832..ed59298 100644 --- a/src/TypeChecker/TypeChecker.hs +++ b/src/TypeChecker/TypeChecker.hs @@ -76,8 +76,8 @@ inferExp = \case return infT Old.EConst c -> case c of - (Old.CInt i) -> return (TMono $ UIdent "Int") - (Old.CStr s) -> return (TMono $ UIdent "String") + (Old.CInt i) -> return (TMono "Int") + (Old.CStr s) -> return (TMono "String") Old.EAdd e1 e2 -> do let int = TMono "Int" diff --git a/src/TypeChecker/TypeCheckerIr.hs b/src/TypeChecker/TypeCheckerIr.hs index 7fb93fe..95e4108 100644 --- a/src/TypeChecker/TypeCheckerIr.hs +++ b/src/TypeChecker/TypeCheckerIr.hs @@ -1,14 +1,19 @@ {-# LANGUAGE LambdaCase #-} -module TypeChecker.TypeCheckerIr (module Grammar.Abs, Exp) where +module TypeChecker.TypeCheckerIr where -import Grammar.Abs (Program(..), Ident(..), Bind(..), Const(..), Type(..), UIdent(..), LIdent(..)) +import Renamer.RenamerIr -data Exp - = EAnn Exp Type - | EId Ident Type - | EConst Const Type - | EApp Exp Exp Type - | EAdd Exp Exp Type - | EAbs Ident Exp Type - deriving (Eq, Ord, Show, Read) +data TProgram = TProgram [TBind] + +data TBind = TBind Ident Type TExp + +data TExp + = TAnn TExp Type + | TBound Integer Ident Type + | TFree Ident Type + | TConst Const Type + | TApp TExp TExp Type + | TAdd TExp TExp Type + | TAbs Integer Ident TExp Type + deriving (Eq, Ord, Show, Read) diff --git a/test_program b/test_program index a17b924..3fcfcea 100644 --- a/test_program +++ b/test_program @@ -1 +1,4 @@ -main = 3; +letters = let x = 1 + in let y = 2 + in let z = 3 + in x + y + z From 5d247057f56fc2ecd18323f863d59e92f34924c2 Mon Sep 17 00:00:00 2001 From: sebastianselander Date: Tue, 14 Feb 2023 22:03:56 +0100 Subject: [PATCH 023/372] Minor rewrite of tc. Some bugs still left --- Grammar.cf | 5 +- src/Main.hs | 21 ++- src/Renamer/RenamerIr.hs | 9 +- src/TypeChecker/TypeChecker.hs | 263 ++++++++++++++++++------------- src/TypeChecker/TypeCheckerIr.hs | 81 +++++++++- test_program | 5 +- 6 files changed, 256 insertions(+), 128 deletions(-) diff --git a/Grammar.cf b/Grammar.cf index 21b563b..234b2f0 100644 --- a/Grammar.cf +++ b/Grammar.cf @@ -3,7 +3,7 @@ Program. Program ::= [Bind] ; Bind. Bind ::= Ident [Ident] "=" Exp ; -EAnn. Exp5 ::= Exp5 ":" Type ; +EAnn. Exp5 ::= "(" Exp ":" Type ")" ; EId. Exp4 ::= Ident ; EConst. Exp4 ::= Const ; EApp. Exp3 ::= Exp3 Exp4 ; @@ -16,8 +16,9 @@ CStr. Const ::= String ; TMono. Type ::= "Mono" Ident ; TPoly. Type ::= "Poly" Ident ; -TArrow. Type ::= Type "->" Type1 ; +TArrow. Type ::= Type1 "->" Type ; +-- This doesn't seem to work so we'll have to live with ugly keywords for now -- token Upper (upper (letter | digit | '_')*) ; -- token Lower (lower (letter | digit | '_')*) ; diff --git a/src/Main.hs b/src/Main.hs index 93b3edd..647ac9d 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -5,8 +5,9 @@ import Grammar.Par (myLexer, pProgram) import Grammar.Print (printTree) import System.Environment (getArgs) import System.Exit (exitFailure, exitSuccess) -import TypeChecker.TypeChecker (typecheck) -import Renamer.Renamer (rename) +import TypeChecker.TypeChecker (typecheck) +import Renamer.Renamer (rename) +import Grammar.Print (prt) main :: IO () main = getArgs >>= \case @@ -19,10 +20,14 @@ main = getArgs >>= \case putStrLn err exitFailure Right prg -> case rename prg of - Right prg -> do - putStrLn "RENAME SUCCESSFUL" - putStrLn $ printTree prg Left err -> do - putStrLn "FAILED RENAMING" - putStrLn . show $ err - exitFailure + putStrLn "FAILED RENAMING" + putStrLn . show $ err + exitFailure + Right prg -> case typecheck prg of + Left err -> do + putStrLn "TYPECHECK ERROR" + putStrLn . show $ err + exitFailure + Right prg -> do + putStrLn . printTree $ prg diff --git a/src/Renamer/RenamerIr.hs b/src/Renamer/RenamerIr.hs index 882129c..ea6f477 100644 --- a/src/Renamer/RenamerIr.hs +++ b/src/Renamer/RenamerIr.hs @@ -1,6 +1,12 @@ {-# LANGUAGE LambdaCase #-} -module Renamer.RenamerIr (module Grammar.Abs, RExp (..), RBind (..), RProgram (..)) where +module Renamer.RenamerIr ( RExp (..) + , RBind (..) + , RProgram (..) + , Const (..) + , Ident (..) + , Type (..) + ) where import Grammar.Abs ( Bind (..), @@ -43,6 +49,7 @@ instance Print RBind where instance Print RExp where prt i = \case + RAnn e t -> prPrec i 2 (concatD [prt 0 e, doc (showString ":"), prt 1 t]) RBound n _ -> prPrec i 3 (concatD [prt 0 ("var" ++ show n)]) RFree id -> prPrec i 3 (concatD [prt 0 id]) RConst n -> prPrec i 3 (concatD [prt 0 n]) diff --git a/src/TypeChecker/TypeChecker.hs b/src/TypeChecker/TypeChecker.hs index ed59298..acb3132 100644 --- a/src/TypeChecker/TypeChecker.hs +++ b/src/TypeChecker/TypeChecker.hs @@ -1,6 +1,6 @@ {-# LANGUAGE LambdaCase, OverloadedStrings, OverloadedRecordDot #-} -module TypeChecker.TypeChecker (typecheck) where +module TypeChecker.TypeChecker where import Control.Monad (when, void) import Control.Monad.Except (ExceptT, throwError, runExceptT) @@ -13,15 +13,11 @@ import qualified Control.Monad.State as St import Data.Functor.Identity (Identity, runIdentity) import Data.Map (Map) import qualified Data.Map as M -import Data.Set (Set) -import qualified Data.Set as S -import Data.Bool (bool) -import qualified Grammar.Abs as Old import Grammar.ErrM (Err) import TypeChecker.TypeCheckerIr -data Ctx = Ctx { env :: Map Ident Type +data Ctx = Ctx { vars :: Map Integer Type , sigs :: Map Ident Type } deriving Show @@ -34,121 +30,165 @@ programmer. -} -type Check = StateT (Map Ident Type) (ReaderT Ctx (ExceptT Error Identity)) +type Infer = StateT Ctx (ExceptT Error Identity) initEnv :: Ctx -initEnv = - Ctx { env = mempty - , sigs = mempty - } +initEnv = Ctx mempty mempty -run :: Check Type -> Either Error Type -run = runIdentity . runExceptT . flip R.runReaderT initEnv . flip St.evalStateT mempty +run :: Infer a -> Either Error a +run = runIdentity . runExceptT . flip St.evalStateT initEnv -typecheck :: Old.Program -> Either Error () -typecheck = todo +typecheck :: RProgram -> Either Error TProgram +typecheck = run . inferPrg -inferPrg :: Old.Program -> Check () -inferPrg (Program [x]) = void $ inferBind x +inferPrg :: RProgram -> Infer TProgram +inferPrg (RProgram xs) = do + xs' <- mapM inferBind xs + return $ TProgram xs' -inferBind :: Old.Bind -> Check () -inferBind (Bind _ _ e) = void $ inferExp e +inferBind :: RBind -> Infer TBind +inferBind (RBind name e) = do + t <- inferExp e + e' <- toTExpr e + return $ TBind name t e' -inferExp :: Old.Exp -> Check Type +toTExpr :: RExp -> Infer TExp +toTExpr = \case + + re@(RAnn e t) -> do + t <- inferExp re + e' <- toTExpr e + return $ TAnn e' t + + re@(RBound num name) -> do + t <- inferExp re + return $ TBound num name t + + re@(RFree name) -> do + t <- inferExp re + return $ TFree name t + + re@(RConst con)-> do + t <- inferExp re + return $ TConst con t + + re@(RApp e1 e2) -> do + t <- inferExp re + e1' <- toTExpr e1 + e2' <- toTExpr e2 + return $ TApp e1' e2' t + + re@(RAdd e1 e2)-> do + t <- inferExp re + e1' <- toTExpr e1 + e2' <- toTExpr e2 + return $ TAdd e1' e2' t + + re@(RAbs num name e) -> do + t <- inferExp re + e' <- toTExpr e + return $ TAbs num name e' t + + +inferExp :: RExp -> Infer Type inferExp = \case - -- TODO: Fix bound variable lookup - Old.EId i -> do - st <- St.get - case lookupBound i st of - Just t -> return t - Nothing -> do - ctx <- R.ask - case lookupEnv i ctx of - Just t -> return t - Nothing -> case lookupSigs i ctx of - Just t -> return t - Nothing -> throwError UnboundVar - - Old.EAnn e t -> do - infT <- inferExp e - when (t /= infT) (throwError AnnotatedMismatch) - return infT + RAnn expr typ -> do + exprT <- inferExp expr + when (not (exprT == typ || isPoly exprT)) (throwError AnnotatedMismatch) + return typ - Old.EConst c -> case c of - (Old.CInt i) -> return (TMono "Int") - (Old.CStr s) -> return (TMono "String") + -- Name is only here for proper error messages + RBound num name -> + M.lookup num <$> St.gets vars >>= \case + Nothing -> throwError UnboundVar + Just t -> return t - Old.EAdd e1 e2 -> do - let int = TMono "Int" - updateBound e1 int - updateBound e2 int - inf1 <- inferExp e1 - inf2 <- inferExp e2 - when (not $ isInt inf1 && isInt inf2) (throwError TypeMismatch) - return int + RFree name -> do + M.lookup name <$> St.gets sigs >>= \case + Nothing -> throwError UnboundVar + Just t -> return t - -- Incomplete and probably wrong - Old.EApp e1 e2 -> do - inferExp e1 >>= \case - TArrow mono@(TMono i) t2 -> do - t <- inferExp e2 - when (t /= mono) (throwError TypeMismatch) - return t2 + RConst (CInt _) -> return $ TMono "Int" + RConst (CStr _) -> return $ TMono "Str" - TArrow poly@(TPoly f) t2 -> do - t <- inferExp e2 - when (not $ t `subtype` t) (throwError TypeMismatch) - return t2 + -- Currently does not accept using a polymorphic type as the function. + RApp expr1 expr2 -> do + typ1 <- inferExp expr1 + typ2 <- inferExp expr2 + fit typ2 typ1 - -- This is not entirely correct. The assumed type can change. - Old.EAbs i e -> do - let assume = (TPoly "a") - St.modify (M.insert i assume) - infT <- R.local (insertEnv i assume) (inferExp e) - St.gets (M.lookup i) >>= \case - Nothing -> todo - Just x -> return (TArrow x infT) + RAdd expr1 expr2 -> do + typ1 <- inferExp expr1 + typ2 <- inferExp expr2 + when (not $ (isInt typ1 || isPoly typ1) && (isInt typ2 || isPoly typ2)) (throwError TypeMismatch) + specifyType expr1 (TMono "Int") + specifyType expr2 (TMono "Int") + return (TMono "Int") - Old.ELet i e1 e2 -> todo + RAbs num name expr -> do + insertVars num (TPoly "a") + typ <- inferExp expr + newTyp <- lookupVars num + return $ TArrow newTyp typ -- Aux - --- Double check this function. It's bad and maybe wrong -subtype :: Type -> Type -> Bool -subtype (TMono t1) (TMono t2) = t1 == t2 -subtype (TMono t1) (TPoly t2) = True -subtype (TPoly t2) (TMono t1) = False -subtype (TArrow t1 t2) (TArrow t3 t4) = t1 `subtype` t3 && t2 `subtype` t4 -subtype _ _ = False - -lookupEnv :: Ident -> Ctx -> Maybe Type -lookupEnv i = M.lookup i . env - -lookupSigs :: Ident -> Ctx -> Maybe Type -lookupSigs i = M.lookup i . sigs - -insertEnv :: Ident -> Type -> Ctx -> Ctx -insertEnv i t c = Ctx { env = M.insert i t c.env - , sigs = c.sigs - } - -updateBound :: Old.Exp -> Type -> Check () -updateBound (Old.EId i) t = St.modify (M.insert i t) -updateBound _ _ = return () - -isBound :: Old.Exp -> Check Bool -isBound (Old.EId i) = (M.member i) <$> St.get -isBound _ = return False - -lookupBound :: Ident -> Map Ident Type -> Maybe Type -lookupBound = M.lookup - isInt :: Type -> Bool isInt (TMono "Int") = True -isInt (TPoly _) = True isInt _ = False +isArrow :: Type -> Bool +isArrow (TArrow _ _) = True +isArrow _ = False + +isPoly :: Type -> Bool +isPoly (TPoly _) = True +isPoly _ = False + +fit :: Type -> Type -> Infer Type +fit (TArrow t1 (TArrow t2 t3)) t4 + | t1 == t4 = return $ TArrow t2 t3 + | otherwise = fit (TArrow (TArrow t1 t2) t3) t4 +fit (TArrow t1 t2) t3 + | t1 == t3 = return t2 + | otherwise = throwError TypeMismatch +fit _ _ = throwError TypeMismatch + +-- a -> (b -> (c -> d)) +-- a -> b + +-- | Specify the type of a bound variable +-- Because in lambdas we have to assume a general type and update it +specifyType :: RExp -> Type -> Infer () +specifyType (RBound num name) typ = do + insertVars num typ + return () +specifyType _ _ = return () + +lookupVars :: Integer -> Infer Type +lookupVars i = do + st <- St.gets vars + case M.lookup i st of + Just t -> return t + Nothing -> throwError UnboundVar + +lookupSigs :: Ident -> Infer Type +lookupSigs i = do + st <- St.gets sigs + case M.lookup i st of + Just t -> return t + Nothing -> throwError UnboundVar + + +insertVars :: Integer -> Type -> Infer () +insertVars i t = do + st <- St.get + St.put ( Ctx { vars = M.insert i t st.vars, sigs = st.sigs } ) + +{-# WARNING todo "TODO IN CODE" #-} +todo :: a +todo = error "TODO in code" + data Error = TypeMismatch | NotNumber @@ -161,18 +201,17 @@ data Error -- Tests -number :: Old.Exp -number = Old.EConst (CInt 3) +lambda = RAbs 0 "x" (RAdd (RBound 0 "x") (RBound 0 "x")) +lambda2 = RAbs 0 "x" (RAnn (RBound 0 "x") (TArrow (TMono "Int") (TMono "String"))) -aToInt :: Old.Exp -aToInt = Old.EAbs (Old.Ident "x") (Old.EAdd (Old.EConst (Old.CInt 3)) (Old.EConst (Old.CInt 3))) +pp :: Type -> String +pp (TMono (Ident x)) = x +pp (TPoly (Ident x)) = x +pp (TArrow t1 t2) = pp t1 <> " -> " <> pp t2 -intToInt :: Old.Exp -intToInt = Old.EAbs (Old.Ident "x") (Old.EAdd (Old.EId $ Ident "x") (Old.EConst (Old.CInt 3))) +int,str :: Type +int = TMono "Int" +str = TMono "Str" -addLambda :: Old.Exp -addLambda = Old.EAbs (Old.Ident "x") (Old.EAdd (Old.EId $ Ident "x") (Old.EId $ Ident "x")) - -{-# WARNING todo "TODO IN CODE" #-} -todo :: a -todo = error "TODO in code" +arrow :: Type -> Type -> Type +arrow = TArrow diff --git a/src/TypeChecker/TypeCheckerIr.hs b/src/TypeChecker/TypeCheckerIr.hs index 95e4108..d1aa706 100644 --- a/src/TypeChecker/TypeCheckerIr.hs +++ b/src/TypeChecker/TypeCheckerIr.hs @@ -1,12 +1,25 @@ {-# LANGUAGE LambdaCase #-} -module TypeChecker.TypeCheckerIr where +module TypeChecker.TypeCheckerIr ( TProgram(..) + , TBind(..) + , TExp(..) + , RProgram(..) + , RBind(..) + , RExp(..) + , Type(..) + , Const(..) + , Ident(..) + ) + where import Renamer.RenamerIr +import Grammar.Print data TProgram = TProgram [TBind] + deriving (Eq, Show, Read, Ord) data TBind = TBind Ident Type TExp + deriving (Eq, Show, Read, Ord) data TExp = TAnn TExp Type @@ -17,3 +30,69 @@ data TExp | TAdd TExp TExp Type | TAbs Integer Ident TExp Type deriving (Eq, Ord, Show, Read) + +instance Print TProgram where + prt i = \case + TProgram defs -> prPrec i 0 (concatD [prt 0 defs]) + +instance Print TBind where + prt i = \case + TBind x t e -> + prPrec i 0 $ + concatD + [ prt 0 x + , doc (showString ":") + , prt 0 t + , doc (showString "=") + , prt 0 e + ] + +instance Print TExp where + prt i = \case + TAnn e t -> prPrec i 2 $ concatD + [ prt 0 e + , doc (showString ":") + , prt 1 t + ] + TBound _ u t -> prPrec i 3 $ concatD + [ doc (showString "(") + , prt 0 u + , doc (showString ":") + , prt 0 t + , doc (showString ")") + ] + TFree u t -> prPrec i 3 $ concatD + [ doc (showString "(") + , prt 0 u + , doc (showString ":") + , prt 0 t + , doc (showString ")") + ] + TConst c _ -> prPrec i 3 (concatD [prt 0 c]) + TApp e e1 t -> prPrec i 2 $ concatD + [ doc (showString "(") + , prt 2 e + , prt 3 e1 + , doc (showString ")") + , doc (showString ":") + , prt 0 t + ] + TAdd e e1 t -> prPrec i 1 $ concatD + [ doc (showString "(") + , prt 1 e + , doc (showString "+") + , prt 2 e1 + , doc (showString ")") + , doc (showString ":") + , prt 0 t + ] + TAbs _ u e t -> prPrec i 0 $ concatD + [ doc (showString "(") + , doc (showString "\\") + , prt 0 u + , doc (showString ".") + , prt 0 e + , doc (showString ")") + , doc (showString ":") + , prt 0 t, doc (showString ".") + ] diff --git a/test_program b/test_program index 3fcfcea..e297617 100644 --- a/test_program +++ b/test_program @@ -1,4 +1 @@ -letters = let x = 1 - in let y = 2 - in let z = 3 - in x + y + z +testType f x = f x From ad3f6b7011b9e2c91606a130425cb92d9963d68d Mon Sep 17 00:00:00 2001 From: sebastianselander Date: Tue, 14 Feb 2023 22:35:00 +0100 Subject: [PATCH 024/372] Attempt at fixing EApp, failed. --- src/TypeChecker/TypeChecker.hs | 36 +++++++++++++++++++--------------- 1 file changed, 20 insertions(+), 16 deletions(-) diff --git a/src/TypeChecker/TypeChecker.hs b/src/TypeChecker/TypeChecker.hs index acb3132..5e16f36 100644 --- a/src/TypeChecker/TypeChecker.hs +++ b/src/TypeChecker/TypeChecker.hs @@ -14,11 +14,13 @@ import Data.Functor.Identity (Identity, runIdentity) import Data.Map (Map) import qualified Data.Map as M import Grammar.ErrM (Err) +import Grammar.Print import TypeChecker.TypeCheckerIr data Ctx = Ctx { vars :: Map Integer Type , sigs :: Map Ident Type + , count :: Int } deriving Show @@ -33,7 +35,7 @@ programmer. type Infer = StateT Ctx (ExceptT Error Identity) initEnv :: Ctx -initEnv = Ctx mempty mempty +initEnv = Ctx mempty mempty 0 run :: Infer a -> Either Error a run = runIdentity . runExceptT . flip St.evalStateT initEnv @@ -147,15 +149,27 @@ isPoly _ = False fit :: Type -> Type -> Infer Type fit (TArrow t1 (TArrow t2 t3)) t4 - | t1 == t4 = return $ TArrow t2 t3 + | t1 `match` t4 = return $ TArrow t2 t3 | otherwise = fit (TArrow (TArrow t1 t2) t3) t4 fit (TArrow t1 t2) t3 - | t1 == t3 = return t2 + | t1 `match` t3 = return t2 | otherwise = throwError TypeMismatch fit _ _ = throwError TypeMismatch --- a -> (b -> (c -> d)) --- a -> b +match :: Type -> Type -> Bool +match (TPoly _) (TMono _) = True +match (TMono _) (TPoly _) = True +match (TMono _) (TMono _) = True +match (TPoly _) (TPoly _) = True +match (TArrow t1 t2) (TArrow t3 t4) = match t1 t3 && match t2 t4 + +incCount :: Infer Int +incCount = do + st <- St.get + St.put (Ctx { vars = st.vars, sigs = st.sigs, count = succ st.count }) + return st.count + + -- | Specify the type of a bound variable -- Because in lambdas we have to assume a general type and update it @@ -204,14 +218,4 @@ data Error lambda = RAbs 0 "x" (RAdd (RBound 0 "x") (RBound 0 "x")) lambda2 = RAbs 0 "x" (RAnn (RBound 0 "x") (TArrow (TMono "Int") (TMono "String"))) -pp :: Type -> String -pp (TMono (Ident x)) = x -pp (TPoly (Ident x)) = x -pp (TArrow t1 t2) = pp t1 <> " -> " <> pp t2 - -int,str :: Type -int = TMono "Int" -str = TMono "Str" - -arrow :: Type -> Type -> Type -arrow = TArrow +fn_on_var = RAbs 0 "x" (RAbs 1 "y" (RApp (RBound 0 "x") (RBound 1 "y"))) From 7619e36c60776f7b0a8ca2d77f02f601e85b06a8 Mon Sep 17 00:00:00 2001 From: sebastianselander Date: Wed, 15 Feb 2023 17:40:18 +0100 Subject: [PATCH 025/372] Inference works better now. Still work to do. Should use proper library --- .gitignore | 1 + Grammar.cf | 8 ++- Makefile | 3 ++ language.cabal | 1 + src/Main.hs | 5 ++ src/TypeChecker/TypeChecker.hs | 87 ++++++++++++++++---------------- src/TypeChecker/TypeCheckerIr.hs | 38 ++------------ test_program | 2 +- 8 files changed, 66 insertions(+), 79 deletions(-) diff --git a/.gitignore b/.gitignore index 193a11d..5e276e4 100644 --- a/.gitignore +++ b/.gitignore @@ -4,3 +4,4 @@ dist-newstyle *.bak src/Grammar language +test_program_result diff --git a/Grammar.cf b/Grammar.cf index 234b2f0..1e99c21 100644 --- a/Grammar.cf +++ b/Grammar.cf @@ -14,8 +14,8 @@ EAbs. Exp ::= "\\" Ident "." Exp ; CInt. Const ::= Integer ; CStr. Const ::= String ; -TMono. Type ::= "Mono" Ident ; -TPoly. Type ::= "Poly" Ident ; +TMono. Type1 ::= "Mono" Ident ; +TPoly. Type1 ::= "Poly" Ident ; TArrow. Type ::= Type1 "->" Type ; -- This doesn't seem to work so we'll have to live with ugly keywords for now @@ -30,3 +30,7 @@ coercions Exp 5 ; comment "--" ; comment "{-" "-}" ; + +-- Adt. Adt ::= "data" UIdent "=" [Constructor] ; +-- Sum. Constructor ::= UIdent ; +-- separator Constructor "|" ; diff --git a/Makefile b/Makefile index ad830b5..9c0be2f 100644 --- a/Makefile +++ b/Makefile @@ -29,4 +29,7 @@ test : ./language ./sample-programs/basic-4 ./language ./sample-programs/basic-5 +run : + cabal -v0 new-run language -- "test_program" + # EOF diff --git a/language.cabal b/language.cabal index 0701df6..5668b83 100644 --- a/language.cabal +++ b/language.cabal @@ -45,5 +45,6 @@ executable language , either , extra , array + , equivalence default-language: GHC2021 diff --git a/src/Main.hs b/src/Main.hs index 647ac9d..e9476fb 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -30,4 +30,9 @@ main = getArgs >>= \case putStrLn . show $ err exitFailure Right prg -> do + putStrLn "" putStrLn . printTree $ prg + putStrLn "" + putStrLn " ----- ADT ----- " + putStrLn "" + putStrLn $ show prg diff --git a/src/TypeChecker/TypeChecker.hs b/src/TypeChecker/TypeChecker.hs index 5e16f36..cf1e7e8 100644 --- a/src/TypeChecker/TypeChecker.hs +++ b/src/TypeChecker/TypeChecker.hs @@ -4,10 +4,6 @@ module TypeChecker.TypeChecker where import Control.Monad (when, void) import Control.Monad.Except (ExceptT, throwError, runExceptT) -import Control.Monad.Reader (ReaderT) -import qualified Control.Monad.Reader as R -import Control.Monad.Writer (WriterT) -import qualified Control.Monad.Writer as W import Control.Monad.State (StateT) import qualified Control.Monad.State as St import Data.Functor.Identity (Identity, runIdentity) @@ -52,6 +48,7 @@ inferBind :: RBind -> Infer TBind inferBind (RBind name e) = do t <- inferExp e e' <- toTExpr e + insertSigs name t return $ TBind name t e' toTExpr :: RExp -> Infer TExp @@ -97,33 +94,40 @@ inferExp = \case RAnn expr typ -> do exprT <- inferExp expr - when (not (exprT == typ || isPoly exprT)) (throwError AnnotatedMismatch) + when (not (exprT == typ || isPoly exprT)) (throwError $ AnnotatedMismatch "inferExp, RAnn") return typ -- Name is only here for proper error messages RBound num name -> M.lookup num <$> St.gets vars >>= \case - Nothing -> throwError UnboundVar + Nothing -> throwError $ UnboundVar "RBound" Just t -> return t RFree name -> do M.lookup name <$> St.gets sigs >>= \case - Nothing -> throwError UnboundVar + Nothing -> throwError $ UnboundVar "RFree" Just t -> return t RConst (CInt _) -> return $ TMono "Int" + RConst (CStr _) -> return $ TMono "Str" - -- Currently does not accept using a polymorphic type as the function. + -- Should do proper unification using union-find. Some nice libs exist RApp expr1 expr2 -> do typ1 <- inferExp expr1 typ2 <- inferExp expr2 - fit typ2 typ1 + cnt <- incCount + case typ1 of + (TPoly (Ident x)) -> do + let newType = (TArrow (TPoly (Ident x)) (TPoly . Ident $ x ++ (show cnt))) + specifyType expr1 newType + apply newType typ1 + _ -> apply typ2 typ1 RAdd expr1 expr2 -> do typ1 <- inferExp expr1 typ2 <- inferExp expr2 - when (not $ (isInt typ1 || isPoly typ1) && (isInt typ2 || isPoly typ2)) (throwError TypeMismatch) + when (not $ (isInt typ1 || isPoly typ1) && (isInt typ2 || isPoly typ2)) (throwError $ TypeMismatch "inferExp, RAdd") specifyType expr1 (TMono "Int") specifyType expr2 (TMono "Int") return (TMono "Int") @@ -147,30 +151,12 @@ isPoly :: Type -> Bool isPoly (TPoly _) = True isPoly _ = False -fit :: Type -> Type -> Infer Type -fit (TArrow t1 (TArrow t2 t3)) t4 - | t1 `match` t4 = return $ TArrow t2 t3 - | otherwise = fit (TArrow (TArrow t1 t2) t3) t4 -fit (TArrow t1 t2) t3 - | t1 `match` t3 = return t2 - | otherwise = throwError TypeMismatch -fit _ _ = throwError TypeMismatch - -match :: Type -> Type -> Bool -match (TPoly _) (TMono _) = True -match (TMono _) (TPoly _) = True -match (TMono _) (TMono _) = True -match (TPoly _) (TPoly _) = True -match (TArrow t1 t2) (TArrow t3 t4) = match t1 t3 && match t2 t4 - incCount :: Infer Int incCount = do st <- St.get - St.put (Ctx { vars = st.vars, sigs = st.sigs, count = succ st.count }) + St.put ( st { count = succ st.count } ) return st.count - - -- | Specify the type of a bound variable -- Because in lambdas we have to assume a general type and update it specifyType :: RExp -> Type -> Infer () @@ -184,33 +170,48 @@ lookupVars i = do st <- St.gets vars case M.lookup i st of Just t -> return t - Nothing -> throwError UnboundVar + Nothing -> throwError $ UnboundVar "lookupVars" + +insertVars :: Integer -> Type -> Infer () +insertVars i t = do + st <- St.get + St.put ( st { vars = M.insert i t st.vars } ) lookupSigs :: Ident -> Infer Type lookupSigs i = do st <- St.gets sigs case M.lookup i st of Just t -> return t - Nothing -> throwError UnboundVar + Nothing -> throwError $ UnboundVar "lookupSigs" - -insertVars :: Integer -> Type -> Infer () -insertVars i t = do +insertSigs :: Ident -> Type -> Infer () +insertSigs i t = do st <- St.get - St.put ( Ctx { vars = M.insert i t st.vars, sigs = st.sigs } ) + St.put ( st { sigs = M.insert i t st.sigs } ) + +union :: Type -> Type -> Infer () +union = todo + +find :: Type -> Type +find = todo + +apply :: Type -> Type -> Infer Type +apply (TArrow t1 t2) t3 + | t1 == t3 = return t2 + | otherwise = throwError $ TypeMismatch "apply" {-# WARNING todo "TODO IN CODE" #-} todo :: a todo = error "TODO in code" data Error - = TypeMismatch - | NotNumber - | FunctionTypeMismatch - | NotFunction - | UnboundVar - | AnnotatedMismatch - | Default + = TypeMismatch String + | NotNumber String + | FunctionTypeMismatch String + | NotFunction String + | UnboundVar String + | AnnotatedMismatch String + | Default String deriving Show -- Tests @@ -218,4 +219,4 @@ data Error lambda = RAbs 0 "x" (RAdd (RBound 0 "x") (RBound 0 "x")) lambda2 = RAbs 0 "x" (RAnn (RBound 0 "x") (TArrow (TMono "Int") (TMono "String"))) -fn_on_var = RAbs 0 "x" (RAbs 1 "y" (RApp (RBound 0 "x") (RBound 1 "y"))) +fn_on_var = RAbs 0 "f" (RAbs 1 "x" (RApp (RBound 0 "f") (RBound 1 "x"))) diff --git a/src/TypeChecker/TypeCheckerIr.hs b/src/TypeChecker/TypeCheckerIr.hs index d1aa706..61f54df 100644 --- a/src/TypeChecker/TypeCheckerIr.hs +++ b/src/TypeChecker/TypeCheckerIr.hs @@ -45,6 +45,7 @@ instance Print TBind where , prt 0 t , doc (showString "=") , prt 0 e + , doc (showString "\n") ] instance Print TExp where @@ -54,38 +55,11 @@ instance Print TExp where , doc (showString ":") , prt 1 t ] - TBound _ u t -> prPrec i 3 $ concatD - [ doc (showString "(") - , prt 0 u - , doc (showString ":") - , prt 0 t - , doc (showString ")") - ] - TFree u t -> prPrec i 3 $ concatD - [ doc (showString "(") - , prt 0 u - , doc (showString ":") - , prt 0 t - , doc (showString ")") - ] + TBound _ u t -> prPrec i 3 $ concatD [ prt 0 u ] + TFree u t -> prPrec i 3 $ concatD [ prt 0 u ] TConst c _ -> prPrec i 3 (concatD [prt 0 c]) - TApp e e1 t -> prPrec i 2 $ concatD - [ doc (showString "(") - , prt 2 e - , prt 3 e1 - , doc (showString ")") - , doc (showString ":") - , prt 0 t - ] - TAdd e e1 t -> prPrec i 1 $ concatD - [ doc (showString "(") - , prt 1 e - , doc (showString "+") - , prt 2 e1 - , doc (showString ")") - , doc (showString ":") - , prt 0 t - ] + TApp e e1 t -> prPrec i 2 $ concatD [ prt 2 e , prt 3 e1 ] + TAdd e e1 t -> prPrec i 1 $ concatD [ prt 1 e , doc (showString "+") , prt 2 e1 ] TAbs _ u e t -> prPrec i 0 $ concatD [ doc (showString "(") , doc (showString "\\") @@ -93,6 +67,4 @@ instance Print TExp where , doc (showString ".") , prt 0 e , doc (showString ")") - , doc (showString ":") - , prt 0 t, doc (showString ".") ] diff --git a/test_program b/test_program index e297617..db9a44e 100644 --- a/test_program +++ b/test_program @@ -1 +1 @@ -testType f x = f x +test f x = f x From b03df17e34621b40f8c5d6c222f5506a0415ef27 Mon Sep 17 00:00:00 2001 From: sebastianselander Date: Wed, 15 Feb 2023 18:10:28 +0100 Subject: [PATCH 026/372] Minor changes. Added a comment --- src/Main.hs | 37 +++++++++++++++++++++------------- src/TypeChecker/TypeChecker.hs | 9 ++++++--- 2 files changed, 29 insertions(+), 17 deletions(-) diff --git a/src/Main.hs b/src/Main.hs index e9476fb..354e468 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -19,20 +19,29 @@ main = getArgs >>= \case putStrLn "SYNTAX ERROR" putStrLn err exitFailure - Right prg -> case rename prg of - Left err -> do - putStrLn "FAILED RENAMING" - putStrLn . show $ err - exitFailure - Right prg -> case typecheck prg of + Right prg -> do + putStrLn "" + putStrLn " ----- PARSER ----- " + putStrLn "" + putStrLn . printTree $ prg + putStrLn . show $ prg + case rename prg of Left err -> do - putStrLn "TYPECHECK ERROR" - putStrLn . show $ err - exitFailure - Right prg -> do + putStrLn "FAILED RENAMING" + putStrLn . show $ err + exitFailure + Right prg ->do + putStrLn "" + putStrLn " ----- RENAMER ----- " putStrLn "" putStrLn . printTree $ prg - putStrLn "" - putStrLn " ----- ADT ----- " - putStrLn "" - putStrLn $ show prg + case typecheck prg of + Left err -> do + putStrLn "TYPECHECK ERROR" + putStrLn . show $ err + exitFailure + Right prg -> do + putStrLn "" + putStrLn " ----- TYPECHECKER ----- " + putStrLn "" + putStrLn . printTree $ prg diff --git a/src/TypeChecker/TypeChecker.hs b/src/TypeChecker/TypeChecker.hs index cf1e7e8..34a27e9 100644 --- a/src/TypeChecker/TypeChecker.hs +++ b/src/TypeChecker/TypeChecker.hs @@ -12,6 +12,7 @@ import qualified Data.Map as M import Grammar.ErrM (Err) import Grammar.Print +import Debug.Trace (trace) import TypeChecker.TypeCheckerIr data Ctx = Ctx { vars :: Map Integer Type @@ -51,6 +52,7 @@ inferBind (RBind name e) = do insertSigs name t return $ TBind name t e' +-- This needs to be fixed. Should not separate inference of type and creation of the new data type. toTExpr :: RExp -> Infer TExp toTExpr = \case @@ -88,7 +90,6 @@ toTExpr = \case e' <- toTExpr e return $ TAbs num name e' t - inferExp :: RExp -> Infer Type inferExp = \case @@ -198,7 +199,7 @@ find = todo apply :: Type -> Type -> Infer Type apply (TArrow t1 t2) t3 | t1 == t3 = return t2 - | otherwise = throwError $ TypeMismatch "apply" +apply t1 t2 = throwError $ TypeMismatch "apply" {-# WARNING todo "TODO IN CODE" #-} todo :: a @@ -219,4 +220,6 @@ data Error lambda = RAbs 0 "x" (RAdd (RBound 0 "x") (RBound 0 "x")) lambda2 = RAbs 0 "x" (RAnn (RBound 0 "x") (TArrow (TMono "Int") (TMono "String"))) -fn_on_var = RAbs 0 "f" (RAbs 1 "x" (RApp (RBound 0 "f") (RBound 1 "x"))) +fn_on_var = RAbs 0 (Ident "f") (RAbs 1 (Ident "x") (RApp (RBound 0 (Ident "f")) (RBound 1 (Ident "x")))) + +bind = RBind "test" fn_on_var From f1b77a7efa60bc47d998c115f8dc125b600ecd17 Mon Sep 17 00:00:00 2001 From: sebastianselander Date: Wed, 15 Feb 2023 19:52:52 +0100 Subject: [PATCH 027/372] Refactored. Cleaner version, ala Martin version --- src/Main.hs | 1 - src/Renamer/RenamerIr.hs | 3 +- src/TypeChecker/TypeChecker.hs | 87 +++++++++++--------------------- src/TypeChecker/TypeCheckerIr.hs | 2 +- 4 files changed, 33 insertions(+), 60 deletions(-) diff --git a/src/Main.hs b/src/Main.hs index 354e468..3679582 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -24,7 +24,6 @@ main = getArgs >>= \case putStrLn " ----- PARSER ----- " putStrLn "" putStrLn . printTree $ prg - putStrLn . show $ prg case rename prg of Left err -> do putStrLn "FAILED RENAMING" diff --git a/src/Renamer/RenamerIr.hs b/src/Renamer/RenamerIr.hs index ea6f477..33f1d3c 100644 --- a/src/Renamer/RenamerIr.hs +++ b/src/Renamer/RenamerIr.hs @@ -45,6 +45,7 @@ instance Print RBind where [ prt 0 x , doc (showString "=") , prt 0 e + , doc (showString "\n") ] instance Print RExp where @@ -55,4 +56,4 @@ instance Print RExp where RConst n -> prPrec i 3 (concatD [prt 0 n]) RApp e e1 -> prPrec i 2 (concatD [prt 2 e, prt 3 e1]) RAdd e e1 -> prPrec i 1 (concatD [prt 1 e, doc (showString "+"), prt 2 e1]) - RAbs u id e -> prPrec i 0 (concatD [doc (showString "\\"), prt 0 ("var" ++ show u), doc (showString "."), prt 0 e]) + RAbs u id e -> prPrec i 0 (concatD [doc (showString "λ"), prt 0 ("var" ++ show u), doc (showString "."), prt 0 e]) diff --git a/src/TypeChecker/TypeChecker.hs b/src/TypeChecker/TypeChecker.hs index 34a27e9..f663ec4 100644 --- a/src/TypeChecker/TypeChecker.hs +++ b/src/TypeChecker/TypeChecker.hs @@ -47,97 +47,60 @@ inferPrg (RProgram xs) = do inferBind :: RBind -> Infer TBind inferBind (RBind name e) = do - t <- inferExp e - e' <- toTExpr e + (t, e') <- inferExp e insertSigs name t return $ TBind name t e' --- This needs to be fixed. Should not separate inference of type and creation of the new data type. -toTExpr :: RExp -> Infer TExp -toTExpr = \case - re@(RAnn e t) -> do - t <- inferExp re - e' <- toTExpr e - return $ TAnn e' t - - re@(RBound num name) -> do - t <- inferExp re - return $ TBound num name t - - re@(RFree name) -> do - t <- inferExp re - return $ TFree name t - - re@(RConst con)-> do - t <- inferExp re - return $ TConst con t - - re@(RApp e1 e2) -> do - t <- inferExp re - e1' <- toTExpr e1 - e2' <- toTExpr e2 - return $ TApp e1' e2' t - - re@(RAdd e1 e2)-> do - t <- inferExp re - e1' <- toTExpr e1 - e2' <- toTExpr e2 - return $ TAdd e1' e2' t - - re@(RAbs num name e) -> do - t <- inferExp re - e' <- toTExpr e - return $ TAbs num name e' t - -inferExp :: RExp -> Infer Type +inferExp :: RExp -> Infer (Type, TExp) inferExp = \case RAnn expr typ -> do - exprT <- inferExp expr - when (not (exprT == typ || isPoly exprT)) (throwError $ AnnotatedMismatch "inferExp, RAnn") - return typ + (t,expr') <- inferExp expr + when (not (t == typ || isPoly t)) (throwError $ AnnotatedMismatch "inferExp, RAnn") + return (typ,expr') -- Name is only here for proper error messages RBound num name -> M.lookup num <$> St.gets vars >>= \case Nothing -> throwError $ UnboundVar "RBound" - Just t -> return t + Just t -> return (t, TBound num name t) RFree name -> do M.lookup name <$> St.gets sigs >>= \case Nothing -> throwError $ UnboundVar "RFree" - Just t -> return t + Just t -> return (t, TFree name t) - RConst (CInt _) -> return $ TMono "Int" + RConst (CInt i) -> return $ (TMono "Int", TConst (CInt i) (TMono "Int")) - RConst (CStr _) -> return $ TMono "Str" + RConst (CStr str) -> return $ (TMono "Str", TConst (CStr str) (TMono "Str")) -- Should do proper unification using union-find. Some nice libs exist RApp expr1 expr2 -> do - typ1 <- inferExp expr1 - typ2 <- inferExp expr2 + (typ1, expr1') <- inferExp expr1 + (typ2, expr2') <- inferExp expr2 cnt <- incCount case typ1 of (TPoly (Ident x)) -> do let newType = (TArrow (TPoly (Ident x)) (TPoly . Ident $ x ++ (show cnt))) specifyType expr1 newType - apply newType typ1 - _ -> apply typ2 typ1 + typ1' <- apply newType typ1 + return $ (typ1', TApp expr1' expr2' typ1') + _ -> (\t -> (t, TApp expr1' expr2' t)) <$> apply typ2 typ1 RAdd expr1 expr2 -> do - typ1 <- inferExp expr1 - typ2 <- inferExp expr2 + (typ1, expr1') <- inferExp expr1 + (typ2, expr2') <- inferExp expr2 when (not $ (isInt typ1 || isPoly typ1) && (isInt typ2 || isPoly typ2)) (throwError $ TypeMismatch "inferExp, RAdd") specifyType expr1 (TMono "Int") specifyType expr2 (TMono "Int") - return (TMono "Int") + return (TMono "Int", TAdd expr1' expr2' (TMono "Int")) RAbs num name expr -> do insertVars num (TPoly "a") - typ <- inferExp expr + (typ, expr') <- inferExp expr newTyp <- lookupVars num - return $ TArrow newTyp typ + return $ (TArrow newTyp typ, TAbs num name expr' typ) -- Aux isInt :: Type -> Bool @@ -196,6 +159,8 @@ union = todo find :: Type -> Type find = todo +-- Have to figure out the equivalence classes for types. +-- Currently this does not support more than exact matches. apply :: Type -> Type -> Infer Type apply (TArrow t1 t2) t3 | t1 == t3 = return t2 @@ -222,4 +187,12 @@ lambda2 = RAbs 0 "x" (RAnn (RBound 0 "x") (TArrow (TMono "Int") (TMono "String") fn_on_var = RAbs 0 (Ident "f") (RAbs 1 (Ident "x") (RApp (RBound 0 (Ident "f")) (RBound 1 (Ident "x")))) -bind = RBind "test" fn_on_var + +--add x = \y. x+y; +add = RAbs 0 "x" (RAbs 1 "y" (RAdd (RBound 0 "x") (RBound 1 "y"))) +-- main = (\z. z+z) ((add 4) 6); +main = RApp (RAbs 0 "z" (RAdd (RBound 0 "z") (RBound 0 "z"))) applyAdd +four = RConst (CInt 4) +six = RConst (CInt 6) +applyAdd = (RApp (RApp add four) six) +partialAdd = RApp add four diff --git a/src/TypeChecker/TypeCheckerIr.hs b/src/TypeChecker/TypeCheckerIr.hs index 61f54df..7d30ae8 100644 --- a/src/TypeChecker/TypeCheckerIr.hs +++ b/src/TypeChecker/TypeCheckerIr.hs @@ -62,7 +62,7 @@ instance Print TExp where TAdd e e1 t -> prPrec i 1 $ concatD [ prt 1 e , doc (showString "+") , prt 2 e1 ] TAbs _ u e t -> prPrec i 0 $ concatD [ doc (showString "(") - , doc (showString "\\") + , doc (showString "λ") , prt 0 u , doc (showString ".") , prt 0 e From eafe0fea0b40fc5adc6b6cee3e5f243c5f2a6490 Mon Sep 17 00:00:00 2001 From: sebastianselander Date: Thu, 16 Feb 2023 16:37:36 +0100 Subject: [PATCH 028/372] Rewrote using unification-fd. Heavily inspired (aka copied) from: https://byorgey.wordpress.com/2021/09/08/implementing-hindley-milner-with-the-unification-fd-library/ --- language.cabal | 3 +- src/Main.hs | 5 +- src/TypeChecker/TypeChecker.hs | 39 +++-- src/TypeChecker/Unification.hs | 284 +++++++++++++++++++++++++++++++++ test_program | 4 +- 5 files changed, 314 insertions(+), 21 deletions(-) create mode 100644 src/TypeChecker/Unification.hs diff --git a/language.cabal b/language.cabal index 5668b83..e3d40b9 100644 --- a/language.cabal +++ b/language.cabal @@ -33,6 +33,7 @@ executable language Grammar.ErrM TypeChecker.TypeChecker TypeChecker.TypeCheckerIr + TypeChecker.Unification Renamer.Renamer Renamer.RenamerIr @@ -45,6 +46,6 @@ executable language , either , extra , array - , equivalence + , unification-fd default-language: GHC2021 diff --git a/src/Main.hs b/src/Main.hs index 3679582..0845f8c 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -5,7 +5,8 @@ import Grammar.Par (myLexer, pProgram) import Grammar.Print (printTree) import System.Environment (getArgs) import System.Exit (exitFailure, exitSuccess) -import TypeChecker.TypeChecker (typecheck) +-- import TypeChecker.TypeChecker (typecheck) +import TypeChecker.Unification (typecheck) import Renamer.Renamer (rename) import Grammar.Print (prt) @@ -43,4 +44,4 @@ main = getArgs >>= \case putStrLn "" putStrLn " ----- TYPECHECKER ----- " putStrLn "" - putStrLn . printTree $ prg + putStrLn . show $ prg diff --git a/src/TypeChecker/TypeChecker.hs b/src/TypeChecker/TypeChecker.hs index f663ec4..1584b4f 100644 --- a/src/TypeChecker/TypeChecker.hs +++ b/src/TypeChecker/TypeChecker.hs @@ -11,13 +11,14 @@ import Data.Map (Map) import qualified Data.Map as M import Grammar.ErrM (Err) import Grammar.Print +import Data.List (findIndex) import Debug.Trace (trace) import TypeChecker.TypeCheckerIr data Ctx = Ctx { vars :: Map Integer Type , sigs :: Map Ident Type - , count :: Int + , nextFresh :: Ident } deriving Show @@ -32,7 +33,7 @@ programmer. type Infer = StateT Ctx (ExceptT Error Identity) initEnv :: Ctx -initEnv = Ctx mempty mempty 0 +initEnv = Ctx mempty mempty "a" run :: Infer a -> Either Error a run = runIdentity . runExceptT . flip St.evalStateT initEnv @@ -51,7 +52,6 @@ inferBind (RBind name e) = do insertSigs name t return $ TBind name t e' - inferExp :: RExp -> Infer (Type, TExp) inferExp = \case @@ -79,14 +79,14 @@ inferExp = \case RApp expr1 expr2 -> do (typ1, expr1') <- inferExp expr1 (typ2, expr2') <- inferExp expr2 - cnt <- incCount + fvar <- fresh case typ1 of (TPoly (Ident x)) -> do - let newType = (TArrow (TPoly (Ident x)) (TPoly . Ident $ x ++ (show cnt))) + let newType = (TArrow (TPoly (Ident x)) (TPoly fvar)) specifyType expr1 newType typ1' <- apply newType typ1 return $ (typ1', TApp expr1' expr2' typ1') - _ -> (\t -> (t, TApp expr1' expr2' t)) <$> apply typ2 typ1 + _ -> (\t -> (t, TApp expr1' expr2' t)) <$> apply typ1 typ2 RAdd expr1 expr2 -> do (typ1, expr1') <- inferExp expr1 @@ -115,11 +115,22 @@ isPoly :: Type -> Bool isPoly (TPoly _) = True isPoly _ = False -incCount :: Infer Int -incCount = do - st <- St.get - St.put ( st { count = succ st.count } ) - return st.count +fresh :: Infer Ident +fresh = do + (Ident var) <- St.gets nextFresh + when (length var == 0) (throwError $ Default "fresh") + index <- case findIndex (== (head var)) alphabet of + Nothing -> throwError $ Default "fresh" + Just i -> return i + let nextIndex = (index + 1) `mod` 26 + let newVar = Ident $ [alphabet !! nextIndex] + St.modify (\st -> st { nextFresh = newVar }) + return newVar + where + alphabet = "abcdefghijklmnopqrstuvwxyz" :: [Char] + +unify :: Type -> Type -> Infer Type +unify = todo -- | Specify the type of a bound variable -- Because in lambdas we have to assume a general type and update it @@ -153,12 +164,6 @@ insertSigs i t = do st <- St.get St.put ( st { sigs = M.insert i t st.sigs } ) -union :: Type -> Type -> Infer () -union = todo - -find :: Type -> Type -find = todo - -- Have to figure out the equivalence classes for types. -- Currently this does not support more than exact matches. apply :: Type -> Type -> Infer Type diff --git a/src/TypeChecker/Unification.hs b/src/TypeChecker/Unification.hs new file mode 100644 index 0000000..1842707 --- /dev/null +++ b/src/TypeChecker/Unification.hs @@ -0,0 +1,284 @@ +{-# LANGUAGE DeriveAnyClass, PatternSynonyms, GADTs, LambdaCase, OverloadedStrings #-} + +module TypeChecker.Unification where + +import Renamer.Renamer +import Renamer.RenamerIr (Const(..), RExp(..), RBind(..), RProgram(..), Ident(..)) +import qualified Renamer.RenamerIr as R + +import Control.Monad.Reader +import Control.Monad.State +import Control.Monad.Except +import Data.Functor.Identity +import Control.Arrow ((>>>)) +import Control.Unification hiding ((=:=), applyBindings) +import qualified Control.Unification as U +import Control.Unification.IntVar +import Data.Functor.Fixedpoint +import GHC.Generics (Generic1) +import Data.Foldable (fold) +import Data.Map (Map) +import qualified Data.Map as M +import Data.Maybe (fromMaybe, fromJust) +import Data.Set (Set, (\\)) +import qualified Data.Set as S +import Debug.Trace (trace) + +type Ctx = Map Ident UPolytype + +type TypeError = String + +data TypeT a = TPolyT Ident | TMonoT Ident | TArrowT a a + deriving (Functor, Foldable, Traversable, Generic1, Unifiable) + +instance Show a => Show (TypeT a) where + show (TPolyT (Ident i)) = i + show (TMonoT (Ident i)) = i + show (TArrowT a b) = show a ++ " -> " ++ show b + +type Infer = StateT (Map Ident UPolytype) (ReaderT Ctx (ExceptT TypeError (IntBindingT TypeT Identity))) + +type Type = Fix TypeT +type UType = UTerm TypeT IntVar + +data Poly t = Forall [Ident] t + deriving (Eq, Show, Functor) + +type Polytype = Poly Type + +type UPolytype = Poly UType + +pattern TPoly :: Ident -> Type +pattern TPoly v = Fix (TPolyT v) + +pattern TMono :: Ident -> Type +pattern TMono v = Fix (TMonoT v) + +pattern TArrow :: Type -> Type -> Type +pattern TArrow t1 t2 = Fix (TArrowT t1 t2) + +pattern UTMono :: Ident -> UType +pattern UTMono v = UTerm (TMonoT v) + +pattern UTArrow :: UType -> UType -> UType +pattern UTArrow t1 t2 = UTerm (TArrowT t1 t2) + +pattern UTPoly :: Ident -> UType +pattern UTPoly v = UTerm (TPolyT v) + +data TType = TTPoly Ident | TTMono Ident | TTArrow TType TType + deriving Show + +data Program = Program [Bind] + deriving Show + +data Bind = Bind Ident Exp Polytype + deriving Show + +data Exp + = EAnn Exp Polytype + | EBound Ident Polytype + | EFree Ident Polytype + | EConst Const Polytype + | EApp Exp Exp Polytype + | EAdd Exp Exp Polytype + | EAbs Ident Exp Polytype + deriving Show + +data TExp + = TAnn TExp UType + | TFree Ident UType + | TBound Ident UType + | TConst Const UType + | TApp TExp TExp UType + | TAdd TExp TExp UType + | TAbs Ident TExp UType + deriving Show + +---------------------------------------------------------- +typecheck :: RProgram -> Either TypeError Program +typecheck = run . inferProgram + +inferProgram :: RProgram -> Infer Program +inferProgram (RProgram binds) = do + binds' <- mapM inferBind binds + return $ Program binds' + +inferBind :: RBind -> Infer Bind +inferBind (RBind i e) = do + (t,e') <- infer e + e'' <- convert fromUType e' + t' <- fromUType t + insertSigs i (Forall [] t) + return $ Bind i e'' t' + +fromUType :: UType -> Infer Polytype +fromUType = applyBindings >>> (>>= (generalize >>> fmap fromUPolytype)) + +convert :: (UType -> Infer Polytype) -> TExp -> Infer Exp +convert f = \case + (TAnn e t) -> do + e' <- convert f e + t' <- (f t) + return $ EAnn e' t' + (TFree i t) -> do + t' <- f t + return $ EFree i t' + (TBound i t) -> do + t' <- f t + return $ EBound i t' + (TConst c t) -> do + t' <- f t + return $ EConst c t' + (TApp e1 e2 t) -> do + e1' <- convert f e1 + e2' <- convert f e2 + t' <- f t + return $ EApp e1' e2' t' + (TAdd e1 e2 t) -> do + e1' <- convert f e1 + e2' <- convert f e2 + t' <- f t + return $ EAdd e1' e2' t' + (TAbs i e t) -> do + e' <- convert f e + t' <- f t + return $ EAbs i e' t' + +run :: Infer a -> Either TypeError a +run = flip evalStateT mempty + >>> flip runReaderT mempty + >>> runExceptT + >>> evalIntBindingT + >>> runIdentity + +infer :: RExp -> Infer (UType, TExp) +infer = \case + (RConst (CInt i)) -> return $ (UTMono "Int", TConst (CInt i) (UTMono "Int")) + (RConst (CStr str)) -> return $ (UTMono "String", TConst (CStr str) (UTMono "String")) + (RAdd e1 e2) -> do + (t1,e1') <- infer e2 + (t2,e2') <- infer e1 + t1 =:= (UTMono "Int") + t2 =:= (UTMono "Int") + return $ (UTMono "Int", TAdd e1' e2' (UTMono "Int")) + (RAnn e t) -> do + (t',e') <- infer e + check e t' + return (t', TAnn e' t') + (RApp e1 e2) -> do + (f,e1') <- infer e1 + (arg,e2') <- infer e2 + res <- fresh + f =:= UTArrow f arg + return (res, TApp e1' e2' res) + (RAbs _ i e) -> do + arg <- fresh + withBinding i (Forall [] arg) $ do + (res, e') <- infer e + return $ (UTArrow arg res, TAbs i e' (UTArrow arg res)) + (RFree i) -> do + t <- lookupSigsT i + return (t, TFree i t) + (RBound _ i) -> do + t <- lookupVarT i + return (t, TBound i t) + +check :: RExp -> UType -> Infer () +check expr t = do + (t', _) <- infer expr + t =:= t' + return () + +lookupVarT :: Ident -> Infer UType +lookupVarT x@(Ident i) = do + ctx <- ask + maybe (throwError $ "Var - Unbound variable: " <> i) instantiate (M.lookup x ctx) + +lookupSigsT :: Ident -> Infer UType +lookupSigsT x@(Ident i) = do + ctx <- ask + case M.lookup x ctx of + Nothing -> trace (show ctx) (throwError $ "Sigs - Unbound variable: " <> i) + Just ut -> return $ fromPolytype ut + +insertSigs :: MonadState (Map Ident UPolytype) m => Ident -> UPolytype -> m () +insertSigs x ty = modify (M.insert x ty) + +fromPolytype :: UPolytype -> UType +fromPolytype (Forall ids ut) = ut + +ucata :: Functor t => (v -> a) -> (t a -> a) -> UTerm t v -> a +ucata f _ (UVar v) = f v +ucata f g (UTerm t) = g (fmap (ucata f g) t) + +withBinding :: MonadReader Ctx m => Ident -> UPolytype -> m a -> m a +withBinding x ty = local (M.insert x ty) + +deriving instance Ord IntVar + +class FreeVars a where + freeVars :: a -> Infer (Set (Either Ident IntVar)) + +instance FreeVars UType where + freeVars ut = do + fuvs <- fmap (S.fromList . map Right) . lift . lift . lift $ getFreeVars ut + let ftvs = ucata (const S.empty) + (\case {TMonoT x -> S.singleton (Left x); f -> fold f}) + ut + return $ fuvs `S.union` ftvs + +instance FreeVars UPolytype where + freeVars (Forall xs ut) = (\\ (S.fromList (map Left xs))) <$> freeVars ut + +instance FreeVars Ctx where + freeVars = fmap S.unions . mapM freeVars . M.elems + +fresh :: Infer UType +fresh = UVar <$> lift (lift (lift freeVar)) + +instance Fallible TypeT IntVar TypeError where + occursFailure iv ut = "Infinite" + mismatchFailure iv ut = "Mismatch" + +(=:=) :: UType -> UType -> Infer UType +(=:=) s t = lift . lift $ s U.=:= t + +applyBindings :: UType -> Infer UType +applyBindings = lift . lift . U.applyBindings + +instantiate :: UPolytype -> Infer UType +instantiate (Forall xs uty) = do + xs' <- mapM (const fresh) xs + return $ substU (M.fromList (zip (map Left xs) xs')) uty + +substU :: Map (Either Ident IntVar) UType -> UType -> UType +substU m = ucata + (\v -> fromMaybe (UVar v) (M.lookup (Right v) m)) + (\case + TPolyT v -> fromMaybe (UTPoly v) (M.lookup (Left v) m) + f -> UTerm f + ) + +skolemize :: UPolytype -> Infer UType +skolemize (Forall xs uty) = do + xs' <- mapM (const fresh) xs + return $ substU (M.fromList (zip (map Left xs) (map toSkolem xs'))) uty + where + toSkolem (UVar v) = UTPoly (mkVarName "s" v) + +mkVarName :: String -> IntVar -> Ident +mkVarName nm (IntVar v) = Ident $ nm ++ show (v + (maxBound :: Int) + 1) + +generalize :: UType -> Infer UPolytype +generalize uty = do + uty' <- applyBindings uty + ctx <- ask + tmfvs <- freeVars uty' + ctxfvs <- freeVars ctx + let fvs = S.toList $ tmfvs \\ ctxfvs + xs = map (either id (mkVarName "a")) fvs + return $ Forall xs (substU (M.fromList (zip fvs (map UTPoly xs))) uty') + +fromUPolytype :: UPolytype -> Polytype +fromUPolytype = fmap (fromJust . freeze) diff --git a/test_program b/test_program index db9a44e..fdb3de4 100644 --- a/test_program +++ b/test_program @@ -1 +1,3 @@ -test f x = f x +apply w x = \y. \z. w + x + y + z ; + +main = apply 1 2 3 4 ; From a9f54dbca1881adb3f364099a73369db52b26ca2 Mon Sep 17 00:00:00 2001 From: sebastianselander Date: Fri, 17 Feb 2023 11:09:48 +0100 Subject: [PATCH 029/372] Simplified quite a bit. Made a unify function. Still bugs left --- fourmolu.yaml | 4 +- language.cabal | 2 +- src/TypeChecker/TypeChecker.hs | 222 +++++++++++++++------------------ src/TypeChecker/Unification.hs | 173 +++++++++++++------------ 4 files changed, 192 insertions(+), 209 deletions(-) diff --git a/fourmolu.yaml b/fourmolu.yaml index f15300e..cf7ab2f 100644 --- a/fourmolu.yaml +++ b/fourmolu.yaml @@ -3,12 +3,12 @@ function-arrows: trailing comma-style: leading import-export-style: diff-friendly indent-wheres: false -record-brace-space: false +record-brace-space: true newlines-between-decls: 1 haddock-style: multi-line haddock-style-module: let-style: auto in-style: right-align -respectful: true +respectful: false fixities: [] unicode: never diff --git a/language.cabal b/language.cabal index e3d40b9..36b63c7 100644 --- a/language.cabal +++ b/language.cabal @@ -17,7 +17,7 @@ extra-source-files: common warnings - ghc-options: -Wdefault + ghc-options: -W executable language import: warnings diff --git a/src/TypeChecker/TypeChecker.hs b/src/TypeChecker/TypeChecker.hs index 1584b4f..9b94f55 100644 --- a/src/TypeChecker/TypeChecker.hs +++ b/src/TypeChecker/TypeChecker.hs @@ -1,26 +1,30 @@ -{-# LANGUAGE LambdaCase, OverloadedStrings, OverloadedRecordDot #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} + +{-# HLINT ignore "Use camelCase" #-} module TypeChecker.TypeChecker where -import Control.Monad (when, void) -import Control.Monad.Except (ExceptT, throwError, runExceptT) +import Control.Monad (void) +import Control.Monad.Except (ExceptT, runExceptT, throwError) import Control.Monad.State (StateT) -import qualified Control.Monad.State as St +import Control.Monad.State qualified as St import Data.Functor.Identity (Identity, runIdentity) import Data.Map (Map) -import qualified Data.Map as M -import Grammar.ErrM (Err) -import Grammar.Print -import Data.List (findIndex) - -import Debug.Trace (trace) +import Data.Map qualified as M import TypeChecker.TypeCheckerIr -data Ctx = Ctx { vars :: Map Integer Type - , sigs :: Map Ident Type - , nextFresh :: Ident - } - deriving Show +data Ctx = Ctx + { vars :: Map Integer Type + , sigs :: Map Ident Type + , nextFresh :: Int + } + deriving (Show) + +-- Perhaps swap over to reader monad instead for vars and sigs. +type Infer = StateT Ctx (ExceptT Error Identity) {- @@ -28,18 +32,20 @@ The type checker will assume we first rename all variables to unique name, as to have to care about scoping. It significantly improves the quality of life of the programmer. +TODOs: + Add skolemization variables. i.e + { \x. 3 : forall a. a -> a } + should not type check + + Generalize. Not really sure what that means though + -} -type Infer = StateT Ctx (ExceptT Error Identity) - -initEnv :: Ctx -initEnv = Ctx mempty mempty "a" - run :: Infer a -> Either Error a -run = runIdentity . runExceptT . flip St.evalStateT initEnv +run = runIdentity . runExceptT . flip St.evalStateT (Ctx mempty mempty 0) typecheck :: RProgram -> Either Error TProgram -typecheck = run . inferPrg +typecheck = run . inferPrg inferPrg :: RProgram -> Infer TProgram inferPrg (RProgram xs) = do @@ -54,122 +60,83 @@ inferBind (RBind name e) = do inferExp :: RExp -> Infer (Type, TExp) inferExp = \case - RAnn expr typ -> do - (t,expr') <- inferExp expr - when (not (t == typ || isPoly t)) (throwError $ AnnotatedMismatch "inferExp, RAnn") - return (typ,expr') - - -- Name is only here for proper error messages - RBound num name -> - M.lookup num <$> St.gets vars >>= \case - Nothing -> throwError $ UnboundVar "RBound" - Just t -> return (t, TBound num name t) - + (t, expr') <- inferExp expr + void $ t =:= typ + return (typ, expr') + RBound num name -> do + t <- lookupVars num + return (t, TBound num name t) RFree name -> do - M.lookup name <$> St.gets sigs >>= \case - Nothing -> throwError $ UnboundVar "RFree" - Just t -> return (t, TFree name t) - - RConst (CInt i) -> return $ (TMono "Int", TConst (CInt i) (TMono "Int")) - - RConst (CStr str) -> return $ (TMono "Str", TConst (CStr str) (TMono "Str")) - - -- Should do proper unification using union-find. Some nice libs exist - RApp expr1 expr2 -> do - (typ1, expr1') <- inferExp expr1 - (typ2, expr2') <- inferExp expr2 - fvar <- fresh - case typ1 of - (TPoly (Ident x)) -> do - let newType = (TArrow (TPoly (Ident x)) (TPoly fvar)) - specifyType expr1 newType - typ1' <- apply newType typ1 - return $ (typ1', TApp expr1' expr2' typ1') - _ -> (\t -> (t, TApp expr1' expr2' t)) <$> apply typ1 typ2 - + t <- lookupSigs name + return (t, TFree name t) + RConst (CInt i) -> return (TMono "Int", TConst (CInt i) (TMono "Int")) + RConst (CStr str) -> return (TMono "Str", TConst (CStr str) (TMono "Str")) RAdd expr1 expr2 -> do - (typ1, expr1') <- inferExp expr1 - (typ2, expr2') <- inferExp expr2 - when (not $ (isInt typ1 || isPoly typ1) && (isInt typ2 || isPoly typ2)) (throwError $ TypeMismatch "inferExp, RAdd") - specifyType expr1 (TMono "Int") - specifyType expr2 (TMono "Int") - return (TMono "Int", TAdd expr1' expr2' (TMono "Int")) - + (typ1, expr1') <- check expr1 (TMono "Int") + (_, expr2') <- check expr2 (TMono "Int") + return (typ1, TAdd expr1' expr2' typ1) + RApp expr1 expr2 -> do + (fn_t, expr1') <- inferExp expr1 + (arg_t, expr2') <- inferExp expr2 + res <- fresh + -- TODO: Double check if this is correct behavior. + -- It might be the case that we should return res, rather than new_t + new_t <- fn_t =:= TArrow arg_t res + return (new_t, TApp expr1' expr2' new_t) RAbs num name expr -> do - insertVars num (TPoly "a") + arg <- fresh + insertVars num arg (typ, expr') <- inferExp expr - newTyp <- lookupVars num - return $ (TArrow newTyp typ, TAbs num name expr' typ) + return (TArrow arg typ, TAbs num name expr' typ) --- Aux -isInt :: Type -> Bool -isInt (TMono "Int") = True -isInt _ = False +check :: RExp -> Type -> Infer (Type, TExp) +check e t = do + (t', e') <- inferExp e + t'' <- t' =:= t + return (t'', e') -isArrow :: Type -> Bool -isArrow (TArrow _ _) = True -isArrow _ = False - -isPoly :: Type -> Bool -isPoly (TPoly _) = True -isPoly _ = False - -fresh :: Infer Ident +fresh :: Infer Type fresh = do - (Ident var) <- St.gets nextFresh - when (length var == 0) (throwError $ Default "fresh") - index <- case findIndex (== (head var)) alphabet of - Nothing -> throwError $ Default "fresh" - Just i -> return i - let nextIndex = (index + 1) `mod` 26 - let newVar = Ident $ [alphabet !! nextIndex] - St.modify (\st -> st { nextFresh = newVar }) - return newVar - where - alphabet = "abcdefghijklmnopqrstuvwxyz" :: [Char] + var <- St.gets nextFresh + St.modify (\st -> st {nextFresh = succ var}) + return (TPoly $ Ident (show var)) -unify :: Type -> Type -> Infer Type -unify = todo - --- | Specify the type of a bound variable --- Because in lambdas we have to assume a general type and update it -specifyType :: RExp -> Type -> Infer () -specifyType (RBound num name) typ = do - insertVars num typ - return () -specifyType _ _ = return () +-- | Unify two types. +(=:=) :: Type -> Type -> Infer Type +(=:=) (TPoly _) b = return b +(=:=) a (TPoly _) = return a +(=:=) (TMono a) (TMono b) | a == b = return (TMono a) +(=:=) (TArrow a b) (TArrow c d) = do + t1 <- a =:= c + t2 <- b =:= d + return $ TArrow t1 t2 +(=:=) a b = throwError (TypeMismatch $ unwords ["Can not unify type", show a, "with", show b]) +-- Unused currently lookupVars :: Integer -> Infer Type lookupVars i = do st <- St.gets vars case M.lookup i st of - Just t -> return t - Nothing -> throwError $ UnboundVar "lookupVars" + Just t -> return t + Nothing -> throwError $ UnboundVar "lookupVars" insertVars :: Integer -> Type -> Infer () insertVars i t = do st <- St.get - St.put ( st { vars = M.insert i t st.vars } ) + St.put (st {vars = M.insert i t st.vars}) lookupSigs :: Ident -> Infer Type lookupSigs i = do st <- St.gets sigs case M.lookup i st of - Just t -> return t - Nothing -> throwError $ UnboundVar "lookupSigs" + Just t -> return t + Nothing -> throwError $ UnboundVar "lookupSigs" insertSigs :: Ident -> Type -> Infer () insertSigs i t = do st <- St.get - St.put ( st { sigs = M.insert i t st.sigs } ) - --- Have to figure out the equivalence classes for types. --- Currently this does not support more than exact matches. -apply :: Type -> Type -> Infer Type -apply (TArrow t1 t2) t3 - | t1 == t3 = return t2 -apply t1 t2 = throwError $ TypeMismatch "apply" + St.put (st {sigs = M.insert i t st.sigs}) {-# WARNING todo "TODO IN CODE" #-} todo :: a @@ -183,21 +150,30 @@ data Error | UnboundVar String | AnnotatedMismatch String | Default String - deriving Show + deriving (Show) -- Tests -lambda = RAbs 0 "x" (RAdd (RBound 0 "x") (RBound 0 "x")) -lambda2 = RAbs 0 "x" (RAnn (RBound 0 "x") (TArrow (TMono "Int") (TMono "String"))) +-- (\x. x + 1) 1 +app_lambda :: RExp +app_lambda = app lambda one -fn_on_var = RAbs 0 (Ident "f") (RAbs 1 (Ident "x") (RApp (RBound 0 (Ident "f")) (RBound 1 (Ident "x")))) +lambda :: RExp +lambda = RAbs 0 "x" $ add bound one +add :: RExp -> RExp -> RExp +add = RAdd ---add x = \y. x+y; -add = RAbs 0 "x" (RAbs 1 "y" (RAdd (RBound 0 "x") (RBound 1 "y"))) --- main = (\z. z+z) ((add 4) 6); -main = RApp (RAbs 0 "z" (RAdd (RBound 0 "z") (RBound 0 "z"))) applyAdd -four = RConst (CInt 4) -six = RConst (CInt 6) -applyAdd = (RApp (RApp add four) six) -partialAdd = RApp add four +bound = RBound 0 "x" + +app :: RExp -> RExp -> RExp +app = RApp + +one :: RExp +one = RConst (CInt 1) + +fn_t = TArrow (TPoly (Ident "0")) (TMono (Ident "Int")) + +arr_t = TArrow (TMono "Int") (TPoly "1") + +f_x = RAbs 0 "f" (RAbs 1 "x" (RApp (RBound 0 "f") (RBound 1 "x"))) diff --git a/src/TypeChecker/Unification.hs b/src/TypeChecker/Unification.hs index 1842707..6c86a70 100644 --- a/src/TypeChecker/Unification.hs +++ b/src/TypeChecker/Unification.hs @@ -1,28 +1,31 @@ -{-# LANGUAGE DeriveAnyClass, PatternSynonyms, GADTs, LambdaCase, OverloadedStrings #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} module TypeChecker.Unification where -import Renamer.Renamer -import Renamer.RenamerIr (Const(..), RExp(..), RBind(..), RProgram(..), Ident(..)) -import qualified Renamer.RenamerIr as R - -import Control.Monad.Reader -import Control.Monad.State -import Control.Monad.Except -import Data.Functor.Identity -import Control.Arrow ((>>>)) -import Control.Unification hiding ((=:=), applyBindings) -import qualified Control.Unification as U -import Control.Unification.IntVar -import Data.Functor.Fixedpoint -import GHC.Generics (Generic1) -import Data.Foldable (fold) -import Data.Map (Map) -import qualified Data.Map as M -import Data.Maybe (fromMaybe, fromJust) -import Data.Set (Set, (\\)) -import qualified Data.Set as S -import Debug.Trace (trace) +import Control.Arrow ((>>>)) +import Control.Monad.Except +import Control.Monad.Reader +import Control.Monad.State +import Control.Unification hiding (applyBindings, (=:=)) +import Control.Unification qualified as U +import Control.Unification.IntVar +import Data.Foldable (fold) +import Data.Functor.Fixedpoint +import Data.Functor.Identity +import Data.Map (Map) +import Data.Map qualified as M +import Data.Maybe (fromJust, fromMaybe) +import Data.Set (Set, (\\)) +import Data.Set qualified as S +import Debug.Trace (trace) +import GHC.Generics (Generic1) +import Renamer.Renamer +import Renamer.RenamerIr (Const (..), Ident (..), RBind (..), RExp (..), RProgram (..)) +import Renamer.RenamerIr qualified as R type Ctx = Map Ident UPolytype @@ -39,12 +42,13 @@ instance Show a => Show (TypeT a) where type Infer = StateT (Map Ident UPolytype) (ReaderT Ctx (ExceptT TypeError (IntBindingT TypeT Identity))) type Type = Fix TypeT + type UType = UTerm TypeT IntVar data Poly t = Forall [Ident] t - deriving (Eq, Show, Functor) + deriving (Eq, Show, Functor) -type Polytype = Poly Type +type Polytype = Poly Type type UPolytype = Poly UType @@ -67,23 +71,23 @@ pattern UTPoly :: Ident -> UType pattern UTPoly v = UTerm (TPolyT v) data TType = TTPoly Ident | TTMono Ident | TTArrow TType TType - deriving Show + deriving (Show) -data Program = Program [Bind] - deriving Show +newtype Program = Program [Bind] + deriving (Show) data Bind = Bind Ident Exp Polytype - deriving Show + deriving (Show) data Exp = EAnn Exp Polytype | EBound Ident Polytype - | EFree Ident Polytype + | EFree Ident Polytype | EConst Const Polytype | EApp Exp Exp Polytype | EAdd Exp Exp Polytype | EAbs Ident Exp Polytype - deriving Show + deriving (Show) data TExp = TAnn TExp UType @@ -93,11 +97,11 @@ data TExp | TApp TExp TExp UType | TAdd TExp TExp UType | TAbs Ident TExp UType - deriving Show + deriving (Show) ---------------------------------------------------------- typecheck :: RProgram -> Either TypeError Program -typecheck = run . inferProgram +typecheck = run . inferProgram inferProgram :: RProgram -> Infer Program inferProgram (RProgram binds) = do @@ -106,7 +110,7 @@ inferProgram (RProgram binds) = do inferBind :: RBind -> Infer Bind inferBind (RBind i e) = do - (t,e') <- infer e + (t, e') <- infer e e'' <- convert fromUType e' t' <- fromUType t insertSigs i (Forall [] t) @@ -114,20 +118,19 @@ inferBind (RBind i e) = do fromUType :: UType -> Infer Polytype fromUType = applyBindings >>> (>>= (generalize >>> fmap fromUPolytype)) - + convert :: (UType -> Infer Polytype) -> TExp -> Infer Exp convert f = \case (TAnn e t) -> do e' <- convert f e - t' <- (f t) - return $ EAnn e' t' + EAnn e' <$> f t (TFree i t) -> do t' <- f t return $ EFree i t' (TBound i t) -> do t' <- f t return $ EBound i t' - (TConst c t) -> do + (TConst c t) -> do t' <- f t return $ EConst c t' (TApp e1 e2 t) -> do @@ -135,42 +138,43 @@ convert f = \case e2' <- convert f e2 t' <- f t return $ EApp e1' e2' t' - (TAdd e1 e2 t) -> do + (TAdd e1 e2 t) -> do e1' <- convert f e1 e2' <- convert f e2 t' <- f t return $ EAdd e1' e2' t' - (TAbs i e t) -> do + (TAbs i e t) -> do e' <- convert f e t' <- f t return $ EAbs i e' t' run :: Infer a -> Either TypeError a -run = flip evalStateT mempty - >>> flip runReaderT mempty - >>> runExceptT - >>> evalIntBindingT - >>> runIdentity +run = + flip evalStateT mempty + >>> flip runReaderT mempty + >>> runExceptT + >>> evalIntBindingT + >>> runIdentity infer :: RExp -> Infer (UType, TExp) infer = \case - (RConst (CInt i)) -> return $ (UTMono "Int", TConst (CInt i) (UTMono "Int")) - (RConst (CStr str)) -> return $ (UTMono "String", TConst (CStr str) (UTMono "String")) + (RConst (CInt i)) -> return (UTMono "Int", TConst (CInt i) (UTMono "Int")) + (RConst (CStr str)) -> return (UTMono "String", TConst (CStr str) (UTMono "String")) (RAdd e1 e2) -> do - (t1,e1') <- infer e2 - (t2,e2') <- infer e1 - t1 =:= (UTMono "Int") - t2 =:= (UTMono "Int") - return $ (UTMono "Int", TAdd e1' e2' (UTMono "Int")) + (t1, e1') <- infer e2 + (t2, e2') <- infer e1 + t1 =:= UTMono "Int" + t2 =:= UTMono "Int" + return (UTMono "Int", TAdd e1' e2' (UTMono "Int")) (RAnn e t) -> do - (t',e') <- infer e + (t', e') <- infer e check e t' return (t', TAnn e' t') (RApp e1 e2) -> do - (f,e1') <- infer e1 - (arg,e2') <- infer e2 + (f, e1') <- infer e1 + (arg, e2') <- infer e2 res <- fresh - f =:= UTArrow f arg + f =:= UTArrow arg res return (res, TApp e1' e2' res) (RAbs _ i e) -> do arg <- fresh @@ -199,8 +203,8 @@ lookupSigsT :: Ident -> Infer UType lookupSigsT x@(Ident i) = do ctx <- ask case M.lookup x ctx of - Nothing -> trace (show ctx) (throwError $ "Sigs - Unbound variable: " <> i) - Just ut -> return $ fromPolytype ut + Nothing -> trace (show ctx) (throwError $ "Sigs - Unbound variable: " <> i) + Just ut -> return $ fromPolytype ut insertSigs :: MonadState (Map Ident UPolytype) m => Ident -> UPolytype -> m () insertSigs x ty = modify (M.insert x ty) @@ -218,21 +222,23 @@ withBinding x ty = local (M.insert x ty) deriving instance Ord IntVar class FreeVars a where - freeVars :: a -> Infer (Set (Either Ident IntVar)) + freeVars :: a -> Infer (Set (Either Ident IntVar)) instance FreeVars UType where - freeVars ut = do - fuvs <- fmap (S.fromList . map Right) . lift . lift . lift $ getFreeVars ut - let ftvs = ucata (const S.empty) - (\case {TMonoT x -> S.singleton (Left x); f -> fold f}) - ut - return $ fuvs `S.union` ftvs + freeVars ut = do + fuvs <- fmap (S.fromList . map Right) . lift . lift . lift $ getFreeVars ut + let ftvs = + ucata + (const S.empty) + (\case TMonoT x -> S.singleton (Left x); f -> fold f) + ut + return $ fuvs `S.union` ftvs instance FreeVars UPolytype where - freeVars (Forall xs ut) = (\\ (S.fromList (map Left xs))) <$> freeVars ut + freeVars (Forall xs ut) = (\\ (S.fromList (map Left xs))) <$> freeVars ut instance FreeVars Ctx where - freeVars = fmap S.unions . mapM freeVars . M.elems + freeVars = fmap S.unions . mapM freeVars . M.elems fresh :: Infer UType fresh = UVar <$> lift (lift (lift freeVar)) @@ -249,21 +255,22 @@ applyBindings = lift . lift . U.applyBindings instantiate :: UPolytype -> Infer UType instantiate (Forall xs uty) = do - xs' <- mapM (const fresh) xs - return $ substU (M.fromList (zip (map Left xs) xs')) uty + xs' <- mapM (const fresh) xs + return $ substU (M.fromList (zip (map Left xs) xs')) uty substU :: Map (Either Ident IntVar) UType -> UType -> UType -substU m = ucata - (\v -> fromMaybe (UVar v) (M.lookup (Right v) m)) - (\case - TPolyT v -> fromMaybe (UTPoly v) (M.lookup (Left v) m) - f -> UTerm f - ) +substU m = + ucata + (\v -> fromMaybe (UVar v) (M.lookup (Right v) m)) + ( \case + TPolyT v -> fromMaybe (UTPoly v) (M.lookup (Left v) m) + f -> UTerm f + ) skolemize :: UPolytype -> Infer UType skolemize (Forall xs uty) = do - xs' <- mapM (const fresh) xs - return $ substU (M.fromList (zip (map Left xs) (map toSkolem xs'))) uty + xs' <- mapM (const fresh) xs + return $ substU (M.fromList (zip (map Left xs) (map toSkolem xs'))) uty where toSkolem (UVar v) = UTPoly (mkVarName "s" v) @@ -272,13 +279,13 @@ mkVarName nm (IntVar v) = Ident $ nm ++ show (v + (maxBound :: Int) + 1) generalize :: UType -> Infer UPolytype generalize uty = do - uty' <- applyBindings uty - ctx <- ask - tmfvs <- freeVars uty' - ctxfvs <- freeVars ctx - let fvs = S.toList $ tmfvs \\ ctxfvs - xs = map (either id (mkVarName "a")) fvs - return $ Forall xs (substU (M.fromList (zip fvs (map UTPoly xs))) uty') + uty' <- applyBindings uty + ctx <- ask + tmfvs <- freeVars uty' + ctxfvs <- freeVars ctx + let fvs = S.toList $ tmfvs \\ ctxfvs + xs = map (either id (mkVarName "a")) fvs + return $ Forall xs (substU (M.fromList (zip fvs (map UTPoly xs))) uty') fromUPolytype :: UPolytype -> Polytype fromUPolytype = fmap (fromJust . freeze) From f2e8a0225546d090b00b9afcf80274675040fcae Mon Sep 17 00:00:00 2001 From: sebastianselander Date: Fri, 17 Feb 2023 12:01:22 +0100 Subject: [PATCH 030/372] Removed adhoc tests --- src/Main.hs | 85 ++++++++++++++++++---------------- src/TypeChecker/TypeChecker.hs | 54 ++++++++------------- test_program | 4 +- 3 files changed, 64 insertions(+), 79 deletions(-) diff --git a/src/Main.hs b/src/Main.hs index 0845f8c..9d83ea6 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -1,47 +1,50 @@ {-# LANGUAGE LambdaCase #-} + module Main where -import Grammar.Par (myLexer, pProgram) -import Grammar.Print (printTree) -import System.Environment (getArgs) -import System.Exit (exitFailure, exitSuccess) +import Grammar.Par (myLexer, pProgram) -- import TypeChecker.TypeChecker (typecheck) -import TypeChecker.Unification (typecheck) -import Renamer.Renamer (rename) -import Grammar.Print (prt) + +import Grammar.Print (printTree) +import Renamer.Renamer (rename) +import System.Environment (getArgs) +import System.Exit (exitFailure, exitSuccess) +import TypeChecker.TypeChecker (typecheck) main :: IO () -main = getArgs >>= \case - [] -> print "Required file path missing" - (x:_) -> do - file <- readFile x - case pProgram (myLexer file) of - Left err -> do - putStrLn "SYNTAX ERROR" - putStrLn err - exitFailure - Right prg -> do - putStrLn "" - putStrLn " ----- PARSER ----- " - putStrLn "" - putStrLn . printTree $ prg - case rename prg of - Left err -> do - putStrLn "FAILED RENAMING" - putStrLn . show $ err - exitFailure - Right prg ->do - putStrLn "" - putStrLn " ----- RENAMER ----- " - putStrLn "" - putStrLn . printTree $ prg - case typecheck prg of - Left err -> do - putStrLn "TYPECHECK ERROR" - putStrLn . show $ err - exitFailure - Right prg -> do - putStrLn "" - putStrLn " ----- TYPECHECKER ----- " - putStrLn "" - putStrLn . show $ prg +main = + getArgs >>= \case + [] -> print "Required file path missing" + (x : _) -> do + file <- readFile x + case pProgram (myLexer file) of + Left err -> do + putStrLn "SYNTAX ERROR" + putStrLn err + exitFailure + Right prg -> do + putStrLn "" + putStrLn " ----- PARSER ----- " + putStrLn "" + putStrLn . printTree $ prg + case rename prg of + Left err -> do + putStrLn "FAILED RENAMING" + print err + exitFailure + Right prg -> do + putStrLn "" + putStrLn " ----- RENAMER ----- " + putStrLn "" + putStrLn . printTree $ prg + case typecheck prg of + Left err -> do + putStrLn "TYPECHECK ERROR" + print err + exitFailure + Right prg -> do + putStrLn "" + putStrLn " ----- TYPECHECKER ----- " + putStrLn "" + putStrLn . printTree $ prg + exitSuccess diff --git a/src/TypeChecker/TypeChecker.hs b/src/TypeChecker/TypeChecker.hs index 9b94f55..d3aa41b 100644 --- a/src/TypeChecker/TypeChecker.hs +++ b/src/TypeChecker/TypeChecker.hs @@ -18,7 +18,7 @@ import TypeChecker.TypeCheckerIr data Ctx = Ctx { vars :: Map Integer Type - , sigs :: Map Ident Type + , sigs :: Map Ident (RBind, Maybe Type) , nextFresh :: Int } deriving (Show) @@ -52,12 +52,16 @@ inferPrg (RProgram xs) = do xs' <- mapM inferBind xs return $ TProgram xs' +-- Binds are not correctly added to the context. +-- Can't type check programs with more than one function currently inferBind :: RBind -> Infer TBind -inferBind (RBind name e) = do +inferBind b@(RBind name e) = do + insertSigs name b Nothing (t, e') <- inferExp e - insertSigs name t return $ TBind name t e' +-- Have to figure out a way to coerce polymorphic types to monomorphic ones where necessary +-- { \x. \y. x + y } will have the type { a -> b -> Int } inferExp :: RExp -> Infer (Type, TExp) inferExp = \case RAnn expr typ -> do @@ -68,8 +72,14 @@ inferExp = \case t <- lookupVars num return (t, TBound num name t) RFree name -> do - t <- lookupSigs name - return (t, TFree name t) + (b@(RBind name _), t) <- lookupSigs name + t' <- case t of + Nothing -> do + (TBind _ a _) <- inferBind b + insertSigs name b (Just a) + return a + Just a -> return a + return (t', TFree name t') RConst (CInt i) -> return (TMono "Int", TConst (CInt i) (TMono "Int")) RConst (CStr str) -> return (TMono "Str", TConst (CStr str) (TMono "Str")) RAdd expr1 expr2 -> do @@ -126,17 +136,17 @@ insertVars i t = do st <- St.get St.put (st {vars = M.insert i t st.vars}) -lookupSigs :: Ident -> Infer Type +lookupSigs :: Ident -> Infer (RBind, Maybe Type) lookupSigs i = do st <- St.gets sigs case M.lookup i st of Just t -> return t Nothing -> throwError $ UnboundVar "lookupSigs" -insertSigs :: Ident -> Type -> Infer () -insertSigs i t = do +insertSigs :: Ident -> RBind -> Maybe Type -> Infer () +insertSigs i b t = do st <- St.get - St.put (st {sigs = M.insert i t st.sigs}) + St.put (st {sigs = M.insert i (b, t) st.sigs}) {-# WARNING todo "TODO IN CODE" #-} todo :: a @@ -151,29 +161,3 @@ data Error | AnnotatedMismatch String | Default String deriving (Show) - --- Tests - --- (\x. x + 1) 1 -app_lambda :: RExp -app_lambda = app lambda one - -lambda :: RExp -lambda = RAbs 0 "x" $ add bound one - -add :: RExp -> RExp -> RExp -add = RAdd - -bound = RBound 0 "x" - -app :: RExp -> RExp -> RExp -app = RApp - -one :: RExp -one = RConst (CInt 1) - -fn_t = TArrow (TPoly (Ident "0")) (TMono (Ident "Int")) - -arr_t = TArrow (TMono "Int") (TPoly "1") - -f_x = RAbs 0 "f" (RAbs 1 "x" (RApp (RBound 0 "f") (RBound 1 "x"))) diff --git a/test_program b/test_program index fdb3de4..0849842 100644 --- a/test_program +++ b/test_program @@ -1,3 +1 @@ -apply w x = \y. \z. w + x + y + z ; - -main = apply 1 2 3 4 ; +apply = \x. \y. (x : Mono Int) From 764faa582ba1a6eacfc54a0a1510df6e9a56360f Mon Sep 17 00:00:00 2001 From: sebastianselander Date: Fri, 17 Feb 2023 12:01:57 +0100 Subject: [PATCH 031/372] Remove hls pragmas --- src/TypeChecker/TypeChecker.hs | 3 --- 1 file changed, 3 deletions(-) diff --git a/src/TypeChecker/TypeChecker.hs b/src/TypeChecker/TypeChecker.hs index d3aa41b..d175773 100644 --- a/src/TypeChecker/TypeChecker.hs +++ b/src/TypeChecker/TypeChecker.hs @@ -1,9 +1,6 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE OverloadedStrings #-} -{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} - -{-# HLINT ignore "Use camelCase" #-} module TypeChecker.TypeChecker where From f188cffb8d373823c08a50af1b69303f4cd6a9e5 Mon Sep 17 00:00:00 2001 From: sebastianselander Date: Fri, 17 Feb 2023 18:42:50 +0100 Subject: [PATCH 032/372] Unification part works (probably). Have a hard time understanding it. --- language.cabal | 2 +- src/Main.hs | 14 ++-- src/Renamer/RenamerIr.hs | 19 ++--- src/TypeChecker/TypeChecker.hs | 127 ++++++++++++++--------------- src/TypeChecker/TypeCheckerIr.hs | 66 ++++++++-------- src/TypeChecker/Unification.hs | 132 ++++++++++++------------------- test_program | 4 +- 7 files changed, 167 insertions(+), 197 deletions(-) diff --git a/language.cabal b/language.cabal index 36b63c7..e3d40b9 100644 --- a/language.cabal +++ b/language.cabal @@ -17,7 +17,7 @@ extra-source-files: common warnings - ghc-options: -W + ghc-options: -Wdefault executable language import: warnings diff --git a/src/Main.hs b/src/Main.hs index 9d83ea6..68027d4 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -2,14 +2,14 @@ module Main where -import Grammar.Par (myLexer, pProgram) +import Grammar.Par (myLexer, pProgram) -- import TypeChecker.TypeChecker (typecheck) -import Grammar.Print (printTree) -import Renamer.Renamer (rename) -import System.Environment (getArgs) -import System.Exit (exitFailure, exitSuccess) -import TypeChecker.TypeChecker (typecheck) +import Grammar.Print (printTree) +import Renamer.Renamer (rename) +import System.Environment (getArgs) +import System.Exit (exitFailure, exitSuccess) +import TypeChecker.TypeChecker (typecheck) main :: IO () main = @@ -46,5 +46,5 @@ main = putStrLn "" putStrLn " ----- TYPECHECKER ----- " putStrLn "" - putStrLn . printTree $ prg + print prg exitSuccess diff --git a/src/Renamer/RenamerIr.hs b/src/Renamer/RenamerIr.hs index 33f1d3c..bac9915 100644 --- a/src/Renamer/RenamerIr.hs +++ b/src/Renamer/RenamerIr.hs @@ -1,12 +1,13 @@ {-# LANGUAGE LambdaCase #-} -module Renamer.RenamerIr ( RExp (..) - , RBind (..) - , RProgram (..) - , Const (..) - , Ident (..) - , Type (..) - ) where +module Renamer.RenamerIr ( + RExp (..), + RBind (..), + RProgram (..), + Const (..), + Ident (..), + Type (..), +) where import Grammar.Abs ( Bind (..), @@ -51,9 +52,9 @@ instance Print RBind where instance Print RExp where prt i = \case RAnn e t -> prPrec i 2 (concatD [prt 0 e, doc (showString ":"), prt 1 t]) - RBound n _ -> prPrec i 3 (concatD [prt 0 ("var" ++ show n)]) + RBound n _ -> prPrec i 3 (concatD [prt 0 n]) RFree id -> prPrec i 3 (concatD [prt 0 id]) RConst n -> prPrec i 3 (concatD [prt 0 n]) RApp e e1 -> prPrec i 2 (concatD [prt 2 e, prt 3 e1]) RAdd e e1 -> prPrec i 1 (concatD [prt 1 e, doc (showString "+"), prt 2 e1]) - RAbs u id e -> prPrec i 0 (concatD [doc (showString "λ"), prt 0 ("var" ++ show u), doc (showString "."), prt 0 e]) + RAbs u _ e -> prPrec i 0 (concatD [doc (showString "λ"), prt 0 u, doc (showString "."), prt 0 e]) diff --git a/src/TypeChecker/TypeChecker.hs b/src/TypeChecker/TypeChecker.hs index d175773..48d26ac 100644 --- a/src/TypeChecker/TypeChecker.hs +++ b/src/TypeChecker/TypeChecker.hs @@ -1,21 +1,22 @@ -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedRecordDot #-} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings #-} module TypeChecker.TypeChecker where -import Control.Monad (void) -import Control.Monad.Except (ExceptT, runExceptT, throwError) -import Control.Monad.State (StateT) -import Control.Monad.State qualified as St -import Data.Functor.Identity (Identity, runIdentity) -import Data.Map (Map) -import Data.Map qualified as M -import TypeChecker.TypeCheckerIr +import Control.Monad (void) +import Control.Monad.Except (ExceptT, runExceptT, throwError) +import Control.Monad.State (StateT) +import qualified Control.Monad.State as St +import Data.Functor.Identity (Identity, runIdentity) +import Data.Map (Map) +import qualified Data.Map as M + +import TypeChecker.TypeCheckerIr data Ctx = Ctx - { vars :: Map Integer Type - , sigs :: Map Ident (RBind, Maybe Type) + { vars :: Map Integer Type + , sigs :: Map Ident Type , nextFresh :: Int } deriving (Show) @@ -38,70 +39,54 @@ TODOs: -} +typecheck :: RProgram -> Either Error TProgram +typecheck = todo + run :: Infer a -> Either Error a run = runIdentity . runExceptT . flip St.evalStateT (Ctx mempty mempty 0) -typecheck :: RProgram -> Either Error TProgram -typecheck = run . inferPrg - -inferPrg :: RProgram -> Infer TProgram -inferPrg (RProgram xs) = do - xs' <- mapM inferBind xs - return $ TProgram xs' - --- Binds are not correctly added to the context. --- Can't type check programs with more than one function currently -inferBind :: RBind -> Infer TBind -inferBind b@(RBind name e) = do - insertSigs name b Nothing - (t, e') <- inferExp e - return $ TBind name t e' - -- Have to figure out a way to coerce polymorphic types to monomorphic ones where necessary -- { \x. \y. x + y } will have the type { a -> b -> Int } -inferExp :: RExp -> Infer (Type, TExp) +inferExp :: RExp -> Infer Type inferExp = \case + RAnn expr typ -> do - (t, expr') <- inferExp expr + t <- inferExp expr void $ t =:= typ - return (typ, expr') - RBound num name -> do - t <- lookupVars num - return (t, TBound num name t) - RFree name -> do - (b@(RBind name _), t) <- lookupSigs name - t' <- case t of - Nothing -> do - (TBind _ a _) <- inferBind b - insertSigs name b (Just a) - return a - Just a -> return a - return (t', TFree name t') - RConst (CInt i) -> return (TMono "Int", TConst (CInt i) (TMono "Int")) - RConst (CStr str) -> return (TMono "Str", TConst (CStr str) (TMono "Str")) + return t + + RBound num name -> lookupVars num + + RFree name -> lookupSigs name + + RConst (CInt i) -> return $ TMono "Int" + + RConst (CStr str) -> return $ TMono "Str" + RAdd expr1 expr2 -> do - (typ1, expr1') <- check expr1 (TMono "Int") - (_, expr2') <- check expr2 (TMono "Int") - return (typ1, TAdd expr1' expr2' typ1) + let int = TMono "Int" + typ1 <- check expr1 int + typ2 <- check expr2 int + return int + RApp expr1 expr2 -> do - (fn_t, expr1') <- inferExp expr1 - (arg_t, expr2') <- inferExp expr2 + fn_t <- inferExp expr1 + arg_t <- inferExp expr2 res <- fresh - -- TODO: Double check if this is correct behavior. - -- It might be the case that we should return res, rather than new_t new_t <- fn_t =:= TArrow arg_t res - return (new_t, TApp expr1' expr2' new_t) + return res + RAbs num name expr -> do arg <- fresh insertVars num arg - (typ, expr') <- inferExp expr - return (TArrow arg typ, TAbs num name expr' typ) + typ <- inferExp expr + return $ TArrow arg typ -check :: RExp -> Type -> Infer (Type, TExp) +check :: RExp -> Type -> Infer () check e t = do - (t', e') <- inferExp e - t'' <- t' =:= t - return (t'', e') + t' <- inferExp e + t =:= t' + return () fresh :: Infer Type fresh = do @@ -120,30 +105,29 @@ fresh = do return $ TArrow t1 t2 (=:=) a b = throwError (TypeMismatch $ unwords ["Can not unify type", show a, "with", show b]) --- Unused currently lookupVars :: Integer -> Infer Type lookupVars i = do st <- St.gets vars case M.lookup i st of - Just t -> return t - Nothing -> throwError $ UnboundVar "lookupVars" + Just t -> return t + Nothing -> throwError $ UnboundVar "lookupVars" insertVars :: Integer -> Type -> Infer () insertVars i t = do st <- St.get St.put (st {vars = M.insert i t st.vars}) -lookupSigs :: Ident -> Infer (RBind, Maybe Type) +lookupSigs :: Ident -> Infer Type lookupSigs i = do st <- St.gets sigs case M.lookup i st of - Just t -> return t + Just t -> return t Nothing -> throwError $ UnboundVar "lookupSigs" -insertSigs :: Ident -> RBind -> Maybe Type -> Infer () -insertSigs i b t = do +insertSigs :: Ident -> Type -> Infer () +insertSigs i t = do st <- St.get - St.put (st {sigs = M.insert i (b, t) st.sigs}) + St.put (st {sigs = M.insert i t st.sigs}) {-# WARNING todo "TODO IN CODE" #-} todo :: a @@ -158,3 +142,12 @@ data Error | AnnotatedMismatch String | Default String deriving (Show) + + +{- + +The procedure inst(σ) specializes the polytype +σ by copying the term and replacing the bound type variables +consistently by new monotype variables. + +-} diff --git a/src/TypeChecker/TypeCheckerIr.hs b/src/TypeChecker/TypeCheckerIr.hs index 7d30ae8..6845afd 100644 --- a/src/TypeChecker/TypeCheckerIr.hs +++ b/src/TypeChecker/TypeCheckerIr.hs @@ -1,21 +1,21 @@ {-# LANGUAGE LambdaCase #-} -module TypeChecker.TypeCheckerIr ( TProgram(..) - , TBind(..) - , TExp(..) - , RProgram(..) - , RBind(..) - , RExp(..) - , Type(..) - , Const(..) - , Ident(..) - ) - where +module TypeChecker.TypeCheckerIr ( + TProgram (..), + TBind (..), + TExp (..), + RProgram (..), + RBind (..), + RExp (..), + Type (..), + Const (..), + Ident (..), +) where -import Renamer.RenamerIr -import Grammar.Print +import Grammar.Print +import Renamer.RenamerIr -data TProgram = TProgram [TBind] +newtype TProgram = TProgram [TBind] deriving (Eq, Show, Read, Ord) data TBind = TBind Ident Type TExp @@ -50,21 +50,25 @@ instance Print TBind where instance Print TExp where prt i = \case - TAnn e t -> prPrec i 2 $ concatD - [ prt 0 e - , doc (showString ":") - , prt 1 t - ] - TBound _ u t -> prPrec i 3 $ concatD [ prt 0 u ] - TFree u t -> prPrec i 3 $ concatD [ prt 0 u ] + TAnn e t -> + prPrec i 2 $ + concatD + [ prt 0 e + , doc (showString ":") + , prt 1 t + ] + TBound _ u t -> prPrec i 3 $ concatD [prt 0 u] + TFree u t -> prPrec i 3 $ concatD [prt 0 u] TConst c _ -> prPrec i 3 (concatD [prt 0 c]) - TApp e e1 t -> prPrec i 2 $ concatD [ prt 2 e , prt 3 e1 ] - TAdd e e1 t -> prPrec i 1 $ concatD [ prt 1 e , doc (showString "+") , prt 2 e1 ] - TAbs _ u e t -> prPrec i 0 $ concatD - [ doc (showString "(") - , doc (showString "λ") - , prt 0 u - , doc (showString ".") - , prt 0 e - , doc (showString ")") - ] + TApp e e1 t -> prPrec i 2 $ concatD [prt 2 e, prt 3 e1] + TAdd e e1 t -> prPrec i 1 $ concatD [prt 1 e, doc (showString "+"), prt 2 e1] + TAbs _ u e t -> + prPrec i 0 $ + concatD + [ doc (showString "(") + , doc (showString "λ") + , prt 0 u + , doc (showString ".") + , prt 0 e + , doc (showString ")") + ] diff --git a/src/TypeChecker/Unification.hs b/src/TypeChecker/Unification.hs index 6c86a70..226e1e9 100644 --- a/src/TypeChecker/Unification.hs +++ b/src/TypeChecker/Unification.hs @@ -1,31 +1,31 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE PatternSynonyms #-} module TypeChecker.Unification where -import Control.Arrow ((>>>)) -import Control.Monad.Except -import Control.Monad.Reader -import Control.Monad.State -import Control.Unification hiding (applyBindings, (=:=)) -import Control.Unification qualified as U -import Control.Unification.IntVar -import Data.Foldable (fold) -import Data.Functor.Fixedpoint -import Data.Functor.Identity -import Data.Map (Map) -import Data.Map qualified as M -import Data.Maybe (fromJust, fromMaybe) -import Data.Set (Set, (\\)) -import Data.Set qualified as S -import Debug.Trace (trace) -import GHC.Generics (Generic1) -import Renamer.Renamer -import Renamer.RenamerIr (Const (..), Ident (..), RBind (..), RExp (..), RProgram (..)) -import Renamer.RenamerIr qualified as R +import Control.Arrow ((>>>)) +import Control.Monad.Except +import Control.Monad.Reader +import Control.Monad.State +import Control.Unification hiding (applyBindings, (=:=)) +import qualified Control.Unification as U +import Control.Unification.IntVar +import Data.Foldable (fold) +import Data.Functor.Fixedpoint +import Data.Functor.Identity +import Data.Map (Map) +import qualified Data.Map as M +import Data.Maybe (fromJust, fromMaybe) +import Data.Set (Set, (\\)) +import qualified Data.Set as S +import Debug.Trace (trace) +import GHC.Generics (Generic1) +import Renamer.Renamer +import qualified Renamer.RenamerIr as R +import Renamer.RenamerIr (Const (..), Ident (..), RBind (..), + RExp (..), RProgram (..)) type Ctx = Map Ident UPolytype @@ -37,7 +37,7 @@ data TypeT a = TPolyT Ident | TMonoT Ident | TArrowT a a instance Show a => Show (TypeT a) where show (TPolyT (Ident i)) = i show (TMonoT (Ident i)) = i - show (TArrowT a b) = show a ++ " -> " ++ show b + show (TArrowT a b) = show a ++ " -> " ++ show b type Infer = StateT (Map Ident UPolytype) (ReaderT Ctx (ExceptT TypeError (IntBindingT TypeT Identity))) @@ -46,7 +46,10 @@ type Type = Fix TypeT type UType = UTerm TypeT IntVar data Poly t = Forall [Ident] t - deriving (Eq, Show, Functor) + deriving (Eq, Functor) + +instance Show t => Show (Poly t) where + show (Forall is t) = unwords (map (\(Ident x) -> "forall " ++ x ++ ".") is) ++ " " ++ show t type Polytype = Poly Type @@ -101,60 +104,17 @@ data TExp ---------------------------------------------------------- typecheck :: RProgram -> Either TypeError Program -typecheck = run . inferProgram +typecheck = undefined -inferProgram :: RProgram -> Infer Program -inferProgram (RProgram binds) = do - binds' <- mapM inferBind binds - return $ Program binds' - -inferBind :: RBind -> Infer Bind -inferBind (RBind i e) = do - (t, e') <- infer e - e'' <- convert fromUType e' - t' <- fromUType t - insertSigs i (Forall [] t) - return $ Bind i e'' t' - -fromUType :: UType -> Infer Polytype -fromUType = applyBindings >>> (>>= (generalize >>> fmap fromUPolytype)) - -convert :: (UType -> Infer Polytype) -> TExp -> Infer Exp -convert f = \case - (TAnn e t) -> do - e' <- convert f e - EAnn e' <$> f t - (TFree i t) -> do - t' <- f t - return $ EFree i t' - (TBound i t) -> do - t' <- f t - return $ EBound i t' - (TConst c t) -> do - t' <- f t - return $ EConst c t' - (TApp e1 e2 t) -> do - e1' <- convert f e1 - e2' <- convert f e2 - t' <- f t - return $ EApp e1' e2' t' - (TAdd e1 e2 t) -> do - e1' <- convert f e1 - e2' <- convert f e2 - t' <- f t - return $ EAdd e1' e2' t' - (TAbs i e t) -> do - e' <- convert f e - t' <- f t - return $ EAbs i e' t' - -run :: Infer a -> Either TypeError a -run = - flip evalStateT mempty - >>> flip runReaderT mempty - >>> runExceptT - >>> evalIntBindingT - >>> runIdentity +run :: Infer (UType, TExp) -> Either TypeError Polytype +run = fmap fst + >>> (>>= applyBindings) + >>> (>>= (generalize >>> fmap fromUPolytype)) + >>> flip evalStateT mempty + >>> flip runReaderT mempty + >>> runExceptT + >>> evalIntBindingT + >>> runIdentity infer :: RExp -> Infer (UType, TExp) infer = \case @@ -166,6 +126,7 @@ infer = \case t1 =:= UTMono "Int" t2 =:= UTMono "Int" return (UTMono "Int", TAdd e1' e2' (UTMono "Int")) + -- type is not used, probably wrong (RAnn e t) -> do (t', e') <- infer e check e t' @@ -180,7 +141,7 @@ infer = \case arg <- fresh withBinding i (Forall [] arg) $ do (res, e') <- infer e - return $ (UTArrow arg res, TAbs i e' (UTArrow arg res)) + return (UTArrow arg res, TAbs i e' (UTArrow arg res)) (RFree i) -> do t <- lookupSigsT i return (t, TFree i t) @@ -213,7 +174,7 @@ fromPolytype :: UPolytype -> UType fromPolytype (Forall ids ut) = ut ucata :: Functor t => (v -> a) -> (t a -> a) -> UTerm t v -> a -ucata f _ (UVar v) = f v +ucata f _ (UVar v) = f v ucata f g (UTerm t) = g (fmap (ucata f g) t) withBinding :: MonadReader Ctx m => Ident -> UPolytype -> m a -> m a @@ -277,6 +238,7 @@ skolemize (Forall xs uty) = do mkVarName :: String -> IntVar -> Ident mkVarName nm (IntVar v) = Ident $ nm ++ show (v + (maxBound :: Int) + 1) +-- | Used in let bindings to generalize functions declared there generalize :: UType -> Infer UPolytype generalize uty = do uty' <- applyBindings uty @@ -289,3 +251,11 @@ generalize uty = do fromUPolytype :: UPolytype -> Polytype fromUPolytype = fmap (fromJust . freeze) + +inf = RAbs 0 "x" (RApp (RBound 0 "x") (RBound 0 "x")) + +one = RConst (CInt 1) + +lambda = RAbs 0 "f" (RAbs 1 "x" (RApp (RBound 0 "f") (RBound 1 "x"))) + +fn = RAbs 0 "x" (RBound 0 "x") diff --git a/test_program b/test_program index 0849842..0639729 100644 --- a/test_program +++ b/test_program @@ -1 +1,3 @@ -apply = \x. \y. (x : Mono Int) +test = \x. (x : Mono String) ; + +apply x y = x + y ; From 287f84377ce6e23043a7dca183376350bc20a4b3 Mon Sep 17 00:00:00 2001 From: Samuel Hammersberg Date: Sat, 18 Feb 2023 14:36:46 +0100 Subject: [PATCH 033/372] Implemented case matching on ints in the code generator --- src/Compiler.hs | 142 ++++++++++++++++++++++++++++++++++++------------ src/LlvmIr.hs | 37 ++++++++----- 2 files changed, 130 insertions(+), 49 deletions(-) diff --git a/src/Compiler.hs b/src/Compiler.hs index 0820523..92f4a23 100644 --- a/src/Compiler.hs +++ b/src/Compiler.hs @@ -1,36 +1,38 @@ -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} module Compiler (compile) where -import Control.Monad.State (StateT, execStateT, gets, modify) -import Data.Map (Map) -import qualified Data.Map as Map -import Data.Tuple.Extra (second) -import Grammar.ErrM (Err) -import Grammar.Print (printTree) -import LlvmIr ( - LLVMIr (..), - LLVMType (..), - LLVMValue (..), - Visibility (..), - llvmIrToString, - ) -import TypeChecker (partitionType) -import TypeCheckerIr +import Control.Monad.State (StateT, execStateT, gets, modify) +import Data.List.Extra (trim) +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Tuple.Extra (second) +import Grammar.ErrM (Err) +import Grammar.Print (printTree) +import LlvmIr (LLVMComp (..), LLVMIr (..), + LLVMType (..), LLVMValue (..), + Visibility (..), llvmIrToString) +import System.IO (stdin) +import System.Process.Extra (CreateProcess (std_in), + StdStream (CreatePipe), createProcess, + readCreateProcess, shell) +import TypeChecker (partitionType) +import TypeCheckerIr -- | The record used as the code generator state data CodeGenerator = CodeGenerator - { instructions :: [LLVMIr] - , functions :: Map Id FunctionInfo + { instructions :: [LLVMIr] + , functions :: Map Id FunctionInfo , variableCount :: Integer + , labelCount :: Integer } -- | A state type synonym type CompilerState a = StateT CodeGenerator Err a data FunctionInfo = FunctionInfo - { numArgs :: Int + { numArgs :: Int , arguments :: [Id] } @@ -50,6 +52,12 @@ getVarCount = gets variableCount getNewVar :: CompilerState Integer getNewVar = increaseVarCount >> getVarCount +-- | Increses the label count and returns a label from the CodeGenerator state +getNewLabel :: CompilerState Integer +getNewLabel = do + modify (\t -> t{labelCount = labelCount t + 1}) + gets labelCount + {- | Produces a map of functions infos from a list of binds, which contains useful data for code generation. -} @@ -67,6 +75,36 @@ getFunctions xs = ) xs +run :: Err String -> IO () +run s = do + let s' = case s of + Right s -> s + Left _ -> error "yo" + writeFile "llvm.ll" s' + putStrLn . trim =<< readCreateProcess (shell "lli") s' +test :: Integer -> Program +test v = Program [ + Bind (Ident "fibonacci", TInt) [(Ident "x", TInt)] ( + ECased (EId ("x", TInt)) [ + Case (CInt 0) (EInt 0), + Case (CInt 1) (EInt 1), + Case CatchAll (EAdd TInt + (EApp TInt (EId (Ident "fibonacci", TInt)) ( + EAdd TInt (EId (Ident "x", TInt)) + (EInt (fromIntegral ((maxBound :: Int) * 2))) + )) + (EApp TInt (EId (Ident "fibonacci", TInt)) ( + EAdd TInt (EId (Ident "x", TInt)) + (EInt (fromIntegral ((maxBound :: Int) * 2 + 1))) + )) + ) + ] + ), + Bind (Ident "main",TInt) [] ( + EApp TInt (EId (Ident "fibonacci", TInt)) (EInt v) -- (EInt 92) + ) + ] + {- | Compiles an AST and produces a LLVM Ir string. An easy way to actually "compile" this output is to Simply pipe it to LLI @@ -78,6 +116,7 @@ compile (Program prg) = do { instructions = defaultStart , functions = getFunctions prg , variableCount = 0 + , labelCount = 0 } ins <- instructions <$> execStateT (goDef prg) s pure $ llvmIrToString ins @@ -112,7 +151,7 @@ compile (Program prg) = do goDef (Bind (name, t) args exp : xs) = do emit $ UnsafeRaw "\n" emit $ Comment $ show name <> ": " <> show exp - emit $ Define (type2LlvmType t_return) name (map (second type2LlvmType) args) + emit $ Define (I64{-type2LlvmType t_return-}) name (map (second type2LlvmType) args) functionBody <- exprToValue exp if name == "main" then mapM_ emit (mainContent functionBody) @@ -124,21 +163,54 @@ compile (Program prg) = do t_return = snd $ partitionType (length args) t go :: Exp -> CompilerState () - go (EInt int) = emitInt int - go (EAdd t e1 e2) = emitAdd t e1 e2 + go (EInt int) = emitInt int + go (EAdd t e1 e2) = emitAdd t e1 e2 go (EId (name, _)) = emitIdent name - go (EApp t e1 e2) = emitApp t e1 e2 - go (EAbs t ti e) = emitAbs t ti e - go (ELet binds e) = emitLet binds e - go (EAnn _ _) = emitEAnn + go (EApp t e1 e2) = emitApp t e1 e2 + go (EAbs t ti e) = emitAbs t ti e + go (ELet binds e) = emitLet binds e + go (EAnn _ _) = emitEAnn + go (ECased e c) = emitECased e c -- go (ESub e1 e2) = emitSub e1 e2 -- go (EMul e1 e2) = emitMul e1 e2 -- go (EDiv e1 e2) = emitDiv e1 e2 -- go (EMod e1 e2) = emitMod e1 e2 --- aux functions --- + emitECased :: Exp -> [Case] -> CompilerState () + emitECased e cs = do + vs <- exprToValue e + lbl <- getNewLabel + let label = Ident $ "escape_" <> show lbl + stackPtr <- getNewVar + emit $ SetVariable (Ident $ show stackPtr) (Alloca I64) + mapM_ (emitCases label stackPtr vs) cs + emit $ Label label + res <- getNewVar + emit $ SetVariable (Ident $ show res) (Load I64 Ptr (Ident $ show stackPtr)) + where + emitCases :: Ident -> Integer -> LLVMValue -> Case -> CompilerState () + emitCases label stackPtr vs (Case (CInt i) exp) = do + ns <- getNewVar + lbl_fail <- getNewLabel + lbl_succ <- getNewLabel + let failed = Ident $ "failed_" <> show lbl_fail + let success = Ident $ "success_" <> show lbl_succ + emit $ SetVariable (Ident $ show ns) (Icmp LLEq I64 vs (VInteger i)) + emit $ BrCond (VIdent (Ident $ show ns) I64) success failed + emit $ Label success + val <- exprToValue exp + emit $ Store I64 val Ptr (Ident . show $ stackPtr) + emit $ Br label + emit $ Label failed + emitCases label stackPtr _ (Case CatchAll exp) = do + val <- exprToValue exp + emit $ Store I64 val Ptr (Ident . show $ stackPtr) + emit $ Br label + + emitEAnn :: CompilerState () - emitEAnn = emit . UnsafeRaw $ "why?" + emitEAnn = emit . UnsafeRaw $ "Annotated escaped previous stages" emitAbs :: Type -> Id -> Exp -> CompilerState () emitAbs _t tid e = do @@ -170,7 +242,7 @@ compile (Program prg) = do funcs <- gets functions let vis = case Map.lookup id funcs of Nothing -> Local - Just _ -> Global + Just _ -> Global let call = Call (type2LlvmType t) vis name ((\x -> (valueGetType x, x)) <$> args) emit $ SetVariable (Ident $ show vs) call x -> do @@ -271,19 +343,19 @@ type2LlvmType = \case where function2LLVMType :: Type -> [LLVMType] -> (LLVMType, [LLVMType]) function2LLVMType (TFun t xs) s = function2LLVMType xs (type2LlvmType t : s) - function2LLVMType x s = (type2LlvmType x, s) + function2LLVMType x s = (type2LlvmType x, s) getType :: Exp -> LLVMType -getType (EInt _) = I64 +getType (EInt _) = I64 getType (EAdd t _ _) = type2LlvmType t getType (EId (_, t)) = type2LlvmType t getType (EApp t _ _) = type2LlvmType t getType (EAbs t _ _) = type2LlvmType t -getType (ELet _ e) = getType e -getType (EAnn _ t) = type2LlvmType t +getType (ELet _ e) = getType e +getType (EAnn _ t) = type2LlvmType t valueGetType :: LLVMValue -> LLVMType -valueGetType (VInteger _) = I64 -valueGetType (VIdent _ t) = t -valueGetType (VConstant s) = Array (length s) I8 +valueGetType (VInteger _) = I64 +valueGetType (VIdent _ t) = t +valueGetType (VConstant s) = Array (length s) I8 valueGetType (VFunction _ _ t) = t diff --git a/src/LlvmIr.hs b/src/LlvmIr.hs index b29f296..281fc34 100644 --- a/src/LlvmIr.hs +++ b/src/LlvmIr.hs @@ -9,8 +9,8 @@ module LlvmIr ( Visibility (..), ) where -import Data.List (intercalate) -import TypeCheckerIr +import Data.List (intercalate) +import TypeCheckerIr -- | A datatype which represents some basic LLVM types data LLVMType @@ -65,7 +65,7 @@ instance Show LLVMComp where data Visibility = Local | Global instance Show Visibility where show :: Visibility -> String - show Local = "%" + show Local = "%" show Global = "@" {- | Represents a LLVM "value", as in an integer, a register variable, @@ -80,10 +80,10 @@ data LLVMValue instance Show LLVMValue where show :: LLVMValue -> String show v = case v of - VInteger i -> show i - VIdent (Ident n) _ -> "%" <> n + VInteger i -> show i + VIdent (Ident n) _ -> "%" <> n VFunction (Ident n) vis _ -> show vis <> n - VConstant s -> "c" <> show s + VConstant s -> "c" <> show s type Params = [(Ident, LLVMType)] type Args = [(LLVMType, LLVMValue)] @@ -106,7 +106,8 @@ data LLVMIr | Label Ident | Call LLVMType Visibility Ident Args | Alloca LLVMType - | Store LLVMType Ident LLVMType Ident + | Store LLVMType LLVMValue LLVMType Ident + | Load LLVMType LLVMType Ident | Bitcast LLVMType Ident LLVMType | Ret LLVMType LLVMValue | Comment String @@ -122,9 +123,9 @@ llvmIrToString = go 0 go _ [] = mempty go i (x : xs) = do let (i', n) = case x of - Define{} -> (i + 1, 0) + Define{} -> (i + 1, 0) DefineEnd -> (i - 1, 0) - _ -> (i, i) + _ -> (i, i) insToString n x <> go i' xs {- | Converts a LLVM inststruction to a String, allowing for printing etc. @@ -175,11 +176,16 @@ llvmIrToString = go 0 , ")\n" ] (Alloca t) -> unwords ["alloca", show t, "\n"] - (Store t1 (Ident id1) t2 (Ident id2)) -> + (Store t1 val t2 (Ident id2)) -> concat - [ "store ", show t1, " %", id1 + [ "store ", show t1, " ", show val , ", ", show t2 , " %", id2, "\n" ] + (Load t1 t2 (Ident addr)) -> + concat + [ "load ", show t1, ", " + , show t2, " %", addr, "\n" + ] (Bitcast t1 (Ident i) t2) -> concat [ "bitcast ", show t1, " %" @@ -196,13 +202,16 @@ llvmIrToString = go 0 , show v, "\n" ] (UnsafeRaw s) -> s - (Label (Ident s)) -> "\nlabel_" <> s <> ":\n" - (Br (Ident s)) -> "br label %label_" <> s <> "\n" + (Label (Ident s)) -> "\n" <> lblPfx <> s <> ":\n" + (Br (Ident s)) -> "br label %" <> lblPfx <> s <> "\n" (BrCond val (Ident s1) (Ident s2)) -> concat [ "br i1 ", show val, ", ", "label %" - , "label_", s1, ", ", "label %", "label_", s2, "\n" + , lblPfx, s1, ", ", "label %", lblPfx, s2, "\n" ] (Comment s) -> "; " <> s <> "\n" (Variable (Ident id)) -> "%" <> id {- FOURMOLU_ENABLE -} + +lblPfx :: String +lblPfx = "lbl_" From 8b5cd3cf9ae6b7de6d046ad50187fb7672e019bc Mon Sep 17 00:00:00 2001 From: sebastianselander Date: Sat, 18 Feb 2023 23:08:27 +0100 Subject: [PATCH 034/372] Remade the algorithm myself. Still some bugs. --- Grammar.cf | 17 +-- language.cabal | 14 +- src/Auxiliary.hs | 21 +++ src/Main.hs | 36 ++--- src/Renamer/Renamer.hs | 8 +- src/Renamer/RenamerIr.hs | 32 +---- src/Renamer/RenamerM.hs | 83 +++++++++++ src/TypeChecker/HM.hs | 155 ++++++++++++++++++++ src/TypeChecker/HMIr.hs | 102 +++++++++++++ src/TypeChecker/TypeChecker.hs | 236 +++++++++++++++---------------- src/TypeChecker/TypeCheckerIr.hs | 132 ++++++++--------- test_program | 5 +- 12 files changed, 584 insertions(+), 257 deletions(-) create mode 100644 src/Auxiliary.hs create mode 100644 src/Renamer/RenamerM.hs create mode 100644 src/TypeChecker/HM.hs create mode 100644 src/TypeChecker/HMIr.hs diff --git a/Grammar.cf b/Grammar.cf index 1e99c21..5406ac8 100644 --- a/Grammar.cf +++ b/Grammar.cf @@ -1,22 +1,21 @@ Program. Program ::= [Bind] ; -Bind. Bind ::= Ident [Ident] "=" Exp ; + +Bind. Bind ::= Ident ":" Type ";" + Ident [Ident] "=" Exp ; EAnn. Exp5 ::= "(" Exp ":" Type ")" ; EId. Exp4 ::= Ident ; -EConst. Exp4 ::= Const ; +EInt. Exp4 ::= Integer ; EApp. Exp3 ::= Exp3 Exp4 ; EAdd. Exp1 ::= Exp1 "+" Exp2 ; ELet. Exp ::= "let" Ident "=" Exp "in" Exp ; EAbs. Exp ::= "\\" Ident "." Exp ; -CInt. Const ::= Integer ; -CStr. Const ::= String ; - TMono. Type1 ::= "Mono" Ident ; -TPoly. Type1 ::= "Poly" Ident ; -TArrow. Type ::= Type1 "->" Type ; +TPol. Type1 ::= "Poly" Ident ; +TArr. Type ::= Type1 "->" Type ; -- This doesn't seem to work so we'll have to live with ugly keywords for now -- token Upper (upper (letter | digit | '_')*) ; @@ -30,7 +29,3 @@ coercions Exp 5 ; comment "--" ; comment "{-" "-}" ; - --- Adt. Adt ::= "data" UIdent "=" [Constructor] ; --- Sum. Constructor ::= UIdent ; --- separator Constructor "|" ; diff --git a/language.cabal b/language.cabal index e3d40b9..5653f08 100644 --- a/language.cabal +++ b/language.cabal @@ -31,11 +31,15 @@ executable language Grammar.Print Grammar.Skel Grammar.ErrM - TypeChecker.TypeChecker - TypeChecker.TypeCheckerIr - TypeChecker.Unification - Renamer.Renamer - Renamer.RenamerIr + Auxiliary + -- TypeChecker.TypeChecker + -- TypeChecker.TypeCheckerIr + -- TypeChecker.Unification + TypeChecker.HM + TypeChecker.HMIr + Renamer.RenamerM + -- Renamer.Renamer + -- Renamer.RenamerIr hs-source-dirs: src diff --git a/src/Auxiliary.hs b/src/Auxiliary.hs new file mode 100644 index 0000000..735d804 --- /dev/null +++ b/src/Auxiliary.hs @@ -0,0 +1,21 @@ +{-# LANGUAGE LambdaCase #-} +module Auxiliary (module Auxiliary) where +import Control.Monad.Error.Class (liftEither) +import Control.Monad.Except (MonadError) +import Data.Either.Combinators (maybeToRight) + +snoc :: a -> [a] -> [a] +snoc x xs = xs ++ [x] + +maybeToRightM :: MonadError l m => l -> Maybe r -> m r +maybeToRightM err = liftEither . maybeToRight err + +mapAccumM :: Monad m => (s -> a -> m (s, b)) -> s -> [a] -> m (s, [b]) +mapAccumM f = go + where + go acc = \case + [] -> pure (acc, []) + x:xs -> do + (acc', x') <- f acc x + (acc'', xs') <- go acc' xs + pure (acc'', x':xs') diff --git a/src/Main.hs b/src/Main.hs index 68027d4..1ef3fe3 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -2,14 +2,14 @@ module Main where -import Grammar.Par (myLexer, pProgram) +import Grammar.Par (myLexer, pProgram) -- import TypeChecker.TypeChecker (typecheck) -import Grammar.Print (printTree) -import Renamer.Renamer (rename) -import System.Environment (getArgs) -import System.Exit (exitFailure, exitSuccess) -import TypeChecker.TypeChecker (typecheck) +import Grammar.Print (printTree) +import Renamer.RenamerM (rename) +import System.Environment (getArgs) +import System.Exit (exitFailure, exitSuccess) +import TypeChecker.HM (typecheck) main :: IO () main = @@ -27,24 +27,18 @@ main = putStrLn " ----- PARSER ----- " putStrLn "" putStrLn . printTree $ prg - case rename prg of + case typecheck (rename prg) of Left err -> do - putStrLn "FAILED RENAMING" + putStrLn "TYPECHECK ERROR" print err exitFailure Right prg -> do putStrLn "" - putStrLn " ----- RENAMER ----- " + putStrLn " ----- RAW ----- " putStrLn "" - putStrLn . printTree $ prg - case typecheck prg of - Left err -> do - putStrLn "TYPECHECK ERROR" - print err - exitFailure - Right prg -> do - putStrLn "" - putStrLn " ----- TYPECHECKER ----- " - putStrLn "" - print prg - exitSuccess + print prg + putStrLn "" + putStrLn " ----- TYPECHECKER ----- " + putStrLn "" + putStrLn $ printTree prg + exitSuccess diff --git a/src/Renamer/Renamer.hs b/src/Renamer/Renamer.hs index 8f09a51..c8b857e 100644 --- a/src/Renamer/Renamer.hs +++ b/src/Renamer/Renamer.hs @@ -38,7 +38,7 @@ renamePrg (Old.Program xs) = do return $ RProgram xs' renameBind :: Old.Bind -> Rename RBind -renameBind (Old.Bind i args e) = do +renameBind (Old.Bind n t i args e) = do insertSig i e' <- renameExp (makeLambda (reverse args) e) return $ RBind i e' @@ -53,12 +53,12 @@ renameExp = \case Old.EId i -> do st <- get case M.lookup i st.env of - Just n -> return $ RBound n i + Just n -> return $ RId i Nothing -> case S.member i st.sig of - True -> return $ RFree i + True -> return $ RId i False -> throwError $ UnboundVar (show i) - Old.EConst c -> return $ RConst c + Old.EInt c -> return $ RInt c Old.EAnn e t -> flip RAnn t <$> renameExp e diff --git a/src/Renamer/RenamerIr.hs b/src/Renamer/RenamerIr.hs index bac9915..77e2f1f 100644 --- a/src/Renamer/RenamerIr.hs +++ b/src/Renamer/RenamerIr.hs @@ -4,14 +4,12 @@ module Renamer.RenamerIr ( RExp (..), RBind (..), RProgram (..), - Const (..), Ident (..), Type (..), ) where import Grammar.Abs ( Bind (..), - Const (..), Ident (..), Program (..), Type (..), @@ -26,35 +24,9 @@ data RBind = RBind Ident RExp data RExp = RAnn RExp Type - | RBound Integer Ident - | RFree Ident - | RConst Const + | RId Ident + | RInt Integer | RApp RExp RExp | RAdd RExp RExp | RAbs Integer Ident RExp deriving (Eq, Ord, Show, Read) - -instance Print RProgram where - prt i = \case - RProgram defs -> prPrec i 0 (concatD [prt 0 defs]) - -instance Print RBind where - prt i = \case - RBind x e -> - prPrec i 0 $ - concatD - [ prt 0 x - , doc (showString "=") - , prt 0 e - , doc (showString "\n") - ] - -instance Print RExp where - prt i = \case - RAnn e t -> prPrec i 2 (concatD [prt 0 e, doc (showString ":"), prt 1 t]) - RBound n _ -> prPrec i 3 (concatD [prt 0 n]) - RFree id -> prPrec i 3 (concatD [prt 0 id]) - RConst n -> prPrec i 3 (concatD [prt 0 n]) - RApp e e1 -> prPrec i 2 (concatD [prt 2 e, prt 3 e1]) - RAdd e e1 -> prPrec i 1 (concatD [prt 1 e, doc (showString "+"), prt 2 e1]) - RAbs u _ e -> prPrec i 0 (concatD [doc (showString "λ"), prt 0 u, doc (showString "."), prt 0 e]) diff --git a/src/Renamer/RenamerM.hs b/src/Renamer/RenamerM.hs new file mode 100644 index 0000000..215290c --- /dev/null +++ b/src/Renamer/RenamerM.hs @@ -0,0 +1,83 @@ +{-# LANGUAGE LambdaCase #-} + +module Renamer.RenamerM where + +import Auxiliary (mapAccumM) +import Control.Monad.State (MonadState, State, evalState, gets, + modify) +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Maybe (fromMaybe) +import Data.Tuple.Extra (dupe) +import Grammar.Abs + + +-- | Rename all variables and local binds +rename :: Program -> Program +rename (Program bs) = Program $ evalState (runRn $ mapM (renameSc initNames) bs) 0 + where + initNames = Map.fromList $ map (\(Bind name _ _ _ _) -> dupe name) bs + renameSc :: Names -> Bind -> Rn Bind + renameSc old_names (Bind name t _ parms rhs) = do + (new_names, parms') <- newNames old_names parms + rhs' <- snd <$> renameExp new_names rhs + pure $ Bind name t name parms' rhs' + + +-- | Rename monad. State holds the number of renamed names. +newtype Rn a = Rn { runRn :: State Int a } + deriving (Functor, Applicative, Monad, MonadState Int) + +-- | Maps old to new name +type Names = Map Ident Ident + +renameLocalBind :: Names -> Bind -> Rn (Names, Bind) +renameLocalBind old_names (Bind name t _ parms rhs) = do + (new_names, name') <- newName old_names name + (new_names', parms') <- newNames new_names parms + (new_names'', rhs') <- renameExp new_names' rhs + pure (new_names'', Bind name' t name' parms' rhs') + +renameExp :: Names -> Exp -> Rn (Names, Exp) +renameExp old_names = \case + EId n -> pure (old_names, EId . fromMaybe n $ Map.lookup n old_names) + + EInt i1 -> pure (old_names, EInt i1) + + EApp e1 e2 -> do + (env1, e1') <- renameExp old_names e1 + (env2, e2') <- renameExp old_names e2 + pure (Map.union env1 env2, EApp e1' e2') + + EAdd e1 e2 -> do + (env1, e1') <- renameExp old_names e1 + (env2, e2') <- renameExp old_names e2 + pure (Map.union env1 env2, EAdd e1' e2') + + ELet i e1 e2 -> do + (new_names, e1') <- renameExp old_names e1 + (new_names', e2') <- renameExp new_names e2 + pure (new_names', ELet i e1' e2') + + EAbs par e -> do + (new_names, par') <- newName old_names par + (new_names', e') <- renameExp new_names e + pure (new_names', EAbs par' e') + + EAnn e t -> do + (new_names, e') <- renameExp old_names e + pure (new_names, EAnn e' t) + +-- | Create a new name and add it to name environment. +newName :: Names -> Ident -> Rn (Names, Ident) +newName env old_name = do + new_name <- makeName old_name + pure (Map.insert old_name new_name env, new_name) + +-- | Create multiple names and add them to the name environment +newNames :: Names -> [Ident] -> Rn (Names, [Ident]) +newNames = mapAccumM newName + +-- | Annotate name with number and increment the number @prefix ⇒ prefix_number@. +makeName :: Ident -> Rn Ident +makeName (Ident prefix) = gets (\i -> Ident $ prefix ++ "_" ++ show i) <* modify succ diff --git a/src/TypeChecker/HM.hs b/src/TypeChecker/HM.hs new file mode 100644 index 0000000..27ed8ba --- /dev/null +++ b/src/TypeChecker/HM.hs @@ -0,0 +1,155 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} +{-# HLINT ignore "Use traverse_" #-} + +module TypeChecker.HM (typecheck) where + +import Control.Monad.Except +import Control.Monad.State +import Data.Bifunctor (second) +import Data.Functor.Identity (Identity, runIdentity) +import Data.Map (Map) +import qualified Data.Map as M + +import Grammar.Abs +import Grammar.Print +import qualified TypeChecker.HMIr as T + +type Infer = StateT Ctx (ExceptT String Identity) +type Error = String + +data Ctx = Ctx { constr :: Map Type Type + , vars :: Map Ident Type + , sigs :: Map Ident Type + , frsh :: Char } + deriving Show + +run :: Infer a -> Either String a +run = runIdentity . runExceptT . flip evalStateT initC + +int = TMono "Int" + +initC :: Ctx +initC = Ctx M.empty M.empty M.empty 'a' + +typecheck :: Program -> Either Error T.Program +typecheck = run . inferPrg + +inferPrg :: Program -> Infer T.Program +inferPrg (Program bs) = do + traverse (\(Bind n t _ _ _) -> insertSig n t) bs + bs' <- mapM inferBind bs + return $ T.Program bs' + +inferBind :: Bind -> Infer T.Bind +inferBind (Bind i t _ params rhs) = do + (t',e') <- inferExp (makeLambda (reverse params) rhs) + addConstraint t t' + -- when (t /= t') (throwError $ "Signature of function" ++ printTree i ++ "does not match inferred type of expression: " ++ printTree e') + return $ T.Bind (t,i) [] e' + +makeLambda :: [Ident] -> Exp -> Exp +makeLambda xs e = foldl (flip EAbs) e xs + +inferExp :: Exp -> Infer (Type, T.Exp) +inferExp = \case + EAnn e t -> do + (t',e') <- inferExp e + when (t' /= t) (throwError "Annotated type and inferred type don't match") + return (t', e') + EInt i -> return (int, T.EInt int i) + EId i -> (\t -> (t, T.EId t i)) <$> lookupVar i + EAdd e1 e2 -> do + (t1, e1') <- inferExp e1 + (t2, e2') <- inferExp e2 + unless (isInt t1 && isInt t2) (throwError "Can not add non-ints") + return (int,T.EAdd int e1' e2') + EApp e1 e2 -> do + (t1, e1') <- inferExp e1 + (t2, e2') <- inferExp e2 + fr <- fresh + addConstraint t1 (TArr t2 fr) + return (fr, T.EApp fr e1' e2') + EAbs name e -> do + fr <- fresh + insertVar name fr + (ret_t,e') <- inferExp e + t <- solveConstraints (TArr fr ret_t) + return (t, T.EAbs t name e') + ELet name e1 e2 -> do + fr <- fresh + insertVar name fr + (t1, e1') <- inferExp e1 + (t2, e2') <- inferExp e2 + ret_t <- solveConstraints t1 + return (ret_t, T.ELet ret_t name e1' e2') + + +isInt :: Type -> Bool +isInt (TMono "Int") = True +isInt _ = False + +lookupVar :: Ident -> Infer Type +lookupVar i = do + st <- get + case M.lookup i (vars st) of + Just t -> return t + Nothing -> case M.lookup i (sigs st) of + Just t -> return t + Nothing -> throwError $ "Unbound variable or function" ++ printTree i + +insertVar :: Ident -> Type -> Infer () +insertVar s t = modify ( \st -> st { vars = M.insert s t (vars st) } ) + +insertSig :: Ident -> Type -> Infer () +insertSig s t = modify ( \st -> st { sigs = M.insert s t (sigs st) } ) + + +fresh :: Infer Type +fresh = do + chr <- gets frsh + modify (\st -> st { frsh = succ chr }) + return $ TPol (Ident [chr]) + +addConstraint :: Type -> Type -> Infer () +addConstraint t1 t2 = do + when (t2 `contains` t1) (throwError $ "Can't match type " ++ printTree t1 ++ " with " ++ printTree t2) + modify (\st -> st { constr = M.insert t1 t2 (constr st) }) + +contains :: Type -> Type -> Bool +contains (TArr t1 t2) b = t1 `contains` b || t2 `contains` b +contains (TMono a) (TMono b) = False +contains a b = a == b + +solveConstraints :: Type -> Infer Type +solveConstraints t = do + c <- gets constr + v <- gets vars + subst t <$> solveAll (M.toList c) + +subst :: Type -> [(Type, Type)] -> Type +subst t [] = t +subst (TArr t1 t2) (x:xs) = subst (TArr (replace x t1) (replace x t2)) xs +subst t (x:xs) = subst (replace x t) xs + +solveAll :: [(Type, Type)] -> Infer [(Type, Type)] +solveAll [] = return [] +solveAll (x:xs) = case x of + (TArr t1 t2, TArr t3 t4) -> solveAll $ (t1,t3) : (t2,t4) : xs + (TArr t1 t2, b) -> fmap ((b, TArr t1 t2) :) $ solveAll $ solve (b, TArr t1 t2) xs + (a, TArr t1 t2) -> fmap ((a, TArr t1 t2) :) $ solveAll $ solve (a, TArr t1 t2) xs + (TMono a, TPol b) -> fmap ((TPol b, TMono a) :) $ solveAll $ solve (TPol b, TMono a) xs + (TPol a, TMono b) -> fmap ((TPol a, TMono a) :) $ solveAll $ solve (TPol a, TMono b) xs + (TMono a, TMono b) -> if a == b then solveAll xs else throwError "Can't unify types" + (TPol a, TPol b) -> fmap ((TPol a, TPol b) :) $ solveAll $ solve (TPol a, TPol b) xs + +solve :: (Type, Type) -> [(Type, Type)] -> [(Type, Type)] +solve x = map (second (replace x)) + +replace :: (Type, Type) -> Type -> Type +replace a (TArr t1 t2) = TArr (replace a t1) (replace a t2) +replace (a,b) c = if a==c then b else c + +-- Known bugs +-- (x : a) + 3 type checks diff --git a/src/TypeChecker/HMIr.hs b/src/TypeChecker/HMIr.hs new file mode 100644 index 0000000..f0158b6 --- /dev/null +++ b/src/TypeChecker/HMIr.hs @@ -0,0 +1,102 @@ +{-# LANGUAGE LambdaCase #-} + +module TypeChecker.HMIr + ( module Grammar.Abs + , module TypeChecker.HMIr + ) where + +import Grammar.Abs (Ident (..), Type (..)) +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 Type Ident + | EInt Type Integer + | ELet Type Ident Exp Exp + | EApp Type Exp Exp + | EAdd Type Exp Exp + | EAbs Type Ident Exp + deriving (C.Eq, C.Ord, C.Show, C.Read) + +type Id = (Type, Ident) + +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 name@(n, _) parms rhs) = prPrec i 0 $ concatD + [ prtId 0 name + , doc $ showString ";" + , prt 0 n + , 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 [prt 0 n] + EInt _ i1 -> prPrec i 3 $ concatD [prt 0 i1] + ELet _ name e1 e2 -> prPrec i 3 $ concatD + [ doc $ showString "let" + , prt 0 name + , prt 0 e1 + , doc $ showString "in" + , prt 0 e2 + ] + EApp t e1 e2 -> prPrec i 2 $ concatD + [ doc $ showString "@" + , prt 0 t + , 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 "\\" + , prt 0 n + , doc $ showString "." + , prt 0 e + ] + + + diff --git a/src/TypeChecker/TypeChecker.hs b/src/TypeChecker/TypeChecker.hs index 48d26ac..99a1e17 100644 --- a/src/TypeChecker/TypeChecker.hs +++ b/src/TypeChecker/TypeChecker.hs @@ -1,153 +1,153 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedRecordDot #-} -{-# LANGUAGE OverloadedStrings #-} +-- {-# LANGUAGE LambdaCase #-} +-- {-# LANGUAGE OverloadedRecordDot #-} +-- {-# LANGUAGE OverloadedStrings #-} module TypeChecker.TypeChecker where -import Control.Monad (void) -import Control.Monad.Except (ExceptT, runExceptT, throwError) -import Control.Monad.State (StateT) -import qualified Control.Monad.State as St -import Data.Functor.Identity (Identity, runIdentity) -import Data.Map (Map) -import qualified Data.Map as M +-- import Control.Monad (void) +-- import Control.Monad.Except (ExceptT, runExceptT, throwError) +-- import Control.Monad.State (StateT) +-- import qualified Control.Monad.State as St +-- import Data.Functor.Identity (Identity, runIdentity) +-- import Data.Map (Map) +-- import qualified Data.Map as M -import TypeChecker.TypeCheckerIr +-- import TypeChecker.TypeCheckerIr -data Ctx = Ctx - { vars :: Map Integer Type - , sigs :: Map Ident Type - , nextFresh :: Int - } - deriving (Show) +-- data Ctx = Ctx +-- { vars :: Map Integer Type +-- , sigs :: Map Ident Type +-- , nextFresh :: Int +-- } +-- deriving (Show) --- Perhaps swap over to reader monad instead for vars and sigs. -type Infer = StateT Ctx (ExceptT Error Identity) +-- -- Perhaps swap over to reader monad instead for vars and sigs. +-- type Infer = StateT Ctx (ExceptT Error Identity) -{- +-- {- -The type checker will assume we first rename all variables to unique name, as to not -have to care about scoping. It significantly improves the quality of life of the -programmer. +-- The type checker will assume we first rename all variables to unique name, as to not +-- have to care about scoping. It significantly improves the quality of life of the +-- programmer. -TODOs: - Add skolemization variables. i.e - { \x. 3 : forall a. a -> a } - should not type check +-- TODOs: +-- Add skolemization variables. i.e +-- { \x. 3 : forall a. a -> a } +-- should not type check - Generalize. Not really sure what that means though +-- Generalize. Not really sure what that means though --} +-- -} -typecheck :: RProgram -> Either Error TProgram -typecheck = todo +-- typecheck :: RProgram -> Either Error TProgram +-- typecheck = todo -run :: Infer a -> Either Error a -run = runIdentity . runExceptT . flip St.evalStateT (Ctx mempty mempty 0) +-- run :: Infer a -> Either Error a +-- run = runIdentity . runExceptT . flip St.evalStateT (Ctx mempty mempty 0) --- Have to figure out a way to coerce polymorphic types to monomorphic ones where necessary --- { \x. \y. x + y } will have the type { a -> b -> Int } -inferExp :: RExp -> Infer Type -inferExp = \case +-- -- Have to figure out a way to coerce polymorphic types to monomorphic ones where necessary +-- -- { \x. \y. x + y } will have the type { a -> b -> Int } +-- inferExp :: RExp -> Infer Type +-- inferExp = \case - RAnn expr typ -> do - t <- inferExp expr - void $ t =:= typ - return t +-- RAnn expr typ -> do +-- t <- inferExp expr +-- void $ t =:= typ +-- return t - RBound num name -> lookupVars num +-- RBound num name -> lookupVars num - RFree name -> lookupSigs name +-- RFree name -> lookupSigs name - RConst (CInt i) -> return $ TMono "Int" +-- RConst (CInt i) -> return $ TMono "Int" - RConst (CStr str) -> return $ TMono "Str" +-- RConst (CStr str) -> return $ TMono "Str" - RAdd expr1 expr2 -> do - let int = TMono "Int" - typ1 <- check expr1 int - typ2 <- check expr2 int - return int +-- RAdd expr1 expr2 -> do +-- let int = TMono "Int" +-- typ1 <- check expr1 int +-- typ2 <- check expr2 int +-- return int - RApp expr1 expr2 -> do - fn_t <- inferExp expr1 - arg_t <- inferExp expr2 - res <- fresh - new_t <- fn_t =:= TArrow arg_t res - return res +-- RApp expr1 expr2 -> do +-- fn_t <- inferExp expr1 +-- arg_t <- inferExp expr2 +-- res <- fresh +-- new_t <- fn_t =:= TArrow arg_t res +-- return res - RAbs num name expr -> do - arg <- fresh - insertVars num arg - typ <- inferExp expr - return $ TArrow arg typ +-- RAbs num name expr -> do +-- arg <- fresh +-- insertVars num arg +-- typ <- inferExp expr +-- return $ TArrow arg typ -check :: RExp -> Type -> Infer () -check e t = do - t' <- inferExp e - t =:= t' - return () +-- check :: RExp -> Type -> Infer () +-- check e t = do +-- t' <- inferExp e +-- t =:= t' +-- return () -fresh :: Infer Type -fresh = do - var <- St.gets nextFresh - St.modify (\st -> st {nextFresh = succ var}) - return (TPoly $ Ident (show var)) +-- fresh :: Infer Type +-- fresh = do +-- var <- St.gets nextFresh +-- St.modify (\st -> st {nextFresh = succ var}) +-- return (TPoly $ Ident (show var)) --- | Unify two types. -(=:=) :: Type -> Type -> Infer Type -(=:=) (TPoly _) b = return b -(=:=) a (TPoly _) = return a -(=:=) (TMono a) (TMono b) | a == b = return (TMono a) -(=:=) (TArrow a b) (TArrow c d) = do - t1 <- a =:= c - t2 <- b =:= d - return $ TArrow t1 t2 -(=:=) a b = throwError (TypeMismatch $ unwords ["Can not unify type", show a, "with", show b]) +-- -- | Unify two types. +-- (=:=) :: Type -> Type -> Infer Type +-- (=:=) (TPoly _) b = return b +-- (=:=) a (TPoly _) = return a +-- (=:=) (TMono a) (TMono b) | a == b = return (TMono a) +-- (=:=) (TArrow a b) (TArrow c d) = do +-- t1 <- a =:= c +-- t2 <- b =:= d +-- return $ TArrow t1 t2 +-- (=:=) a b = throwError (TypeMismatch $ unwords ["Can not unify type", show a, "with", show b]) -lookupVars :: Integer -> Infer Type -lookupVars i = do - st <- St.gets vars - case M.lookup i st of - Just t -> return t - Nothing -> throwError $ UnboundVar "lookupVars" +-- lookupVars :: Integer -> Infer Type +-- lookupVars i = do +-- st <- St.gets vars +-- case M.lookup i st of +-- Just t -> return t +-- Nothing -> throwError $ UnboundVar "lookupVars" -insertVars :: Integer -> Type -> Infer () -insertVars i t = do - st <- St.get - St.put (st {vars = M.insert i t st.vars}) +-- insertVars :: Integer -> Type -> Infer () +-- insertVars i t = do +-- st <- St.get +-- St.put (st {vars = M.insert i t st.vars}) -lookupSigs :: Ident -> Infer Type -lookupSigs i = do - st <- St.gets sigs - case M.lookup i st of - Just t -> return t - Nothing -> throwError $ UnboundVar "lookupSigs" +-- lookupSigs :: Ident -> Infer Type +-- lookupSigs i = do +-- st <- St.gets sigs +-- case M.lookup i st of +-- Just t -> return t +-- Nothing -> throwError $ UnboundVar "lookupSigs" -insertSigs :: Ident -> Type -> Infer () -insertSigs i t = do - st <- St.get - St.put (st {sigs = M.insert i t st.sigs}) +-- insertSigs :: Ident -> Type -> Infer () +-- insertSigs i t = do +-- st <- St.get +-- St.put (st {sigs = M.insert i t st.sigs}) -{-# WARNING todo "TODO IN CODE" #-} -todo :: a -todo = error "TODO in code" +-- {-# WARNING todo "TODO IN CODE" #-} +-- todo :: a +-- todo = error "TODO in code" -data Error - = TypeMismatch String - | NotNumber String - | FunctionTypeMismatch String - | NotFunction String - | UnboundVar String - | AnnotatedMismatch String - | Default String - deriving (Show) +-- data Error +-- = TypeMismatch String +-- | NotNumber String +-- | FunctionTypeMismatch String +-- | NotFunction String +-- | UnboundVar String +-- | AnnotatedMismatch String +-- | Default String +-- deriving (Show) -{- +-- {- -The procedure inst(σ) specializes the polytype -σ by copying the term and replacing the bound type variables -consistently by new monotype variables. +-- The procedure inst(σ) specializes the polytype +-- σ by copying the term and replacing the bound type variables +-- consistently by new monotype variables. --} +-- -} diff --git a/src/TypeChecker/TypeCheckerIr.hs b/src/TypeChecker/TypeCheckerIr.hs index 6845afd..c08d981 100644 --- a/src/TypeChecker/TypeCheckerIr.hs +++ b/src/TypeChecker/TypeCheckerIr.hs @@ -1,74 +1,74 @@ -{-# LANGUAGE LambdaCase #-} +-- {-# LANGUAGE LambdaCase #-} -module TypeChecker.TypeCheckerIr ( - TProgram (..), - TBind (..), - TExp (..), - RProgram (..), - RBind (..), - RExp (..), - Type (..), - Const (..), - Ident (..), -) where +module TypeChecker.TypeCheckerIr --( +-- TProgram (..), +-- TBind (..), +-- TExp (..), +-- RProgram (..), +-- RBind (..), +-- RExp (..), +-- Type (..), +-- Const (..), +-- Ident (..), +-- ) where -import Grammar.Print -import Renamer.RenamerIr +-- import Grammar.Print +-- import Renamer.RenamerIr -newtype TProgram = TProgram [TBind] - deriving (Eq, Show, Read, Ord) +-- newtype TProgram = TProgram [TBind] +-- deriving (Eq, Show, Read, Ord) -data TBind = TBind Ident Type TExp - deriving (Eq, Show, Read, Ord) +-- data TBind = TBind Ident Type TExp +-- deriving (Eq, Show, Read, Ord) -data TExp - = TAnn TExp Type - | TBound Integer Ident Type - | TFree Ident Type - | TConst Const Type - | TApp TExp TExp Type - | TAdd TExp TExp Type - | TAbs Integer Ident TExp Type - deriving (Eq, Ord, Show, Read) +-- data TExp +-- = TAnn TExp Type +-- | TBound Integer Ident Type +-- | TFree Ident Type +-- | TConst Const Type +-- | TApp TExp TExp Type +-- | TAdd TExp TExp Type +-- | TAbs Integer Ident TExp Type +-- deriving (Eq, Ord, Show, Read) -instance Print TProgram where - prt i = \case - TProgram defs -> prPrec i 0 (concatD [prt 0 defs]) +-- instance Print TProgram where +-- prt i = \case +-- TProgram defs -> prPrec i 0 (concatD [prt 0 defs]) -instance Print TBind where - prt i = \case - TBind x t e -> - prPrec i 0 $ - concatD - [ prt 0 x - , doc (showString ":") - , prt 0 t - , doc (showString "=") - , prt 0 e - , doc (showString "\n") - ] +-- instance Print TBind where +-- prt i = \case +-- TBind x t e -> +-- prPrec i 0 $ +-- concatD +-- [ prt 0 x +-- , doc (showString ":") +-- , prt 0 t +-- , doc (showString "=") +-- , prt 0 e +-- , doc (showString "\n") +-- ] -instance Print TExp where - prt i = \case - TAnn e t -> - prPrec i 2 $ - concatD - [ prt 0 e - , doc (showString ":") - , prt 1 t - ] - TBound _ u t -> prPrec i 3 $ concatD [prt 0 u] - TFree u t -> prPrec i 3 $ concatD [prt 0 u] - TConst c _ -> prPrec i 3 (concatD [prt 0 c]) - TApp e e1 t -> prPrec i 2 $ concatD [prt 2 e, prt 3 e1] - TAdd e e1 t -> prPrec i 1 $ concatD [prt 1 e, doc (showString "+"), prt 2 e1] - TAbs _ u e t -> - prPrec i 0 $ - concatD - [ doc (showString "(") - , doc (showString "λ") - , prt 0 u - , doc (showString ".") - , prt 0 e - , doc (showString ")") - ] +-- instance Print TExp where +-- prt i = \case +-- TAnn e t -> +-- prPrec i 2 $ +-- concatD +-- [ prt 0 e +-- , doc (showString ":") +-- , prt 1 t +-- ] +-- TBound _ u t -> prPrec i 3 $ concatD [prt 0 u] +-- TFree u t -> prPrec i 3 $ concatD [prt 0 u] +-- TConst c _ -> prPrec i 3 (concatD [prt 0 c]) +-- TApp e e1 t -> prPrec i 2 $ concatD [prt 2 e, prt 3 e1] +-- TAdd e e1 t -> prPrec i 1 $ concatD [prt 1 e, doc (showString "+"), prt 2 e1] +-- TAbs _ u e t -> +-- prPrec i 0 $ +-- concatD +-- [ doc (showString "(") +-- , doc (showString "λ") +-- , prt 0 u +-- , doc (showString ".") +-- , prt 0 e +-- , doc (showString ")") +-- ] diff --git a/test_program b/test_program index 0639729..b81c8de 100644 --- a/test_program +++ b/test_program @@ -1,3 +1,4 @@ -test = \x. (x : Mono String) ; +main : Mono Int ; +main = let f = \x. x in f 5 ; + -apply x y = x + y ; From db932048bab8d46070b6888b5d2427cb8f9309d4 Mon Sep 17 00:00:00 2001 From: sebastianselander Date: Sun, 19 Feb 2023 02:10:57 +0100 Subject: [PATCH 035/372] Tried fixing bug. Failed. --- src/TypeChecker/HM.hs | 58 ++++++++++++++++++++++++++--------------- src/TypeChecker/HMIr.hs | 10 ++++++- test_program | 7 ++--- 3 files changed, 50 insertions(+), 25 deletions(-) diff --git a/src/TypeChecker/HM.hs b/src/TypeChecker/HM.hs index 27ed8ba..8671d1b 100644 --- a/src/TypeChecker/HM.hs +++ b/src/TypeChecker/HM.hs @@ -3,11 +3,11 @@ {-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} {-# HLINT ignore "Use traverse_" #-} -module TypeChecker.HM (typecheck) where +module TypeChecker.HM where import Control.Monad.Except import Control.Monad.State -import Data.Bifunctor (second) +import Data.Bifunctor (bimap, second) import Data.Functor.Identity (Identity, runIdentity) import Data.Map (Map) import qualified Data.Map as M @@ -25,16 +25,14 @@ data Ctx = Ctx { constr :: Map Type Type , frsh :: Char } deriving Show -run :: Infer a -> Either String a -run = runIdentity . runExceptT . flip evalStateT initC - -int = TMono "Int" +run :: Infer a -> Either String (a, Ctx) +run = runIdentity . runExceptT . flip runStateT initC initC :: Ctx initC = Ctx M.empty M.empty M.empty 'a' typecheck :: Program -> Either Error T.Program -typecheck = run . inferPrg +typecheck = undefined . run . inferPrg inferPrg :: Program -> Infer T.Program inferPrg (Program bs) = do @@ -61,10 +59,8 @@ inferExp = \case EInt i -> return (int, T.EInt int i) EId i -> (\t -> (t, T.EId t i)) <$> lookupVar i EAdd e1 e2 -> do - (t1, e1') <- inferExp e1 - (t2, e2') <- inferExp e2 - unless (isInt t1 && isInt t2) (throwError "Can not add non-ints") - return (int,T.EAdd int e1' e2') + insertSig "+" (TArr int (TArr int int)) + inferExp (EApp (EApp (EId "+") e1) e2) EApp e1 e2 -> do (t1, e1') <- inferExp e1 (t2, e2') <- inferExp e2 @@ -77,13 +73,7 @@ inferExp = \case (ret_t,e') <- inferExp e t <- solveConstraints (TArr fr ret_t) return (t, T.EAbs t name e') - ELet name e1 e2 -> do - fr <- fresh - insertVar name fr - (t1, e1') <- inferExp e1 - (t2, e2') <- inferExp e2 - ret_t <- solveConstraints t1 - return (ret_t, T.ELet ret_t name e1' e2') + ELet name e1 e2 -> error "Let expression not implemented yet" isInt :: Type -> Bool @@ -112,6 +102,8 @@ fresh = do modify (\st -> st { frsh = succ chr }) return $ TPol (Ident [chr]) +-- Constraint solving is wrong. (\x. x) 3 is inferred with the type 'a' + addConstraint :: Type -> Type -> Infer () addConstraint t1 t2 = do when (t2 `contains` t1) (throwError $ "Can't match type " ++ printTree t1 ++ " with " ++ printTree t2) @@ -126,13 +118,16 @@ solveConstraints :: Type -> Infer Type solveConstraints t = do c <- gets constr v <- gets vars - subst t <$> solveAll (M.toList c) + xs <- solveAll (M.toList c) + modify (\st -> st { constr = M.fromList xs }) + return $ subst t xs subst :: Type -> [(Type, Type)] -> Type subst t [] = t subst (TArr t1 t2) (x:xs) = subst (TArr (replace x t1) (replace x t2)) xs subst t (x:xs) = subst (replace x t) xs +-- Annoying fucking bug here solveAll :: [(Type, Type)] -> Infer [(Type, Type)] solveAll [] = return [] solveAll (x:xs) = case x of @@ -140,16 +135,37 @@ solveAll (x:xs) = case x of (TArr t1 t2, b) -> fmap ((b, TArr t1 t2) :) $ solveAll $ solve (b, TArr t1 t2) xs (a, TArr t1 t2) -> fmap ((a, TArr t1 t2) :) $ solveAll $ solve (a, TArr t1 t2) xs (TMono a, TPol b) -> fmap ((TPol b, TMono a) :) $ solveAll $ solve (TPol b, TMono a) xs - (TPol a, TMono b) -> fmap ((TPol a, TMono a) :) $ solveAll $ solve (TPol a, TMono b) xs + (TPol a, TMono b) -> fmap ((TPol a, TMono b) :) $ solveAll $ solve (TPol a, TMono b) xs (TMono a, TMono b) -> if a == b then solveAll xs else throwError "Can't unify types" (TPol a, TPol b) -> fmap ((TPol a, TPol b) :) $ solveAll $ solve (TPol a, TPol b) xs solve :: (Type, Type) -> [(Type, Type)] -> [(Type, Type)] -solve x = map (second (replace x)) +solve x = map (both (replace x)) replace :: (Type, Type) -> Type -> Type replace a (TArr t1 t2) = TArr (replace a t1) (replace a t2) replace (a,b) c = if a==c then b else c +both :: (a -> b) -> (a,a) -> (b,b) +both f = bimap f f + +int = TMono "Int" +a = TPol "a" +b = TPol "b" +c = TPol "c" +d = TPol "d" +e = TPol "e" +arr = TArr + +set = [(a, arr d e), (c, arr int d), (arr int (arr int int), arr b c)] + +prg = EAbs "f" (EAbs "x" (EApp (EId "f") (EAdd (EId "x") (EInt 1)))) + +bug = EApp (EAbs "x" (EAdd (EAnn (EId "x") a) (EInt 3))) (EInt 2) + +-- (\x. \y. x + y + 1) +prg2 = EApp (EAbs "x" (EId "x")) (EInt 1) + +-- -- Known bugs -- (x : a) + 3 type checks diff --git a/src/TypeChecker/HMIr.hs b/src/TypeChecker/HMIr.hs index f0158b6..036fa42 100644 --- a/src/TypeChecker/HMIr.hs +++ b/src/TypeChecker/HMIr.hs @@ -20,7 +20,15 @@ data Exp | EApp Type Exp Exp | EAdd Type Exp Exp | EAbs Type Ident Exp - deriving (C.Eq, C.Ord, C.Show, C.Read) + deriving (C.Eq, C.Ord, C.Read) + +instance Show Exp where + show (EId t (Ident i)) = i ++ " : " ++ show t + show (EInt _ i) = show i + show (ELet t i e1 e2) = error "Show for let not implemented" + show (EApp t e1 e2) = show e1 ++ " " ++ show e2 ++ " : " ++ show t + show (EAdd _ e1 e2) = show e1 ++ " + " ++ show e2 + show (EAbs t (Ident i) e) = "\\ " ++ i ++ ". " ++ show e ++ " : " ++ show t type Id = (Type, Ident) diff --git a/test_program b/test_program index b81c8de..e342096 100644 --- a/test_program +++ b/test_program @@ -1,4 +1,5 @@ -main : Mono Int ; -main = let f = \x. x in f 5 ; - +id : Mono Int -> Mono Int ; +id = \x. x ; +main : Poly a ; +main = id 3 ; From 420fb107f0867ab86ed7532d17685e8ab4b7de2e Mon Sep 17 00:00:00 2001 From: sebastianselander Date: Sun, 19 Feb 2023 15:25:49 +0100 Subject: [PATCH 036/372] Commented code and fixed some bugs I think. Still not complete id : Int -> Int id x = x does not type check --- src/TypeChecker/HM.hs | 126 ++++++++++++++++++++++-------------------- test_program | 7 +-- 2 files changed, 67 insertions(+), 66 deletions(-) diff --git a/src/TypeChecker/HM.hs b/src/TypeChecker/HM.hs index 8671d1b..63072d1 100644 --- a/src/TypeChecker/HM.hs +++ b/src/TypeChecker/HM.hs @@ -2,6 +2,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} {-# HLINT ignore "Use traverse_" #-} +{-# LANGUAGE FlexibleInstances #-} module TypeChecker.HM where @@ -25,14 +26,17 @@ data Ctx = Ctx { constr :: Map Type Type , frsh :: Char } deriving Show -run :: Infer a -> Either String (a, Ctx) -run = runIdentity . runExceptT . flip runStateT initC +runC :: Ctx -> Infer a -> Either String (a, Ctx) +runC c = runIdentity . runExceptT . flip runStateT c + +run :: Infer a -> Either String a +run = runIdentity . runExceptT . flip evalStateT initC initC :: Ctx initC = Ctx M.empty M.empty M.empty 'a' typecheck :: Program -> Either Error T.Program -typecheck = undefined . run . inferPrg +typecheck = run . inferPrg inferPrg :: Program -> Infer T.Program inferPrg (Program bs) = do @@ -42,39 +46,54 @@ inferPrg (Program bs) = do inferBind :: Bind -> Infer T.Bind inferBind (Bind i t _ params rhs) = do - (t',e') <- inferExp (makeLambda (reverse params) rhs) - addConstraint t t' - -- when (t /= t') (throwError $ "Signature of function" ++ printTree i ++ "does not match inferred type of expression: " ++ printTree e') + (t',e') <- inferExp (makeLambda rhs (reverse params)) + when (t /= t') (throwError $ "Signature of function " ++ show i ++ " with type: " ++ show t ++ " does not match inferred type " ++ show t' ++ " of expression: " ++ show e') return $ T.Bind (t,i) [] e' -makeLambda :: [Ident] -> Exp -> Exp -makeLambda xs e = foldl (flip EAbs) e xs +makeLambda :: Exp -> [Ident] -> Exp +makeLambda = foldl (flip EAbs) inferExp :: Exp -> Infer (Type, T.Exp) -inferExp = \case - EAnn e t -> do - (t',e') <- inferExp e - when (t' /= t) (throwError "Annotated type and inferred type don't match") - return (t', e') - EInt i -> return (int, T.EInt int i) - EId i -> (\t -> (t, T.EId t i)) <$> lookupVar i - EAdd e1 e2 -> do - insertSig "+" (TArr int (TArr int int)) - inferExp (EApp (EApp (EId "+") e1) e2) - EApp e1 e2 -> do - (t1, e1') <- inferExp e1 - (t2, e2') <- inferExp e2 - fr <- fresh - addConstraint t1 (TArr t2 fr) - return (fr, T.EApp fr e1' e2') - EAbs name e -> do - fr <- fresh - insertVar name fr - (ret_t,e') <- inferExp e - t <- solveConstraints (TArr fr ret_t) - return (t, T.EAbs t name e') - ELet name e1 e2 -> error "Let expression not implemented yet" +inferExp e = do + (t, e') <- inferExp' e + t'' <- solveConstraints t + return (t'', replaceType t'' e') + where + inferExp' :: Exp -> Infer (Type, T.Exp) + inferExp' = \case + EAnn e t -> do + (t',e') <- inferExp' e + t'' <- solveConstraints t' + when (t'' /= t) (throwError "Annotated type and inferred type don't match") + return (t', e') + EInt i -> return (int, T.EInt int i) + EId i -> (\t -> (t, T.EId t i)) <$> lookupVar i + EAdd e1 e2 -> do + insertSig "+" (TArr int (TArr int int)) + inferExp' (EApp (EApp (EId "+") e1) e2) + EApp e1 e2 -> do + (t1, e1') <- inferExp' e1 + (t2, e2') <- inferExp' e2 + fr <- fresh + addConstraint t1 (TArr t2 fr) + return (fr, T.EApp fr e1' e2') + EAbs name e -> do + fr <- fresh + insertVar name fr + (ret_t,e') <- inferExp' e + t <- solveConstraints (TArr fr ret_t) + return (t, T.EAbs t name e') + ELet name e1 e2 -> error "Let expression not implemented yet" + +replaceType :: Type -> T.Exp -> T.Exp +replaceType t = \case + T.EInt _ i -> T.EInt t i + T.EId _ i -> T.EId t i + T.EAdd _ e1 e2 -> T.EAdd t e1 e2 + T.EApp _ e1 e2 -> T.EApp t e1 e2 + T.EAbs _ name e -> T.EAbs t name e + T.ELet _ name e1 e2 -> T.ELet t name e1 e2 isInt :: Type -> Bool isInt (TMono "Int") = True @@ -95,25 +114,24 @@ insertVar s t = modify ( \st -> st { vars = M.insert s t (vars st) } ) insertSig :: Ident -> Type -> Infer () insertSig s t = modify ( \st -> st { sigs = M.insert s t (sigs st) } ) - +-- | Generate a new fresh variable and increment the state fresh :: Infer Type fresh = do chr <- gets frsh modify (\st -> st { frsh = succ chr }) return $ TPol (Ident [chr]) --- Constraint solving is wrong. (\x. x) 3 is inferred with the type 'a' - +-- | Adds a constraint to the constraint set. +-- i.e: a = int -> b +-- b = int +-- thus when solving constraints it must be the case that +-- a = int -> int +-- addConstraint :: Type -> Type -> Infer () addConstraint t1 t2 = do - when (t2 `contains` t1) (throwError $ "Can't match type " ++ printTree t1 ++ " with " ++ printTree t2) modify (\st -> st { constr = M.insert t1 t2 (constr st) }) -contains :: Type -> Type -> Bool -contains (TArr t1 t2) b = t1 `contains` b || t2 `contains` b -contains (TMono a) (TMono b) = False -contains a b = a == b - +-- | Given a type, solve the constraints and figure out the type that should be assigned to it. solveConstraints :: Type -> Infer Type solveConstraints t = do c <- gets constr @@ -122,12 +140,15 @@ solveConstraints t = do modify (\st -> st { constr = M.fromList xs }) return $ subst t xs +-- | Substitute subst :: Type -> [(Type, Type)] -> Type subst t [] = t subst (TArr t1 t2) (x:xs) = subst (TArr (replace x t1) (replace x t2)) xs subst t (x:xs) = subst (replace x t) xs --- Annoying fucking bug here +-- | Given a set of constraints run the replacement on all of them, producing a new set of +-- replacements. +-- https://youtu.be/trmq3wYcUxU - good video for explanation solveAll :: [(Type, Type)] -> Infer [(Type, Type)] solveAll [] = return [] solveAll (x:xs) = case x of @@ -136,12 +157,14 @@ solveAll (x:xs) = case x of (a, TArr t1 t2) -> fmap ((a, TArr t1 t2) :) $ solveAll $ solve (a, TArr t1 t2) xs (TMono a, TPol b) -> fmap ((TPol b, TMono a) :) $ solveAll $ solve (TPol b, TMono a) xs (TPol a, TMono b) -> fmap ((TPol a, TMono b) :) $ solveAll $ solve (TPol a, TMono b) xs - (TMono a, TMono b) -> if a == b then solveAll xs else throwError "Can't unify types" (TPol a, TPol b) -> fmap ((TPol a, TPol b) :) $ solveAll $ solve (TPol a, TPol b) xs + (TMono a, TMono b) -> if a == b then solveAll xs else throwError "Can't unify types" solve :: (Type, Type) -> [(Type, Type)] -> [(Type, Type)] solve x = map (both (replace x)) +-- | Given a constraint (type, type) and a type, if the constraint matches the input +-- replace with the constrained type replace :: (Type, Type) -> Type -> Type replace a (TArr t1 t2) = TArr (replace a t1) (replace a t2) replace (a,b) c = if a==c then b else c @@ -150,22 +173,3 @@ both :: (a -> b) -> (a,a) -> (b,b) both f = bimap f f int = TMono "Int" -a = TPol "a" -b = TPol "b" -c = TPol "c" -d = TPol "d" -e = TPol "e" -arr = TArr - -set = [(a, arr d e), (c, arr int d), (arr int (arr int int), arr b c)] - -prg = EAbs "f" (EAbs "x" (EApp (EId "f") (EAdd (EId "x") (EInt 1)))) - -bug = EApp (EAbs "x" (EAdd (EAnn (EId "x") a) (EInt 3))) (EInt 2) - --- (\x. \y. x + y + 1) -prg2 = EApp (EAbs "x" (EId "x")) (EInt 1) - --- --- Known bugs --- (x : a) + 3 type checks diff --git a/test_program b/test_program index e342096..6d38647 100644 --- a/test_program +++ b/test_program @@ -1,5 +1,2 @@ -id : Mono Int -> Mono Int ; -id = \x. x ; - -main : Poly a ; -main = id 3 ; +fun : Mono Int -> Mono Int ; +fun = \x. x ; From dfbdb6678edbb25083bcf2dc7515ac716e39a65e Mon Sep 17 00:00:00 2001 From: sebastianselander Date: Mon, 20 Feb 2023 12:09:31 +0100 Subject: [PATCH 037/372] Working on non-ugly version of algorithm W (Hindley-Milner) --- language.cabal | 1 + src/TypeChecker/AlgoW.hs | 123 +++++++++++++++++++++++++++++++++++++++ src/TypeChecker/HM.hs | 10 +++- 3 files changed, 132 insertions(+), 2 deletions(-) create mode 100644 src/TypeChecker/AlgoW.hs diff --git a/language.cabal b/language.cabal index 5653f08..7b21b60 100644 --- a/language.cabal +++ b/language.cabal @@ -36,6 +36,7 @@ executable language -- TypeChecker.TypeCheckerIr -- TypeChecker.Unification TypeChecker.HM + TypeChecker.AlgoW TypeChecker.HMIr Renamer.RenamerM -- Renamer.Renamer diff --git a/src/TypeChecker/AlgoW.hs b/src/TypeChecker/AlgoW.hs new file mode 100644 index 0000000..e630da2 --- /dev/null +++ b/src/TypeChecker/AlgoW.hs @@ -0,0 +1,123 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} + +module TypeChecker.AlgoW where + +import Control.Monad.Except +import Control.Monad.Reader +import Control.Monad.State +import Data.Bifunctor (bimap, second) +import Data.Functor.Identity (Identity, runIdentity) +import Data.List (intersect) +import Data.Map (Map) +import qualified Data.Map as M +import Data.Maybe (fromMaybe) + +import Grammar.Abs +import qualified TypeChecker.HMIr as T + +data Poly = Forall [Ident] Type + deriving Show + +a = TPol "a" +b = TPol "b" +int = TMono "int" +arr = TArr + +data Ctx = Ctx { vars :: Map Ident Poly + , sigs :: Map Ident Poly } + +data Env = Env { counter :: Int + , substitutions :: Map Type Type + } + +type Subst = Map Type Type +type Error = String + +newtype Infer a = Infer { runInfer :: StateT Env (ReaderT Ctx (ExceptT Error Identity)) a } + deriving (Functor, Applicative, Monad, MonadState Env, MonadReader Ctx, MonadError Error) + +initCtx :: Ctx +initCtx = Ctx mempty mempty + +initEnv :: Env +initEnv = Env 0 mempty + +run :: Ctx -> Env -> Infer a -> Either Error a +run c e = runIdentity . runExceptT . flip runReaderT c . flip evalStateT e . runInfer + +w :: Exp -> Infer Type +w = \case + EInt n -> return int + EId i -> (\(Forall _ t) -> t) <$> (lookupVar i >>= inst) + EAbs var e -> do + fr <- fresh + withBinding var (Forall [] (TPol fr)) $ do + t' <- w e + subst (Forall [] $ TArr (TPol fr) t') + EApp e0 e1 -> do + t0 <- substCtx (w e0) + t1 <- w e1 + undefined + +substCtx :: Infer Type -> Infer Type +substCtx m = do + vs <- asks (M.toList . vars) + ks <- traverse (subst . snd) vs + let x = map fst vs + local (\st -> st { vars = M.fromList $ zip x ks }) m + +subst :: Poly -> Infer Poly +subst (Forall xs t) = do + subs <- gets substitutions + case t of + TPol a -> case M.lookup (TPol a) subs of + Nothing -> return $ Forall xs t + Just t' -> return $ Forall (remove a xs) t' + TMono a -> case M.lookup (TMono a) subs of + Nothing -> return $ Forall xs t + Just t' -> return $ Forall (remove a xs) t' + TArr a b -> do + (Forall xs' a') <- subst (Forall xs a) + (Forall xs'' b') <- subst (Forall xs b) + return $ Forall (xs' `intersect` xs'') (TArr a' b') + + +remove :: Ord a => a -> [a] -> [a] +remove a = foldr (\x acc -> if x == a then acc else x : acc) [] + +inst :: Poly -> Infer Poly +inst (Forall xs t) = do + xs' <- mapM (const fresh) xs + let sub = zip xs xs' + let subst' t = case t of + TMono a -> return $ TMono a + TPol a -> case lookup a sub of + Nothing -> return $ TPol a + Just t -> return $ TPol t + TArr a b -> TArr <$> subst' a <*> subst' b + Forall [] <$> subst' t + +-- | Generate a new fresh variable and increment the state +fresh :: Infer Ident +fresh = do + n <- gets counter + modify (\st -> st { counter = n + 1 }) + return . Ident $ "t" ++ show n + +insertSub :: Type -> Type -> Infer () +insertSub t1 t2 = modify (\st -> st { substitutions = M.insert t1 t2 (substitutions st) }) + +withBinding :: Ident -> Poly -> Infer Poly -> Infer Type +withBinding i t m = (\(Forall _ t) -> t) <$> local (\re -> re { vars = M.insert i t (vars re) }) m + +lookupVar :: Ident -> Infer Poly +lookupVar i = do + m <- asks vars + case M.lookup i m of + Just t -> return t + Nothing -> throwError $ "Unbound variable: " ++ show i + +{-# WARNING todo "TODO IN CODE" #-} +todo :: a +todo = error "TODO in code" diff --git a/src/TypeChecker/HM.hs b/src/TypeChecker/HM.hs index 63072d1..7b33cbe 100644 --- a/src/TypeChecker/HM.hs +++ b/src/TypeChecker/HM.hs @@ -47,7 +47,14 @@ inferPrg (Program bs) = do inferBind :: Bind -> Infer T.Bind inferBind (Bind i t _ params rhs) = do (t',e') <- inferExp (makeLambda rhs (reverse params)) - when (t /= t') (throwError $ "Signature of function " ++ show i ++ " with type: " ++ show t ++ " does not match inferred type " ++ show t' ++ " of expression: " ++ show e') + when (t /= t') (throwError . unwords $ [ "Signature of function" + , show i + , "with type:" + , show t + , "does not match inferred type" + , show t' + , "of expression:" + , show e']) return $ T.Bind (t,i) [] e' makeLambda :: Exp -> [Ident] -> Exp @@ -126,7 +133,6 @@ fresh = do -- b = int -- thus when solving constraints it must be the case that -- a = int -> int --- addConstraint :: Type -> Type -> Infer () addConstraint t1 t2 = do modify (\st -> st { constr = M.insert t1 t2 (constr st) }) From 18e0a92fe023b67f17b1f2e9d21a95edaac1ec61 Mon Sep 17 00:00:00 2001 From: Samuel Hammersberg Date: Mon, 20 Feb 2023 14:39:00 +0100 Subject: [PATCH 038/372] Added grammar for case matching. --- Grammar.cf | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/Grammar.cf b/Grammar.cf index 8035af5..f98631e 100644 --- a/Grammar.cf +++ b/Grammar.cf @@ -7,11 +7,13 @@ ELet. Exp3 ::= "let" Bind "in" Exp; EApp. Exp2 ::= Exp2 Exp3; EAdd. Exp1 ::= Exp1 "+" Exp2; EAbs. Exp ::= "\\" Ident ":" Type "." Exp; -ECase. Exp ::= "case" Exp "of" "{" [CaseMatch] "}"; +ECase. Exp ::= "case" Exp "of" "{" [CaseMatch] "}" ":" Type; CaseMatch. CaseMatch ::= Case "=>" Exp ; separator CaseMatch ","; -CInt. Case ::= Integer ; + +CInt. Case ::= Integer ; +CatchAll. Case ::= "_" ; Bind. Bind ::= Ident ":" Type ";" Ident [Ident] "=" Exp; From 6749650223f4f77d2fd5df71d54658c8661ff09d Mon Sep 17 00:00:00 2001 From: Samuel Hammersberg Date: Mon, 20 Feb 2023 14:39:43 +0100 Subject: [PATCH 039/372] Added support for pattern matching on ints. Might need a lookover. --- .gitignore | 1 + sample-programs/basic-1 | 26 +++++++--- src/Compiler.hs | 103 ++++++++++++++++++++-------------------- src/LambdaLifter.hs | 33 ++++++++++++- src/Renamer.hs | 9 ++++ src/TypeChecker.hs | 20 +++++++- src/TypeCheckerIr.hs | 29 +++++++++-- 7 files changed, 157 insertions(+), 64 deletions(-) diff --git a/.gitignore b/.gitignore index 8d1bad3..735aa23 100644 --- a/.gitignore +++ b/.gitignore @@ -5,3 +5,4 @@ dist-newstyle src/Grammar language llvm.ll +output \ No newline at end of file diff --git a/sample-programs/basic-1 b/sample-programs/basic-1 index f0cdcc4..14a24df 100644 --- a/sample-programs/basic-1 +++ b/sample-programs/basic-1 @@ -11,11 +11,25 @@ -- main = apply (\x : Int . x + 5) 5 -- answer: 10 -apply : (Int -> Int -> Int) -> Int -> Int -> Int; -apply f x y = f x y; -krimp: Int -> Int -> Int; -krimp x y = x + y; -main : Int; -main = apply (krimp) 2 3; +-- apply : (Int -> Int -> Int) -> Int -> Int -> Int; +-- apply f x y = f x y; +-- krimp: Int -> Int -> Int; +-- krimp x y = x + y; +-- main : Int; +-- main = apply (krimp) 2 3; -- answer: 5 +fibbonaci : Int -> Int; +fibbonaci x = case x of { + 0 => 0, + 1 => 1, + -- abusing overflows to represent negatives like a boss + _ => (fibbonaci (x + 9223372036854775807 + 9223372036854775807)) + + (fibbonaci (x + 9223372036854775807 + 9223372036854775807 + 1)) +} : Int; + +faccer : Int -> Int; + +main : Int; +main = fibbonaci 10; +-- answer: 55 diff --git a/src/Compiler.hs b/src/Compiler.hs index 3c744c9..f905e0f 100644 --- a/src/Compiler.hs +++ b/src/Compiler.hs @@ -5,19 +5,18 @@ module Compiler (compile) where import Auxiliary (snoc) import Control.Monad.State (StateT, execStateT, gets, modify) ---import Data.List.Extra (trim) import Data.Map (Map) import qualified Data.Map as Map import Data.Tuple.Extra (dupe, first, second) +import qualified Grammar.Abs as GA import Grammar.ErrM (Err) import LlvmIr (LLVMComp (..), LLVMIr (..), LLVMType (..), LLVMValue (..), Visibility (..), llvmIrToString) ---import System.Process.Extra (readCreateProcess, shell) import TypeChecker (partitionType) -import TypeCheckerIr (Bind (..), CLit (CInt, CatchAll), - Case (..), Exp (..), Id, Ident (..), - Program (..), Type (TFun, TInt)) +import TypeCheckerIr (Bind (..), Case (..), Exp (..), Id, + Ident (..), Program (..), + Type (TFun, TInt)) -- | The record used as the code generator state data CodeGenerator = CodeGenerator @@ -73,38 +72,38 @@ initCodeGenerator scs = CodeGenerator { instructions = defaultStart , variableCount = 0 , labelCount = 0 } +{- +run :: Err String -> IO () +run s = do + let s' = case s of + Right s -> s + Left _ -> error "yo" + writeFile "llvm.ll" s' + putStrLn . trim =<< readCreateProcess (shell "lli") s' ---run :: Err String -> IO () ---run s = do --- let s' = case s of --- Right s -> s --- Left _ -> error "yo" --- writeFile "llvm.ll" s' --- putStrLn . trim =<< readCreateProcess (shell "lli") s' --- ---test :: Integer -> Program ---test v = Program [ --- Bind (Ident "fibonacci", TInt) [(Ident "x", TInt)] ( --- ECased (EId ("x", TInt)) [ --- Case (CInt 0) (EInt 0), --- Case (CInt 1) (EInt 1), --- Case CatchAll (EAdd TInt --- (EApp TInt (EId (Ident "fibonacci", TInt)) ( --- EAdd TInt (EId (Ident "x", TInt)) --- (EInt (fromIntegral ((maxBound :: Int) * 2))) --- )) --- (EApp TInt (EId (Ident "fibonacci", TInt)) ( --- EAdd TInt (EId (Ident "x", TInt)) --- (EInt (fromIntegral ((maxBound :: Int) * 2 + 1))) --- )) --- ) --- ] --- ), --- Bind (Ident "main",TInt) [] ( --- EApp TInt (EId (Ident "fibonacci", TInt)) (EInt v) -- (EInt 92) --- ) --- ] - +test :: Integer -> Program +test v = Program [ + Bind (Ident "fibonacci", TInt) [(Ident "x", TInt)] ( + ECase TInt (EId ("x", TInt)) [ + (TInt,Case (CInt 0) (EInt 0)), + Case (CInt 1) (EInt 1), + Case CatchAll (EAdd TInt + (EApp TInt (EId (Ident "fibonacci", TInt)) ( + EAdd TInt (EId (Ident "x", TInt)) + (EInt (fromIntegral ((maxBound :: Int) * 2))) + )) + (EApp TInt (EId (Ident "fibonacci", TInt)) ( + EAdd TInt (EId (Ident "x", TInt)) + (EInt (fromIntegral ((maxBound :: Int) * 2 + 1))) + )) + ) + ] + ), + Bind (Ident "main", TInt) [] ( + EApp TInt (EId (Ident "fibonacci", TInt)) (EInt v) -- (EInt 92) + ) + ] +-} {- | Compiles an AST and produces a LLVM Ir string. An easy way to actually "compile" this output is to Simply pipe it to LLI @@ -120,7 +119,7 @@ compileScs (Bind (name, t) args exp : xs) = do emit $ UnsafeRaw "\n" emit . Comment $ show name <> ": " <> show exp let args' = map (second type2LlvmType) args - emit $ Define (type2LlvmType t_return) name args' + emit $ Define I64 {-(type2LlvmType t_return)-} name args' functionBody <- exprToValue exp if name == "main" then mapM_ emit $ mainContent functionBody @@ -161,42 +160,44 @@ compileExp (EId (name, _)) = emitIdent name compileExp (EApp t e1 e2) = emitApp t e1 e2 compileExp (EAbs t ti e) = emitAbs t ti e compileExp (ELet binds e) = emitLet binds e -compileExp (ECased e c) = emitECased e c +compileExp (ECase t e cs) = emitECased t e cs -- go (ESub e1 e2) = emitSub e1 e2 -- go (EMul e1 e2) = emitMul e1 e2 -- go (EDiv e1 e2) = emitDiv e1 e2 -- go (EMod e1 e2) = emitMod e1 e2 --- aux functions --- -emitECased :: Exp -> [Case] -> CompilerState () -emitECased e cs = do +emitECased :: Type -> Exp -> [(Type, Case)] -> CompilerState () +emitECased t e cases = do + let cs = snd <$> cases + let ty = type2LlvmType t vs <- exprToValue e lbl <- getNewLabel let label = Ident $ "escape_" <> show lbl stackPtr <- getNewVar - emit $ SetVariable (Ident $ show stackPtr) (Alloca I64) - mapM_ (emitCases label stackPtr vs) cs + emit $ SetVariable (Ident $ show stackPtr) (Alloca ty) + mapM_ (emitCases ty label stackPtr vs) cs emit $ Label label res <- getNewVar - emit $ SetVariable (Ident $ show res) (Load I64 Ptr (Ident $ show stackPtr)) + emit $ SetVariable (Ident $ show res) (Load ty Ptr (Ident $ show stackPtr)) where - emitCases :: Ident -> Integer -> LLVMValue -> Case -> CompilerState () - emitCases label stackPtr vs (Case (CInt i) exp) = do + emitCases :: LLVMType -> Ident -> Integer -> LLVMValue -> Case -> CompilerState () + emitCases ty label stackPtr vs (Case (GA.CInt i) exp) = do ns <- getNewVar lbl_fail <- getNewLabel lbl_succ <- getNewLabel let failed = Ident $ "failed_" <> show lbl_fail let success = Ident $ "success_" <> show lbl_succ - emit $ SetVariable (Ident $ show ns) (Icmp LLEq I64 vs (VInteger i)) - emit $ BrCond (VIdent (Ident $ show ns) I64) success failed + emit $ SetVariable (Ident $ show ns) (Icmp LLEq ty vs (VInteger i)) + emit $ BrCond (VIdent (Ident $ show ns) ty) success failed emit $ Label success val <- exprToValue exp - emit $ Store I64 val Ptr (Ident . show $ stackPtr) + emit $ Store ty val Ptr (Ident . show $ stackPtr) emit $ Br label emit $ Label failed - emitCases label stackPtr _ (Case CatchAll exp) = do + emitCases ty label stackPtr _ (Case GA.CatchAll exp) = do val <- exprToValue exp - emit $ Store I64 val Ptr (Ident . show $ stackPtr) + emit $ Store ty val Ptr (Ident . show $ stackPtr) emit $ Br label @@ -343,7 +344,7 @@ getType (EId (_, t)) = type2LlvmType t getType (EApp t _ _) = type2LlvmType t getType (EAbs t _ _) = type2LlvmType t getType (ELet _ e) = getType e -getType (ECased e cs) = undefined +getType (ECase t _ _) = type2LlvmType t valueGetType :: LLVMValue -> LLVMType valueGetType (VInteger _) = I64 diff --git a/src/LambdaLifter.hs b/src/LambdaLifter.hs index 015e7f3..393a1d6 100644 --- a/src/LambdaLifter.hs +++ b/src/LambdaLifter.hs @@ -9,6 +9,8 @@ import Control.Applicative (Applicative (liftA2)) import Control.Monad.State (MonadState (get, put), State, evalState) import Data.Set (Set) import qualified Data.Set as Set +import Debug.Trace (trace) +import qualified Grammar.Abs as GA import Prelude hiding (exp) import Renamer import TypeCheckerIr @@ -22,7 +24,6 @@ import TypeCheckerIr lambdaLift :: Program -> Program lambdaLift = collectScs . abstract . freeVars - -- | Annotate free variables freeVars :: Program -> AnnProgram freeVars (Program ds) = [ (n, xs, freeVarsExp (Set.fromList xs) e) @@ -62,6 +63,16 @@ freeVarsExp localVars = \case e' = freeVarsExp e_localVars e e_localVars = Set.insert name localVars + (ECase t e cs) -> do + let e' = freeVarsExp localVars e + let vars = freeVarsOf e' + let (vars', cs') = foldr (\(_, Case c e) (vars,acc) -> do + let e' = freeVarsExp vars e + let vars' = freeVarsOf e' + (Set.union vars vars', AnnCase c e' : acc) + ) (vars, []) cs + (vars', ACase t e' (reverse cs')) + freeVarsOf :: AnnExp -> Set Id freeVarsOf = fst @@ -79,7 +90,12 @@ data AnnExp' = AId Id | AApp Type AnnExp AnnExp | AAdd Type AnnExp AnnExp | AAbs Type Id AnnExp + | ACase Type AnnExp [AnnCase] deriving Show +data AnnCase = AnnCase GA.Case AnnExp + deriving Show + + -- | Lift lambdas to let expression of the form @let sc = \v₁ x₁ -> e₁@. -- Free variables are @v₁ v₂ .. vₙ@ are bound. abstract :: AnnProgram -> Program @@ -120,6 +136,14 @@ abstractExp (free, exp) = case exp of AAbs t par ae1 -> EAbs t par <$> skipLambdas f ae1 _ -> f (free, ae) + + ACase t e cs -> do + e' <- abstractExp e + cs' <- mapM (\(AnnCase c e) -> do + e' <- abstractExp e + pure (t,Case c e')) cs + pure $ ECase t e' cs' + -- Lift lambda into let and bind free variables AAbs t parm e -> do i <- nextNumber @@ -179,6 +203,13 @@ collectScsExp = \case bind = Bind name parms rhs' (rhs_scs, rhs') = collectScsExp rhs (e_scs, e') = collectScsExp e + ECase t e cs -> do + let (scs, e') = collectScsExp e + let (scs',cs') = foldr (\(t, Case c e) (scs, acc) -> do + let (scs', e') = collectScsExp e + (scs ++ scs', (t,Case c e') : acc) + ) (scs,[]) cs + (scs', ECase t e' cs') -- @\x.\y.\z. e → (e, [x,y,z])@ diff --git a/src/Renamer.hs b/src/Renamer.hs index b284e92..4dee763 100644 --- a/src/Renamer.hs +++ b/src/Renamer.hs @@ -3,6 +3,7 @@ module Renamer (module Renamer) where import Auxiliary (mapAccumM) +import Control.Monad (foldM) import Control.Monad.State (MonadState, State, evalState, gets, modify) import Data.Map (Map) @@ -68,6 +69,14 @@ renameExp old_names = \case (new_names, e') <- renameExp old_names e pure (new_names, EAnn e' t) + ECase e cs t -> do + (new_names, e') <- renameExp old_names e + (new_names', cs') <- foldM (\(names, stack) (CaseMatch c exp) -> do + (nm,exp') <- renameExp names exp + pure (nm,CaseMatch c exp' : stack) + ) (new_names, []) cs + pure (new_names', ECase e' cs' t) + -- | Create a new name and add it to name environment. newName :: Names -> Ident -> Rn (Names, Ident) newName env old_name = do diff --git a/src/TypeChecker.hs b/src/TypeChecker.hs index 1e44888..e5ee467 100644 --- a/src/TypeChecker.hs +++ b/src/TypeChecker.hs @@ -95,10 +95,23 @@ infer cxt = \case throwError "Inferred type and type annotation doesn't match" pure (e', t1) + ECase e cs t -> do + (e',t1) <- infer cxt e + unless (typeEq t t1) $ + throwError "Inferred type and type annotation doesn't match" + case traverse (\(CaseMatch c e) -> do + -- //TODO check c as well + e' <- check cxt e t + unless (typeEq t t1) $ + throwError "Inferred type and type annotation doesn't match" + pure (t1, T.Case c e') + ) cs of + Right cs -> pure (T.ECase t1 e' cs,t1) + Left e -> throwError e + -- | Check infered type matches the supplied type. check :: Cxt -> Exp -> Type -> Err T.Exp check cxt exp typ = case exp of - EId x -> do t <- case lookupEnv x cxt of Nothing -> maybeToRightM @@ -142,6 +155,11 @@ check cxt exp typ = case exp of throwError "Inferred type and type annotation doesn't match" check cxt e t + ECase e _ t -> do + unless (typeEq t typ) $ + throwError "Inferred type and type annotation doesn't match" + check cxt e t + -- | Check if types are equivalent. Doesn't handle coercion or polymorphism. typeEq :: Type -> Type -> Bool typeEq (TFun t t1) (TFun q q1) = typeEq t q && typeEq t1 q1 diff --git a/src/TypeCheckerIr.hs b/src/TypeCheckerIr.hs index d684ce5..2bbf0ea 100644 --- a/src/TypeCheckerIr.hs +++ b/src/TypeCheckerIr.hs @@ -6,6 +6,7 @@ module TypeCheckerIr ) where import Grammar.Abs (Ident (..), Type (..)) +import qualified Grammar.Abs as GA import Grammar.Print import Prelude import qualified Prelude as C (Eq, Ord, Read, Show) @@ -20,14 +21,12 @@ data Exp | EApp Type Exp Exp | EAdd Type Exp Exp | EAbs Type Id Exp - | ECased Exp [Case] + | ECase Type Exp [(Type, Case)] deriving (C.Eq, C.Ord, C.Show, C.Read) -data Case = Case CLit Exp +data Case = Case GA.Case Exp deriving (C.Eq, C.Ord, C.Show, C.Read) -data CLit = CInt Integer | CatchAll - deriving (C.Eq, C.Ord, C.Show, C.Read) type Id = (Ident, Type) data Bind = Bind Id [Id] Exp @@ -102,5 +101,25 @@ instance Print Exp where , doc $ showString "." , prt 0 e ] + ECase t e cs -> prPrec i 0 $ concatD + [ doc $ showString "@" + , prt 0 t + , doc $ showString "(" + , prt 0 e + , doc $ showString ")" + , prPrec i 0 $ concatD . printCases $ cs + ] - + where + printCases :: [(Type, Case)] -> [Doc] + printCases [] = [] + printCases ((t, Case c e):xs) = concatD + [ doc $ showString "@" + , prt 0 t + , doc $ showString "(" + , doc . showString . show $ c + , doc $ showString ")" + , doc $ showString "=>" + , prt 0 e + , doc $ showString "\n" + ] : printCases xs From fe4533c7aeb39055b4bbfcbfaab08aafad191cd6 Mon Sep 17 00:00:00 2001 From: Samuel Hammersberg Date: Mon, 20 Feb 2023 14:39:56 +0100 Subject: [PATCH 040/372] Added an option to output some debug info. --- language.cabal | 1 + src/Main.hs | 55 +++++++++++++++++++++++++++++++++++--------------- 2 files changed, 40 insertions(+), 16 deletions(-) diff --git a/language.cabal b/language.cabal index 8b958a5..bddbd21 100644 --- a/language.cabal +++ b/language.cabal @@ -49,4 +49,5 @@ executable language , either , array , extra + , directory default-language: GHC2021 diff --git a/src/Main.hs b/src/Main.hs index 1831428..8309349 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -2,28 +2,35 @@ module Main where -import Compiler (compile) -import GHC.IO.Handle.Text (hPutStrLn) -import Grammar.ErrM (Err) -import Grammar.Par (myLexer, pProgram) -import Grammar.Print (printTree) +import Compiler (compile) +import GHC.IO.Handle.Text (hPutStrLn) +import Grammar.ErrM (Err) +import Grammar.Par (myLexer, pProgram) +import Grammar.Print (printTree) -- import Interpreter (interpret) -import LambdaLifter (lambdaLift) -import Renamer (rename) -import System.Environment (getArgs) -import System.Exit (exitFailure, exitSuccess) -import System.IO (stderr) -import TypeChecker (typecheck) +import Control.Monad (unless, when) +import Data.List.Extra (isSuffixOf) +import LambdaLifter (lambdaLift) +import Renamer (rename) +import System.Directory (createDirectory, doesPathExist, + getDirectoryContents, + setCurrentDirectory) +import System.Environment (getArgs) +import System.Exit (exitFailure, exitSuccess) +import System.IO (stderr) +import System.Process.Extra (spawnCommand, waitForProcess) +import TypeChecker (typecheck) main :: IO () main = getArgs >>= \case [] -> print "Required file path missing" - (s : _) -> main' s + ("-d": s : _) -> main' True s + (s : _) -> main' False s -main' :: String -> IO () -main' s = do +main' :: Bool -> String -> IO () +main' debug s = do file <- readFile s printToErr "-- Parse Tree -- " @@ -44,8 +51,13 @@ main' s = do printToErr "\n -- Printing compiler output to stdout --" compiled <- fromCompilerErr $ compile lifted - putStrLn compiled - writeFile "llvm.ll" compiled + --putStrLn compiled + + check <- doesPathExist "output" + unless check (createDirectory "output") + writeFile "output/llvm.ll" compiled + if debug then debugDotViz else putStrLn compiled + -- interpred <- fromInterpreterErr $ interpret lifted -- putStrLn "\n-- interpret" @@ -53,6 +65,17 @@ main' s = do exitSuccess +debugDotViz :: IO () +debugDotViz = do + setCurrentDirectory "output" + spawnWait "opt -dot-cfg llvm.ll -disable-output" + content <- filter (isSuffixOf ".dot") <$> getDirectoryContents "." + let commands = (\p -> "dot " <> p <> " -Tpng -o" <> p <> ".png") <$> content + mapM_ spawnWait commands + setCurrentDirectory ".." + return () + where + spawnWait s = spawnCommand s >>= waitForProcess printToErr :: String -> IO () printToErr = hPutStrLn stderr From a36de2bde16ebf90cc670ffd93f7bc2d79d3ce10 Mon Sep 17 00:00:00 2001 From: Samuel Hammersberg Date: Mon, 20 Feb 2023 14:52:11 +0100 Subject: [PATCH 041/372] Added support for the minus operator. --- Grammar.cf | 1 + sample-programs/basic-1 | 5 ++--- src/Compiler.hs | 18 +++++++++--------- src/LambdaLifter.hs | 13 +++++++++++++ src/Renamer.hs | 5 +++++ src/TypeChecker.hs | 10 ++++++++++ src/TypeCheckerIr.hs | 8 ++++++++ 7 files changed, 48 insertions(+), 12 deletions(-) diff --git a/Grammar.cf b/Grammar.cf index f98631e..dddab37 100644 --- a/Grammar.cf +++ b/Grammar.cf @@ -6,6 +6,7 @@ EAnn. Exp3 ::= "(" Exp ":" Type ")"; ELet. Exp3 ::= "let" Bind "in" Exp; EApp. Exp2 ::= Exp2 Exp3; EAdd. Exp1 ::= Exp1 "+" Exp2; +ESub. Exp1 ::= Exp1 "-" Exp2; EAbs. Exp ::= "\\" Ident ":" Type "." Exp; ECase. Exp ::= "case" Exp "of" "{" [CaseMatch] "}" ":" Type; CaseMatch. CaseMatch ::= Case "=>" Exp ; diff --git a/sample-programs/basic-1 b/sample-programs/basic-1 index 14a24df..107fb5f 100644 --- a/sample-programs/basic-1 +++ b/sample-programs/basic-1 @@ -24,11 +24,10 @@ fibbonaci x = case x of { 0 => 0, 1 => 1, -- abusing overflows to represent negatives like a boss - _ => (fibbonaci (x + 9223372036854775807 + 9223372036854775807)) - + (fibbonaci (x + 9223372036854775807 + 9223372036854775807 + 1)) + _ => (fibbonaci (x - 2)) + + (fibbonaci (x - 1)) } : Int; -faccer : Int -> Int; main : Int; main = fibbonaci 10; diff --git a/src/Compiler.hs b/src/Compiler.hs index f905e0f..bffab3b 100644 --- a/src/Compiler.hs +++ b/src/Compiler.hs @@ -156,12 +156,12 @@ defaultStart = [ UnsafeRaw "@.str = private unnamed_addr constant [3 x i8] c\"%i compileExp :: Exp -> CompilerState () compileExp (EInt int) = emitInt int compileExp (EAdd t e1 e2) = emitAdd t e1 e2 +compileExp (ESub t e1 e2) = emitSub t e1 e2 compileExp (EId (name, _)) = emitIdent name compileExp (EApp t e1 e2) = emitApp t e1 e2 compileExp (EAbs t ti e) = emitAbs t ti e compileExp (ELet binds e) = emitLet binds e compileExp (ECase t e cs) = emitECased t e cs - -- go (ESub e1 e2) = emitSub e1 e2 -- go (EMul e1 e2) = emitMul e1 e2 -- go (EDiv e1 e2) = emitDiv e1 e2 -- go (EMod e1 e2) = emitMod e1 e2 @@ -258,6 +258,13 @@ emitAdd t e1 e2 = do v <- getNewVar emit $ SetVariable (Ident $ show v) (Add (type2LlvmType t) v1 v2) +emitSub :: Type -> Exp -> Exp -> CompilerState () +emitSub t e1 e2 = do + v1 <- exprToValue e1 + v2 <- exprToValue e2 + v <- getNewVar + emit $ SetVariable (Ident $ show v) (Sub (type2LlvmType t) v1 v2) + -- emitMul :: Exp -> Exp -> CompilerState () -- emitMul e1 e2 = do -- (v1,v2) <- binExprToValues e1 e2 @@ -295,14 +302,6 @@ emitAdd t e1 e2 = do -- emit $ SetVariable $ Ident $ show v -- emit $ Div I64 v1 v2 --- emitSub :: Exp -> Exp -> CompilerState () --- emitSub e1 e2 = do --- (v1,v2) <- binExprToValues e1 e2 --- increaseVarCount --- v <- gets variableCount --- emit $ SetVariable $ Ident $ show v --- emit $ Sub I64 v1 v2 - exprToValue :: Exp -> CompilerState LLVMValue exprToValue = \case EInt i -> pure $ VInteger i @@ -340,6 +339,7 @@ type2LlvmType = \case getType :: Exp -> LLVMType getType (EInt _) = I64 getType (EAdd t _ _) = type2LlvmType t +getType (ESub t _ _) = type2LlvmType t getType (EId (_, t)) = type2LlvmType t getType (EApp t _ _) = type2LlvmType t getType (EAbs t _ _) = type2LlvmType t diff --git a/src/LambdaLifter.hs b/src/LambdaLifter.hs index 393a1d6..6522bba 100644 --- a/src/LambdaLifter.hs +++ b/src/LambdaLifter.hs @@ -47,6 +47,12 @@ freeVarsExp localVars = \case e1' = freeVarsExp localVars e1 e2' = freeVarsExp localVars e2 + ESub t e1 e2 -> (Set.union (freeVarsOf e1') (freeVarsOf e2'), ASub t e1' e2') + where + e1' = freeVarsExp localVars e1 + e2' = freeVarsExp localVars e2 + + EAbs t par e -> (Set.delete par $ freeVarsOf e', AAbs t par e') where e' = freeVarsExp (Set.insert par localVars) e @@ -89,6 +95,7 @@ data AnnExp' = AId Id | ALet ABind AnnExp | AApp Type AnnExp AnnExp | AAdd Type AnnExp AnnExp + | ASub Type AnnExp AnnExp | AAbs Type Id AnnExp | ACase Type AnnExp [AnnCase] deriving Show @@ -125,6 +132,7 @@ abstractExp (free, exp) = case exp of AInt i -> pure $ EInt i AApp t e1 e2 -> liftA2 (EApp t) (abstractExp e1) (abstractExp e2) AAdd t e1 e2 -> liftA2 (EAdd t) (abstractExp e1) (abstractExp e2) + ASub t e1 e2 -> liftA2 (ESub t) (abstractExp e1) (abstractExp e2) ALet b e -> liftA2 ELet (go b) (abstractExp e) where go (ABind name parms rhs) = do @@ -188,6 +196,11 @@ collectScsExp = \case (scs1, e1') = collectScsExp e1 (scs2, e2') = collectScsExp e2 + ESub t e1 e2 -> (scs1 ++ scs2, ESub t e1' e2') + where + (scs1, e1') = collectScsExp e1 + (scs2, e2') = collectScsExp e2 + EAbs t par e -> (scs, EAbs t par e') where (scs, e') = collectScsExp e diff --git a/src/Renamer.hs b/src/Renamer.hs index 4dee763..a91615b 100644 --- a/src/Renamer.hs +++ b/src/Renamer.hs @@ -55,6 +55,11 @@ renameExp old_names = \case (env2, e2') <- renameExp old_names e2 pure (Map.union env1 env2, EAdd e1' e2') + ESub e1 e2 -> do + (env1, e1') <- renameExp old_names e1 + (env2, e2') <- renameExp old_names e2 + pure (Map.union env1 env2, ESub e1' e2') + ELet b e -> do (new_names, b) <- renameLocalBind old_names b (new_names', e') <- renameExp new_names e diff --git a/src/TypeChecker.hs b/src/TypeChecker.hs index e5ee467..9cb9c39 100644 --- a/src/TypeChecker.hs +++ b/src/TypeChecker.hs @@ -78,6 +78,11 @@ infer cxt = \case e1' <- check cxt e1 T.TInt pure (T.EAdd T.TInt e' e1', T.TInt) + ESub e e1 -> do + e' <- check cxt e T.TInt + e1' <- check cxt e1 T.TInt + pure (T.ESub T.TInt e' e1', T.TInt) + EAbs x t e -> do (e', t1) <- infer (insertEnv x t cxt) e let t_abs = TFun t t1 @@ -138,6 +143,11 @@ check cxt exp typ = case exp of e1' <- check cxt e1 T.TInt pure $ T.EAdd T.TInt e' e1' + ESub e e1 -> do + e' <- check cxt e T.TInt + e1' <- check cxt e1 T.TInt + pure $ T.ESub T.TInt e' e1' + EAbs x t e -> do (e', t_e) <- infer (insertEnv x t cxt) e let t1 = TFun t t_e diff --git a/src/TypeCheckerIr.hs b/src/TypeCheckerIr.hs index 2bbf0ea..0e30d0c 100644 --- a/src/TypeCheckerIr.hs +++ b/src/TypeCheckerIr.hs @@ -20,6 +20,7 @@ data Exp | ELet Bind Exp | EApp Type Exp Exp | EAdd Type Exp Exp + | ESub Type Exp Exp | EAbs Type Id Exp | ECase Type Exp [(Type, Case)] deriving (C.Eq, C.Ord, C.Show, C.Read) @@ -93,6 +94,13 @@ instance Print Exp where , doc $ showString "+" , prt 2 e2 ] + ESub 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 From cd0f9dd456cd862b7cce953a6f0d43beaee9fa45 Mon Sep 17 00:00:00 2001 From: Samuel Hammersberg Date: Mon, 20 Feb 2023 15:27:13 +0100 Subject: [PATCH 042/372] The output directory is now cleared when the program is ran. --- sample-programs/basic-1 | 34 +++++++++++++++++++++++++--------- src/Main.hs | 6 ++++-- 2 files changed, 29 insertions(+), 11 deletions(-) diff --git a/sample-programs/basic-1 b/sample-programs/basic-1 index 107fb5f..7a458eb 100644 --- a/sample-programs/basic-1 +++ b/sample-programs/basic-1 @@ -19,16 +19,32 @@ -- main = apply (krimp) 2 3; -- answer: 5 -fibbonaci : Int -> Int; -fibbonaci x = case x of { - 0 => 0, - 1 => 1, - -- abusing overflows to represent negatives like a boss - _ => (fibbonaci (x - 2)) - + (fibbonaci (x - 1)) +-- fibbonaci : Int -> Int; +-- fibbonaci x = case x of { +-- 0 => 0, +-- 1 => 1, +-- -- abusing overflows to represent negatives like a boss +-- _ => (fibbonaci (x - 2)) +-- + (fibbonaci (x - 1)) +-- } : Int; +-- main : Int; +-- main = fibbonaci 10; +-- answer: 55 + +succ : Int -> Int; +succ x = x - 1; + +isZero : Int -> Int; +isZero x = case x of { + 0 => 1, + _ => 0 } : Int; +minimization : (Int -> Int) -> Int -> Int; +minimization p x = case p x of { + 1 => 0, + _ => minimization p (succ x) +} : Int; main : Int; -main = fibbonaci 10; --- answer: 55 +main = minimization isZero 10; \ No newline at end of file diff --git a/src/Main.hs b/src/Main.hs index 8309349..29b7158 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -14,7 +14,8 @@ import Data.List.Extra (isSuffixOf) import LambdaLifter (lambdaLift) import Renamer (rename) import System.Directory (createDirectory, doesPathExist, - getDirectoryContents, + getDirectoryContents, removeDirectory, + removeDirectoryRecursive, setCurrentDirectory) import System.Environment (getArgs) import System.Exit (exitFailure, exitSuccess) @@ -54,7 +55,8 @@ main' debug s = do --putStrLn compiled check <- doesPathExist "output" - unless check (createDirectory "output") + when check (removeDirectoryRecursive "output") + createDirectory "output" writeFile "output/llvm.ll" compiled if debug then debugDotViz else putStrLn compiled From afbc700db24f88e30c342413e4db60e285da3492 Mon Sep 17 00:00:00 2001 From: Samuel Hammersberg Date: Mon, 20 Feb 2023 16:43:54 +0100 Subject: [PATCH 043/372] Fixed the type checker accidentally chucking cases in some cases. --- src/TypeChecker.hs | 19 ++++++++++++++----- 1 file changed, 14 insertions(+), 5 deletions(-) diff --git a/src/TypeChecker.hs b/src/TypeChecker.hs index 9cb9c39..bb31a2f 100644 --- a/src/TypeChecker.hs +++ b/src/TypeChecker.hs @@ -154,6 +154,20 @@ check cxt exp typ = case exp of unless (typeEq t1 typ) $ throwError "Wrong lamda type!" pure $ T.EAbs t1 (x, t) e' + ECase e cs t -> do + (e',t1) <- infer cxt e + unless (typeEq t t1) $ + throwError "Inferred type and type annotation doesn't match" + case traverse (\(CaseMatch c e) -> do + -- //TODO check c as well + e' <- check cxt e t + unless (typeEq t t1) $ + throwError "Inferred type and type annotation doesn't match" + pure (t1, T.Case c e') + ) cs of + Right cs -> pure $ T.ECase t1 e' cs + Left e -> throwError e + ELet b e -> do let cxt' = insertBind b cxt b' <- checkBind cxt' b @@ -165,11 +179,6 @@ check cxt exp typ = case exp of throwError "Inferred type and type annotation doesn't match" check cxt e t - ECase e _ t -> do - unless (typeEq t typ) $ - throwError "Inferred type and type annotation doesn't match" - check cxt e t - -- | Check if types are equivalent. Doesn't handle coercion or polymorphism. typeEq :: Type -> Type -> Bool typeEq (TFun t t1) (TFun q q1) = typeEq t q && typeEq t1 q1 From 4df3f705ed167bbd75c3bc4901c62c422ddabb20 Mon Sep 17 00:00:00 2001 From: Samuel Hammersberg Date: Mon, 20 Feb 2023 16:44:27 +0100 Subject: [PATCH 044/372] =?UTF-8?q?LLVMIr=20code=20now=20has=20the=20fastc?= =?UTF-8?q?c=20flag=20to=20enable=20speeed=20=F0=9F=98=8E?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- sample-programs/basic-1 | 38 +++++++++++++++++++++++++++----------- src/LlvmIr.hs | 4 ++-- 2 files changed, 29 insertions(+), 13 deletions(-) diff --git a/sample-programs/basic-1 b/sample-programs/basic-1 index 7a458eb..a88960b 100644 --- a/sample-programs/basic-1 +++ b/sample-programs/basic-1 @@ -31,20 +31,36 @@ -- main = fibbonaci 10; -- answer: 55 -succ : Int -> Int; -succ x = x - 1; +-- succ : Int -> Int; +-- succ x = x - 1; +-- +-- isZero : Int -> Int; +-- isZero x = case x of { +-- 0 => 1, +-- _ => 0 +-- } : Int; +-- +-- minimization : (Int -> Int) -> Int -> Int; +-- minimization p x = case p x of { +-- 1 => 0, +-- _ => minimization p (succ x) +-- } : Int; +-- +-- main : Int; +-- main = minimization isZero 10; +-- answer: 0 -isZero : Int -> Int; -isZero x = case x of { - 0 => 1, - _ => 0 +posMul : Int -> Int -> Int; +posMul a b = case b of { + 0 => 0, + _ => a + posMul a (b - 1) } : Int; -minimization : (Int -> Int) -> Int -> Int; -minimization p x = case p x of { - 1 => 0, - _ => minimization p (succ x) +facc : Int -> Int; +facc a = case a of { + 1 => 1, + _ => posMul a (facc (a - 1)) } : Int; main : Int; -main = minimization isZero 10; \ No newline at end of file +main = facc 27 \ No newline at end of file diff --git a/src/LlvmIr.hs b/src/LlvmIr.hs index 5c5532a..68f45f2 100644 --- a/src/LlvmIr.hs +++ b/src/LlvmIr.hs @@ -136,7 +136,7 @@ llvmIrToString = go 0 replicate i '\t' <> case l of (Define t (Ident i) params) -> concat - [ "define ", show t, " @", i + [ "define fastcc ", show t, " @", i , "(", intercalate ", " (map (\(Ident y, x) -> unwords [show x, "%" <> y]) params) , ") {\n" ] @@ -170,7 +170,7 @@ llvmIrToString = go 0 ] (Call t vis (Ident i) arg) -> concat - [ "call ", show t, " ", show vis, i, "(" + [ "call fastcc ", show t, " ", show vis, i, "(" , intercalate ", " $ Prelude.map (\(x, y) -> show x <> " " <> show y) arg , ")\n" ] From a98135827c5fb1df1afeb5387df4199abe2dc50d Mon Sep 17 00:00:00 2001 From: sebastianselander Date: Mon, 20 Feb 2023 16:51:44 +0100 Subject: [PATCH 045/372] EAdd is bugged. Mostly complete though. --- src/TypeChecker/AlgoW.hs | 183 ++++++++++++++++++++++++--------------- 1 file changed, 113 insertions(+), 70 deletions(-) diff --git a/src/TypeChecker/AlgoW.hs b/src/TypeChecker/AlgoW.hs index e630da2..3667761 100644 --- a/src/TypeChecker/AlgoW.hs +++ b/src/TypeChecker/AlgoW.hs @@ -8,108 +8,151 @@ import Control.Monad.Reader import Control.Monad.State import Data.Bifunctor (bimap, second) import Data.Functor.Identity (Identity, runIdentity) -import Data.List (intersect) +import Data.List (foldl', intersect) import Data.Map (Map) import qualified Data.Map as M import Data.Maybe (fromMaybe) +import Data.Set (Set) +import qualified Data.Set as S import Grammar.Abs +import Grammar.Print (printTree) import qualified TypeChecker.HMIr as T data Poly = Forall [Ident] Type deriving Show -a = TPol "a" -b = TPol "b" -int = TMono "int" -arr = TArr - data Ctx = Ctx { vars :: Map Ident Poly - , sigs :: Map Ident Poly } + , sigs :: Map Ident Type } -data Env = Env { counter :: Int - , substitutions :: Map Type Type - } - -type Subst = Map Type Type type Error = String +type Subst = Map Ident Type -newtype Infer a = Infer { runInfer :: StateT Env (ReaderT Ctx (ExceptT Error Identity)) a } - deriving (Functor, Applicative, Monad, MonadState Env, MonadReader Ctx, MonadError Error) +type Infer = StateT Int (ReaderT Ctx (ExceptT Error Identity)) -initCtx :: Ctx initCtx = Ctx mempty mempty -initEnv :: Env -initEnv = Env 0 mempty +run :: Infer a -> Either Error a +run = runC initCtx 0 -run :: Ctx -> Env -> Infer a -> Either Error a -run c e = runIdentity . runExceptT . flip runReaderT c . flip evalStateT e . runInfer +runC :: Ctx -> Int -> Infer a -> Either Error a +runC c e = runIdentity . runExceptT . flip runReaderT c . flip evalStateT e -w :: Exp -> Infer Type -w = \case - EInt n -> return int - EId i -> (\(Forall _ t) -> t) <$> (lookupVar i >>= inst) +inferExp :: Exp -> Infer Type +inferExp e = snd <$> w nullSubst e + +w :: Subst -> Exp -> Infer (Subst, Type) +w s = \case + EAnn e t -> do + (s1, t') <- w nullSubst e + let t'' = apply s1 t + return (s1, t'') + EInt n -> return (nullSubst, TMono "Int") + EId i -> do + var <- asks vars + case M.lookup i var of + Nothing -> throwError $ "Unbound variable: " ++ show i + Just t -> (nullSubst,) <$> inst t EAbs var e -> do fr <- fresh - withBinding var (Forall [] (TPol fr)) $ do - t' <- w e - subst (Forall [] $ TArr (TPol fr) t') + withBinding var (Forall [] fr) $ do + (s1, t') <- w s e + return (s, TArr (apply s1 fr) t') + EAdd e0 e1 -> do + (s1, t1) <- w s e0 + (s2, t2) <- w s1 e1 + return (s2, TMono "Int") EApp e0 e1 -> do - t0 <- substCtx (w e0) - t1 <- w e1 - undefined + fr <- fresh + (s1, t0) <- w s e0 + (s2, t1) <- w s1 e1 + s3 <- unify (subst s2 t0) (TArr t1 fr) + return (s3 `compose` s2 `compose` s1, apply s3 fr) + ELet name e0 e1 -> do + (s1, t1) <- w s e0 + env <- asks vars + let t' = generalize (apply s1 env) t1 + withBinding name t' $ do + (s2, t2) <- w s1 e1 + return (s1 `compose` s2, t2) -substCtx :: Infer Type -> Infer Type -substCtx m = do - vs <- asks (M.toList . vars) - ks <- traverse (subst . snd) vs - let x = map fst vs - local (\st -> st { vars = M.fromList $ zip x ks }) m +unify :: Type -> Type -> Infer Subst +unify t0 t1 = case (t0, t1) of + (TArr a b, TArr c d) -> do + s1 <- unify a c + s2 <- unify (subst s1 b) (subst s1 c) + return $ s1 `compose` s2 + (TPol a, b) -> occurs a b + (a, TPol b) -> occurs b a + (TMono a, TMono b) -> if a == b then return M.empty else throwError "Types do not unify" -subst :: Poly -> Infer Poly -subst (Forall xs t) = do - subs <- gets substitutions - case t of - TPol a -> case M.lookup (TPol a) subs of - Nothing -> return $ Forall xs t - Just t' -> return $ Forall (remove a xs) t' - TMono a -> case M.lookup (TMono a) subs of - Nothing -> return $ Forall xs t - Just t' -> return $ Forall (remove a xs) t' - TArr a b -> do - (Forall xs' a') <- subst (Forall xs a) - (Forall xs'' b') <- subst (Forall xs b) - return $ Forall (xs' `intersect` xs'') (TArr a' b') +occurs :: Ident -> Type -> Infer Subst +occurs i (TPol a) = return nullSubst +occurs i t = if S.member i (free t) + then throwError "Occurs check failed" + else return $ M.singleton i t +generalize :: Map Ident Poly -> Type -> Poly +generalize env t = Forall (S.toList $ free t S.\\ free env) t -remove :: Ord a => a -> [a] -> [a] -remove a = foldr (\x acc -> if x == a then acc else x : acc) [] - -inst :: Poly -> Infer Poly +inst :: Poly -> Infer Type inst (Forall xs t) = do xs' <- mapM (const fresh) xs - let sub = zip xs xs' - let subst' t = case t of - TMono a -> return $ TMono a - TPol a -> case lookup a sub of - Nothing -> return $ TPol a - Just t -> return $ TPol t - TArr a b -> TArr <$> subst' a <*> subst' b - Forall [] <$> subst' t + let s = M.fromList $ zip xs xs' + return $ apply s t + +compose :: Subst -> Subst -> Subst +compose m1 m2 = M.map (subst m1) m2 `M.union` m1 + +class FreeVars t where + free :: t -> Set Ident + apply :: Subst -> t -> t + +instance FreeVars Type where + free :: Type -> Set Ident + free (TPol a) = S.singleton a + free (TMono _) = mempty + free (TArr a b) = free a `S.union` free b + apply :: Subst -> Type -> Type + apply sub t = do + case t of + TMono a -> TMono a + TPol a -> case M.lookup a sub of + Nothing -> TPol a + Just t -> t + TArr a b -> TArr (apply sub a) (apply sub b) + +instance FreeVars Poly where + free :: Poly -> Set Ident + free (Forall xs t) = free t S.\\ S.fromList xs + apply :: Subst -> Poly -> Poly + apply s (Forall xs t) = Forall xs (apply (foldr M.delete s xs) t) + +instance FreeVars (Map Ident Poly) where + free :: Map Ident Poly -> Set Ident + free m = foldl' S.union S.empty (map free $ M.elems m) + apply :: Subst -> Map Ident Poly -> Map Ident Poly + apply s = M.map (apply s) + +nullSubst :: Subst +nullSubst = M.empty + +subst :: Subst -> Type -> Type +subst m t = do + case t of + TPol a -> fromMaybe t (M.lookup a m) + TMono a -> TMono a + TArr a b -> TArr (subst m a) (subst m b) -- | Generate a new fresh variable and increment the state -fresh :: Infer Ident +fresh :: Infer Type fresh = do - n <- gets counter - modify (\st -> st { counter = n + 1 }) - return . Ident $ "t" ++ show n + n <- get + put (n + 1) + return . TPol . Ident $ "t" ++ show n -insertSub :: Type -> Type -> Infer () -insertSub t1 t2 = modify (\st -> st { substitutions = M.insert t1 t2 (substitutions st) }) - -withBinding :: Ident -> Poly -> Infer Poly -> Infer Type -withBinding i t m = (\(Forall _ t) -> t) <$> local (\re -> re { vars = M.insert i t (vars re) }) m +withBinding :: Ident -> Poly -> Infer (Subst, Type) -> Infer (Subst, Type) +withBinding i t = local (\re -> re { vars = M.insert i t (vars re) }) lookupVar :: Ident -> Infer Poly lookupVar i = do From 8065576c31a141e191dc9f3b55afa0348b70cba9 Mon Sep 17 00:00:00 2001 From: sebastianselander Date: Mon, 20 Feb 2023 20:38:36 +0100 Subject: [PATCH 046/372] Let has a bug, otherwise probably(?) done --- src/Main.hs | 2 +- src/TypeChecker/AlgoW.hs | 157 +++++++++++++++++++++++++++------------ 2 files changed, 112 insertions(+), 47 deletions(-) diff --git a/src/Main.hs b/src/Main.hs index 1ef3fe3..1a73e95 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -9,7 +9,7 @@ import Grammar.Print (printTree) import Renamer.RenamerM (rename) import System.Environment (getArgs) import System.Exit (exitFailure, exitSuccess) -import TypeChecker.HM (typecheck) +import TypeChecker.AlgoW (typecheck) main :: IO () main = diff --git a/src/TypeChecker/AlgoW.hs b/src/TypeChecker/AlgoW.hs index 3667761..3c4b9b3 100644 --- a/src/TypeChecker/AlgoW.hs +++ b/src/TypeChecker/AlgoW.hs @@ -1,7 +1,9 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} +{-# HLINT ignore "Use traverse_" #-} -module TypeChecker.AlgoW where +module TypeChecker.AlgoW where import Control.Monad.Except import Control.Monad.Reader @@ -16,65 +18,119 @@ import Data.Set (Set) import qualified Data.Set as S import Grammar.Abs -import Grammar.Print (printTree) +import Grammar.Print (Print, printTree) import qualified TypeChecker.HMIr as T data Poly = Forall [Ident] Type deriving Show -data Ctx = Ctx { vars :: Map Ident Poly - , sigs :: Map Ident Type } +newtype Ctx = Ctx { vars :: Map Ident Poly } + +data Env = Env { count :: Int + , sigs :: Map Ident Type + } type Error = String type Subst = Map Ident Type -type Infer = StateT Int (ReaderT Ctx (ExceptT Error Identity)) +type Infer = StateT Env (ReaderT Ctx (ExceptT Error Identity)) -initCtx = Ctx mempty mempty +int = TMono "Int" +a = TPol "a" +b = TPol "b" +arr = TArr + +initCtx = Ctx mempty +initEnv = Env 0 mempty + +runPretty :: Print a => Infer a -> Either Error String +runPretty = fmap printTree . run run :: Infer a -> Either Error a -run = runC initCtx 0 +run = runC initEnv initCtx -runC :: Ctx -> Int -> Infer a -> Either Error a -runC c e = runIdentity . runExceptT . flip runReaderT c . flip evalStateT e +runC :: Env -> Ctx -> Infer a -> Either Error a +runC e c = runIdentity . runExceptT . flip runReaderT c . flip evalStateT e -inferExp :: Exp -> Infer Type -inferExp e = snd <$> w nullSubst e +typecheck :: Program -> Either Error T.Program +typecheck = run . checkPrg -w :: Subst -> Exp -> Infer (Subst, Type) -w s = \case +checkPrg :: Program -> Infer T.Program +checkPrg (Program bs) = do + traverse (\(Bind n t _ _ _) -> insertSig n t) bs + bs' <- mapM checkBind bs + return $ T.Program bs' + +checkBind :: Bind -> Infer T.Bind +checkBind (Bind n t _ args e) = do + (t', e') <- inferExp $ makeLambda e (reverse args) + -- when (t /= t') (throwError "Signature of function and inferred type of body do not match") + s <- unify t t' + let t'' = apply s t + return $ T.Bind (t'',n) [] e' + where + makeLambda :: Exp -> [Ident] -> Exp + makeLambda = foldl (flip EAbs) + +inferExp :: Exp -> Infer (Type, T.Exp) +inferExp e = do + (s, t, e') <- w e + let subbed = apply s t + return (subbed, replace subbed e') + +replace :: Type -> T.Exp -> T.Exp +replace t = \case + T.EInt t' e -> T.EInt t e + T.EId t' i -> T.EId t i + T.EAbs t' name e -> T.EAbs t name e + T.EApp t' e1 e2 -> T.EApp t e1 e2 + T.EAdd t' e1 e2 -> T.EAdd t e1 e2 + T.ELet t' name e1 e2 -> T.ELet t name e1 e2 + +w :: Exp -> Infer (Subst, Type, T.Exp) +w = \case EAnn e t -> do - (s1, t') <- w nullSubst e - let t'' = apply s1 t - return (s1, t'') - EInt n -> return (nullSubst, TMono "Int") + (s1, t', e') <- w e + applySt s1 $ do + s2 <- unify (apply s1 t) t' + return (s2 `compose` s1, t, e') + EInt n -> return (nullSubst, TMono "Int", T.EInt (TMono "Int") n) EId i -> do var <- asks vars case M.lookup i var of Nothing -> throwError $ "Unbound variable: " ++ show i - Just t -> (nullSubst,) <$> inst t - EAbs var e -> do + Just t -> inst t >>= \x -> return (nullSubst, x, T.EId x i) + EAbs name e -> do fr <- fresh - withBinding var (Forall [] fr) $ do - (s1, t') <- w s e - return (s, TArr (apply s1 fr) t') + withBinding name (Forall [] fr) $ do + (s1, t', e') <- w e + let newArr = TArr (apply s1 fr) t' + return (s1, newArr, T.EAbs newArr name e') EAdd e0 e1 -> do - (s1, t1) <- w s e0 - (s2, t2) <- w s1 e1 - return (s2, TMono "Int") + (s1, t0, e0') <- w e0 + applySt s1 $ do + (s2, t1, e1') <- w e1 + applySt s2 $ do + s3 <- unify (subst s2 t0) (TMono "Int") + s4 <- unify (subst s3 t1) (TMono "Int") + return (s4 `compose` s3 `compose` s2 `compose` s1, TMono "Int", T.EAdd (TMono "Int") e0' e1') EApp e0 e1 -> do fr <- fresh - (s1, t0) <- w s e0 - (s2, t1) <- w s1 e1 - s3 <- unify (subst s2 t0) (TArr t1 fr) - return (s3 `compose` s2 `compose` s1, apply s3 fr) + (s1, t0, e0') <- w e0 + applySt s1 $ do + (s2, t1, e1') <- w e1 + applySt s2 $ do + s3 <- unify (subst s2 t0) (TArr t1 fr) + let t = apply s3 fr + return (s3 `compose` s2 `compose` s1, t, T.EApp t e0' e1') ELet name e0 e1 -> do - (s1, t1) <- w s e0 - env <- asks vars - let t' = generalize (apply s1 env) t1 - withBinding name t' $ do - (s2, t2) <- w s1 e1 - return (s1 `compose` s2, t2) + (s1, t1, e0') <- w e0 + applySt s1 $ do + env <- asks vars + let t' = generalize (apply s1 env) t1 + withBinding name t' $ do + (s2, t2, e1') <- w e1 + return (s2 `compose` s1, t2, T.ELet t2 name e0' e1' ) unify :: Type -> Type -> Infer Subst unify t0 t1 = case (t0, t1) of @@ -85,6 +141,7 @@ unify t0 t1 = case (t0, t1) of (TPol a, b) -> occurs a b (a, TPol b) -> occurs b a (TMono a, TMono b) -> if a == b then return M.empty else throwError "Types do not unify" + (a, b) -> throwError . unwords $ ["Type:", printTree a, "can't be unified with:", printTree b] occurs :: Ident -> Type -> Infer Subst occurs i (TPol a) = return nullSubst @@ -104,8 +161,11 @@ inst (Forall xs t) = do compose :: Subst -> Subst -> Subst compose m1 m2 = M.map (subst m1) m2 `M.union` m1 +-- | A class representing free variables functions class FreeVars t where + -- | Get all free variables from t free :: t -> Set Ident + -- | Apply a substitution to t, generating a new t apply :: Subst -> t -> t instance FreeVars Type where @@ -134,9 +194,14 @@ instance FreeVars (Map Ident Poly) where apply :: Subst -> Map Ident Poly -> Map Ident Poly apply s = M.map (apply s) +applySt :: Subst -> Infer a -> Infer a +applySt s = local (\st -> st { vars = apply s (vars st) }) + +-- | Represents the empty substition set nullSubst :: Subst nullSubst = M.empty +-- | Substitute type variables with their mappings from the substitution set. subst :: Subst -> Type -> Type subst m t = do case t of @@ -144,23 +209,23 @@ subst m t = do TMono a -> TMono a TArr a b -> TArr (subst m a) (subst m b) --- | Generate a new fresh variable and increment the state +-- | Generate a new fresh variable and increment the state counter fresh :: Infer Type fresh = do - n <- get - put (n + 1) + n <- gets count + modify (\st -> st { count = n + 1 }) return . TPol . Ident $ "t" ++ show n -withBinding :: Ident -> Poly -> Infer (Subst, Type) -> Infer (Subst, Type) -withBinding i t = local (\re -> re { vars = M.insert i t (vars re) }) +withBinding :: (Monad m, MonadReader Ctx m) => Ident -> Poly -> m a -> m a +withBinding i p = local (\st -> st { vars = M.insert i p (vars st) }) +insertSig :: Ident -> Type -> Infer () +insertSig i t = modify (\st -> st { sigs = M.insert i t (sigs st) }) + +-- | Lookup a variable in the context lookupVar :: Ident -> Infer Poly lookupVar i = do m <- asks vars case M.lookup i m of - Just t -> return t - Nothing -> throwError $ "Unbound variable: " ++ show i - -{-# WARNING todo "TODO IN CODE" #-} -todo :: a -todo = error "TODO in code" + Just t -> return t + Nothing -> throwError $ "Unbound variable: " ++ show i From 5daa5573f26c42a1db125758d2e229fa772a2cec Mon Sep 17 00:00:00 2001 From: sebastianselander Date: Wed, 22 Feb 2023 15:24:38 +0100 Subject: [PATCH 047/372] Added more comments to the code --- src/TypeChecker/AlgoW.hs | 22 +++++++++++++++------- src/TypeChecker/HMIr.hs | 2 +- test_program | 3 ++- 3 files changed, 18 insertions(+), 9 deletions(-) diff --git a/src/TypeChecker/AlgoW.hs b/src/TypeChecker/AlgoW.hs index 3c4b9b3..3492908 100644 --- a/src/TypeChecker/AlgoW.hs +++ b/src/TypeChecker/AlgoW.hs @@ -21,6 +21,7 @@ import Grammar.Abs import Grammar.Print (Print, printTree) import qualified TypeChecker.HMIr as T +-- | A data type representing type variables data Poly = Forall [Ident] Type deriving Show @@ -35,11 +36,6 @@ type Subst = Map Ident Type type Infer = StateT Env (ReaderT Ctx (ExceptT Error Identity)) -int = TMono "Int" -a = TPol "a" -b = TPol "b" -arr = TArr - initCtx = Ctx mempty initEnv = Env 0 mempty @@ -64,7 +60,6 @@ checkPrg (Program bs) = do checkBind :: Bind -> Infer T.Bind checkBind (Bind n t _ args e) = do (t', e') <- inferExp $ makeLambda e (reverse args) - -- when (t /= t') (throwError "Signature of function and inferred type of body do not match") s <- unify t t' let t'' = apply s t return $ T.Bind (t'',n) [] e' @@ -132,6 +127,7 @@ w = \case (s2, t2, e1') <- w e1 return (s2 `compose` s1, t2, T.ELet t2 name e0' e1' ) +-- | Unify two types producing a new substitution (constraint) unify :: Type -> Type -> Infer Subst unify t0 t1 = case (t0, t1) of (TArr a b, TArr c d) -> do @@ -143,15 +139,19 @@ unify t0 t1 = case (t0, t1) of (TMono a, TMono b) -> if a == b then return M.empty else throwError "Types do not unify" (a, b) -> throwError . unwords $ ["Type:", printTree a, "can't be unified with:", printTree b] +-- | Check if a type is contained in another type. +-- I.E. { a = a -> b } is an unsolvable constraint since there is no substitution such that these are equal occurs :: Ident -> Type -> Infer Subst occurs i (TPol a) = return nullSubst occurs i t = if S.member i (free t) then throwError "Occurs check failed" else return $ M.singleton i t +-- | Generalize a type over all free variables in the substitution set generalize :: Map Ident Poly -> Type -> Poly generalize env t = Forall (S.toList $ free t S.\\ free env) t +-- | Instantiate a polymorphic type. The free type variables are substituted with fresh ones. inst :: Poly -> Infer Type inst (Forall xs t) = do xs' <- mapM (const fresh) xs @@ -165,7 +165,7 @@ compose m1 m2 = M.map (subst m1) m2 `M.union` m1 class FreeVars t where -- | Get all free variables from t free :: t -> Set Ident - -- | Apply a substitution to t, generating a new t + -- | Apply a substitution to t apply :: Subst -> t -> t instance FreeVars Type where @@ -216,9 +216,11 @@ fresh = do modify (\st -> st { count = n + 1 }) return . TPol . Ident $ "t" ++ show n +-- | Run the monadic action with an additional binding withBinding :: (Monad m, MonadReader Ctx m) => Ident -> Poly -> m a -> m a withBinding i p = local (\st -> st { vars = M.insert i p (vars st) }) +-- | Insert a function signature into the environment insertSig :: Ident -> Type -> Infer () insertSig i t = modify (\st -> st { sigs = M.insert i t (sigs st) }) @@ -229,3 +231,9 @@ lookupVar i = do case M.lookup i m of Just t -> return t Nothing -> throwError $ "Unbound variable: " ++ show i + +lett = let (Right (t,e)) = run $ inferExp $ ELet "x" (EAdd (EInt 5) (EInt 5)) (EAdd (EId "x") (EId "x")) + in t == TMono "Int" + +letty = let (Right (t,e)) = run $ inferExp $ ELet "f" (EAbs "x" (EId "x")) (EApp (EId "f") (EInt 3)) + in e diff --git a/src/TypeChecker/HMIr.hs b/src/TypeChecker/HMIr.hs index 036fa42..0a6085c 100644 --- a/src/TypeChecker/HMIr.hs +++ b/src/TypeChecker/HMIr.hs @@ -25,7 +25,7 @@ data Exp instance Show Exp where show (EId t (Ident i)) = i ++ " : " ++ show t show (EInt _ i) = show i - show (ELet t i e1 e2) = error "Show for let not implemented" + show (ELet t i e1 e2) = "let " ++ show t ++ " = " ++ show e1 ++ " in " ++ show e2 show (EApp t e1 e2) = show e1 ++ " " ++ show e2 ++ " : " ++ show t show (EAdd _ e1 e2) = show e1 ++ " + " ++ show e2 show (EAbs t (Ident i) e) = "\\ " ++ i ++ ". " ++ show e ++ " : " ++ show t diff --git a/test_program b/test_program index 6d38647..3481a0b 100644 --- a/test_program +++ b/test_program @@ -1,2 +1,3 @@ fun : Mono Int -> Mono Int ; -fun = \x. x ; +fun = let f = \x. x in f 3 ; + From 06e65de23574b53f2bd334af9a859357fe7e7051 Mon Sep 17 00:00:00 2001 From: sebastianselander Date: Thu, 23 Feb 2023 11:54:35 +0100 Subject: [PATCH 048/372] started on a test suite --- language.cabal | 31 +++- src/Main.hs | 3 +- src/Renamer/RenamerM.hs | 2 +- src/TypeChecker/AlgoW.hs | 11 +- src/TypeChecker/Unification.hs | 261 --------------------------------- tests/Main.hs | 21 +++ 6 files changed, 57 insertions(+), 272 deletions(-) delete mode 100644 src/TypeChecker/Unification.hs create mode 100644 tests/Main.hs diff --git a/language.cabal b/language.cabal index 7b21b60..f803c1b 100644 --- a/language.cabal +++ b/language.cabal @@ -15,7 +15,6 @@ extra-doc-files: CHANGELOG.md extra-source-files: Grammar.cf - common warnings ghc-options: -Wdefault @@ -51,6 +50,34 @@ executable language , either , extra , array - , unification-fd default-language: GHC2021 + +test-suite test + hs-source-dirs: tests, src + main-is: Main.hs + type: exitcode-stdio-1.0 + + other-modules: + Grammar.Abs + Grammar.Lex + Grammar.Par + Grammar.Print + Grammar.Skel + Grammar.ErrM + Auxiliary + Renamer.RenamerM + TypeChecker.AlgoW + TypeChecker.HM + TypeChecker.HMIr + + build-depends: + base >=4.16 + , mtl + , containers + , either + , array + , extra + , hspec + + default-language: GHC2021 diff --git a/src/Main.hs b/src/Main.hs index 1a73e95..58811fe 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -12,8 +12,7 @@ import System.Exit (exitFailure, exitSuccess) import TypeChecker.AlgoW (typecheck) main :: IO () -main = - getArgs >>= \case +main = getArgs >>= \case [] -> print "Required file path missing" (x : _) -> do file <- readFile x diff --git a/src/Renamer/RenamerM.hs b/src/Renamer/RenamerM.hs index 215290c..5fb1fa2 100644 --- a/src/Renamer/RenamerM.hs +++ b/src/Renamer/RenamerM.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE LambdaCase #-} module Renamer.RenamerM where diff --git a/src/TypeChecker/AlgoW.hs b/src/TypeChecker/AlgoW.hs index 3492908..de931d1 100644 --- a/src/TypeChecker/AlgoW.hs +++ b/src/TypeChecker/AlgoW.hs @@ -120,12 +120,11 @@ w = \case return (s3 `compose` s2 `compose` s1, t, T.EApp t e0' e1') ELet name e0 e1 -> do (s1, t1, e0') <- w e0 - applySt s1 $ do - env <- asks vars - let t' = generalize (apply s1 env) t1 - withBinding name t' $ do - (s2, t2, e1') <- w e1 - return (s2 `compose` s1, t2, T.ELet t2 name e0' e1' ) + env <- asks vars + let t' = generalize (apply s1 env) t1 + withBinding name t' $ do + (s2, t2, e1') <- w e1 + return (s2 `compose` s1, t2, T.ELet t2 name e0' e1' ) -- | Unify two types producing a new substitution (constraint) unify :: Type -> Type -> Infer Subst diff --git a/src/TypeChecker/Unification.hs b/src/TypeChecker/Unification.hs deleted file mode 100644 index 226e1e9..0000000 --- a/src/TypeChecker/Unification.hs +++ /dev/null @@ -1,261 +0,0 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PatternSynonyms #-} - -module TypeChecker.Unification where - -import Control.Arrow ((>>>)) -import Control.Monad.Except -import Control.Monad.Reader -import Control.Monad.State -import Control.Unification hiding (applyBindings, (=:=)) -import qualified Control.Unification as U -import Control.Unification.IntVar -import Data.Foldable (fold) -import Data.Functor.Fixedpoint -import Data.Functor.Identity -import Data.Map (Map) -import qualified Data.Map as M -import Data.Maybe (fromJust, fromMaybe) -import Data.Set (Set, (\\)) -import qualified Data.Set as S -import Debug.Trace (trace) -import GHC.Generics (Generic1) -import Renamer.Renamer -import qualified Renamer.RenamerIr as R -import Renamer.RenamerIr (Const (..), Ident (..), RBind (..), - RExp (..), RProgram (..)) - -type Ctx = Map Ident UPolytype - -type TypeError = String - -data TypeT a = TPolyT Ident | TMonoT Ident | TArrowT a a - deriving (Functor, Foldable, Traversable, Generic1, Unifiable) - -instance Show a => Show (TypeT a) where - show (TPolyT (Ident i)) = i - show (TMonoT (Ident i)) = i - show (TArrowT a b) = show a ++ " -> " ++ show b - -type Infer = StateT (Map Ident UPolytype) (ReaderT Ctx (ExceptT TypeError (IntBindingT TypeT Identity))) - -type Type = Fix TypeT - -type UType = UTerm TypeT IntVar - -data Poly t = Forall [Ident] t - deriving (Eq, Functor) - -instance Show t => Show (Poly t) where - show (Forall is t) = unwords (map (\(Ident x) -> "forall " ++ x ++ ".") is) ++ " " ++ show t - -type Polytype = Poly Type - -type UPolytype = Poly UType - -pattern TPoly :: Ident -> Type -pattern TPoly v = Fix (TPolyT v) - -pattern TMono :: Ident -> Type -pattern TMono v = Fix (TMonoT v) - -pattern TArrow :: Type -> Type -> Type -pattern TArrow t1 t2 = Fix (TArrowT t1 t2) - -pattern UTMono :: Ident -> UType -pattern UTMono v = UTerm (TMonoT v) - -pattern UTArrow :: UType -> UType -> UType -pattern UTArrow t1 t2 = UTerm (TArrowT t1 t2) - -pattern UTPoly :: Ident -> UType -pattern UTPoly v = UTerm (TPolyT v) - -data TType = TTPoly Ident | TTMono Ident | TTArrow TType TType - deriving (Show) - -newtype Program = Program [Bind] - deriving (Show) - -data Bind = Bind Ident Exp Polytype - deriving (Show) - -data Exp - = EAnn Exp Polytype - | EBound Ident Polytype - | EFree Ident Polytype - | EConst Const Polytype - | EApp Exp Exp Polytype - | EAdd Exp Exp Polytype - | EAbs Ident Exp Polytype - deriving (Show) - -data TExp - = TAnn TExp UType - | TFree Ident UType - | TBound Ident UType - | TConst Const UType - | TApp TExp TExp UType - | TAdd TExp TExp UType - | TAbs Ident TExp UType - deriving (Show) - ----------------------------------------------------------- -typecheck :: RProgram -> Either TypeError Program -typecheck = undefined - -run :: Infer (UType, TExp) -> Either TypeError Polytype -run = fmap fst - >>> (>>= applyBindings) - >>> (>>= (generalize >>> fmap fromUPolytype)) - >>> flip evalStateT mempty - >>> flip runReaderT mempty - >>> runExceptT - >>> evalIntBindingT - >>> runIdentity - -infer :: RExp -> Infer (UType, TExp) -infer = \case - (RConst (CInt i)) -> return (UTMono "Int", TConst (CInt i) (UTMono "Int")) - (RConst (CStr str)) -> return (UTMono "String", TConst (CStr str) (UTMono "String")) - (RAdd e1 e2) -> do - (t1, e1') <- infer e2 - (t2, e2') <- infer e1 - t1 =:= UTMono "Int" - t2 =:= UTMono "Int" - return (UTMono "Int", TAdd e1' e2' (UTMono "Int")) - -- type is not used, probably wrong - (RAnn e t) -> do - (t', e') <- infer e - check e t' - return (t', TAnn e' t') - (RApp e1 e2) -> do - (f, e1') <- infer e1 - (arg, e2') <- infer e2 - res <- fresh - f =:= UTArrow arg res - return (res, TApp e1' e2' res) - (RAbs _ i e) -> do - arg <- fresh - withBinding i (Forall [] arg) $ do - (res, e') <- infer e - return (UTArrow arg res, TAbs i e' (UTArrow arg res)) - (RFree i) -> do - t <- lookupSigsT i - return (t, TFree i t) - (RBound _ i) -> do - t <- lookupVarT i - return (t, TBound i t) - -check :: RExp -> UType -> Infer () -check expr t = do - (t', _) <- infer expr - t =:= t' - return () - -lookupVarT :: Ident -> Infer UType -lookupVarT x@(Ident i) = do - ctx <- ask - maybe (throwError $ "Var - Unbound variable: " <> i) instantiate (M.lookup x ctx) - -lookupSigsT :: Ident -> Infer UType -lookupSigsT x@(Ident i) = do - ctx <- ask - case M.lookup x ctx of - Nothing -> trace (show ctx) (throwError $ "Sigs - Unbound variable: " <> i) - Just ut -> return $ fromPolytype ut - -insertSigs :: MonadState (Map Ident UPolytype) m => Ident -> UPolytype -> m () -insertSigs x ty = modify (M.insert x ty) - -fromPolytype :: UPolytype -> UType -fromPolytype (Forall ids ut) = ut - -ucata :: Functor t => (v -> a) -> (t a -> a) -> UTerm t v -> a -ucata f _ (UVar v) = f v -ucata f g (UTerm t) = g (fmap (ucata f g) t) - -withBinding :: MonadReader Ctx m => Ident -> UPolytype -> m a -> m a -withBinding x ty = local (M.insert x ty) - -deriving instance Ord IntVar - -class FreeVars a where - freeVars :: a -> Infer (Set (Either Ident IntVar)) - -instance FreeVars UType where - freeVars ut = do - fuvs <- fmap (S.fromList . map Right) . lift . lift . lift $ getFreeVars ut - let ftvs = - ucata - (const S.empty) - (\case TMonoT x -> S.singleton (Left x); f -> fold f) - ut - return $ fuvs `S.union` ftvs - -instance FreeVars UPolytype where - freeVars (Forall xs ut) = (\\ (S.fromList (map Left xs))) <$> freeVars ut - -instance FreeVars Ctx where - freeVars = fmap S.unions . mapM freeVars . M.elems - -fresh :: Infer UType -fresh = UVar <$> lift (lift (lift freeVar)) - -instance Fallible TypeT IntVar TypeError where - occursFailure iv ut = "Infinite" - mismatchFailure iv ut = "Mismatch" - -(=:=) :: UType -> UType -> Infer UType -(=:=) s t = lift . lift $ s U.=:= t - -applyBindings :: UType -> Infer UType -applyBindings = lift . lift . U.applyBindings - -instantiate :: UPolytype -> Infer UType -instantiate (Forall xs uty) = do - xs' <- mapM (const fresh) xs - return $ substU (M.fromList (zip (map Left xs) xs')) uty - -substU :: Map (Either Ident IntVar) UType -> UType -> UType -substU m = - ucata - (\v -> fromMaybe (UVar v) (M.lookup (Right v) m)) - ( \case - TPolyT v -> fromMaybe (UTPoly v) (M.lookup (Left v) m) - f -> UTerm f - ) - -skolemize :: UPolytype -> Infer UType -skolemize (Forall xs uty) = do - xs' <- mapM (const fresh) xs - return $ substU (M.fromList (zip (map Left xs) (map toSkolem xs'))) uty - where - toSkolem (UVar v) = UTPoly (mkVarName "s" v) - -mkVarName :: String -> IntVar -> Ident -mkVarName nm (IntVar v) = Ident $ nm ++ show (v + (maxBound :: Int) + 1) - --- | Used in let bindings to generalize functions declared there -generalize :: UType -> Infer UPolytype -generalize uty = do - uty' <- applyBindings uty - ctx <- ask - tmfvs <- freeVars uty' - ctxfvs <- freeVars ctx - let fvs = S.toList $ tmfvs \\ ctxfvs - xs = map (either id (mkVarName "a")) fvs - return $ Forall xs (substU (M.fromList (zip fvs (map UTPoly xs))) uty') - -fromUPolytype :: UPolytype -> Polytype -fromUPolytype = fmap (fromJust . freeze) - -inf = RAbs 0 "x" (RApp (RBound 0 "x") (RBound 0 "x")) - -one = RConst (CInt 1) - -lambda = RAbs 0 "f" (RAbs 1 "x" (RApp (RBound 0 "f") (RBound 1 "x"))) - -fn = RAbs 0 "x" (RBound 0 "x") diff --git a/tests/Main.hs b/tests/Main.hs new file mode 100644 index 0000000..7432800 --- /dev/null +++ b/tests/Main.hs @@ -0,0 +1,21 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Main where + +import Grammar.Abs +import System.Exit (exitFailure) +import Test.Hspec +import TypeChecker.AlgoW + +main :: IO () +main = do + print "RUNNING TESTS BROTHER" + exitFailure + -- hspec $ do + -- describe "the algorithm W" $ do + -- it "infers EInt as type Int" $ do + -- fmap fst (run (inferExp (EInt 1))) `shouldBe` Right (TMono "Int") + -- it "throws an exception if a variable is inferred with an empty env" $ do + -- run (inferExp (EId "x")) `shouldBe` Left "Unbound variable: x" + -- it "throws an exception if the annotated type does not match the inferred type" $ do + -- fmap fst (run (inferExp (EAnn (EInt 3) (TPol "a")))) `shouldBe` Right (TMono "bad") From 5d004f4286a5101a1df1b996a3c1793fef031cd7 Mon Sep 17 00:00:00 2001 From: Samuel Hammersberg Date: Fri, 24 Feb 2023 09:00:29 +0100 Subject: [PATCH 049/372] Added calling conventions to functions. --- sample-programs/basic-1 | 23 ++++++++++++++++++++++- src/Compiler.hs | 38 +++++++++++++++++++++++++------------- src/LlvmIr.hs | 21 +++++++++++++++------ 3 files changed, 62 insertions(+), 20 deletions(-) diff --git a/sample-programs/basic-1 b/sample-programs/basic-1 index a88960b..113c8b7 100644 --- a/sample-programs/basic-1 +++ b/sample-programs/basic-1 @@ -61,6 +61,27 @@ facc a = case a of { 1 => 1, _ => posMul a (facc (a - 1)) } : Int; +-- main : Int; +-- main = facc 5 +-- answer: 120 + +-- pow : Int -> Int -> Int; +-- pow a b = case b of { +-- 0 => 1, +-- _ => posMul a (pow a (b-1)) +-- } : Int; + +minimization : (Int -> Int) -> Int -> Int; +minimization p x = case p x of { + 1 => x, + _ => minimization p (x + 1) +} : Int; + +checkFac : Int -> Int; +checkFac x = case facc x of { + 0 => 1, + _ => 0 +} : Int; main : Int; -main = facc 27 \ No newline at end of file +main = minimization checkFac 1 \ No newline at end of file diff --git a/src/Compiler.hs b/src/Compiler.hs index bffab3b..7490917 100644 --- a/src/Compiler.hs +++ b/src/Compiler.hs @@ -10,7 +10,8 @@ import qualified Data.Map as Map import Data.Tuple.Extra (dupe, first, second) import qualified Grammar.Abs as GA import Grammar.ErrM (Err) -import LlvmIr (LLVMComp (..), LLVMIr (..), LLVMType (..), +import LlvmIr (CallingConvention (..), LLVMComp (..), + LLVMIr (..), LLVMType (..), LLVMValue (..), Visibility (..), llvmIrToString) import TypeChecker (partitionType) @@ -119,7 +120,7 @@ compileScs (Bind (name, t) args exp : xs) = do emit $ UnsafeRaw "\n" emit . Comment $ show name <> ": " <> show exp let args' = map (second type2LlvmType) args - emit $ Define I64 {-(type2LlvmType t_return)-} name args' + emit $ Define FastCC I64 {-(type2LlvmType t_return)-} name args' functionBody <- exprToValue exp if name == "main" then mapM_ emit $ mainContent functionBody @@ -182,19 +183,30 @@ emitECased t e cases = do emit $ SetVariable (Ident $ show res) (Load ty Ptr (Ident $ show stackPtr)) where emitCases :: LLVMType -> Ident -> Integer -> LLVMValue -> Case -> CompilerState () - emitCases ty label stackPtr vs (Case (GA.CInt i) exp) = do + emitCases ty label stackPtr vs (Case (GA.CInt 0) exp) = do ns <- getNewVar - lbl_fail <- getNewLabel - lbl_succ <- getNewLabel - let failed = Ident $ "failed_" <> show lbl_fail - let success = Ident $ "success_" <> show lbl_succ - emit $ SetVariable (Ident $ show ns) (Icmp LLEq ty vs (VInteger i)) - emit $ BrCond (VIdent (Ident $ show ns) ty) success failed - emit $ Label success + lbl_failPos <- (\x -> Ident $ "failed_" <> show x) <$> getNewLabel + lbl_succPos <- (\x -> Ident $ "success_" <> show x) <$> getNewLabel + lbl_failNeg <- (\x -> Ident $ "failed_" <> show x) <$> getNewLabel + lbl_succNeg <- (\x -> Ident $ "success_" <> show x) <$> getNewLabel + emit $ SetVariable (Ident $ show ns) (Icmp LLEq ty vs (VInteger 0)) + emit $ BrCond (VIdent (Ident $ show ns) ty) lbl_succPos lbl_failPos + emit $ Label lbl_succPos val <- exprToValue exp emit $ Store ty val Ptr (Ident . show $ stackPtr) emit $ Br label - emit $ Label failed + emit $ Label lbl_failPos + emitCases ty label stackPtr vs (Case (GA.CInt i) exp) = do + ns <- getNewVar + lbl_failPos <- (\x -> Ident $ "failed_" <> show x) <$> getNewLabel + lbl_succPos <- (\x -> Ident $ "success_" <> show x) <$> getNewLabel + emit $ SetVariable (Ident $ show ns) (Icmp LLEq ty vs (VInteger i)) + emit $ BrCond (VIdent (Ident $ show ns) ty) lbl_succPos lbl_failPos + emit $ Label lbl_succPos + val <- exprToValue exp + emit $ Store ty val Ptr (Ident . show $ stackPtr) + emit $ Br label + emit $ Label lbl_failPos emitCases ty label stackPtr _ (Case GA.CatchAll exp) = do val <- exprToValue exp emit $ Store ty val Ptr (Ident . show $ stackPtr) @@ -231,7 +243,7 @@ emitApp t e1 e2 = appEmitter t e1 e2 [] funcs <- gets functions let visibility = maybe Local (const Global) $ Map.lookup id funcs args' = map (first valueGetType . dupe) args - call = Call (type2LlvmType t) visibility name args' + call = Call FastCC (type2LlvmType t) visibility name args' emit $ SetVariable (Ident $ show vs) call x -> do emit . Comment $ "The unspeakable happened: " @@ -314,7 +326,7 @@ exprToValue = \case then do vc <- getNewVar emit $ SetVariable (Ident $ show vc) - (Call (type2LlvmType t) Global name []) + (Call FastCC (type2LlvmType t) Global name []) pure $ VIdent (Ident $ show vc) (type2LlvmType t) else pure $ VFunction name Global (type2LlvmType t) Nothing -> pure $ VIdent name (type2LlvmType t) diff --git a/src/LlvmIr.hs b/src/LlvmIr.hs index 68f45f2..7fe40c0 100644 --- a/src/LlvmIr.hs +++ b/src/LlvmIr.hs @@ -7,11 +7,20 @@ module LlvmIr ( LLVMValue (..), LLVMComp (..), Visibility (..), + CallingConvention (..) ) where import Data.List (intercalate) import TypeCheckerIr +data CallingConvention = TailCC | FastCC | CCC | ColdCC +instance Show CallingConvention where + show :: CallingConvention -> String + show TailCC = "tailcc" + show FastCC = "fastcc" + show CCC = "ccc" + show ColdCC = "coldcc" + -- | A datatype which represents some basic LLVM types data LLVMType = I1 @@ -89,7 +98,7 @@ type Args = [(LLVMType, LLVMValue)] -- | A datatype which represents different instructions in LLVM data LLVMIr - = Define LLVMType Ident Params + = Define CallingConvention LLVMType Ident Params | DefineEnd | Declare LLVMType Ident Params | SetVariable Ident LLVMIr @@ -103,7 +112,7 @@ data LLVMIr | Br Ident | BrCond LLVMValue Ident Ident | Label Ident - | Call LLVMType Visibility Ident Args + | Call CallingConvention LLVMType Visibility Ident Args | Alloca LLVMType | Store LLVMType LLVMValue LLVMType Ident | Load LLVMType LLVMType Ident @@ -134,9 +143,9 @@ llvmIrToString = go 0 insToString :: Int -> LLVMIr -> String insToString i l = replicate i '\t' <> case l of - (Define t (Ident i) params) -> + (Define c t (Ident i) params) -> concat - [ "define fastcc ", show t, " @", i + [ "define ", show c, " ", show t, " @", i , "(", intercalate ", " (map (\(Ident y, x) -> unwords [show x, "%" <> y]) params) , ") {\n" ] @@ -168,9 +177,9 @@ llvmIrToString = go 0 [ "srem ", show t, " ", show v1, ", " , show v2, "\n" ] - (Call t vis (Ident i) arg) -> + (Call c t vis (Ident i) arg) -> concat - [ "call fastcc ", show t, " ", show vis, i, "(" + [ "call ", show c, " ", show t, " ", show vis, i, "(" , intercalate ", " $ Prelude.map (\(x, y) -> show x <> " " <> show y) arg , ")\n" ] From 272fbe350487beb6c700bede0312b2c52037b247 Mon Sep 17 00:00:00 2001 From: Samuel Hammersberg Date: Fri, 24 Feb 2023 09:29:55 +0100 Subject: [PATCH 050/372] Removed some unused code. --- src/LlvmIr.hs | 9 ++++++++- 1 file changed, 8 insertions(+), 1 deletion(-) diff --git a/src/LlvmIr.hs b/src/LlvmIr.hs index 7fe40c0..b156edb 100644 --- a/src/LlvmIr.hs +++ b/src/LlvmIr.hs @@ -98,7 +98,8 @@ type Args = [(LLVMType, LLVMValue)] -- | A datatype which represents different instructions in LLVM data LLVMIr - = Define CallingConvention LLVMType Ident Params + = Type Ident [LLVMType] + | Define CallingConvention LLVMType Ident Params | DefineEnd | Declare LLVMType Ident Params | SetVariable Ident LLVMIr @@ -143,6 +144,12 @@ llvmIrToString = go 0 insToString :: Int -> LLVMIr -> String insToString i l = replicate i '\t' <> case l of + (Type (Ident n) types) -> + concat + [ "%", n, " = {" + , intercalate " , " (map show types) + , "}" + ] (Define c t (Ident i) params) -> concat [ "define ", show c, " ", show t, " @", i From 262543931c0704c8866d9f089668749d93784de5 Mon Sep 17 00:00:00 2001 From: Samuel Hammersberg Date: Fri, 24 Feb 2023 16:05:49 +0100 Subject: [PATCH 051/372] Types for data types are now created. --- src/Compiler.hs | 138 ++++++++++++++++++++++++++----------------- src/LlvmIr.hs | 8 +-- src/TypeCheckerIr.hs | 8 ++- 3 files changed, 94 insertions(+), 60 deletions(-) diff --git a/src/Compiler.hs b/src/Compiler.hs index 7490917..bbcde26 100644 --- a/src/Compiler.hs +++ b/src/Compiler.hs @@ -3,26 +3,28 @@ module Compiler (compile) where -import Auxiliary (snoc) -import Control.Monad.State (StateT, execStateT, gets, modify) -import Data.Map (Map) -import qualified Data.Map as Map -import Data.Tuple.Extra (dupe, first, second) -import qualified Grammar.Abs as GA -import Grammar.ErrM (Err) -import LlvmIr (CallingConvention (..), LLVMComp (..), - LLVMIr (..), LLVMType (..), - LLVMValue (..), Visibility (..), - llvmIrToString) -import TypeChecker (partitionType) -import TypeCheckerIr (Bind (..), Case (..), Exp (..), Id, - Ident (..), Program (..), - Type (TFun, TInt)) +import Auxiliary (snoc) +import Control.Monad.State (StateT, execStateT, gets, modify) +import Data.List.Extra (trim) +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Tuple.Extra (dupe, first, second) +import qualified Grammar.Abs as GA +import Grammar.ErrM (Err) +import LlvmIr (CallingConvention (..), LLVMComp (..), + LLVMIr (..), LLVMType (..), + LLVMValue (..), Visibility (..), + llvmIrToString) +import System.Process.Extra (readCreateProcess, shell) +import TypeChecker (partitionType) +import TypeCheckerIr (Bind (..), Case (..), Exp (..), Id, + Ident (..), Program (..), Type (..)) -- | The record used as the code generator state data CodeGenerator = CodeGenerator { instructions :: [LLVMIr] , functions :: Map Id FunctionInfo + , constructors :: Map Id FunctionInfo , variableCount :: Integer , labelCount :: Integer } @@ -34,6 +36,7 @@ data FunctionInfo = FunctionInfo { numArgs :: Int , arguments :: [Id] } + deriving Show -- | Adds a instruction to the CodeGenerator state emit :: LLVMIr -> CompilerState () @@ -60,51 +63,62 @@ getNewLabel = do -- | Produces a map of functions infos from a list of binds, -- which contains useful data for code generation. getFunctions :: [Bind] -> Map Id FunctionInfo -getFunctions bs = Map.fromList $ map go bs +getFunctions bs = Map.fromList $ go bs where - go (Bind id args _) = + go [] = [] + go (Bind id args _ : xs) = (id, FunctionInfo { numArgs=length args, arguments=args }) + : go xs + go (DataStructure n cons : xs) = do + map (\(id, xs) -> ((id, TPol n), FunctionInfo { + numArgs=length xs, arguments=createArgs xs + })) cons + <> go xs +createArgs :: [Type] -> [Id] +createArgs xs = fst $ foldl (\(acc, l) t -> (acc ++ [(Ident ("arg_" <> show l) , t)],l+1)) ([], 0) xs +-- | Produces a map of functions infos from a list of binds, +-- which contains useful data for code generation. +getConstructors :: [Bind] -> Map Id FunctionInfo +getConstructors bs = Map.fromList $ go bs + where + go [] = [] + go (DataStructure n cons : xs) = do + map (\(id, xs) -> ((id, TPol n), FunctionInfo { + numArgs=length xs, arguments=createArgs xs + })) cons + <> go xs + go (_: xs) = go xs initCodeGenerator :: [Bind] -> CodeGenerator initCodeGenerator scs = CodeGenerator { instructions = defaultStart , functions = getFunctions scs + , constructors = getConstructors scs , variableCount = 0 , labelCount = 0 } -{- + run :: Err String -> IO () run s = do let s' = case s of Right s -> s Left _ -> error "yo" - writeFile "llvm.ll" s' + writeFile "output/llvm.ll" s' putStrLn . trim =<< readCreateProcess (shell "lli") s' test :: Integer -> Program test v = Program [ - Bind (Ident "fibonacci", TInt) [(Ident "x", TInt)] ( - ECase TInt (EId ("x", TInt)) [ - (TInt,Case (CInt 0) (EInt 0)), - Case (CInt 1) (EInt 1), - Case CatchAll (EAdd TInt - (EApp TInt (EId (Ident "fibonacci", TInt)) ( - EAdd TInt (EId (Ident "x", TInt)) - (EInt (fromIntegral ((maxBound :: Int) * 2))) - )) - (EApp TInt (EId (Ident "fibonacci", TInt)) ( - EAdd TInt (EId (Ident "x", TInt)) - (EInt (fromIntegral ((maxBound :: Int) * 2 + 1))) - )) - ) - ] - ), + DataStructure (Ident "Craig") [ + (Ident "Bob", [TInt]), + (Ident "Alice", [TInt, TInt]) + ], + Bind (Ident "fibonacci", TInt) [(Ident "x", TInt)] (EId ("x",TInt)), Bind (Ident "main", TInt) [] ( EApp TInt (EId (Ident "fibonacci", TInt)) (EInt v) -- (EInt 92) ) ] --} + {- | Compiles an AST and produces a LLVM Ir string. An easy way to actually "compile" this output is to Simply pipe it to LLI @@ -115,8 +129,14 @@ compile (Program scs) = do llvmIrToString . instructions <$> execStateT (compileScs scs) codegen compileScs :: [Bind] -> CompilerState () -compileScs [] = pure () -compileScs (Bind (name, t) args exp : xs) = do +compileScs [] = do + return () + -- c <- gets (Map.toList . constructors) + -- mapM_ (\((id, t), fi) -> do + -- emit $ Define FastCC (type2LlvmType t) id [] + -- emit DefineEnd + -- ) c +compileScs (Bind (name, _t) args exp : xs) = do emit $ UnsafeRaw "\n" emit . Comment $ show name <> ": " <> show exp let args' = map (second type2LlvmType) args @@ -128,8 +148,16 @@ compileScs (Bind (name, t) args exp : xs) = do emit DefineEnd modify $ \s -> s { variableCount = 0 } compileScs xs - where - t_return = snd $ partitionType (length args) t +compileScs (DataStructure id@(Ident outer_id) ts : xs) = do + let biggest_variant = maximum ((\(_, t) -> sum $ typeByteSize . type2LlvmType <$> t) <$> ts) + emit $ Type id [I8, Array biggest_variant I8] + mapM_ (\(Ident inner_id, fi) -> do + emit $ Type (Ident $ outer_id <> "_" <> inner_id) (I8 : map type2LlvmType fi) + ) ts + compileScs xs + + -- where + -- _t_return = snd $ partitionType (length args) t mainContent :: LLVMValue -> [LLVMIr] mainContent var = @@ -150,7 +178,9 @@ mainContent var = ] defaultStart :: [LLVMIr] -defaultStart = [ UnsafeRaw "@.str = private unnamed_addr constant [3 x i8] c\"%i\n\", align 1\n" +defaultStart = [ UnsafeRaw "target triple = \"x86_64-pc-linux-gnu\"\n" + , UnsafeRaw "target datalayout = \"e-m:o-i64:64-f80:128-n8:16:32:64-S128\"\n" + , UnsafeRaw "@.str = private unnamed_addr constant [3 x i8] c\"%i\n\", align 1\n" , UnsafeRaw "declare i32 @printf(ptr noalias nocapture, ...)\n" ] @@ -183,19 +213,6 @@ emitECased t e cases = do emit $ SetVariable (Ident $ show res) (Load ty Ptr (Ident $ show stackPtr)) where emitCases :: LLVMType -> Ident -> Integer -> LLVMValue -> Case -> CompilerState () - emitCases ty label stackPtr vs (Case (GA.CInt 0) exp) = do - ns <- getNewVar - lbl_failPos <- (\x -> Ident $ "failed_" <> show x) <$> getNewLabel - lbl_succPos <- (\x -> Ident $ "success_" <> show x) <$> getNewLabel - lbl_failNeg <- (\x -> Ident $ "failed_" <> show x) <$> getNewLabel - lbl_succNeg <- (\x -> Ident $ "success_" <> show x) <$> getNewLabel - emit $ SetVariable (Ident $ show ns) (Icmp LLEq ty vs (VInteger 0)) - emit $ BrCond (VIdent (Ident $ show ns) ty) lbl_succPos lbl_failPos - emit $ Label lbl_succPos - val <- exprToValue exp - emit $ Store ty val Ptr (Ident . show $ stackPtr) - emit $ Br label - emit $ Label lbl_failPos emitCases ty label stackPtr vs (Case (GA.CInt i) exp) = do ns <- getNewVar lbl_failPos <- (\x -> Ident $ "failed_" <> show x) <$> getNewLabel @@ -342,7 +359,7 @@ type2LlvmType = \case TFun t xs -> do let (t', xs') = function2LLVMType xs [type2LlvmType t] Function t' xs' - t -> CustomType $ Ident ("\"" ++ show t ++ "\"") + TPol t -> CustomType t where function2LLVMType :: Type -> [LLVMType] -> (LLVMType, [LLVMType]) function2LLVMType (TFun t xs) s = function2LLVMType xs (type2LlvmType t : s) @@ -363,3 +380,14 @@ valueGetType (VInteger _) = I64 valueGetType (VIdent _ t) = t valueGetType (VConstant s) = Array (length s) I8 valueGetType (VFunction _ _ t) = t + +typeByteSize :: LLVMType -> Int +typeByteSize I1 = 1 +typeByteSize I8 = 1 +typeByteSize I32 = 4 +typeByteSize I64 = 8 +typeByteSize Ptr = 8 +typeByteSize (Ref _) = 8 +typeByteSize (Function _ _) = 8 +typeByteSize (Array n t) = n * typeByteSize t +typeByteSize (CustomType _) = 8 diff --git a/src/LlvmIr.hs b/src/LlvmIr.hs index b156edb..2a96957 100644 --- a/src/LlvmIr.hs +++ b/src/LlvmIr.hs @@ -44,7 +44,7 @@ instance Show LLVMType where Ref ty -> show ty <> "*" Function t xs -> show t <> " (" <> intercalate ", " (map show xs) <> ")*" Array n ty -> concat ["[", show n, " x ", show ty, "]"] - CustomType (Ident ty) -> ty + CustomType (Ident ty) -> "%" <> ty data LLVMComp = LLEq @@ -146,9 +146,9 @@ llvmIrToString = go 0 replicate i '\t' <> case l of (Type (Ident n) types) -> concat - [ "%", n, " = {" - , intercalate " , " (map show types) - , "}" + [ "%", n, " = type { " + , intercalate ", " (map show types) + , " }\n" ] (Define c t (Ident i) params) -> concat diff --git a/src/TypeCheckerIr.hs b/src/TypeCheckerIr.hs index 0e30d0c..8053bd1 100644 --- a/src/TypeCheckerIr.hs +++ b/src/TypeCheckerIr.hs @@ -30,7 +30,7 @@ data Case = Case GA.Case Exp type Id = (Ident, Type) -data Bind = Bind Id [Id] Exp +data Bind = Bind Id [Id] Exp | DataStructure Ident [(Ident, [Type])] deriving (C.Eq, C.Ord, C.Show, C.Read) instance Print Program where @@ -45,6 +45,12 @@ instance Print Bind where , doc $ showString "=" , prt 0 rhs ] + prt i (DataStructure (Ident n) xs) = prPrec i 0 $ concatD + [ prt 0 n + , doc $ showString "{" + , doc . showString . show $ xs + , doc $ showString "}" + ] instance Print [Bind] where prt _ [] = concatD [] From 7cf6f308356d45fe1bdde18d42f113f6238849b1 Mon Sep 17 00:00:00 2001 From: Samuel Hammersberg Date: Fri, 24 Feb 2023 18:37:31 +0100 Subject: [PATCH 052/372] Data type constructors now properly tag the data. --- src/Compiler.hs | 46 +++++++++++++++++++++++++++++++++------------- src/LlvmIr.hs | 7 +++++++ 2 files changed, 40 insertions(+), 13 deletions(-) diff --git a/src/Compiler.hs b/src/Compiler.hs index bbcde26..3b57dbe 100644 --- a/src/Compiler.hs +++ b/src/Compiler.hs @@ -5,6 +5,7 @@ module Compiler (compile) where import Auxiliary (snoc) import Control.Monad.State (StateT, execStateT, gets, modify) +import qualified Data.Bifunctor as BI import Data.List.Extra (trim) import Data.Map (Map) import qualified Data.Map as Map @@ -16,7 +17,6 @@ import LlvmIr (CallingConvention (..), LLVMComp (..), LLVMValue (..), Visibility (..), llvmIrToString) import System.Process.Extra (readCreateProcess, shell) -import TypeChecker (partitionType) import TypeCheckerIr (Bind (..), Case (..), Exp (..), Id, Ident (..), Program (..), Type (..)) @@ -24,7 +24,7 @@ import TypeCheckerIr (Bind (..), Case (..), Exp (..), Id, data CodeGenerator = CodeGenerator { instructions :: [LLVMIr] , functions :: Map Id FunctionInfo - , constructors :: Map Id FunctionInfo + , constructors :: Map Id ConstructorInfo , variableCount :: Integer , labelCount :: Integer } @@ -36,7 +36,12 @@ data FunctionInfo = FunctionInfo { numArgs :: Int , arguments :: [Id] } - deriving Show +data ConstructorInfo = ConstructorInfo + { numArgsCI :: Int + , argumentsCI :: [Id] + , numCI :: Integer + } + -- | Adds a instruction to the CodeGenerator state emit :: LLVMIr -> CompilerState () @@ -80,14 +85,16 @@ createArgs xs = fst $ foldl (\(acc, l) t -> (acc ++ [(Ident ("arg_" <> show l) , -- | Produces a map of functions infos from a list of binds, -- which contains useful data for code generation. -getConstructors :: [Bind] -> Map Id FunctionInfo +getConstructors :: [Bind] -> Map Id ConstructorInfo getConstructors bs = Map.fromList $ go bs where go [] = [] go (DataStructure n cons : xs) = do - map (\(id, xs) -> ((id, TPol n), FunctionInfo { - numArgs=length xs, arguments=createArgs xs - })) cons + fst (foldl (\(acc,i) (id, xs) -> (((id, TPol n), ConstructorInfo { + numArgsCI=length xs, + argumentsCI=createArgs xs, + numCI=i + }) : acc, i+1)) ([],0) cons) <> go xs go (_: xs) = go xs @@ -130,12 +137,25 @@ compile (Program scs) = do compileScs :: [Bind] -> CompilerState () compileScs [] = do - return () - -- c <- gets (Map.toList . constructors) - -- mapM_ (\((id, t), fi) -> do - -- emit $ Define FastCC (type2LlvmType t) id [] - -- emit DefineEnd - -- ) c + -- as a last step create all the constructors + c <- gets (Map.toList . constructors) + mapM_ (\((id, t), ci) -> do + let x = BI.second type2LlvmType <$> argumentsCI ci + emit $ Define FastCC (type2LlvmType t) id x + top <- Ident . show <$> getNewVar + ptr <- Ident . show <$> getNewVar + emit $ SetVariable top (Alloca (type2LlvmType t)) + -- %0 = getelementptr inbounds %Foo, %Foo* %x, i32 0, i32 0 + emit $ SetVariable ptr $ + GetElementPtrInbounds (type2LlvmType t) (Ref $ type2LlvmType t) + (VIdent top I8) I32 (VInteger 0) I32 (VInteger 0) + emit $ Store I8 (VInteger $ numCI ci ) (Ref I8) ptr + -- store i8 1, i8* %0 + emit $ Ret I64 (VInteger 0) + emit DefineEnd + + modify $ \s -> s { variableCount = 0 } + ) c compileScs (Bind (name, _t) args exp : xs) = do emit $ UnsafeRaw "\n" emit . Comment $ show name <> ": " <> show exp diff --git a/src/LlvmIr.hs b/src/LlvmIr.hs index 2a96957..8f07346 100644 --- a/src/LlvmIr.hs +++ b/src/LlvmIr.hs @@ -104,6 +104,7 @@ data LLVMIr | Declare LLVMType Ident Params | SetVariable Ident LLVMIr | Variable Ident + | GetElementPtrInbounds LLVMType LLVMType LLVMValue LLVMType LLVMValue LLVMType LLVMValue | Add LLVMType LLVMValue LLVMValue | Sub LLVMType LLVMValue LLVMValue | Div LLVMType LLVMValue LLVMValue @@ -144,6 +145,12 @@ llvmIrToString = go 0 insToString :: Int -> LLVMIr -> String insToString i l = replicate i '\t' <> case l of + (GetElementPtrInbounds t1 t2 p t3 v1 t4 v2) -> do + -- getelementptr inbounds %Foo, %Foo* %x, i32 0, i32 0 + concat + [ "getelementptr inbounds ", show t1, ", " , show t2 + , " ", show p, ", ", show t3, " ", show v1, + ", ", show t4, " ", show v2, "\n" ] (Type (Ident n) types) -> concat [ "%", n, " = type { " From 2f45f39435f207bfb5eb3a922ac33e86792a548e Mon Sep 17 00:00:00 2001 From: sebastianselander Date: Mon, 27 Feb 2023 11:12:05 +0100 Subject: [PATCH 053/372] Incorporated most of main, as well as started on quickcheck --- Grammar.cf | 44 +++- language.cabal | 68 +++---- src/Codegen/Codegen.hs | 277 +++++++++++++++++++++++++ src/Codegen/LlvmIr.hs | 204 +++++++++++++++++++ src/Compiler.hs | 0 src/Interpreter.hs | 78 -------- src/LambdaLifter/LambdaLifter.hs | 192 ++++++++++++++++++ src/Main.hs | 109 ++++++---- src/Renamer/Renamer.hs | 154 +++++++------- src/Renamer/RenamerIr.hs | 32 --- src/Renamer/RenamerM.hs | 83 -------- src/TypeChecker/AlgoW.hs | 238 ---------------------- src/TypeChecker/HM.hs | 181 ----------------- src/TypeChecker/HMIr.hs | 110 ---------- src/TypeChecker/TypeChecker.hs | 333 ++++++++++++++++++++----------- src/TypeChecker/TypeCheckerIr.hs | 157 +++++++++------ test_program | 5 +- tests/Main.hs | 21 -- tests/Tests.hs | 56 ++++++ 19 files changed, 1252 insertions(+), 1090 deletions(-) create mode 100644 src/Codegen/Codegen.hs create mode 100644 src/Codegen/LlvmIr.hs delete mode 100644 src/Compiler.hs delete mode 100644 src/Interpreter.hs create mode 100644 src/LambdaLifter/LambdaLifter.hs delete mode 100644 src/Renamer/RenamerIr.hs delete mode 100644 src/Renamer/RenamerM.hs delete mode 100644 src/TypeChecker/AlgoW.hs delete mode 100644 src/TypeChecker/HM.hs delete mode 100644 src/TypeChecker/HMIr.hs delete mode 100644 tests/Main.hs create mode 100644 tests/Tests.hs diff --git a/Grammar.cf b/Grammar.cf index 5406ac8..6870367 100644 --- a/Grammar.cf +++ b/Grammar.cf @@ -1,27 +1,54 @@ -Program. Program ::= [Bind] ; +Program. Program ::= [Def] ; +DBind. Def ::= Bind ; +DData. Def ::= Data ; +terminator Def ";" ; Bind. Bind ::= Ident ":" Type ";" Ident [Ident] "=" Exp ; EAnn. Exp5 ::= "(" Exp ":" Type ")" ; EId. Exp4 ::= Ident ; -EInt. Exp4 ::= Integer ; +ELit. Exp4 ::= Literal ; EApp. Exp3 ::= Exp3 Exp4 ; EAdd. Exp1 ::= Exp1 "+" Exp2 ; -ELet. Exp ::= "let" Ident "=" Exp "in" Exp ; +ELet. Exp ::= "let" Ident "=" Exp "in" Exp ; EAbs. Exp ::= "\\" Ident "." Exp ; +ECase. Exp ::= "case" Exp "of" "{" [Inj] "}"; -TMono. Type1 ::= "Mono" Ident ; -TPol. Type1 ::= "Poly" Ident ; +LInt. Literal ::= Integer ; + +Inj. Inj ::= Init "=>" Exp ; +terminator Inj ";" ; + +InitLit. Init ::= Literal ; +InitConstr. Init ::= Ident [Match] ; +InitCatch. Init ::= "_" ; + +LMatch. Match ::= Literal ; +IMatch. Match ::= Ident ; +InitMatch. Match ::= Ident Match ; +separator Match " " ; + +TMono. Type1 ::= "_" Ident ; +TPol. Type1 ::= "'" Ident ; TArr. Type ::= Type1 "->" Type ; +separator Type " " ; + +-- shift/reduce problem here +Data. Data ::= "data" Ident [Type] "where" ";" + [Constructor]; + +terminator Constructor ";" ; + +Constructor. Constructor ::= Ident ":" Type ; -- This doesn't seem to work so we'll have to live with ugly keywords for now --- token Upper (upper (letter | digit | '_')*) ; --- token Lower (lower (letter | digit | '_')*) ; +-- token Poly upper (letter | digit | '_')* ; +-- token Mono lower (letter | digit | '_')* ; -separator Bind ";" ; +terminator Bind ";" ; separator Ident " "; coercions Type 1 ; @@ -29,3 +56,4 @@ coercions Exp 5 ; comment "--" ; comment "{-" "-}" ; + diff --git a/language.cabal b/language.cabal index f803c1b..eb58aa0 100644 --- a/language.cabal +++ b/language.cabal @@ -16,7 +16,7 @@ extra-source-files: Grammar.cf common warnings - ghc-options: -Wdefault + ghc-options: -W executable language import: warnings @@ -31,15 +31,12 @@ executable language Grammar.Skel Grammar.ErrM Auxiliary - -- TypeChecker.TypeChecker - -- TypeChecker.TypeCheckerIr - -- TypeChecker.Unification - TypeChecker.HM - TypeChecker.AlgoW - TypeChecker.HMIr - Renamer.RenamerM - -- Renamer.Renamer - -- Renamer.RenamerIr + TypeChecker.TypeChecker + TypeChecker.TypeCheckerIr + Renamer.Renamer + LambdaLifter.LambdaLifter + Codegen.Codegen + Codegen.LlvmIr hs-source-dirs: src @@ -50,34 +47,35 @@ executable language , either , extra , array + , QuickCheck default-language: GHC2021 -test-suite test - hs-source-dirs: tests, src - main-is: Main.hs - type: exitcode-stdio-1.0 +Test-suite language-testsuite + type: exitcode-stdio-1.0 + main-is: Tests.hs - other-modules: - Grammar.Abs - Grammar.Lex - Grammar.Par - Grammar.Print - Grammar.Skel - Grammar.ErrM - Auxiliary - Renamer.RenamerM - TypeChecker.AlgoW - TypeChecker.HM - TypeChecker.HMIr + other-modules: + Grammar.Abs + Grammar.Lex + Grammar.Par + Grammar.Print + Grammar.Skel + Grammar.ErrM + Auxiliary + TypeChecker.TypeChecker + TypeChecker.TypeCheckerIr + Renamer.Renamer - build-depends: - base >=4.16 - , mtl - , containers - , either - , array - , extra - , hspec + hs-source-dirs: src, tests - default-language: GHC2021 + build-depends: + base >=4.16 + , mtl + , containers + , either + , extra + , array + , QuickCheck + + default-language: GHC2021 diff --git a/src/Codegen/Codegen.hs b/src/Codegen/Codegen.hs new file mode 100644 index 0000000..76a1f02 --- /dev/null +++ b/src/Codegen/Codegen.hs @@ -0,0 +1,277 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} + +module Codegen.Codegen (compile) where + +import Auxiliary (snoc) +import Codegen.LlvmIr (LLVMIr (..), LLVMType (..), + LLVMValue (..), Visibility (..), + llvmIrToString) +import Control.Monad.State (StateT, execStateT, gets, modify) +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Tuple.Extra (dupe, first, second) +import Grammar.ErrM (Err) +import TypeChecker.TypeChecker +import TypeChecker.TypeCheckerIr + +-- | The record used as the code generator state +data CodeGenerator = CodeGenerator + { instructions :: [LLVMIr] + , functions :: Map Id FunctionInfo + , variableCount :: Integer + } + +-- | A state type synonym +type CompilerState a = StateT CodeGenerator Err a + +data FunctionInfo = FunctionInfo + { numArgs :: Int + , arguments :: [Id] + } + +-- | Adds a instruction to the CodeGenerator state +emit :: LLVMIr -> CompilerState () +emit l = modify $ \t -> t { instructions = snoc l $ instructions t } + +-- | Increases the variable counter in the CodeGenerator state +increaseVarCount :: CompilerState () +increaseVarCount = modify $ \t -> t { variableCount = variableCount t + 1 } + +-- | Returns the variable count from the CodeGenerator state +getVarCount :: CompilerState Integer +getVarCount = gets variableCount + +-- | Increases the variable count and returns it from the CodeGenerator state +getNewVar :: CompilerState Integer +getNewVar = increaseVarCount >> getVarCount + +-- | Produces a map of functions infos from a list of binds, +-- which contains useful data for code generation. +getFunctions :: [Bind] -> Map Id FunctionInfo +getFunctions bs = Map.fromList $ map go bs + where + go (Bind id args _) = + (id, FunctionInfo { numArgs=length args, arguments=args }) + + + +initCodeGenerator :: [Bind] -> CodeGenerator +initCodeGenerator scs = CodeGenerator { instructions = defaultStart + , functions = getFunctions scs + , variableCount = 0 + } + +-- | Compiles an AST and produces a LLVM Ir string. +-- An easy way to actually "compile" this output is to +-- Simply pipe it to lli +compile :: Program -> Err String +compile (Program scs) = do + let codegen = initCodeGenerator scs + llvmIrToString . instructions <$> execStateT (compileScs scs) codegen + +compileScs :: [Bind] -> CompilerState () +compileScs [] = pure () +compileScs (Bind (name, t) args exp : xs) = do + emit $ UnsafeRaw "\n" + emit . Comment $ show name <> ": " <> show exp + let args' = map (second type2LlvmType) args + emit $ Define (type2LlvmType t_return) name args' + functionBody <- exprToValue exp + if name == "main" + then mapM_ emit $ mainContent functionBody + else emit $ Ret I64 functionBody + emit DefineEnd + modify $ \s -> s { variableCount = 0 } + compileScs xs + where + t_return = snd $ partitionType (length args) t + +mainContent :: LLVMValue -> [LLVMIr] +mainContent var = + [ UnsafeRaw $ + "call i32 (ptr, ...) @printf(ptr noundef @.str, i64 noundef " <> show var <> ")\n" + , -- , SetVariable (Ident "p") (Icmp LLEq I64 (VInteger 2) (VInteger 2)) + -- , BrCond (VIdent (Ident "p")) (Ident "b_1") (Ident "b_2") + -- , Label (Ident "b_1") + -- , UnsafeRaw + -- "call i32 (ptr, ...) @printf(ptr noundef @.str, i64 noundef 1)\n" + -- , Br (Ident "end") + -- , Label (Ident "b_2") + -- , UnsafeRaw + -- "call i32 (ptr, ...) @printf(ptr noundef @.str, i64 noundef 2)\n" + -- , Br (Ident "end") + -- , Label (Ident "end") + Ret I64 (VInteger 0) + ] + +defaultStart :: [LLVMIr] +defaultStart = [ UnsafeRaw "@.str = private unnamed_addr constant [3 x i8] c\"%i\n\", align 1\n" + , UnsafeRaw "declare i32 @printf(ptr noalias nocapture, ...)\n" + ] + +compileExp :: Exp -> CompilerState () +compileExp = \case + ELit _ (LInt i) -> emitInt i + EAdd t e1 e2 -> emitAdd t e1 e2 + EId (name, _) -> emitIdent name + EApp t e1 e2 -> emitApp t e1 e2 + EAbs t ti e -> emitAbs t ti e + ELet bind e -> emitLet bind e + +--- aux functions --- +emitAbs :: Type -> Id -> Exp -> CompilerState () +emitAbs _t tid e = emit . Comment $ "Lambda escaped previous stages: \\" <> show tid <> " . " <> show e + +emitLet :: Bind -> Exp -> CompilerState () +emitLet b e = emit . Comment $ concat [ "ELet (" + , show b + , " = " + , show e + , ") is not implemented!" + ] + +emitApp :: Type -> Exp -> Exp -> CompilerState () +emitApp t e1 e2 = appEmitter t e1 e2 [] + where + appEmitter :: Type -> Exp -> Exp -> [Exp] -> CompilerState () + appEmitter t e1 e2 stack = do + let newStack = e2 : stack + case e1 of + EApp _ e1' e2' -> appEmitter t e1' e2' newStack + EId id@(name, _) -> do + args <- traverse exprToValue newStack + vs <- getNewVar + funcs <- gets functions + let visibility = maybe Local (const Global) $ Map.lookup id funcs + args' = map (first valueGetType . dupe) args + call = Call (type2LlvmType t) visibility name args' + emit $ SetVariable (Ident $ show vs) call + x -> do + emit . Comment $ "The unspeakable happened: " + emit . Comment $ show x + +emitIdent :: Ident -> CompilerState () +emitIdent id = do + -- !!this should never happen!! + emit $ Comment "This should not have happened!" + emit $ Variable id + emit $ UnsafeRaw "\n" + +emitInt :: Integer -> CompilerState () +emitInt i = do + -- !!this should never happen!! + varCount <- getNewVar + emit $ Comment "This should not have happened!" + emit $ SetVariable (Ident (show varCount)) (Add I64 (VInteger i) (VInteger 0)) + +emitAdd :: Type -> Exp -> Exp -> CompilerState () +emitAdd t e1 e2 = do + v1 <- exprToValue e1 + v2 <- exprToValue e2 + v <- getNewVar + emit $ SetVariable (Ident $ show v) (Add (type2LlvmType t) v1 v2) + +-- emitMul :: Exp -> Exp -> CompilerState () +-- emitMul e1 e2 = do +-- (v1,v2) <- binExprToValues e1 e2 +-- increaseVarCount +-- v <- gets variableCount +-- emit $ SetVariable $ Ident $ show v +-- emit $ Mul I64 v1 v2 + +-- emitMod :: Exp -> Exp -> CompilerState () +-- emitMod e1 e2 = do +-- -- `let m a b = rem (abs $ b + a) b` +-- (v1,v2) <- binExprToValues e1 e2 +-- increaseVarCount +-- vadd <- gets variableCount +-- emit $ SetVariable $ Ident $ show vadd +-- emit $ Add I64 v1 v2 +-- +-- increaseVarCount +-- vabs <- gets variableCount +-- emit $ SetVariable $ Ident $ show vabs +-- emit $ Call I64 (Ident "llvm.abs.i64") +-- [ (I64, VIdent (Ident $ show vadd)) +-- , (I1, VInteger 1) +-- ] +-- increaseVarCount +-- v <- gets variableCount +-- emit $ SetVariable $ Ident $ show v +-- emit $ Srem I64 (VIdent (Ident $ show vabs)) v2 + +-- emitDiv :: Exp -> Exp -> CompilerState () +-- emitDiv e1 e2 = do +-- (v1,v2) <- binExprToValues e1 e2 +-- increaseVarCount +-- v <- gets variableCount +-- emit $ SetVariable $ Ident $ show v +-- emit $ Div I64 v1 v2 + +-- emitSub :: Exp -> Exp -> CompilerState () +-- emitSub e1 e2 = do +-- (v1,v2) <- binExprToValues e1 e2 +-- increaseVarCount +-- v <- gets variableCount +-- emit $ SetVariable $ Ident $ show v +-- emit $ Sub I64 v1 v2 + +exprToValue :: Exp -> CompilerState LLVMValue +exprToValue = \case + ELit _ (LInt i) -> pure $ VInteger i + + EId id@(name, t) -> do + funcs <- gets functions + case Map.lookup id funcs of + Just fi -> do + if numArgs fi == 0 + then do + vc <- getNewVar + emit $ SetVariable (Ident $ show vc) + (Call (type2LlvmType t) Global name []) + pure $ VIdent (Ident $ show vc) (type2LlvmType t) + else pure $ VFunction name Global (type2LlvmType t) + Nothing -> pure $ VIdent name (type2LlvmType t) + + e -> do + compileExp e + v <- getVarCount + pure $ VIdent (Ident $ show v) (getType e) + +type2LlvmType :: Type -> LLVMType +type2LlvmType = \case + (TMono "Int") -> I64 + TArr t xs -> do + let (t', xs') = function2LLVMType xs [type2LlvmType t] + Function t' xs' + t -> I64 --CustomType $ Ident ("\"" ++ show t ++ "\"") + where + function2LLVMType :: Type -> [LLVMType] -> (LLVMType, [LLVMType]) + function2LLVMType (TArr t xs) s = function2LLVMType xs (type2LlvmType t : s) + function2LLVMType x s = (type2LlvmType x, s) + +getType :: Exp -> LLVMType +getType (ELit _ (LInt _)) = I64 +getType (EAdd t _ _) = type2LlvmType t +getType (EId (_, t)) = type2LlvmType t +getType (EApp t _ _) = type2LlvmType t +getType (EAbs t _ _) = type2LlvmType t +getType (ELet _ e) = getType e + +valueGetType :: LLVMValue -> LLVMType +valueGetType (VInteger _) = I64 +valueGetType (VIdent _ t) = t +valueGetType (VConstant s) = Array (length s) I8 +valueGetType (VFunction _ _ t) = t + +-- | Partion type into types of parameters and return type. +partitionType :: Int -- Number of parameters to apply + -> Type + -> ([Type], Type) +partitionType = go [] + where + go acc 0 t = (acc, t) + go acc i t = case t of + TArr t1 t2 -> go (snoc t1 acc) (i - 1) t2 + _ -> error "Number of parameters and type doesn't match" diff --git a/src/Codegen/LlvmIr.hs b/src/Codegen/LlvmIr.hs new file mode 100644 index 0000000..aa6de54 --- /dev/null +++ b/src/Codegen/LlvmIr.hs @@ -0,0 +1,204 @@ +{-# LANGUAGE LambdaCase #-} + +module Codegen.LlvmIr ( + LLVMType (..), + LLVMIr (..), + llvmIrToString, + LLVMValue (..), + LLVMComp (..), + Visibility (..), +) where + +import Data.List (intercalate) +import TypeChecker.TypeCheckerIr + +-- | A datatype which represents some basic LLVM types +data LLVMType + = I1 + | I8 + | I32 + | I64 + | Ptr + | Ref LLVMType + | Function LLVMType [LLVMType] + | Array Int LLVMType + | CustomType Ident + +instance Show LLVMType where + show :: LLVMType -> String + show = \case + I1 -> "i1" + I8 -> "i8" + I32 -> "i32" + I64 -> "i64" + Ptr -> "ptr" + Ref ty -> show ty <> "*" + Function t xs -> show t <> " (" <> intercalate ", " (map show xs) <> ")*" + Array n ty -> concat ["[", show n, " x ", show ty, "]"] + CustomType (Ident ty) -> ty + +data LLVMComp + = LLEq + | LLNe + | LLUgt + | LLUge + | LLUlt + | LLUle + | LLSgt + | LLSge + | LLSlt + | LLSle +instance Show LLVMComp where + show :: LLVMComp -> String + show = \case + LLEq -> "eq" + LLNe -> "ne" + LLUgt -> "ugt" + LLUge -> "uge" + LLUlt -> "ult" + LLUle -> "ule" + LLSgt -> "sgt" + LLSge -> "sge" + LLSlt -> "slt" + LLSle -> "sle" + +data Visibility = Local | Global +instance Show Visibility where + show :: Visibility -> String + show Local = "%" + show Global = "@" + +-- | Represents a LLVM "value", as in an integer, a register variable, +-- or a string contstant +data LLVMValue + = VInteger Integer + | VIdent Ident LLVMType + | VConstant String + | VFunction Ident Visibility LLVMType + +instance Show LLVMValue where + show :: LLVMValue -> String + show v = case v of + VInteger i -> show i + VIdent (Ident n) _ -> "%" <> n + VFunction (Ident n) vis _ -> show vis <> n + VConstant s -> "c" <> show s + +type Params = [(Ident, LLVMType)] +type Args = [(LLVMType, LLVMValue)] + +-- | A datatype which represents different instructions in LLVM +data LLVMIr + = Define LLVMType Ident Params + | DefineEnd + | Declare LLVMType Ident Params + | SetVariable Ident LLVMIr + | Variable Ident + | Add LLVMType LLVMValue LLVMValue + | Sub LLVMType LLVMValue LLVMValue + | Div LLVMType LLVMValue LLVMValue + | Mul LLVMType LLVMValue LLVMValue + | Srem LLVMType LLVMValue LLVMValue + | Icmp LLVMComp LLVMType LLVMValue LLVMValue + | Br Ident + | BrCond LLVMValue Ident Ident + | Label Ident + | Call LLVMType Visibility Ident Args + | Alloca LLVMType + | Store LLVMType Ident LLVMType Ident + | Bitcast LLVMType Ident LLVMType + | Ret LLVMType LLVMValue + | Comment String + | UnsafeRaw String -- This should generally be avoided, and proper + -- instructions should be used in its place + deriving (Show) + +-- | Converts a list of LLVMIr instructions to a string +llvmIrToString :: [LLVMIr] -> String +llvmIrToString = go 0 + where + go :: Int -> [LLVMIr] -> String + go _ [] = mempty + go i (x : xs) = do + let (i', n) = case x of + Define{} -> (i + 1, 0) + DefineEnd -> (i - 1, 0) + _ -> (i, i) + insToString n x <> go i' xs + +-- | Converts a LLVM inststruction to a String, allowing for printing etc. +-- The integer represents the indentation +insToString :: Int -> LLVMIr -> String +insToString i l = + replicate i '\t' <> case l of + (Define t (Ident i) params) -> + concat + [ "define ", show t, " @", i + , "(", intercalate ", " (map (\(Ident y, x) -> unwords [show x, "%" <> y]) params) + , ") {\n" + ] + DefineEnd -> "}\n" + (Declare _t (Ident _i) _params) -> undefined + (SetVariable (Ident i) ir) -> concat ["%", i, " = ", insToString 0 ir] + (Add t v1 v2) -> + concat + [ "add ", show t, " ", show v1 + , ", ", show v2, "\n" + ] + (Sub t v1 v2) -> + concat + [ "sub ", show t, " ", show v1, ", " + , show v2, "\n" + ] + (Div t v1 v2) -> + concat + [ "sdiv ", show t, " ", show v1, ", " + , show v2, "\n" + ] + (Mul t v1 v2) -> + concat + [ "mul ", show t, " ", show v1 + , ", ", show v2, "\n" + ] + (Srem t v1 v2) -> + concat + [ "srem ", show t, " ", show v1, ", " + , show v2, "\n" + ] + (Call t vis (Ident i) arg) -> + concat + [ "call ", show t, " ", show vis, i, "(" + , intercalate ", " $ Prelude.map (\(x, y) -> show x <> " " <> show y) arg + , ")\n" + ] + (Alloca t) -> unwords ["alloca", show t, "\n"] + (Store t1 (Ident id1) t2 (Ident id2)) -> + concat + [ "store ", show t1, " %", id1 + , ", ", show t2 , " %", id2, "\n" + ] + (Bitcast t1 (Ident i) t2) -> + concat + [ "bitcast ", show t1, " %" + , i, " to ", show t2, "\n" + ] + (Icmp comp t v1 v2) -> + concat + [ "icmp ", show comp, " ", show t + , " ", show v1, ", ", show v2, "\n" + ] + (Ret t v) -> + concat + [ "ret ", show t, " " + , show v, "\n" + ] + (UnsafeRaw s) -> s + (Label (Ident s)) -> "\nlabel_" <> s <> ":\n" + (Br (Ident s)) -> "br label %label_" <> s <> "\n" + (BrCond val (Ident s1) (Ident s2)) -> + concat + [ "br i1 ", show val, ", ", "label %" + , "label_", s1, ", ", "label %", "label_", s2, "\n" + ] + (Comment s) -> "; " <> s <> "\n" + (Variable (Ident id)) -> "%" <> id diff --git a/src/Compiler.hs b/src/Compiler.hs deleted file mode 100644 index e69de29..0000000 diff --git a/src/Interpreter.hs b/src/Interpreter.hs deleted file mode 100644 index 378c95b..0000000 --- a/src/Interpreter.hs +++ /dev/null @@ -1,78 +0,0 @@ -{-# LANGUAGE LambdaCase #-} -module Interpreter where - -import Control.Applicative (Applicative) -import Control.Monad.Except (Except, MonadError (throwError), - liftEither) -import Data.Either.Combinators (maybeToRight) -import Data.Map (Map) -import qualified Data.Map as Map -import Grammar.Abs -import Grammar.Print (printTree) - -interpret :: Program -> Except String Integer -interpret (Program e) = - eval mempty e >>= \case - VClosure {} -> throwError "main evaluated to a function" - VInt i -> pure i - - -data Val = VInt Integer - | VClosure Cxt Ident Exp - -type Cxt = Map Ident Val - -eval :: Cxt -> Exp -> Except String Val -eval cxt = \case - - - -- ------------ x ∈ γ - -- γ ⊢ x ⇓ γ(x) - - EId x -> - maybeToRightM - ("Unbound variable:" ++ printTree x) - $ Map.lookup x cxt - - -- --------- - -- γ ⊢ i ⇓ i - - EInt i -> pure $ VInt i - - -- γ ⊢ e ⇓ let δ in λx. f - -- γ ⊢ e₁ ⇓ v - -- δ,x=v ⊢ f ⇓ v₁ - -- ------------------------------ - -- γ ⊢ e e₁ ⇓ v₁ - - EApp e e1 -> - eval cxt e >>= \case - VInt _ -> throwError "Not a function" - VClosure delta x f -> do - v <- eval cxt e1 - eval (Map.insert x v delta) f - - -- - -- ----------------------------- - -- γ ⊢ λx. f ⇓ let γ in λx. f - - EAbs x e -> pure $ VClosure cxt x e - - - -- γ ⊢ e ⇓ v - -- γ ⊢ e₁ ⇓ v₁ - -- ------------------ - -- γ ⊢ e e₁ ⇓ v + v₁ - - EAdd e e1 -> do - v <- eval cxt e - v1 <- eval cxt e1 - case (v, v1) of - (VInt i, VInt i1) -> pure $ VInt (i + i1) - _ -> throwError "Can't add a function" - - - -maybeToRightM :: MonadError l m => l -> Maybe r -> m r -maybeToRightM err = liftEither . maybeToRight err - diff --git a/src/LambdaLifter/LambdaLifter.hs b/src/LambdaLifter/LambdaLifter.hs new file mode 100644 index 0000000..a617159 --- /dev/null +++ b/src/LambdaLifter/LambdaLifter.hs @@ -0,0 +1,192 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} + + +module LambdaLifter.LambdaLifter (lambdaLift, freeVars, abstract, rename, collectScs) where + +import Auxiliary (snoc) +import Control.Applicative (Applicative (liftA2)) +import Control.Monad.State (MonadState (get, put), State, + evalState) +import Data.Set (Set) +import qualified Data.Set as Set +import Prelude hiding (exp) +import Renamer.Renamer +import TypeChecker.TypeCheckerIr + + +-- | Lift lambdas and let expression into supercombinators. +-- Three phases: +-- @freeVars@ annotatss all the free variables. +-- @abstract@ converts lambdas into let expressions. +-- @collectScs@ moves every non-constant let expression to a top-level function. +lambdaLift :: Program -> Program +lambdaLift = collectScs . abstract . freeVars + + +-- | Annotate free variables +freeVars :: Program -> AnnProgram +freeVars (Program ds) = [ (n, xs, freeVarsExp (Set.fromList xs) e) + | Bind n xs e <- ds + ] + +freeVarsExp :: Set Id -> Exp -> AnnExp +freeVarsExp localVars = \case + EId n | Set.member n localVars -> (Set.singleton n, AId n) + | otherwise -> (mempty, AId n) + + ELit _ (LInt i) -> (mempty, AInt i) + + EApp t e1 e2 -> (Set.union (freeVarsOf e1') (freeVarsOf e2'), AApp t e1' e2') + where + e1' = freeVarsExp localVars e1 + e2' = freeVarsExp localVars e2 + + EAdd t e1 e2 -> (Set.union (freeVarsOf e1') (freeVarsOf e2'), AAdd t e1' e2') + where + e1' = freeVarsExp localVars e1 + e2' = freeVarsExp localVars e2 + + EAbs t par e -> (Set.delete par $ freeVarsOf e', AAbs t par e') + where + e' = freeVarsExp (Set.insert par localVars) e + + -- Sum free variables present in bind and the expression + ELet (Bind name parms rhs) e -> (Set.union binders_frees e_free, ALet new_bind e') + where + binders_frees = Set.delete name $ freeVarsOf rhs' + e_free = Set.delete name $ freeVarsOf e' + + rhs' = freeVarsExp e_localVars rhs + new_bind = ABind name parms rhs' + + e' = freeVarsExp e_localVars e + e_localVars = Set.insert name localVars + + +freeVarsOf :: AnnExp -> Set Id +freeVarsOf = fst + +-- AST annotated with free variables +type AnnProgram = [(Id, [Id], AnnExp)] + +type AnnExp = (Set Id, AnnExp') + +data ABind = ABind Id [Id] AnnExp deriving Show + +data AnnExp' = AId Id + | AInt Integer + | ALet ABind AnnExp + | AApp Type AnnExp AnnExp + | AAdd Type AnnExp AnnExp + | AAbs Type Id AnnExp + deriving Show +-- | Lift lambdas to let expression of the form @let sc = \v₁ x₁ -> e₁@. +-- Free variables are @v₁ v₂ .. vₙ@ are bound. +abstract :: AnnProgram -> Program +abstract prog = Program $ evalState (mapM go prog) 0 + where + go :: (Id, [Id], AnnExp) -> State Int Bind + go (name, parms, rhs) = Bind name (parms ++ parms1) <$> abstractExp rhs' + where + (rhs', parms1) = flattenLambdasAnn rhs + + +-- | Flatten nested lambdas and collect the parameters +-- @\x.\y.\z. ae → (ae, [x,y,z])@ +flattenLambdasAnn :: AnnExp -> (AnnExp, [Id]) +flattenLambdasAnn ae = go (ae, []) + where + go :: (AnnExp, [Id]) -> (AnnExp, [Id]) + go ((free, e), acc) = + case e of + AAbs _ par (free1, e1) -> + go ((Set.delete par free1, e1), snoc par acc) + _ -> ((free, e), acc) + +abstractExp :: AnnExp -> State Int Exp +abstractExp (free, exp) = case exp of + AId n -> pure $ EId n + AInt i -> pure $ ELit (TMono "Int") (LInt i) + AApp t e1 e2 -> liftA2 (EApp t) (abstractExp e1) (abstractExp e2) + AAdd t e1 e2 -> liftA2 (EAdd t) (abstractExp e1) (abstractExp e2) + ALet b e -> liftA2 ELet (go b) (abstractExp e) + where + go (ABind name parms rhs) = do + (rhs', parms1) <- flattenLambdas <$> skipLambdas abstractExp rhs + pure $ Bind name (parms ++ parms1) rhs' + + skipLambdas :: (AnnExp -> State Int Exp) -> AnnExp -> State Int Exp + skipLambdas f (free, ae) = case ae of + AAbs t par ae1 -> EAbs t par <$> skipLambdas f ae1 + _ -> f (free, ae) + + -- Lift lambda into let and bind free variables + AAbs t parm e -> do + i <- nextNumber + rhs <- abstractExp e + + let sc_name = Ident ("sc_" ++ show i) + sc = ELet (Bind (sc_name, t) parms rhs) $ EId (sc_name, t) + + pure $ foldl (EApp $ TMono "Int") sc $ map EId freeList + where + freeList = Set.toList free + parms = snoc parm freeList + + +nextNumber :: State Int Int +nextNumber = do + i <- get + put $ succ i + pure i + +-- | Collects supercombinators by lifting non-constant let expressions +collectScs :: Program -> Program +collectScs (Program scs) = Program $ concatMap collectFromRhs scs + where + collectFromRhs (Bind name parms rhs) = + let (rhs_scs, rhs') = collectScsExp rhs + in Bind name parms rhs' : rhs_scs + + +collectScsExp :: Exp -> ([Bind], Exp) +collectScsExp = \case + EId n -> ([], EId n) + ELit _ (LInt i) -> ([], ELit (TMono "Int") (LInt i)) + + EApp t e1 e2 -> (scs1 ++ scs2, EApp t e1' e2') + where + (scs1, e1') = collectScsExp e1 + (scs2, e2') = collectScsExp e2 + + EAdd t e1 e2 -> (scs1 ++ scs2, EAdd t e1' e2') + where + (scs1, e1') = collectScsExp e1 + (scs2, e2') = collectScsExp e2 + + EAbs t par e -> (scs, EAbs t par e') + where + (scs, e') = collectScsExp e + + -- Collect supercombinators from bind, the rhss, and the expression. + -- + -- > f = let sc x y = rhs in e + -- + ELet (Bind name parms rhs) e -> if null parms + then ( rhs_scs ++ e_scs, ELet bind e') + else (bind : rhs_scs ++ e_scs, e') + where + bind = Bind name parms rhs' + (rhs_scs, rhs') = collectScsExp rhs + (e_scs, e') = collectScsExp e + + +-- @\x.\y.\z. e → (e, [x,y,z])@ +flattenLambdas :: Exp -> (Exp, [Id]) +flattenLambdas = go . (, []) + where + go (e, acc) = case e of + EAbs _ par e1 -> go (e1, snoc par acc) + _ -> (e, acc) + diff --git a/src/Main.hs b/src/Main.hs index 58811fe..3a7bde4 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -2,42 +2,81 @@ module Main where -import Grammar.Par (myLexer, pProgram) --- import TypeChecker.TypeChecker (typecheck) +import Codegen.Codegen (compile) +import GHC.IO.Handle.Text (hPutStrLn) +import Grammar.ErrM (Err) +import Grammar.Par (myLexer, pProgram) +import Grammar.Print (printTree) -import Grammar.Print (printTree) -import Renamer.RenamerM (rename) -import System.Environment (getArgs) -import System.Exit (exitFailure, exitSuccess) -import TypeChecker.AlgoW (typecheck) +import LambdaLifter.LambdaLifter (lambdaLift) +import Renamer.Renamer (rename) +import System.Environment (getArgs) +import System.Exit (exitFailure, exitSuccess) +import System.IO (stderr) +import TypeChecker.TypeChecker (typecheck) main :: IO () -main = getArgs >>= \case +main = + getArgs >>= \case [] -> print "Required file path missing" - (x : _) -> do - file <- readFile x - case pProgram (myLexer file) of - Left err -> do - putStrLn "SYNTAX ERROR" - putStrLn err - exitFailure - Right prg -> do - putStrLn "" - putStrLn " ----- PARSER ----- " - putStrLn "" - putStrLn . printTree $ prg - case typecheck (rename prg) of - Left err -> do - putStrLn "TYPECHECK ERROR" - print err - exitFailure - Right prg -> do - putStrLn "" - putStrLn " ----- RAW ----- " - putStrLn "" - print prg - putStrLn "" - putStrLn " ----- TYPECHECKER ----- " - putStrLn "" - putStrLn $ printTree prg - exitSuccess + (s : _) -> main' s + +main' :: String -> IO () +main' s = do + file <- readFile s + + printToErr "-- Parse Tree -- " + parsed <- fromSyntaxErr . pProgram $ myLexer file + printToErr $ printTree parsed + + printToErr "\n-- Renamer --" + let renamed = rename parsed + printToErr $ printTree renamed + + printToErr "\n-- TypeChecker --" + typechecked <- fromTypeCheckerErr $ typecheck renamed + printToErr $ printTree typechecked + + printToErr "\n-- Lambda Lifter --" + let lifted = lambdaLift typechecked + printToErr $ printTree lifted + + printToErr "\n -- Printing compiler output to stdout --" + compiled <- fromCompilerErr $ compile lifted + putStrLn compiled + writeFile "llvm.ll" compiled + + exitSuccess + +printToErr :: String -> IO () +printToErr = hPutStrLn stderr + +fromCompilerErr :: Err a -> IO a +fromCompilerErr = + either + ( \err -> do + putStrLn "\nCOMPILER ERROR" + putStrLn err + exitFailure + ) + pure + +fromSyntaxErr :: Err a -> IO a +fromSyntaxErr = + either + ( \err -> do + putStrLn "\nSYNTAX ERROR" + putStrLn err + exitFailure + ) + pure + +fromTypeCheckerErr :: Err a -> IO a +fromTypeCheckerErr = + either + ( \err -> do + putStrLn "\nTYPECHECKER ERROR" + putStrLn err + exitFailure + ) + pure diff --git a/src/Renamer/Renamer.hs b/src/Renamer/Renamer.hs index c8b857e..1ea892c 100644 --- a/src/Renamer/Renamer.hs +++ b/src/Renamer/Renamer.hs @@ -1,101 +1,91 @@ -{-# LANGUAGE LambdaCase, OverloadedRecordDot, OverloadedStrings #-} +{-# LANGUAGE LambdaCase #-} -module Renamer.Renamer (rename) where +module Renamer.Renamer where -import Renamer.RenamerIr -import Control.Monad.State -import Control.Monad.Except -import Control.Monad.Reader -import Data.Functor.Identity (Identity, runIdentity) -import Data.Set (Set) -import qualified Data.Set as S -import Data.Map (Map) -import qualified Data.Map as M +import Auxiliary (mapAccumM) +import Control.Monad.State (MonadState, State, evalState, gets, + modify) +import Data.List (foldl') +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Maybe (fromMaybe) +import Data.Tuple.Extra (dupe) +import Grammar.Abs -import Renamer.RenamerIr -import qualified Grammar.Abs as Old -type Rename = StateT Ctx (ExceptT Error Identity) +-- | Rename all variables and local binds +rename :: Program -> Program +rename (Program bs) = Program $ evalState (runRn $ mapM (renameSc initNames) bs) 0 + where + -- initNames = Map.fromList $ map (\(Bind name _ _ _ _) -> dupe name) bs + initNames = Map.fromList $ foldl' saveIfBind [] bs + saveIfBind acc (DBind (Bind name _ _ _ _)) = dupe name : acc + saveIfBind acc _ = acc + renameSc :: Names -> Def -> Rn Def + renameSc old_names (DBind (Bind name t _ parms rhs)) = do + (new_names, parms') <- newNames old_names parms + rhs' <- snd <$> renameExp new_names rhs + pure . DBind $ Bind name t name parms' rhs' + renameSc _ def = pure def -data Ctx = Ctx { count :: Integer - , sig :: Set Ident - , env :: Map Ident Integer} +-- -run :: Rename a -> Either Error a -run = runIdentity . runExceptT . flip evalStateT initCtx +-- | Rename monad. State holds the number of renamed names. +newtype Rn a = Rn { runRn :: State Int a } + deriving (Functor, Applicative, Monad, MonadState Int) -initCtx :: Ctx -initCtx = Ctx { count = 0 - , sig = mempty - , env = mempty } +-- | Maps old to new name +type Names = Map Ident Ident -rename :: Old.Program -> Either Error RProgram -rename = run . renamePrg +renameLocalBind :: Names -> Bind -> Rn (Names, Bind) +renameLocalBind old_names (Bind name t _ parms rhs) = do + (new_names, name') <- newName old_names name + (new_names', parms') <- newNames new_names parms + (new_names'', rhs') <- renameExp new_names' rhs + pure (new_names'', Bind name' t name' parms' rhs') -renamePrg :: Old.Program -> Rename RProgram -renamePrg (Old.Program xs) = do - xs' <- mapM renameBind xs - return $ RProgram xs' +renameExp :: Names -> Exp -> Rn (Names, Exp) +renameExp old_names = \case + EId n -> pure (old_names, EId . fromMaybe n $ Map.lookup n old_names) -renameBind :: Old.Bind -> Rename RBind -renameBind (Old.Bind n t i args e) = do - insertSig i - e' <- renameExp (makeLambda (reverse args) e) - return $ RBind i e' - where - makeLambda :: [Ident] -> Old.Exp -> Old.Exp - makeLambda [] e = e - makeLambda (x:xs) e = makeLambda xs (Old.EAbs x e) + ELit (LInt i1) -> pure (old_names, ELit (LInt i1)) -renameExp :: Old.Exp -> Rename RExp -renameExp = \case + EApp e1 e2 -> do + (env1, e1') <- renameExp old_names e1 + (env2, e2') <- renameExp old_names e2 + pure (Map.union env1 env2, EApp e1' e2') - Old.EId i -> do - st <- get - case M.lookup i st.env of - Just n -> return $ RId i - Nothing -> case S.member i st.sig of - True -> return $ RId i - False -> throwError $ UnboundVar (show i) + EAdd e1 e2 -> do + (env1, e1') <- renameExp old_names e1 + (env2, e2') <- renameExp old_names e2 + pure (Map.union env1 env2, EAdd e1' e2') - Old.EInt c -> return $ RInt c + ELet i e1 e2 -> do + (new_names, e1') <- renameExp old_names e1 + (new_names', e2') <- renameExp new_names e2 + pure (new_names', ELet i e1' e2') - Old.EAnn e t -> flip RAnn t <$> renameExp e + EAbs par e -> do + (new_names, par') <- newName old_names par + (new_names', e') <- renameExp new_names e + pure (new_names', EAbs par' e') - Old.EApp e1 e2 -> RApp <$> renameExp e1 <*> renameExp e2 + EAnn e t -> do + (new_names, e') <- renameExp old_names e + pure (new_names, EAnn e' t) - Old.EAdd e1 e2 -> RAdd <$> renameExp e1 <*> renameExp e2 + ECase _ _ -> error "ECase NOT IMPLEMENTED YET" - -- Convert let-expressions to lambdas - Old.ELet i e1 e2 -> renameExp (Old.EApp (Old.EAbs i e2) e1) +-- | Create a new name and add it to name environment. +newName :: Names -> Ident -> Rn (Names, Ident) +newName env old_name = do + new_name <- makeName old_name + pure (Map.insert old_name new_name env, new_name) - Old.EAbs i e -> do - n <- cnt - ctx <- get - insertEnv i n - re <- renameExp e - return $ RAbs n i re +-- | Create multiple names and add them to the name environment +newNames :: Names -> [Ident] -> Rn (Names, [Ident]) +newNames = mapAccumM newName --- | Get current count and increase it by one -cnt :: Rename Integer -cnt = do - st <- get - put (Ctx { count = succ st.count - , sig = st.sig - , env = st.env }) - return st.count - -insertEnv :: Ident -> Integer -> Rename () -insertEnv i n = do - c <- get - put ( Ctx { env = M.insert i n c.env , sig = c.sig , count = c.count} ) - -insertSig :: Ident -> Rename () -insertSig i = do - c <- get - put ( Ctx { sig = S.insert i c.sig , env = c.env , count = c.count } ) - -data Error = UnboundVar String - -instance Show Error where - show (UnboundVar str) = "Unbound variable: " <> str +-- | Annotate name with number and increment the number @prefix ⇒ prefix_number@. +makeName :: Ident -> Rn Ident +makeName (Ident prefix) = gets (\i -> Ident $ prefix ++ "_" ++ show i) <* modify succ diff --git a/src/Renamer/RenamerIr.hs b/src/Renamer/RenamerIr.hs deleted file mode 100644 index 77e2f1f..0000000 --- a/src/Renamer/RenamerIr.hs +++ /dev/null @@ -1,32 +0,0 @@ -{-# LANGUAGE LambdaCase #-} - -module Renamer.RenamerIr ( - RExp (..), - RBind (..), - RProgram (..), - Ident (..), - Type (..), -) where - -import Grammar.Abs ( - Bind (..), - Ident (..), - Program (..), - Type (..), - ) -import Grammar.Print - -data RProgram = RProgram [RBind] - deriving (Eq, Show, Read, Ord) - -data RBind = RBind Ident RExp - deriving (Eq, Show, Read, Ord) - -data RExp - = RAnn RExp Type - | RId Ident - | RInt Integer - | RApp RExp RExp - | RAdd RExp RExp - | RAbs Integer Ident RExp - deriving (Eq, Ord, Show, Read) diff --git a/src/Renamer/RenamerM.hs b/src/Renamer/RenamerM.hs deleted file mode 100644 index 5fb1fa2..0000000 --- a/src/Renamer/RenamerM.hs +++ /dev/null @@ -1,83 +0,0 @@ -{-# LANGUAGE LambdaCase #-} - -module Renamer.RenamerM where - -import Auxiliary (mapAccumM) -import Control.Monad.State (MonadState, State, evalState, gets, - modify) -import Data.Map (Map) -import qualified Data.Map as Map -import Data.Maybe (fromMaybe) -import Data.Tuple.Extra (dupe) -import Grammar.Abs - - --- | Rename all variables and local binds -rename :: Program -> Program -rename (Program bs) = Program $ evalState (runRn $ mapM (renameSc initNames) bs) 0 - where - initNames = Map.fromList $ map (\(Bind name _ _ _ _) -> dupe name) bs - renameSc :: Names -> Bind -> Rn Bind - renameSc old_names (Bind name t _ parms rhs) = do - (new_names, parms') <- newNames old_names parms - rhs' <- snd <$> renameExp new_names rhs - pure $ Bind name t name parms' rhs' - - --- | Rename monad. State holds the number of renamed names. -newtype Rn a = Rn { runRn :: State Int a } - deriving (Functor, Applicative, Monad, MonadState Int) - --- | Maps old to new name -type Names = Map Ident Ident - -renameLocalBind :: Names -> Bind -> Rn (Names, Bind) -renameLocalBind old_names (Bind name t _ parms rhs) = do - (new_names, name') <- newName old_names name - (new_names', parms') <- newNames new_names parms - (new_names'', rhs') <- renameExp new_names' rhs - pure (new_names'', Bind name' t name' parms' rhs') - -renameExp :: Names -> Exp -> Rn (Names, Exp) -renameExp old_names = \case - EId n -> pure (old_names, EId . fromMaybe n $ Map.lookup n old_names) - - EInt i1 -> pure (old_names, EInt i1) - - EApp e1 e2 -> do - (env1, e1') <- renameExp old_names e1 - (env2, e2') <- renameExp old_names e2 - pure (Map.union env1 env2, EApp e1' e2') - - EAdd e1 e2 -> do - (env1, e1') <- renameExp old_names e1 - (env2, e2') <- renameExp old_names e2 - pure (Map.union env1 env2, EAdd e1' e2') - - ELet i e1 e2 -> do - (new_names, e1') <- renameExp old_names e1 - (new_names', e2') <- renameExp new_names e2 - pure (new_names', ELet i e1' e2') - - EAbs par e -> do - (new_names, par') <- newName old_names par - (new_names', e') <- renameExp new_names e - pure (new_names', EAbs par' e') - - EAnn e t -> do - (new_names, e') <- renameExp old_names e - pure (new_names, EAnn e' t) - --- | Create a new name and add it to name environment. -newName :: Names -> Ident -> Rn (Names, Ident) -newName env old_name = do - new_name <- makeName old_name - pure (Map.insert old_name new_name env, new_name) - --- | Create multiple names and add them to the name environment -newNames :: Names -> [Ident] -> Rn (Names, [Ident]) -newNames = mapAccumM newName - --- | Annotate name with number and increment the number @prefix ⇒ prefix_number@. -makeName :: Ident -> Rn Ident -makeName (Ident prefix) = gets (\i -> Ident $ prefix ++ "_" ++ show i) <* modify succ diff --git a/src/TypeChecker/AlgoW.hs b/src/TypeChecker/AlgoW.hs deleted file mode 100644 index de931d1..0000000 --- a/src/TypeChecker/AlgoW.hs +++ /dev/null @@ -1,238 +0,0 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} -{-# HLINT ignore "Use traverse_" #-} - -module TypeChecker.AlgoW where - -import Control.Monad.Except -import Control.Monad.Reader -import Control.Monad.State -import Data.Bifunctor (bimap, second) -import Data.Functor.Identity (Identity, runIdentity) -import Data.List (foldl', intersect) -import Data.Map (Map) -import qualified Data.Map as M -import Data.Maybe (fromMaybe) -import Data.Set (Set) -import qualified Data.Set as S - -import Grammar.Abs -import Grammar.Print (Print, printTree) -import qualified TypeChecker.HMIr as T - --- | A data type representing type variables -data Poly = Forall [Ident] Type - deriving Show - -newtype Ctx = Ctx { vars :: Map Ident Poly } - -data Env = Env { count :: Int - , sigs :: Map Ident Type - } - -type Error = String -type Subst = Map Ident Type - -type Infer = StateT Env (ReaderT Ctx (ExceptT Error Identity)) - -initCtx = Ctx mempty -initEnv = Env 0 mempty - -runPretty :: Print a => Infer a -> Either Error String -runPretty = fmap printTree . run - -run :: Infer a -> Either Error a -run = runC initEnv initCtx - -runC :: Env -> Ctx -> Infer a -> Either Error a -runC e c = runIdentity . runExceptT . flip runReaderT c . flip evalStateT e - -typecheck :: Program -> Either Error T.Program -typecheck = run . checkPrg - -checkPrg :: Program -> Infer T.Program -checkPrg (Program bs) = do - traverse (\(Bind n t _ _ _) -> insertSig n t) bs - bs' <- mapM checkBind bs - return $ T.Program bs' - -checkBind :: Bind -> Infer T.Bind -checkBind (Bind n t _ args e) = do - (t', e') <- inferExp $ makeLambda e (reverse args) - s <- unify t t' - let t'' = apply s t - return $ T.Bind (t'',n) [] e' - where - makeLambda :: Exp -> [Ident] -> Exp - makeLambda = foldl (flip EAbs) - -inferExp :: Exp -> Infer (Type, T.Exp) -inferExp e = do - (s, t, e') <- w e - let subbed = apply s t - return (subbed, replace subbed e') - -replace :: Type -> T.Exp -> T.Exp -replace t = \case - T.EInt t' e -> T.EInt t e - T.EId t' i -> T.EId t i - T.EAbs t' name e -> T.EAbs t name e - T.EApp t' e1 e2 -> T.EApp t e1 e2 - T.EAdd t' e1 e2 -> T.EAdd t e1 e2 - T.ELet t' name e1 e2 -> T.ELet t name e1 e2 - -w :: Exp -> Infer (Subst, Type, T.Exp) -w = \case - EAnn e t -> do - (s1, t', e') <- w e - applySt s1 $ do - s2 <- unify (apply s1 t) t' - return (s2 `compose` s1, t, e') - EInt n -> return (nullSubst, TMono "Int", T.EInt (TMono "Int") n) - EId i -> do - var <- asks vars - case M.lookup i var of - Nothing -> throwError $ "Unbound variable: " ++ show i - Just t -> inst t >>= \x -> return (nullSubst, x, T.EId x i) - EAbs name e -> do - fr <- fresh - withBinding name (Forall [] fr) $ do - (s1, t', e') <- w e - let newArr = TArr (apply s1 fr) t' - return (s1, newArr, T.EAbs newArr name e') - EAdd e0 e1 -> do - (s1, t0, e0') <- w e0 - applySt s1 $ do - (s2, t1, e1') <- w e1 - applySt s2 $ do - s3 <- unify (subst s2 t0) (TMono "Int") - s4 <- unify (subst s3 t1) (TMono "Int") - return (s4 `compose` s3 `compose` s2 `compose` s1, TMono "Int", T.EAdd (TMono "Int") e0' e1') - EApp e0 e1 -> do - fr <- fresh - (s1, t0, e0') <- w e0 - applySt s1 $ do - (s2, t1, e1') <- w e1 - applySt s2 $ do - s3 <- unify (subst s2 t0) (TArr t1 fr) - let t = apply s3 fr - return (s3 `compose` s2 `compose` s1, t, T.EApp t e0' e1') - ELet name e0 e1 -> do - (s1, t1, e0') <- w e0 - env <- asks vars - let t' = generalize (apply s1 env) t1 - withBinding name t' $ do - (s2, t2, e1') <- w e1 - return (s2 `compose` s1, t2, T.ELet t2 name e0' e1' ) - --- | Unify two types producing a new substitution (constraint) -unify :: Type -> Type -> Infer Subst -unify t0 t1 = case (t0, t1) of - (TArr a b, TArr c d) -> do - s1 <- unify a c - s2 <- unify (subst s1 b) (subst s1 c) - return $ s1 `compose` s2 - (TPol a, b) -> occurs a b - (a, TPol b) -> occurs b a - (TMono a, TMono b) -> if a == b then return M.empty else throwError "Types do not unify" - (a, b) -> throwError . unwords $ ["Type:", printTree a, "can't be unified with:", printTree b] - --- | Check if a type is contained in another type. --- I.E. { a = a -> b } is an unsolvable constraint since there is no substitution such that these are equal -occurs :: Ident -> Type -> Infer Subst -occurs i (TPol a) = return nullSubst -occurs i t = if S.member i (free t) - then throwError "Occurs check failed" - else return $ M.singleton i t - --- | Generalize a type over all free variables in the substitution set -generalize :: Map Ident Poly -> Type -> Poly -generalize env t = Forall (S.toList $ free t S.\\ free env) t - --- | Instantiate a polymorphic type. The free type variables are substituted with fresh ones. -inst :: Poly -> Infer Type -inst (Forall xs t) = do - xs' <- mapM (const fresh) xs - let s = M.fromList $ zip xs xs' - return $ apply s t - -compose :: Subst -> Subst -> Subst -compose m1 m2 = M.map (subst m1) m2 `M.union` m1 - --- | A class representing free variables functions -class FreeVars t where - -- | Get all free variables from t - free :: t -> Set Ident - -- | Apply a substitution to t - apply :: Subst -> t -> t - -instance FreeVars Type where - free :: Type -> Set Ident - free (TPol a) = S.singleton a - free (TMono _) = mempty - free (TArr a b) = free a `S.union` free b - apply :: Subst -> Type -> Type - apply sub t = do - case t of - TMono a -> TMono a - TPol a -> case M.lookup a sub of - Nothing -> TPol a - Just t -> t - TArr a b -> TArr (apply sub a) (apply sub b) - -instance FreeVars Poly where - free :: Poly -> Set Ident - free (Forall xs t) = free t S.\\ S.fromList xs - apply :: Subst -> Poly -> Poly - apply s (Forall xs t) = Forall xs (apply (foldr M.delete s xs) t) - -instance FreeVars (Map Ident Poly) where - free :: Map Ident Poly -> Set Ident - free m = foldl' S.union S.empty (map free $ M.elems m) - apply :: Subst -> Map Ident Poly -> Map Ident Poly - apply s = M.map (apply s) - -applySt :: Subst -> Infer a -> Infer a -applySt s = local (\st -> st { vars = apply s (vars st) }) - --- | Represents the empty substition set -nullSubst :: Subst -nullSubst = M.empty - --- | Substitute type variables with their mappings from the substitution set. -subst :: Subst -> Type -> Type -subst m t = do - case t of - TPol a -> fromMaybe t (M.lookup a m) - TMono a -> TMono a - TArr a b -> TArr (subst m a) (subst m b) - --- | Generate a new fresh variable and increment the state counter -fresh :: Infer Type -fresh = do - n <- gets count - modify (\st -> st { count = n + 1 }) - return . TPol . Ident $ "t" ++ show n - --- | Run the monadic action with an additional binding -withBinding :: (Monad m, MonadReader Ctx m) => Ident -> Poly -> m a -> m a -withBinding i p = local (\st -> st { vars = M.insert i p (vars st) }) - --- | Insert a function signature into the environment -insertSig :: Ident -> Type -> Infer () -insertSig i t = modify (\st -> st { sigs = M.insert i t (sigs st) }) - --- | Lookup a variable in the context -lookupVar :: Ident -> Infer Poly -lookupVar i = do - m <- asks vars - case M.lookup i m of - Just t -> return t - Nothing -> throwError $ "Unbound variable: " ++ show i - -lett = let (Right (t,e)) = run $ inferExp $ ELet "x" (EAdd (EInt 5) (EInt 5)) (EAdd (EId "x") (EId "x")) - in t == TMono "Int" - -letty = let (Right (t,e)) = run $ inferExp $ ELet "f" (EAbs "x" (EId "x")) (EApp (EId "f") (EInt 3)) - in e diff --git a/src/TypeChecker/HM.hs b/src/TypeChecker/HM.hs deleted file mode 100644 index 7b33cbe..0000000 --- a/src/TypeChecker/HM.hs +++ /dev/null @@ -1,181 +0,0 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} -{-# HLINT ignore "Use traverse_" #-} -{-# LANGUAGE FlexibleInstances #-} - -module TypeChecker.HM where - -import Control.Monad.Except -import Control.Monad.State -import Data.Bifunctor (bimap, second) -import Data.Functor.Identity (Identity, runIdentity) -import Data.Map (Map) -import qualified Data.Map as M - -import Grammar.Abs -import Grammar.Print -import qualified TypeChecker.HMIr as T - -type Infer = StateT Ctx (ExceptT String Identity) -type Error = String - -data Ctx = Ctx { constr :: Map Type Type - , vars :: Map Ident Type - , sigs :: Map Ident Type - , frsh :: Char } - deriving Show - -runC :: Ctx -> Infer a -> Either String (a, Ctx) -runC c = runIdentity . runExceptT . flip runStateT c - -run :: Infer a -> Either String a -run = runIdentity . runExceptT . flip evalStateT initC - -initC :: Ctx -initC = Ctx M.empty M.empty M.empty 'a' - -typecheck :: Program -> Either Error T.Program -typecheck = run . inferPrg - -inferPrg :: Program -> Infer T.Program -inferPrg (Program bs) = do - traverse (\(Bind n t _ _ _) -> insertSig n t) bs - bs' <- mapM inferBind bs - return $ T.Program bs' - -inferBind :: Bind -> Infer T.Bind -inferBind (Bind i t _ params rhs) = do - (t',e') <- inferExp (makeLambda rhs (reverse params)) - when (t /= t') (throwError . unwords $ [ "Signature of function" - , show i - , "with type:" - , show t - , "does not match inferred type" - , show t' - , "of expression:" - , show e']) - return $ T.Bind (t,i) [] e' - -makeLambda :: Exp -> [Ident] -> Exp -makeLambda = foldl (flip EAbs) - -inferExp :: Exp -> Infer (Type, T.Exp) -inferExp e = do - (t, e') <- inferExp' e - t'' <- solveConstraints t - return (t'', replaceType t'' e') - - where - inferExp' :: Exp -> Infer (Type, T.Exp) - inferExp' = \case - EAnn e t -> do - (t',e') <- inferExp' e - t'' <- solveConstraints t' - when (t'' /= t) (throwError "Annotated type and inferred type don't match") - return (t', e') - EInt i -> return (int, T.EInt int i) - EId i -> (\t -> (t, T.EId t i)) <$> lookupVar i - EAdd e1 e2 -> do - insertSig "+" (TArr int (TArr int int)) - inferExp' (EApp (EApp (EId "+") e1) e2) - EApp e1 e2 -> do - (t1, e1') <- inferExp' e1 - (t2, e2') <- inferExp' e2 - fr <- fresh - addConstraint t1 (TArr t2 fr) - return (fr, T.EApp fr e1' e2') - EAbs name e -> do - fr <- fresh - insertVar name fr - (ret_t,e') <- inferExp' e - t <- solveConstraints (TArr fr ret_t) - return (t, T.EAbs t name e') - ELet name e1 e2 -> error "Let expression not implemented yet" - -replaceType :: Type -> T.Exp -> T.Exp -replaceType t = \case - T.EInt _ i -> T.EInt t i - T.EId _ i -> T.EId t i - T.EAdd _ e1 e2 -> T.EAdd t e1 e2 - T.EApp _ e1 e2 -> T.EApp t e1 e2 - T.EAbs _ name e -> T.EAbs t name e - T.ELet _ name e1 e2 -> T.ELet t name e1 e2 - -isInt :: Type -> Bool -isInt (TMono "Int") = True -isInt _ = False - -lookupVar :: Ident -> Infer Type -lookupVar i = do - st <- get - case M.lookup i (vars st) of - Just t -> return t - Nothing -> case M.lookup i (sigs st) of - Just t -> return t - Nothing -> throwError $ "Unbound variable or function" ++ printTree i - -insertVar :: Ident -> Type -> Infer () -insertVar s t = modify ( \st -> st { vars = M.insert s t (vars st) } ) - -insertSig :: Ident -> Type -> Infer () -insertSig s t = modify ( \st -> st { sigs = M.insert s t (sigs st) } ) - --- | Generate a new fresh variable and increment the state -fresh :: Infer Type -fresh = do - chr <- gets frsh - modify (\st -> st { frsh = succ chr }) - return $ TPol (Ident [chr]) - --- | Adds a constraint to the constraint set. --- i.e: a = int -> b --- b = int --- thus when solving constraints it must be the case that --- a = int -> int -addConstraint :: Type -> Type -> Infer () -addConstraint t1 t2 = do - modify (\st -> st { constr = M.insert t1 t2 (constr st) }) - --- | Given a type, solve the constraints and figure out the type that should be assigned to it. -solveConstraints :: Type -> Infer Type -solveConstraints t = do - c <- gets constr - v <- gets vars - xs <- solveAll (M.toList c) - modify (\st -> st { constr = M.fromList xs }) - return $ subst t xs - --- | Substitute -subst :: Type -> [(Type, Type)] -> Type -subst t [] = t -subst (TArr t1 t2) (x:xs) = subst (TArr (replace x t1) (replace x t2)) xs -subst t (x:xs) = subst (replace x t) xs - --- | Given a set of constraints run the replacement on all of them, producing a new set of --- replacements. --- https://youtu.be/trmq3wYcUxU - good video for explanation -solveAll :: [(Type, Type)] -> Infer [(Type, Type)] -solveAll [] = return [] -solveAll (x:xs) = case x of - (TArr t1 t2, TArr t3 t4) -> solveAll $ (t1,t3) : (t2,t4) : xs - (TArr t1 t2, b) -> fmap ((b, TArr t1 t2) :) $ solveAll $ solve (b, TArr t1 t2) xs - (a, TArr t1 t2) -> fmap ((a, TArr t1 t2) :) $ solveAll $ solve (a, TArr t1 t2) xs - (TMono a, TPol b) -> fmap ((TPol b, TMono a) :) $ solveAll $ solve (TPol b, TMono a) xs - (TPol a, TMono b) -> fmap ((TPol a, TMono b) :) $ solveAll $ solve (TPol a, TMono b) xs - (TPol a, TPol b) -> fmap ((TPol a, TPol b) :) $ solveAll $ solve (TPol a, TPol b) xs - (TMono a, TMono b) -> if a == b then solveAll xs else throwError "Can't unify types" - -solve :: (Type, Type) -> [(Type, Type)] -> [(Type, Type)] -solve x = map (both (replace x)) - --- | Given a constraint (type, type) and a type, if the constraint matches the input --- replace with the constrained type -replace :: (Type, Type) -> Type -> Type -replace a (TArr t1 t2) = TArr (replace a t1) (replace a t2) -replace (a,b) c = if a==c then b else c - -both :: (a -> b) -> (a,a) -> (b,b) -both f = bimap f f - -int = TMono "Int" diff --git a/src/TypeChecker/HMIr.hs b/src/TypeChecker/HMIr.hs deleted file mode 100644 index 0a6085c..0000000 --- a/src/TypeChecker/HMIr.hs +++ /dev/null @@ -1,110 +0,0 @@ -{-# LANGUAGE LambdaCase #-} - -module TypeChecker.HMIr - ( module Grammar.Abs - , module TypeChecker.HMIr - ) where - -import Grammar.Abs (Ident (..), Type (..)) -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 Type Ident - | EInt Type Integer - | ELet Type Ident Exp Exp - | EApp Type Exp Exp - | EAdd Type Exp Exp - | EAbs Type Ident Exp - deriving (C.Eq, C.Ord, C.Read) - -instance Show Exp where - show (EId t (Ident i)) = i ++ " : " ++ show t - show (EInt _ i) = show i - show (ELet t i e1 e2) = "let " ++ show t ++ " = " ++ show e1 ++ " in " ++ show e2 - show (EApp t e1 e2) = show e1 ++ " " ++ show e2 ++ " : " ++ show t - show (EAdd _ e1 e2) = show e1 ++ " + " ++ show e2 - show (EAbs t (Ident i) e) = "\\ " ++ i ++ ". " ++ show e ++ " : " ++ show t - -type Id = (Type, Ident) - -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 name@(n, _) parms rhs) = prPrec i 0 $ concatD - [ prtId 0 name - , doc $ showString ";" - , prt 0 n - , 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 [prt 0 n] - EInt _ i1 -> prPrec i 3 $ concatD [prt 0 i1] - ELet _ name e1 e2 -> prPrec i 3 $ concatD - [ doc $ showString "let" - , prt 0 name - , prt 0 e1 - , doc $ showString "in" - , prt 0 e2 - ] - EApp t e1 e2 -> prPrec i 2 $ concatD - [ doc $ showString "@" - , prt 0 t - , 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 "\\" - , prt 0 n - , doc $ showString "." - , prt 0 e - ] - - - diff --git a/src/TypeChecker/TypeChecker.hs b/src/TypeChecker/TypeChecker.hs index 99a1e17..0d9ace9 100644 --- a/src/TypeChecker/TypeChecker.hs +++ b/src/TypeChecker/TypeChecker.hs @@ -1,153 +1,250 @@ --- {-# LANGUAGE LambdaCase #-} --- {-# LANGUAGE OverloadedRecordDot #-} --- {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} +{-# HLINT ignore "Use traverse_" #-} +{-# OPTIONS_GHC -Wno-overlapping-patterns #-} module TypeChecker.TypeChecker where --- import Control.Monad (void) --- import Control.Monad.Except (ExceptT, runExceptT, throwError) --- import Control.Monad.State (StateT) --- import qualified Control.Monad.State as St --- import Data.Functor.Identity (Identity, runIdentity) --- import Data.Map (Map) --- import qualified Data.Map as M +import Control.Monad.Except +import Control.Monad.Reader +import Control.Monad.State +import Data.Functor.Identity (Identity, runIdentity) +import Data.List (foldl') +import Data.Map (Map) +import qualified Data.Map as M +import Data.Set (Set) +import qualified Data.Set as S --- import TypeChecker.TypeCheckerIr +import Grammar.Abs +import Grammar.Print (printTree) +import qualified TypeChecker.TypeCheckerIr as T --- data Ctx = Ctx --- { vars :: Map Integer Type --- , sigs :: Map Ident Type --- , nextFresh :: Int --- } --- deriving (Show) +-- | A data type representing type variables +data Poly = Forall [Ident] Type + deriving Show --- -- Perhaps swap over to reader monad instead for vars and sigs. --- type Infer = StateT Ctx (ExceptT Error Identity) +newtype Ctx = Ctx { vars :: Map Ident Poly } --- {- +data Env = Env { count :: Int + , sigs :: Map Ident Type + } --- The type checker will assume we first rename all variables to unique name, as to not --- have to care about scoping. It significantly improves the quality of life of the --- programmer. +type Error = String +type Subst = Map Ident Type --- TODOs: --- Add skolemization variables. i.e --- { \x. 3 : forall a. a -> a } --- should not type check +type Infer = StateT Env (ReaderT Ctx (ExceptT Error Identity)) --- Generalize. Not really sure what that means though +initCtx = Ctx mempty +initEnv = Env 0 mempty --- -} +runPretty :: Exp -> Either Error String +runPretty = fmap (printTree . fst). run . inferExp --- typecheck :: RProgram -> Either Error TProgram --- typecheck = todo +run :: Infer a -> Either Error a +run = runC initEnv initCtx --- run :: Infer a -> Either Error a --- run = runIdentity . runExceptT . flip St.evalStateT (Ctx mempty mempty 0) +runC :: Env -> Ctx -> Infer a -> Either Error a +runC e c = runIdentity . runExceptT . flip runReaderT c . flip evalStateT e --- -- Have to figure out a way to coerce polymorphic types to monomorphic ones where necessary --- -- { \x. \y. x + y } will have the type { a -> b -> Int } --- inferExp :: RExp -> Infer Type --- inferExp = \case +typecheck :: Program -> Either Error T.Program +typecheck = run . checkPrg --- RAnn expr typ -> do --- t <- inferExp expr --- void $ t =:= typ --- return t +checkPrg :: Program -> Infer T.Program +checkPrg (Program bs) = do + let bs' = getBinds bs + traverse (\(Bind n t _ _ _) -> insertSig n t) bs' + bs' <- mapM checkBind bs' + return $ T.Program bs' + where + getBinds :: [Def] -> [Bind] + getBinds = map toBind . filter isBind + isBind :: Def -> Bool + isBind (DBind _) = True + isBind _ = True + toBind :: Def -> Bind + toBind (DBind bind) = bind + toBind _ = error "Can't convert DData to Bind" --- RBound num name -> lookupVars num +checkBind :: Bind -> Infer T.Bind +checkBind (Bind n t _ args e) = do + (t', e') <- inferExp $ makeLambda e (reverse args) + s <- unify t t' + let t'' = apply s t + unless (t `typeEq` t'') (throwError $ unwords ["Top level signature", printTree t, "does not match body with type:", printTree t'']) + return $ T.Bind (n, t) [] e' + where + makeLambda :: Exp -> [Ident] -> Exp + makeLambda = foldl (flip EAbs) --- RFree name -> lookupSigs name +typeEq :: Type -> Type -> Bool +typeEq (TArr l r) (TArr l' r') = typeEq l l' && typeEq r r' +typeEq (TMono a) (TMono b) = a == b +typeEq (TPol _) (TPol _) = True +typeEq _ _ = False --- RConst (CInt i) -> return $ TMono "Int" +inferExp :: Exp -> Infer (Type, T.Exp) +inferExp e = do + (s, t, e') <- w e + let subbed = apply s t + return (subbed, replace subbed e') --- RConst (CStr str) -> return $ TMono "Str" +replace :: Type -> T.Exp -> T.Exp +replace t = \case + T.ELit _ e -> T.ELit t e + T.EId (n, _) -> T.EId (n, t) + T.EAbs _ name e -> T.EAbs t name e + T.EApp _ e1 e2 -> T.EApp t e1 e2 + T.EAdd _ e1 e2 -> T.EAdd t e1 e2 + T.ELet (T.Bind (n, _) args e1) e2 -> T.ELet (T.Bind (n, t) args e1) e2 --- RAdd expr1 expr2 -> do --- let int = TMono "Int" --- typ1 <- check expr1 int --- typ2 <- check expr2 int --- return int +w :: Exp -> Infer (Subst, Type, T.Exp) +w = \case --- RApp expr1 expr2 -> do --- fn_t <- inferExp expr1 --- arg_t <- inferExp expr2 --- res <- fresh --- new_t <- fn_t =:= TArrow arg_t res --- return res + EAnn e t -> do + (s1, t', e') <- w e + applySt s1 $ do + s2 <- unify (apply s1 t) t' + return (s2 `compose` s1, t, e') --- RAbs num name expr -> do --- arg <- fresh --- insertVars num arg --- typ <- inferExp expr --- return $ TArrow arg typ + ELit (LInt n) -> return (nullSubst, TMono "Int", T.ELit (TMono "Int") (LInt n)) --- check :: RExp -> Type -> Infer () --- check e t = do --- t' <- inferExp e --- t =:= t' --- return () + ELit a -> error $ "NOT IMPLEMENTED YET: ELit " ++ show a --- fresh :: Infer Type --- fresh = do --- var <- St.gets nextFresh --- St.modify (\st -> st {nextFresh = succ var}) --- return (TPoly $ Ident (show var)) + EId i -> do + var <- asks vars + case M.lookup i var of + Just t -> inst t >>= \x -> return (nullSubst, x, T.EId (i, x)) + Nothing -> do + sig <- gets sigs + case M.lookup i sig of + Nothing -> throwError $ "Unbound variable: " ++ show i + Just t -> return (nullSubst, t, T.EId (i, t)) --- -- | Unify two types. --- (=:=) :: Type -> Type -> Infer Type --- (=:=) (TPoly _) b = return b --- (=:=) a (TPoly _) = return a --- (=:=) (TMono a) (TMono b) | a == b = return (TMono a) --- (=:=) (TArrow a b) (TArrow c d) = do --- t1 <- a =:= c --- t2 <- b =:= d --- return $ TArrow t1 t2 --- (=:=) a b = throwError (TypeMismatch $ unwords ["Can not unify type", show a, "with", show b]) + EAbs name e -> do + fr <- fresh + withBinding name (Forall [] fr) $ do + (s1, t', e') <- w e + let varType = apply s1 fr + let newArr = TArr varType t' + return (s1, newArr, T.EAbs newArr (name, varType) e') --- lookupVars :: Integer -> Infer Type --- lookupVars i = do --- st <- St.gets vars --- case M.lookup i st of --- Just t -> return t --- Nothing -> throwError $ UnboundVar "lookupVars" + EAdd e0 e1 -> do + (s1, t0, e0') <- w e0 + applySt s1 $ do + (s2, t1, e1') <- w e1 + applySt s2 $ do + s3 <- unify (apply s2 t0) (TMono "Int") + s4 <- unify (apply s3 t1) (TMono "Int") + return (s4 `compose` s3 `compose` s2 `compose` s1, TMono "Int", T.EAdd (TMono "Int") e0' e1') --- insertVars :: Integer -> Type -> Infer () --- insertVars i t = do --- st <- St.get --- St.put (st {vars = M.insert i t st.vars}) + EApp e0 e1 -> do + fr <- fresh + (s0, t0, e0') <- w e0 + applySt s0 $ do + (s1, t1, e1') <- w e1 + -- applySt s1 $ do + s2 <- unify (apply s1 t0) (TArr t1 fr) + let t = apply s2 fr + return (s2 `compose` s1 `compose` s0, t, T.EApp t e0' e1') --- lookupSigs :: Ident -> Infer Type --- lookupSigs i = do --- st <- St.gets sigs --- case M.lookup i st of --- Just t -> return t --- Nothing -> throwError $ UnboundVar "lookupSigs" + ELet name e0 e1 -> do + (s1, t1, e0') <- w e0 + env <- asks vars + let t' = generalize (apply s1 env) t1 + withBinding name t' $ do + (s2, t2, e1') <- w e1 + return (s2 `compose` s1, t2, T.ELet (T.Bind (name,t2) [] e0') e1' ) --- insertSigs :: Ident -> Type -> Infer () --- insertSigs i t = do --- st <- St.get --- St.put (st {sigs = M.insert i t st.sigs}) + ECase a b -> error $ "NOT IMPLEMENTED YET: ECase" ++ show a ++ " " ++ show b --- {-# WARNING todo "TODO IN CODE" #-} --- todo :: a --- todo = error "TODO in code" +-- | Unify two types producing a new substitution (constraint) +unify :: Type -> Type -> Infer Subst +unify t0 t1 = case (t0, t1) of + (TArr a b, TArr c d) -> do + s1 <- unify a c + s2 <- unify (apply s1 b) (apply s1 d) + return $ s1 `compose` s2 + (TPol a, b) -> occurs a b + (a, TPol b) -> occurs b a + (TMono a, TMono b) -> if a == b then return M.empty else throwError "Types do not unify" + (a, b) -> throwError . unwords $ ["Type:", printTree a, "can't be unified with:", printTree b] --- data Error --- = TypeMismatch String --- | NotNumber String --- | FunctionTypeMismatch String --- | NotFunction String --- | UnboundVar String --- | AnnotatedMismatch String --- | Default String --- deriving (Show) +-- | Check if a type is contained in another type. +-- I.E. { a = a -> b } is an unsolvable constraint since there is no substitution such that these are equal +occurs :: Ident -> Type -> Infer Subst +occurs _ (TPol _) = return nullSubst +occurs i t = if S.member i (free t) + then throwError "Occurs check failed" + else return $ M.singleton i t +-- | Generalize a type over all free variables in the substitution set +generalize :: Map Ident Poly -> Type -> Poly +generalize env t = Forall (S.toList $ free t S.\\ free env) t --- {- +-- | Instantiate a polymorphic type. The free type variables are substituted with fresh ones. +inst :: Poly -> Infer Type +inst (Forall xs t) = do + xs' <- mapM (const fresh) xs + let s = M.fromList $ zip xs xs' + return $ apply s t --- The procedure inst(σ) specializes the polytype --- σ by copying the term and replacing the bound type variables --- consistently by new monotype variables. +-- | Compose two substitution sets +compose :: Subst -> Subst -> Subst +compose m1 m2 = M.map (apply m1) m2 `M.union` m1 --- -} +-- | A class representing free variables functions +class FreeVars t where + -- | Get all free variables from t + free :: t -> Set Ident + -- | Apply a substitution to t + apply :: Subst -> t -> t + +instance FreeVars Type where + free :: Type -> Set Ident + free (TPol a) = S.singleton a + free (TMono _) = mempty + free (TArr a b) = free a `S.union` free b + apply :: Subst -> Type -> Type + apply sub t = do + case t of + TMono a -> TMono a + TPol a -> case M.lookup a sub of + Nothing -> TPol a + Just t -> t + TArr a b -> TArr (apply sub a) (apply sub b) + +instance FreeVars Poly where + free :: Poly -> Set Ident + free (Forall xs t) = free t S.\\ S.fromList xs + apply :: Subst -> Poly -> Poly + apply s (Forall xs t) = Forall xs (apply (foldr M.delete s xs) t) + +instance FreeVars (Map Ident Poly) where + free :: Map Ident Poly -> Set Ident + free m = foldl' S.union S.empty (map free $ M.elems m) + apply :: Subst -> Map Ident Poly -> Map Ident Poly + apply s = M.map (apply s) + +-- | Apply substitutions to the environment. +applySt :: Subst -> Infer a -> Infer a +applySt s = local (\st -> st { vars = apply s (vars st) }) + +-- | Represents the empty substition set +nullSubst :: Subst +nullSubst = M.empty + +-- | Generate a new fresh variable and increment the state counter +fresh :: Infer Type +fresh = do + n <- gets count + modify (\st -> st { count = n + 1 }) + return . TPol . Ident $ "t" ++ show n + +-- | Run the monadic action with an additional binding +withBinding :: (Monad m, MonadReader Ctx m) => Ident -> Poly -> m a -> m a +withBinding i p = local (\st -> st { vars = M.insert i p (vars st) }) + +-- | Insert a function signature into the environment +insertSig :: Ident -> Type -> Infer () +insertSig i t = modify (\st -> st { sigs = M.insert i t (sigs st) }) diff --git a/src/TypeChecker/TypeCheckerIr.hs b/src/TypeChecker/TypeCheckerIr.hs index c08d981..c85ebcc 100644 --- a/src/TypeChecker/TypeCheckerIr.hs +++ b/src/TypeChecker/TypeCheckerIr.hs @@ -1,74 +1,99 @@ --- {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE LambdaCase #-} -module TypeChecker.TypeCheckerIr --( --- TProgram (..), --- TBind (..), --- TExp (..), --- RProgram (..), --- RBind (..), --- RExp (..), --- Type (..), --- Const (..), --- Ident (..), --- ) where +module TypeChecker.TypeCheckerIr + ( module Grammar.Abs + , module TypeChecker.TypeCheckerIr + ) where --- import Grammar.Print --- import Renamer.RenamerIr +import Grammar.Abs (Ident (..), Literal (..), Type (..)) +import Grammar.Print +import Prelude +import qualified Prelude as C (Eq, Ord, Read, Show) --- newtype TProgram = TProgram [TBind] --- deriving (Eq, Show, Read, Ord) +newtype Program = Program [Bind] + deriving (C.Eq, C.Ord, C.Show, C.Read) --- data TBind = TBind Ident Type TExp --- deriving (Eq, Show, Read, Ord) +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) --- data TExp --- = TAnn TExp Type --- | TBound Integer Ident Type --- | TFree Ident Type --- | TConst Const Type --- | TApp TExp TExp Type --- | TAdd TExp TExp Type --- | TAbs Integer Ident TExp Type --- deriving (Eq, Ord, Show, Read) +type Id = (Ident, Type) + +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 + ] --- instance Print TProgram where --- prt i = \case --- TProgram defs -> prPrec i 0 (concatD [prt 0 defs]) --- instance Print TBind where --- prt i = \case --- TBind x t e -> --- prPrec i 0 $ --- concatD --- [ prt 0 x --- , doc (showString ":") --- , prt 0 t --- , doc (showString "=") --- , prt 0 e --- , doc (showString "\n") --- ] --- instance Print TExp where --- prt i = \case --- TAnn e t -> --- prPrec i 2 $ --- concatD --- [ prt 0 e --- , doc (showString ":") --- , prt 1 t --- ] --- TBound _ u t -> prPrec i 3 $ concatD [prt 0 u] --- TFree u t -> prPrec i 3 $ concatD [prt 0 u] --- TConst c _ -> prPrec i 3 (concatD [prt 0 c]) --- TApp e e1 t -> prPrec i 2 $ concatD [prt 2 e, prt 3 e1] --- TAdd e e1 t -> prPrec i 1 $ concatD [prt 1 e, doc (showString "+"), prt 2 e1] --- TAbs _ u e t -> --- prPrec i 0 $ --- concatD --- [ doc (showString "(") --- , doc (showString "λ") --- , prt 0 u --- , doc (showString ".") --- , prt 0 e --- , doc (showString ")") --- ] diff --git a/test_program b/test_program index 3481a0b..69a2c20 100644 --- a/test_program +++ b/test_program @@ -1,3 +1,2 @@ -fun : Mono Int -> Mono Int ; -fun = let f = \x. x in f 3 ; - +main : _Int ; +main = 3 + 3 ; diff --git a/tests/Main.hs b/tests/Main.hs deleted file mode 100644 index 7432800..0000000 --- a/tests/Main.hs +++ /dev/null @@ -1,21 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Main where - -import Grammar.Abs -import System.Exit (exitFailure) -import Test.Hspec -import TypeChecker.AlgoW - -main :: IO () -main = do - print "RUNNING TESTS BROTHER" - exitFailure - -- hspec $ do - -- describe "the algorithm W" $ do - -- it "infers EInt as type Int" $ do - -- fmap fst (run (inferExp (EInt 1))) `shouldBe` Right (TMono "Int") - -- it "throws an exception if a variable is inferred with an empty env" $ do - -- run (inferExp (EId "x")) `shouldBe` Left "Unbound variable: x" - -- it "throws an exception if the annotated type does not match the inferred type" $ do - -- fmap fst (run (inferExp (EAnn (EInt 3) (TPol "a")))) `shouldBe` Right (TMono "bad") diff --git a/tests/Tests.hs b/tests/Tests.hs new file mode 100644 index 0000000..46a9a3f --- /dev/null +++ b/tests/Tests.hs @@ -0,0 +1,56 @@ +{-# 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 qualified TypeChecker.TypeCheckerIr as T + +main :: IO () +main = do + quickCheck prop_isInt + quickCheck prop_idAbs_generic + +newtype AbsExp = AE Exp deriving Show +newtype EIntExp = EI Exp deriving Show + +instance Arbitrary EIntExp where + arbitrary = genInt + +instance Arbitrary AbsExp where + arbitrary = genLambda + +getType :: Infer (Type, T.Exp) -> Either Error Type +getType ie = case run ie of + Left err -> Left err + Right (t,e) -> return t + +genInt :: Gen EIntExp +genInt = EI . ELit . LInt <$> arbitrary + +genLambda :: Gen AbsExp +genLambda = do + str <- arbitrary @String + let str' = Ident str + return $ AE $ EAbs str' (EId str') + +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 + +int :: Type +int = TMono "Int" + +isGenericArr :: Type -> Bool +isGenericArr (TArr (TPol a) (TPol b)) = a == b +isGenericArr _ = False From bbf6e159c7790056bb816cf94e428e7542978cbc Mon Sep 17 00:00:00 2001 From: sebastianselander Date: Mon, 27 Feb 2023 17:22:42 +0100 Subject: [PATCH 054/372] Type inference/checking on ADTs mostly complete(?). Still have to test --- Grammar.cf | 18 +- language.cabal | 6 +- src/Codegen/Codegen.hs | 484 +++++++++++++++---------------- src/LambdaLifter/LambdaLifter.hs | 304 +++++++++---------- src/Main.hs | 36 +-- src/TypeChecker/TypeChecker.hs | 153 +++++++--- src/TypeChecker/TypeCheckerIr.hs | 13 +- test_program | 16 +- 8 files changed, 563 insertions(+), 467 deletions(-) diff --git a/Grammar.cf b/Grammar.cf index 6870367..96554bb 100644 --- a/Grammar.cf +++ b/Grammar.cf @@ -3,7 +3,7 @@ Program. Program ::= [Def] ; DBind. Def ::= Bind ; DData. Def ::= Data ; -terminator Def ";" ; +separator Def ";" ; Bind. Bind ::= Ident ":" Type ";" Ident [Ident] "=" Exp ; @@ -31,16 +31,19 @@ IMatch. Match ::= Ident ; InitMatch. Match ::= Ident Match ; separator Match " " ; -TMono. Type1 ::= "_" Ident ; -TPol. Type1 ::= "'" Ident ; -TArr. Type ::= Type1 "->" Type ; +TMono. Type1 ::= "_" Ident ; +TPol. Type1 ::= "'" Ident ; +TConstr. Type1 ::= Ident "(" [Type] ")" ; +TArr. Type ::= Type1 "->" Type ; + separator Type " " ; +coercions Type 2 ; -- shift/reduce problem here -Data. Data ::= "data" Ident [Type] "where" ";" +Data. Data ::= "data" Type "where" ";" [Constructor]; -terminator Constructor ";" ; +separator Constructor "," ; Constructor. Constructor ::= Ident ":" Type ; @@ -48,10 +51,9 @@ Constructor. Constructor ::= Ident ":" Type ; -- token Poly upper (letter | digit | '_')* ; -- token Mono lower (letter | digit | '_')* ; -terminator Bind ";" ; +separator Bind ";" ; separator Ident " "; -coercions Type 1 ; coercions Exp 5 ; comment "--" ; diff --git a/language.cabal b/language.cabal index eb58aa0..3556367 100644 --- a/language.cabal +++ b/language.cabal @@ -34,9 +34,9 @@ executable language TypeChecker.TypeChecker TypeChecker.TypeCheckerIr Renamer.Renamer - LambdaLifter.LambdaLifter - Codegen.Codegen - Codegen.LlvmIr + -- LambdaLifter.LambdaLifter + -- Codegen.Codegen + -- Codegen.LlvmIr hs-source-dirs: src diff --git a/src/Codegen/Codegen.hs b/src/Codegen/Codegen.hs index 76a1f02..fe66b43 100644 --- a/src/Codegen/Codegen.hs +++ b/src/Codegen/Codegen.hs @@ -1,277 +1,277 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} +--{-# LANGUAGE LambdaCase #-} +--{-# LANGUAGE OverloadedStrings #-} -module Codegen.Codegen (compile) where +module Codegen.Codegen where -import Auxiliary (snoc) -import Codegen.LlvmIr (LLVMIr (..), LLVMType (..), - LLVMValue (..), Visibility (..), - llvmIrToString) -import Control.Monad.State (StateT, execStateT, gets, modify) -import Data.Map (Map) -import qualified Data.Map as Map -import Data.Tuple.Extra (dupe, first, second) -import Grammar.ErrM (Err) -import TypeChecker.TypeChecker -import TypeChecker.TypeCheckerIr +--import Auxiliary (snoc) +--import Codegen.LlvmIr (LLVMIr (..), LLVMType (..), +-- LLVMValue (..), Visibility (..), +-- llvmIrToString) +--import Control.Monad.State (StateT, execStateT, gets, modify) +--import Data.Map (Map) +--import qualified Data.Map as Map +--import Data.Tuple.Extra (dupe, first, second) +--import Grammar.ErrM (Err) +--import TypeChecker.TypeCheckerIr --- | The record used as the code generator state -data CodeGenerator = CodeGenerator - { instructions :: [LLVMIr] - , functions :: Map Id FunctionInfo - , variableCount :: Integer - } +---- | The record used as the code generator state +--data CodeGenerator = CodeGenerator +-- { instructions :: [LLVMIr] +-- , functions :: Map Id FunctionInfo +-- , variableCount :: Integer +-- } --- | A state type synonym -type CompilerState a = StateT CodeGenerator Err a +---- | A state type synonym +--type CompilerState a = StateT CodeGenerator Err a -data FunctionInfo = FunctionInfo - { numArgs :: Int - , arguments :: [Id] - } +--data FunctionInfo = FunctionInfo +-- { numArgs :: Int +-- , arguments :: [Id] +-- } --- | Adds a instruction to the CodeGenerator state -emit :: LLVMIr -> CompilerState () -emit l = modify $ \t -> t { instructions = snoc l $ instructions t } +---- | Adds a instruction to the CodeGenerator state +--emit :: LLVMIr -> CompilerState () +--emit l = modify $ \t -> t { instructions = snoc l $ instructions t } --- | Increases the variable counter in the CodeGenerator state -increaseVarCount :: CompilerState () -increaseVarCount = modify $ \t -> t { variableCount = variableCount t + 1 } +---- | Increases the variable counter in the CodeGenerator state +--increaseVarCount :: CompilerState () +--increaseVarCount = modify $ \t -> t { variableCount = variableCount t + 1 } --- | Returns the variable count from the CodeGenerator state -getVarCount :: CompilerState Integer -getVarCount = gets variableCount +---- | Returns the variable count from the CodeGenerator state +--getVarCount :: CompilerState Integer +--getVarCount = gets variableCount --- | Increases the variable count and returns it from the CodeGenerator state -getNewVar :: CompilerState Integer -getNewVar = increaseVarCount >> getVarCount +---- | Increases the variable count and returns it from the CodeGenerator state +--getNewVar :: CompilerState Integer +--getNewVar = increaseVarCount >> getVarCount --- | Produces a map of functions infos from a list of binds, --- which contains useful data for code generation. -getFunctions :: [Bind] -> Map Id FunctionInfo -getFunctions bs = Map.fromList $ map go bs - where - go (Bind id args _) = - (id, FunctionInfo { numArgs=length args, arguments=args }) +---- | Produces a map of functions infos from a list of binds, +---- which contains useful data for code generation. +--getFunctions :: [Bind] -> Map Id FunctionInfo +--getFunctions bs = Map.fromList $ map go bs +-- where +-- go (Bind id args _) = +-- (id, FunctionInfo { numArgs=length args, arguments=args }) -initCodeGenerator :: [Bind] -> CodeGenerator -initCodeGenerator scs = CodeGenerator { instructions = defaultStart - , functions = getFunctions scs - , variableCount = 0 - } +--initCodeGenerator :: [Bind] -> CodeGenerator +--initCodeGenerator scs = CodeGenerator { instructions = defaultStart +-- , functions = getFunctions scs +-- , variableCount = 0 +-- } --- | Compiles an AST and produces a LLVM Ir string. --- An easy way to actually "compile" this output is to --- Simply pipe it to lli -compile :: Program -> Err String -compile (Program scs) = do - let codegen = initCodeGenerator scs - llvmIrToString . instructions <$> execStateT (compileScs scs) codegen +---- | Compiles an AST and produces a LLVM Ir string. +---- An easy way to actually "compile" this output is to +---- Simply pipe it to lli +--compile :: Program -> Err String +--compile (Program scs) = do +-- let codegen = initCodeGenerator scs +-- llvmIrToString . instructions <$> execStateT (compileScs scs) codegen -compileScs :: [Bind] -> CompilerState () -compileScs [] = pure () -compileScs (Bind (name, t) args exp : xs) = do - emit $ UnsafeRaw "\n" - emit . Comment $ show name <> ": " <> show exp - let args' = map (second type2LlvmType) args - emit $ Define (type2LlvmType t_return) name args' - functionBody <- exprToValue exp - if name == "main" - then mapM_ emit $ mainContent functionBody - else emit $ Ret I64 functionBody - emit DefineEnd - modify $ \s -> s { variableCount = 0 } - compileScs xs - where - t_return = snd $ partitionType (length args) t +--compileScs :: [Bind] -> CompilerState () +--compileScs [] = pure () +--compileScs (Bind (name, t) args exp : xs) = do +-- emit $ UnsafeRaw "\n" +-- emit . Comment $ show name <> ": " <> show exp +-- let args' = map (second type2LlvmType) args +-- emit $ Define (type2LlvmType t_return) name args' +-- functionBody <- exprToValue exp +-- if name == "main" +-- then mapM_ emit $ mainContent functionBody +-- else emit $ Ret I64 functionBody +-- emit DefineEnd +-- modify $ \s -> s { variableCount = 0 } +-- compileScs xs +-- where +-- t_return = snd $ partitionType (length args) t -mainContent :: LLVMValue -> [LLVMIr] -mainContent var = - [ UnsafeRaw $ - "call i32 (ptr, ...) @printf(ptr noundef @.str, i64 noundef " <> show var <> ")\n" - , -- , SetVariable (Ident "p") (Icmp LLEq I64 (VInteger 2) (VInteger 2)) - -- , BrCond (VIdent (Ident "p")) (Ident "b_1") (Ident "b_2") - -- , Label (Ident "b_1") - -- , UnsafeRaw - -- "call i32 (ptr, ...) @printf(ptr noundef @.str, i64 noundef 1)\n" - -- , Br (Ident "end") - -- , Label (Ident "b_2") - -- , UnsafeRaw - -- "call i32 (ptr, ...) @printf(ptr noundef @.str, i64 noundef 2)\n" - -- , Br (Ident "end") - -- , Label (Ident "end") - Ret I64 (VInteger 0) - ] +--mainContent :: LLVMValue -> [LLVMIr] +--mainContent var = +-- [ UnsafeRaw $ +-- "call i32 (ptr, ...) @printf(ptr noundef @.str, i64 noundef " <> show var <> ")\n" +-- , -- , SetVariable (Ident "p") (Icmp LLEq I64 (VInteger 2) (VInteger 2)) +-- -- , BrCond (VIdent (Ident "p")) (Ident "b_1") (Ident "b_2") +-- -- , Label (Ident "b_1") +-- -- , UnsafeRaw +-- -- "call i32 (ptr, ...) @printf(ptr noundef @.str, i64 noundef 1)\n" +-- -- , Br (Ident "end") +-- -- , Label (Ident "b_2") +-- -- , UnsafeRaw +-- -- "call i32 (ptr, ...) @printf(ptr noundef @.str, i64 noundef 2)\n" +-- -- , Br (Ident "end") +-- -- , Label (Ident "end") +-- Ret I64 (VInteger 0) +-- ] -defaultStart :: [LLVMIr] -defaultStart = [ UnsafeRaw "@.str = private unnamed_addr constant [3 x i8] c\"%i\n\", align 1\n" - , UnsafeRaw "declare i32 @printf(ptr noalias nocapture, ...)\n" - ] +--defaultStart :: [LLVMIr] +--defaultStart = [ UnsafeRaw "@.str = private unnamed_addr constant [3 x i8] c\"%i\n\", align 1\n" +-- , UnsafeRaw "declare i32 @printf(ptr noalias nocapture, ...)\n" +-- ] -compileExp :: Exp -> CompilerState () -compileExp = \case - ELit _ (LInt i) -> emitInt i - EAdd t e1 e2 -> emitAdd t e1 e2 - EId (name, _) -> emitIdent name - EApp t e1 e2 -> emitApp t e1 e2 - EAbs t ti e -> emitAbs t ti e - ELet bind e -> emitLet bind e +--compileExp :: Exp -> CompilerState () +--compileExp = \case +-- ELit _ (LInt i) -> emitInt i +-- EAdd t e1 e2 -> emitAdd t e1 e2 +-- EId (name, _) -> emitIdent name +-- EApp t e1 e2 -> emitApp t e1 e2 +-- EAbs t ti e -> emitAbs t ti e +-- ELet bind e -> emitLet bind e ---- aux functions --- -emitAbs :: Type -> Id -> Exp -> CompilerState () -emitAbs _t tid e = emit . Comment $ "Lambda escaped previous stages: \\" <> show tid <> " . " <> show e +----- aux functions --- +--emitAbs :: Type -> Id -> Exp -> CompilerState () +--emitAbs _t tid e = emit . Comment $ "Lambda escaped previous stages: \\" <> show tid <> " . " <> show e -emitLet :: Bind -> Exp -> CompilerState () -emitLet b e = emit . Comment $ concat [ "ELet (" - , show b - , " = " - , show e - , ") is not implemented!" - ] +--emitLet :: Bind -> Exp -> CompilerState () +--emitLet b e = emit . Comment $ concat [ "ELet (" +-- , show b +-- , " = " +-- , show e +-- , ") is not implemented!" +-- ] -emitApp :: Type -> Exp -> Exp -> CompilerState () -emitApp t e1 e2 = appEmitter t e1 e2 [] - where - appEmitter :: Type -> Exp -> Exp -> [Exp] -> CompilerState () - appEmitter t e1 e2 stack = do - let newStack = e2 : stack - case e1 of - EApp _ e1' e2' -> appEmitter t e1' e2' newStack - EId id@(name, _) -> do - args <- traverse exprToValue newStack - vs <- getNewVar - funcs <- gets functions - let visibility = maybe Local (const Global) $ Map.lookup id funcs - args' = map (first valueGetType . dupe) args - call = Call (type2LlvmType t) visibility name args' - emit $ SetVariable (Ident $ show vs) call - x -> do - emit . Comment $ "The unspeakable happened: " - emit . Comment $ show x +--emitApp :: Type -> Exp -> Exp -> CompilerState () +--emitApp t e1 e2 = appEmitter t e1 e2 [] +-- where +-- appEmitter :: Type -> Exp -> Exp -> [Exp] -> CompilerState () +-- appEmitter t e1 e2 stack = do +-- let newStack = e2 : stack +-- case e1 of +-- EApp _ e1' e2' -> appEmitter t e1' e2' newStack +-- EId id@(name, _) -> do +-- args <- traverse exprToValue newStack +-- vs <- getNewVar +-- funcs <- gets functions +-- let visibility = maybe Local (const Global) $ Map.lookup id funcs +-- args' = map (first valueGetType . dupe) args +-- call = Call (type2LlvmType t) visibility name args' +-- emit $ SetVariable (Ident $ show vs) call +-- x -> do +-- emit . Comment $ "The unspeakable happened: " +-- emit . Comment $ show x -emitIdent :: Ident -> CompilerState () -emitIdent id = do - -- !!this should never happen!! - emit $ Comment "This should not have happened!" - emit $ Variable id - emit $ UnsafeRaw "\n" +--emitIdent :: Ident -> CompilerState () +--emitIdent id = do +-- -- !!this should never happen!! +-- emit $ Comment "This should not have happened!" +-- emit $ Variable id +-- emit $ UnsafeRaw "\n" -emitInt :: Integer -> CompilerState () -emitInt i = do - -- !!this should never happen!! - varCount <- getNewVar - emit $ Comment "This should not have happened!" - emit $ SetVariable (Ident (show varCount)) (Add I64 (VInteger i) (VInteger 0)) +--emitInt :: Integer -> CompilerState () +--emitInt i = do +-- -- !!this should never happen!! +-- varCount <- getNewVar +-- emit $ Comment "This should not have happened!" +-- emit $ SetVariable (Ident (show varCount)) (Add I64 (VInteger i) (VInteger 0)) -emitAdd :: Type -> Exp -> Exp -> CompilerState () -emitAdd t e1 e2 = do - v1 <- exprToValue e1 - v2 <- exprToValue e2 - v <- getNewVar - emit $ SetVariable (Ident $ show v) (Add (type2LlvmType t) v1 v2) +--emitAdd :: Type -> Exp -> Exp -> CompilerState () +--emitAdd t e1 e2 = do +-- v1 <- exprToValue e1 +-- v2 <- exprToValue e2 +-- v <- getNewVar +-- emit $ SetVariable (Ident $ show v) (Add (type2LlvmType t) v1 v2) --- emitMul :: Exp -> Exp -> CompilerState () --- emitMul e1 e2 = do --- (v1,v2) <- binExprToValues e1 e2 --- increaseVarCount --- v <- gets variableCount --- emit $ SetVariable $ Ident $ show v --- emit $ Mul I64 v1 v2 +---- emitMul :: Exp -> Exp -> CompilerState () +---- emitMul e1 e2 = do +---- (v1,v2) <- binExprToValues e1 e2 +---- increaseVarCount +---- v <- gets variableCount +---- emit $ SetVariable $ Ident $ show v +---- emit $ Mul I64 v1 v2 --- emitMod :: Exp -> Exp -> CompilerState () --- emitMod e1 e2 = do --- -- `let m a b = rem (abs $ b + a) b` --- (v1,v2) <- binExprToValues e1 e2 --- increaseVarCount --- vadd <- gets variableCount --- emit $ SetVariable $ Ident $ show vadd --- emit $ Add I64 v1 v2 --- --- increaseVarCount --- vabs <- gets variableCount --- emit $ SetVariable $ Ident $ show vabs --- emit $ Call I64 (Ident "llvm.abs.i64") --- [ (I64, VIdent (Ident $ show vadd)) --- , (I1, VInteger 1) --- ] --- increaseVarCount --- v <- gets variableCount --- emit $ SetVariable $ Ident $ show v --- emit $ Srem I64 (VIdent (Ident $ show vabs)) v2 +---- emitMod :: Exp -> Exp -> CompilerState () +---- emitMod e1 e2 = do +---- -- `let m a b = rem (abs $ b + a) b` +---- (v1,v2) <- binExprToValues e1 e2 +---- increaseVarCount +---- vadd <- gets variableCount +---- emit $ SetVariable $ Ident $ show vadd +---- emit $ Add I64 v1 v2 +---- +---- increaseVarCount +---- vabs <- gets variableCount +---- emit $ SetVariable $ Ident $ show vabs +---- emit $ Call I64 (Ident "llvm.abs.i64") +---- [ (I64, VIdent (Ident $ show vadd)) +---- , (I1, VInteger 1) +---- ] +---- increaseVarCount +---- v <- gets variableCount +---- emit $ SetVariable $ Ident $ show v +---- emit $ Srem I64 (VIdent (Ident $ show vabs)) v2 --- emitDiv :: Exp -> Exp -> CompilerState () --- emitDiv e1 e2 = do --- (v1,v2) <- binExprToValues e1 e2 --- increaseVarCount --- v <- gets variableCount --- emit $ SetVariable $ Ident $ show v --- emit $ Div I64 v1 v2 +---- emitDiv :: Exp -> Exp -> CompilerState () +---- emitDiv e1 e2 = do +---- (v1,v2) <- binExprToValues e1 e2 +---- increaseVarCount +---- v <- gets variableCount +---- emit $ SetVariable $ Ident $ show v +---- emit $ Div I64 v1 v2 --- emitSub :: Exp -> Exp -> CompilerState () --- emitSub e1 e2 = do --- (v1,v2) <- binExprToValues e1 e2 --- increaseVarCount --- v <- gets variableCount --- emit $ SetVariable $ Ident $ show v --- emit $ Sub I64 v1 v2 +---- emitSub :: Exp -> Exp -> CompilerState () +---- emitSub e1 e2 = do +---- (v1,v2) <- binExprToValues e1 e2 +---- increaseVarCount +---- v <- gets variableCount +---- emit $ SetVariable $ Ident $ show v +---- emit $ Sub I64 v1 v2 -exprToValue :: Exp -> CompilerState LLVMValue -exprToValue = \case - ELit _ (LInt i) -> pure $ VInteger i +--exprToValue :: Exp -> CompilerState LLVMValue +--exprToValue = \case +-- ELit _ (LInt i) -> pure $ VInteger i - EId id@(name, t) -> do - funcs <- gets functions - case Map.lookup id funcs of - Just fi -> do - if numArgs fi == 0 - then do - vc <- getNewVar - emit $ SetVariable (Ident $ show vc) - (Call (type2LlvmType t) Global name []) - pure $ VIdent (Ident $ show vc) (type2LlvmType t) - else pure $ VFunction name Global (type2LlvmType t) - Nothing -> pure $ VIdent name (type2LlvmType t) +-- EId id@(name, t) -> do +-- funcs <- gets functions +-- case Map.lookup id funcs of +-- Just fi -> do +-- if numArgs fi == 0 +-- then do +-- vc <- getNewVar +-- emit $ SetVariable (Ident $ show vc) +-- (Call (type2LlvmType t) Global name []) +-- pure $ VIdent (Ident $ show vc) (type2LlvmType t) +-- else pure $ VFunction name Global (type2LlvmType t) +-- Nothing -> pure $ VIdent name (type2LlvmType t) - e -> do - compileExp e - v <- getVarCount - pure $ VIdent (Ident $ show v) (getType e) +-- e -> do +-- compileExp e +-- v <- getVarCount +-- pure $ VIdent (Ident $ show v) (getType e) -type2LlvmType :: Type -> LLVMType -type2LlvmType = \case - (TMono "Int") -> I64 - TArr t xs -> do - let (t', xs') = function2LLVMType xs [type2LlvmType t] - Function t' xs' - t -> I64 --CustomType $ Ident ("\"" ++ show t ++ "\"") - where - function2LLVMType :: Type -> [LLVMType] -> (LLVMType, [LLVMType]) - function2LLVMType (TArr t xs) s = function2LLVMType xs (type2LlvmType t : s) - function2LLVMType x s = (type2LlvmType x, s) +--type2LlvmType :: Type -> LLVMType +--type2LlvmType = \case +-- (TMono "Int") -> I64 +-- TArr t xs -> do +-- let (t', xs') = function2LLVMType xs [type2LlvmType t] +-- Function t' xs' +-- -- This part will not work as we don't have a monomorphization step yet +-- t -> CustomType $ Ident ("\"" ++ show t ++ "\"") +-- where +-- function2LLVMType :: Type -> [LLVMType] -> (LLVMType, [LLVMType]) +-- function2LLVMType (TArr t xs) s = function2LLVMType xs (type2LlvmType t : s) +-- function2LLVMType x s = (type2LlvmType x, s) -getType :: Exp -> LLVMType -getType (ELit _ (LInt _)) = I64 -getType (EAdd t _ _) = type2LlvmType t -getType (EId (_, t)) = type2LlvmType t -getType (EApp t _ _) = type2LlvmType t -getType (EAbs t _ _) = type2LlvmType t -getType (ELet _ e) = getType e +--getType :: Exp -> LLVMType +--getType (ELit _ (LInt _)) = I64 +--getType (EAdd t _ _) = type2LlvmType t +--getType (EId (_, t)) = type2LlvmType t +--getType (EApp t _ _) = type2LlvmType t +--getType (EAbs t _ _) = type2LlvmType t +--getType (ELet _ e) = getType e -valueGetType :: LLVMValue -> LLVMType -valueGetType (VInteger _) = I64 -valueGetType (VIdent _ t) = t -valueGetType (VConstant s) = Array (length s) I8 -valueGetType (VFunction _ _ t) = t +--valueGetType :: LLVMValue -> LLVMType +--valueGetType (VInteger _) = I64 +--valueGetType (VIdent _ t) = t +--valueGetType (VConstant s) = Array (length s) I8 +--valueGetType (VFunction _ _ t) = t --- | Partion type into types of parameters and return type. -partitionType :: Int -- Number of parameters to apply - -> Type - -> ([Type], Type) -partitionType = go [] - where - go acc 0 t = (acc, t) - go acc i t = case t of - TArr t1 t2 -> go (snoc t1 acc) (i - 1) t2 - _ -> error "Number of parameters and type doesn't match" +---- | Partion type into types of parameters and return type. +--partitionType :: Int -- Number of parameters to apply +-- -> Type +-- -> ([Type], Type) +--partitionType = go [] +-- where +-- go acc 0 t = (acc, t) +-- go acc i t = case t of +-- TArr t1 t2 -> go (snoc t1 acc) (i - 1) t2 +-- _ -> error "Number of parameters and type doesn't match" diff --git a/src/LambdaLifter/LambdaLifter.hs b/src/LambdaLifter/LambdaLifter.hs index a617159..271cc70 100644 --- a/src/LambdaLifter/LambdaLifter.hs +++ b/src/LambdaLifter/LambdaLifter.hs @@ -1,192 +1,192 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} +--{-# LANGUAGE LambdaCase #-} +--{-# LANGUAGE OverloadedStrings #-} -module LambdaLifter.LambdaLifter (lambdaLift, freeVars, abstract, rename, collectScs) where +module LambdaLifter.LambdaLifter where -import Auxiliary (snoc) -import Control.Applicative (Applicative (liftA2)) -import Control.Monad.State (MonadState (get, put), State, - evalState) -import Data.Set (Set) -import qualified Data.Set as Set -import Prelude hiding (exp) -import Renamer.Renamer -import TypeChecker.TypeCheckerIr +--import Auxiliary (snoc) +--import Control.Applicative (Applicative (liftA2)) +--import Control.Monad.State (MonadState (get, put), State, +-- evalState) +--import Data.Set (Set) +--import qualified Data.Set as Set +--import Prelude hiding (exp) +--import Renamer.Renamer +--import TypeChecker.TypeCheckerIr --- | Lift lambdas and let expression into supercombinators. --- Three phases: --- @freeVars@ annotatss all the free variables. --- @abstract@ converts lambdas into let expressions. --- @collectScs@ moves every non-constant let expression to a top-level function. -lambdaLift :: Program -> Program -lambdaLift = collectScs . abstract . freeVars +---- | Lift lambdas and let expression into supercombinators. +---- Three phases: +---- @freeVars@ annotatss all the free variables. +---- @abstract@ converts lambdas into let expressions. +---- @collectScs@ moves every non-constant let expression to a top-level function. +--lambdaLift :: Program -> Program +--lambdaLift = collectScs . abstract . freeVars --- | Annotate free variables -freeVars :: Program -> AnnProgram -freeVars (Program ds) = [ (n, xs, freeVarsExp (Set.fromList xs) e) - | Bind n xs e <- ds - ] +---- | Annotate free variables +--freeVars :: Program -> AnnProgram +--freeVars (Program ds) = [ (n, xs, freeVarsExp (Set.fromList xs) e) +-- | Bind n xs e <- ds +-- ] -freeVarsExp :: Set Id -> Exp -> AnnExp -freeVarsExp localVars = \case - EId n | Set.member n localVars -> (Set.singleton n, AId n) - | otherwise -> (mempty, AId n) +--freeVarsExp :: Set Id -> Exp -> AnnExp +--freeVarsExp localVars = \case +-- EId n | Set.member n localVars -> (Set.singleton n, AId n) +-- | otherwise -> (mempty, AId n) - ELit _ (LInt i) -> (mempty, AInt i) +-- ELit _ (LInt i) -> (mempty, AInt i) - EApp t e1 e2 -> (Set.union (freeVarsOf e1') (freeVarsOf e2'), AApp t e1' e2') - where - e1' = freeVarsExp localVars e1 - e2' = freeVarsExp localVars e2 +-- EApp t e1 e2 -> (Set.union (freeVarsOf e1') (freeVarsOf e2'), AApp t e1' e2') +-- where +-- e1' = freeVarsExp localVars e1 +-- e2' = freeVarsExp localVars e2 - EAdd t e1 e2 -> (Set.union (freeVarsOf e1') (freeVarsOf e2'), AAdd t e1' e2') - where - e1' = freeVarsExp localVars e1 - e2' = freeVarsExp localVars e2 +-- EAdd t e1 e2 -> (Set.union (freeVarsOf e1') (freeVarsOf e2'), AAdd t e1' e2') +-- where +-- e1' = freeVarsExp localVars e1 +-- e2' = freeVarsExp localVars e2 - EAbs t par e -> (Set.delete par $ freeVarsOf e', AAbs t par e') - where - e' = freeVarsExp (Set.insert par localVars) e +-- EAbs t par e -> (Set.delete par $ freeVarsOf e', AAbs t par e') +-- where +-- e' = freeVarsExp (Set.insert par localVars) e - -- Sum free variables present in bind and the expression - ELet (Bind name parms rhs) e -> (Set.union binders_frees e_free, ALet new_bind e') - where - binders_frees = Set.delete name $ freeVarsOf rhs' - e_free = Set.delete name $ freeVarsOf e' +-- -- Sum free variables present in bind and the expression +-- ELet (Bind name parms rhs) e -> (Set.union binders_frees e_free, ALet new_bind e') +-- where +-- binders_frees = Set.delete name $ freeVarsOf rhs' +-- e_free = Set.delete name $ freeVarsOf e' - rhs' = freeVarsExp e_localVars rhs - new_bind = ABind name parms rhs' +-- rhs' = freeVarsExp e_localVars rhs +-- new_bind = ABind name parms rhs' - e' = freeVarsExp e_localVars e - e_localVars = Set.insert name localVars +-- e' = freeVarsExp e_localVars e +-- e_localVars = Set.insert name localVars -freeVarsOf :: AnnExp -> Set Id -freeVarsOf = fst +--freeVarsOf :: AnnExp -> Set Id +--freeVarsOf = fst --- AST annotated with free variables -type AnnProgram = [(Id, [Id], AnnExp)] +---- AST annotated with free variables +--type AnnProgram = [(Id, [Id], AnnExp)] -type AnnExp = (Set Id, AnnExp') +--type AnnExp = (Set Id, AnnExp') -data ABind = ABind Id [Id] AnnExp deriving Show +--data ABind = ABind Id [Id] AnnExp deriving Show -data AnnExp' = AId Id - | AInt Integer - | ALet ABind AnnExp - | AApp Type AnnExp AnnExp - | AAdd Type AnnExp AnnExp - | AAbs Type Id AnnExp - deriving Show --- | Lift lambdas to let expression of the form @let sc = \v₁ x₁ -> e₁@. --- Free variables are @v₁ v₂ .. vₙ@ are bound. -abstract :: AnnProgram -> Program -abstract prog = Program $ evalState (mapM go prog) 0 - where - go :: (Id, [Id], AnnExp) -> State Int Bind - go (name, parms, rhs) = Bind name (parms ++ parms1) <$> abstractExp rhs' - where - (rhs', parms1) = flattenLambdasAnn rhs +--data AnnExp' = AId Id +-- | AInt Integer +-- | ALet ABind AnnExp +-- | AApp Type AnnExp AnnExp +-- | AAdd Type AnnExp AnnExp +-- | AAbs Type Id AnnExp +-- deriving Show +---- | Lift lambdas to let expression of the form @let sc = \v₁ x₁ -> e₁@. +---- Free variables are @v₁ v₂ .. vₙ@ are bound. +--abstract :: AnnProgram -> Program +--abstract prog = Program $ evalState (mapM go prog) 0 +-- where +-- go :: (Id, [Id], AnnExp) -> State Int Bind +-- go (name, parms, rhs) = Bind name (parms ++ parms1) <$> abstractExp rhs' +-- where +-- (rhs', parms1) = flattenLambdasAnn rhs --- | Flatten nested lambdas and collect the parameters --- @\x.\y.\z. ae → (ae, [x,y,z])@ -flattenLambdasAnn :: AnnExp -> (AnnExp, [Id]) -flattenLambdasAnn ae = go (ae, []) - where - go :: (AnnExp, [Id]) -> (AnnExp, [Id]) - go ((free, e), acc) = - case e of - AAbs _ par (free1, e1) -> - go ((Set.delete par free1, e1), snoc par acc) - _ -> ((free, e), acc) +---- | Flatten nested lambdas and collect the parameters +---- @\x.\y.\z. ae → (ae, [x,y,z])@ +--flattenLambdasAnn :: AnnExp -> (AnnExp, [Id]) +--flattenLambdasAnn ae = go (ae, []) +-- where +-- go :: (AnnExp, [Id]) -> (AnnExp, [Id]) +-- go ((free, e), acc) = +-- case e of +-- AAbs _ par (free1, e1) -> +-- go ((Set.delete par free1, e1), snoc par acc) +-- _ -> ((free, e), acc) -abstractExp :: AnnExp -> State Int Exp -abstractExp (free, exp) = case exp of - AId n -> pure $ EId n - AInt i -> pure $ ELit (TMono "Int") (LInt i) - AApp t e1 e2 -> liftA2 (EApp t) (abstractExp e1) (abstractExp e2) - AAdd t e1 e2 -> liftA2 (EAdd t) (abstractExp e1) (abstractExp e2) - ALet b e -> liftA2 ELet (go b) (abstractExp e) - where - go (ABind name parms rhs) = do - (rhs', parms1) <- flattenLambdas <$> skipLambdas abstractExp rhs - pure $ Bind name (parms ++ parms1) rhs' +--abstractExp :: AnnExp -> State Int Exp +--abstractExp (free, exp) = case exp of +-- AId n -> pure $ EId n +-- AInt i -> pure $ ELit (TMono "Int") (LInt i) +-- AApp t e1 e2 -> liftA2 (EApp t) (abstractExp e1) (abstractExp e2) +-- AAdd t e1 e2 -> liftA2 (EAdd t) (abstractExp e1) (abstractExp e2) +-- ALet b e -> liftA2 ELet (go b) (abstractExp e) +-- where +-- go (ABind name parms rhs) = do +-- (rhs', parms1) <- flattenLambdas <$> skipLambdas abstractExp rhs +-- pure $ Bind name (parms ++ parms1) rhs' - skipLambdas :: (AnnExp -> State Int Exp) -> AnnExp -> State Int Exp - skipLambdas f (free, ae) = case ae of - AAbs t par ae1 -> EAbs t par <$> skipLambdas f ae1 - _ -> f (free, ae) +-- skipLambdas :: (AnnExp -> State Int Exp) -> AnnExp -> State Int Exp +-- skipLambdas f (free, ae) = case ae of +-- AAbs t par ae1 -> EAbs t par <$> skipLambdas f ae1 +-- _ -> f (free, ae) - -- Lift lambda into let and bind free variables - AAbs t parm e -> do - i <- nextNumber - rhs <- abstractExp e +-- -- Lift lambda into let and bind free variables +-- AAbs t parm e -> do +-- i <- nextNumber +-- rhs <- abstractExp e - let sc_name = Ident ("sc_" ++ show i) - sc = ELet (Bind (sc_name, t) parms rhs) $ EId (sc_name, t) +-- let sc_name = Ident ("sc_" ++ show i) +-- sc = ELet (Bind (sc_name, t) parms rhs) $ EId (sc_name, t) - pure $ foldl (EApp $ TMono "Int") sc $ map EId freeList - where - freeList = Set.toList free - parms = snoc parm freeList +-- pure $ foldl (EApp $ TMono "Int") sc $ map EId freeList +-- where +-- freeList = Set.toList free +-- parms = snoc parm freeList -nextNumber :: State Int Int -nextNumber = do - i <- get - put $ succ i - pure i +--nextNumber :: State Int Int +--nextNumber = do +-- i <- get +-- put $ succ i +-- pure i --- | Collects supercombinators by lifting non-constant let expressions -collectScs :: Program -> Program -collectScs (Program scs) = Program $ concatMap collectFromRhs scs - where - collectFromRhs (Bind name parms rhs) = - let (rhs_scs, rhs') = collectScsExp rhs - in Bind name parms rhs' : rhs_scs +---- | Collects supercombinators by lifting non-constant let expressions +--collectScs :: Program -> Program +--collectScs (Program scs) = Program $ concatMap collectFromRhs scs +-- where +-- collectFromRhs (Bind name parms rhs) = +-- let (rhs_scs, rhs') = collectScsExp rhs +-- in Bind name parms rhs' : rhs_scs -collectScsExp :: Exp -> ([Bind], Exp) -collectScsExp = \case - EId n -> ([], EId n) - ELit _ (LInt i) -> ([], ELit (TMono "Int") (LInt i)) +--collectScsExp :: Exp -> ([Bind], Exp) +--collectScsExp = \case +-- EId n -> ([], EId n) +-- ELit _ (LInt i) -> ([], ELit (TMono "Int") (LInt i)) - EApp t e1 e2 -> (scs1 ++ scs2, EApp t e1' e2') - where - (scs1, e1') = collectScsExp e1 - (scs2, e2') = collectScsExp e2 +-- EApp t e1 e2 -> (scs1 ++ scs2, EApp t e1' e2') +-- where +-- (scs1, e1') = collectScsExp e1 +-- (scs2, e2') = collectScsExp e2 - EAdd t e1 e2 -> (scs1 ++ scs2, EAdd t e1' e2') - where - (scs1, e1') = collectScsExp e1 - (scs2, e2') = collectScsExp e2 +-- EAdd t e1 e2 -> (scs1 ++ scs2, EAdd t e1' e2') +-- where +-- (scs1, e1') = collectScsExp e1 +-- (scs2, e2') = collectScsExp e2 - EAbs t par e -> (scs, EAbs t par e') - where - (scs, e') = collectScsExp e +-- EAbs t par e -> (scs, EAbs t par e') +-- where +-- (scs, e') = collectScsExp e - -- Collect supercombinators from bind, the rhss, and the expression. - -- - -- > f = let sc x y = rhs in e - -- - ELet (Bind name parms rhs) e -> if null parms - then ( rhs_scs ++ e_scs, ELet bind e') - else (bind : rhs_scs ++ e_scs, e') - where - bind = Bind name parms rhs' - (rhs_scs, rhs') = collectScsExp rhs - (e_scs, e') = collectScsExp e +-- -- Collect supercombinators from bind, the rhss, and the expression. +-- -- +-- -- > f = let sc x y = rhs in e +-- -- +-- ELet (Bind name parms rhs) e -> if null parms +-- then ( rhs_scs ++ e_scs, ELet bind e') +-- else (bind : rhs_scs ++ e_scs, e') +-- where +-- bind = Bind name parms rhs' +-- (rhs_scs, rhs') = collectScsExp rhs +-- (e_scs, e') = collectScsExp e --- @\x.\y.\z. e → (e, [x,y,z])@ -flattenLambdas :: Exp -> (Exp, [Id]) -flattenLambdas = go . (, []) - where - go (e, acc) = case e of - EAbs _ par e1 -> go (e1, snoc par acc) - _ -> (e, acc) +---- @\x.\y.\z. e → (e, [x,y,z])@ +--flattenLambdas :: Exp -> (Exp, [Id]) +--flattenLambdas = go . (, []) +-- where +-- go (e, acc) = case e of +-- EAbs _ par e1 -> go (e1, snoc par acc) +-- _ -> (e, acc) diff --git a/src/Main.hs b/src/Main.hs index 3a7bde4..316c599 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -2,18 +2,18 @@ module Main where -import Codegen.Codegen (compile) -import GHC.IO.Handle.Text (hPutStrLn) -import Grammar.ErrM (Err) -import Grammar.Par (myLexer, pProgram) -import Grammar.Print (printTree) +-- import Codegen.Codegen (compile) +import GHC.IO.Handle.Text (hPutStrLn) +import Grammar.ErrM (Err) +import Grammar.Par (myLexer, pProgram) +import Grammar.Print (printTree) -import LambdaLifter.LambdaLifter (lambdaLift) -import Renamer.Renamer (rename) -import System.Environment (getArgs) -import System.Exit (exitFailure, exitSuccess) -import System.IO (stderr) -import TypeChecker.TypeChecker (typecheck) +-- import LambdaLifter.LambdaLifter (lambdaLift) +import Renamer.Renamer (rename) +import System.Environment (getArgs) +import System.Exit (exitFailure, exitSuccess) +import System.IO (stderr) +import TypeChecker.TypeChecker (typecheck) main :: IO () main = @@ -37,14 +37,14 @@ main' s = do typechecked <- fromTypeCheckerErr $ typecheck renamed printToErr $ printTree typechecked - printToErr "\n-- Lambda Lifter --" - let lifted = lambdaLift typechecked - printToErr $ printTree lifted + -- printToErr "\n-- Lambda Lifter --" + -- 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 -- Printing compiler output to stdout --" + -- compiled <- fromCompilerErr $ compile lifted + -- putStrLn compiled + -- writeFile "llvm.ll" compiled exitSuccess diff --git a/src/TypeChecker/TypeChecker.hs b/src/TypeChecker/TypeChecker.hs index 0d9ace9..d09a002 100644 --- a/src/TypeChecker/TypeChecker.hs +++ b/src/TypeChecker/TypeChecker.hs @@ -3,6 +3,7 @@ {-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} {-# HLINT ignore "Use traverse_" #-} {-# OPTIONS_GHC -Wno-overlapping-patterns #-} +{-# HLINT ignore "Use zipWithM" #-} module TypeChecker.TypeChecker where @@ -16,6 +17,7 @@ import qualified Data.Map as M import Data.Set (Set) import qualified Data.Set as S +import Data.Foldable (traverse_) import Grammar.Abs import Grammar.Print (printTree) import qualified TypeChecker.TypeCheckerIr as T @@ -24,10 +26,12 @@ import qualified TypeChecker.TypeCheckerIr as T data Poly = Forall [Ident] Type deriving Show -newtype Ctx = Ctx { vars :: Map Ident Poly } +newtype Ctx = Ctx { vars :: Map Ident Poly + } -data Env = Env { count :: Int - , sigs :: Map Ident Type +data Env = Env { count :: Int + , sigs :: Map Ident Type + , dtypes :: Map Ident Type } type Error = String @@ -36,7 +40,7 @@ type Subst = Map Ident Type type Infer = StateT Env (ReaderT Ctx (ExceptT Error Identity)) initCtx = Ctx mempty -initEnv = Env 0 mempty +initEnv = Env 0 mempty mempty runPretty :: Exp -> Either Error String runPretty = fmap (printTree . fst). run . inferExp @@ -50,21 +54,44 @@ runC e c = runIdentity . runExceptT . flip runReaderT c . flip evalStateT e typecheck :: Program -> Either Error T.Program typecheck = run . checkPrg +checkData :: Data -> Infer () +checkData d = case d of + (Data typ@(TConstr name _) constrs) -> do + traverse_ (\(Constructor name' t') + -> if typ == retType t' + then insertConstr name' t' else + throwError $ + unwords + [ "return type of constructor:" + , printTree name + , "with type:" + , printTree (retType t') + , "does not match data: " + , printTree typ]) constrs + _ -> throwError "Data type incorrectly declared" + where + retType :: Type -> Type + retType (TArr _ t2) = retType t2 + retType a = a + checkPrg :: Program -> Infer T.Program checkPrg (Program bs) = do - let bs' = getBinds bs - traverse (\(Bind n t _ _ _) -> insertSig n t) bs' - bs' <- mapM checkBind bs' - return $ T.Program bs' + preRun bs + T.Program <$> checkDef bs where - getBinds :: [Def] -> [Bind] - getBinds = map toBind . filter isBind - isBind :: Def -> Bool - isBind (DBind _) = True - isBind _ = True - toBind :: Def -> Bind - toBind (DBind bind) = bind - toBind _ = error "Can't convert DData to Bind" + preRun :: [Def] -> Infer () + preRun [] = return () + preRun (x:xs) = case x of + DBind (Bind n t _ _ _ ) -> insertSig n t >> preRun xs + DData d@(Data _ _) -> checkData d >> preRun xs + + checkDef :: [Def] -> Infer [T.Def] + checkDef [] = return [] + checkDef (x:xs) = case x of + (DBind b) -> do + b' <- checkBind b + fmap (T.DBind b' :) (checkDef xs) + (DData d) -> fmap (T.DData d :) (checkDef xs) checkBind :: Bind -> Infer T.Bind checkBind (Bind n t _ args e) = do @@ -77,15 +104,18 @@ checkBind (Bind n t _ args e) = do makeLambda :: Exp -> [Ident] -> Exp makeLambda = foldl (flip EAbs) +-- | Check if two types are considered equal +-- For the purpose of the algorithm two polymorphic types are always considered equal typeEq :: Type -> Type -> Bool -typeEq (TArr l r) (TArr l' r') = typeEq l l' && typeEq r r' -typeEq (TMono a) (TMono b) = a == b -typeEq (TPol _) (TPol _) = True -typeEq _ _ = False +typeEq (TArr l r) (TArr l' r') = typeEq l l' && typeEq r r' +typeEq (TMono a) (TMono b) = a == b +typeEq (TConstr name a) (TConstr name' b) = name == name' && and (zipWith typeEq a b) +typeEq (TPol _) (TPol _) = True +typeEq _ _ = False inferExp :: Exp -> Infer (Type, T.Exp) inferExp e = do - (s, t, e') <- w e + (s, t, e') <- algoW e let subbed = apply s t return (subbed, replace subbed e') @@ -98,19 +128,26 @@ replace t = \case T.EAdd _ e1 e2 -> T.EAdd t e1 e2 T.ELet (T.Bind (n, _) args e1) e2 -> T.ELet (T.Bind (n, t) args e1) e2 -w :: Exp -> Infer (Subst, Type, T.Exp) -w = \case +algoW :: Exp -> Infer (Subst, Type, T.Exp) +algoW = \case EAnn e t -> do - (s1, t', e') <- w e + (s1, t', e') <- algoW e applySt s1 $ do s2 <- unify (apply s1 t) t' return (s2 `compose` s1, t, e') +-- | ------------------ +-- | Γ ⊢ e₀ : Int, ∅ + ELit (LInt n) -> return (nullSubst, TMono "Int", T.ELit (TMono "Int") (LInt n)) ELit a -> error $ "NOT IMPLEMENTED YET: ELit " ++ show a +-- | x : σ ∈ Γ   τ = inst(σ) +-- | ---------------------- +-- | Γ ⊢ x : τ, ∅ + EId i -> do var <- asks vars case M.lookup i var of @@ -118,42 +155,67 @@ w = \case Nothing -> do sig <- gets sigs case M.lookup i sig of - Nothing -> throwError $ "Unbound variable: " ++ show i Just t -> return (nullSubst, t, T.EId (i, t)) + Nothing -> do + constr <- gets dtypes + case M.lookup i constr of + Just t -> return (nullSubst, t, T.EId (i, t)) + Nothing -> throwError $ "Unbound variable: " ++ show i + +-- | τ = newvar Γ, x : τ ⊢ e : τ', S +-- | --------------------------------- +-- | Γ ⊢ w λx. e : Sτ → τ', S EAbs name e -> do fr <- fresh withBinding name (Forall [] fr) $ do - (s1, t', e') <- w e + (s1, t', e') <- algoW e let varType = apply s1 fr let newArr = TArr varType t' return (s1, newArr, T.EAbs newArr (name, varType) e') +-- | Γ ⊢ e₀ : τ₀, S₀ S₀Γ ⊢ e₁ : τ₁, S₁ +-- | s₂ = mgu(s₁τ₀, Int) s₃ = mgu(s₂τ₁, Int) +-- | ------------------------------------------ +-- | Γ ⊢ e₀ + e₁ : Int, S₃S₂S₁S₀ +-- This might be wrong + EAdd e0 e1 -> do - (s1, t0, e0') <- w e0 + (s1, t0, e0') <- algoW e0 applySt s1 $ do - (s2, t1, e1') <- w e1 - applySt s2 $ do - s3 <- unify (apply s2 t0) (TMono "Int") - s4 <- unify (apply s3 t1) (TMono "Int") - return (s4 `compose` s3 `compose` s2 `compose` s1, TMono "Int", T.EAdd (TMono "Int") e0' e1') + (s2, t1, e1') <- algoW e1 + -- applySt s2 $ do + s3 <- unify (apply s2 t0) (TMono "Int") + s4 <- unify (apply s3 t1) (TMono "Int") + return (s4 `compose` s3 `compose` s2 `compose` s1, TMono "Int", T.EAdd (TMono "Int") e0' e1') + +-- | Γ ⊢ e₀ : τ₀, S₀ S₀Γ ⊢ e₁ : τ₁, S1 +-- | τ' = newvar S₂ = mgu(S₁τ₀, τ₁ → τ') +-- | -------------------------------------- +-- | Γ ⊢ e₀ e₁ : S₂τ', S₂S₁S₀ EApp e0 e1 -> do fr <- fresh - (s0, t0, e0') <- w e0 + (s0, t0, e0') <- algoW e0 applySt s0 $ do - (s1, t1, e1') <- w e1 + (s1, t1, e1') <- algoW e1 -- applySt s1 $ do s2 <- unify (apply s1 t0) (TArr t1 fr) let t = apply s2 fr return (s2 `compose` s1 `compose` s0, t, T.EApp t e0' e1') +-- | Γ ⊢ e₀ : τ, S₀ S₀Γ, x : S̅₀Γ̅(τ) ⊢ e₁ : τ', S₁ +-- | ---------------------------------------------- +-- | Γ ⊢ let x = e₀ in e₁ : τ', S₁S₀ + +-- The bar over S₀ and Γ means "generalize" + ELet name e0 e1 -> do - (s1, t1, e0') <- w e0 + (s1, t1, e0') <- algoW e0 env <- asks vars let t' = generalize (apply s1 env) t1 withBinding name t' $ do - (s2, t2, e1') <- w e1 + (s2, t2, e1') <- algoW e1 return (s2 `compose` s1, t2, T.ELet (T.Bind (name,t2) [] e0') e1' ) ECase a b -> error $ "NOT IMPLEMENTED YET: ECase" ++ show a ++ " " ++ show b @@ -168,6 +230,12 @@ unify t0 t1 = case (t0, t1) of (TPol a, b) -> occurs a b (a, TPol b) -> occurs b a (TMono a, TMono b) -> if a == b then return M.empty else throwError "Types do not unify" + -- | TODO: Figure out a cleaner way to express the same thing + (TConstr name t, TConstr name' t') -> if name == name' && length t == length t' + then do + xs <- sequence $ zipWith unify t t' + return $ foldr compose nullSubst xs + else throwError $ unwords ["Type constructor:", printTree name, "(" ++ printTree t ++ ")", "does not match with:", printTree name', "(" ++ printTree t' ++ ")"] (a, b) -> throwError . unwords $ ["Type:", printTree a, "can't be unified with:", printTree b] -- | Check if a type is contained in another type. @@ -202,9 +270,11 @@ class FreeVars t where instance FreeVars Type where free :: Type -> Set Ident - free (TPol a) = S.singleton a - free (TMono _) = mempty - free (TArr a b) = free a `S.union` free b + free (TPol a) = S.singleton a + free (TMono _) = mempty + free (TArr a b) = free a `S.union` free b + -- | Not guaranteed to be correct + free (TConstr _ a) = foldl' (\acc x -> free x `S.union` acc) S.empty a apply :: Subst -> Type -> Type apply sub t = do case t of @@ -213,6 +283,7 @@ instance FreeVars Type where Nothing -> TPol a Just t -> t TArr a b -> TArr (apply sub a) (apply sub b) + TConstr name a -> TConstr name (map (apply sub) a) instance FreeVars Poly where free :: Poly -> Set Ident @@ -248,3 +319,7 @@ withBinding i p = local (\st -> st { vars = M.insert i p (vars st) }) -- | Insert a function signature into the environment insertSig :: Ident -> Type -> Infer () insertSig i t = modify (\st -> st { sigs = M.insert i t (sigs st) }) + +-- | Insert a constructor with its data type +insertConstr :: Ident -> Type -> Infer () +insertConstr i t = modify (\st -> st { dtypes = M.insert i t (dtypes st) }) diff --git a/src/TypeChecker/TypeCheckerIr.hs b/src/TypeChecker/TypeCheckerIr.hs index c85ebcc..ee02416 100644 --- a/src/TypeChecker/TypeCheckerIr.hs +++ b/src/TypeChecker/TypeCheckerIr.hs @@ -5,12 +5,12 @@ module TypeChecker.TypeCheckerIr , module TypeChecker.TypeCheckerIr ) where -import Grammar.Abs (Ident (..), Literal (..), Type (..)) +import Grammar.Abs (Data (..), Ident (..), Literal (..), Type (..)) import Grammar.Print import Prelude import qualified Prelude as C (Eq, Ord, Read, Show) -newtype Program = Program [Bind] +newtype Program = Program [Def] deriving (C.Eq, C.Ord, C.Show, C.Read) data Exp @@ -22,11 +22,18 @@ data Exp | EAbs Type Id Exp deriving (C.Eq, C.Ord, C.Read, C.Show) +data Def = DBind Bind | DData Data + deriving (C.Eq, C.Ord, C.Read, C.Show) + type Id = (Ident, Type) data Bind = Bind Id [Id] Exp deriving (C.Eq, C.Ord, C.Show, C.Read) +instance Print Def where + prt i (DBind bind) = prt i bind + prt i (DData d) = prt i d + instance Print Program where prt i (Program sc) = prPrec i 0 $ prt 0 sc @@ -75,7 +82,7 @@ instance Print Exp where , doc $ showString "in" , prt 0 e ] - EApp t e1 e2 -> prPrec i 2 $ concatD + EApp _ e1 e2 -> prPrec i 2 $ concatD [ prt 2 e1 , prt 3 e2 ] diff --git a/test_program b/test_program index 69a2c20..5c2a164 100644 --- a/test_program +++ b/test_program @@ -1,2 +1,14 @@ -main : _Int ; -main = 3 + 3 ; +data List ('a) where; + Nil : List ('a), + Cons : 'a -> List ('a) -> List ('a) ; + +main : List (_Int) ; +main = Cons 1 (Cons 0 Nil) ; + +data Bool () where; + True : Bool (), + False : Bool (); + +boolean : Bool (_Int); +boolean = True ; + From d23d417ff36040a712f9b015741e46be86cba9b9 Mon Sep 17 00:00:00 2001 From: Sebastian Selander <70573736+sebastianselander@users.noreply.github.com> Date: Mon, 27 Feb 2023 19:38:45 +0100 Subject: [PATCH 055/372] Update TypeChecker.hs --- src/TypeChecker/TypeChecker.hs | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/src/TypeChecker/TypeChecker.hs b/src/TypeChecker/TypeChecker.hs index d09a002..b938477 100644 --- a/src/TypeChecker/TypeChecker.hs +++ b/src/TypeChecker/TypeChecker.hs @@ -109,7 +109,9 @@ checkBind (Bind n t _ args e) = do typeEq :: Type -> Type -> Bool typeEq (TArr l r) (TArr l' r') = typeEq l l' && typeEq r r' typeEq (TMono a) (TMono b) = a == b -typeEq (TConstr name a) (TConstr name' b) = name == name' && and (zipWith typeEq a b) +typeEq (TConstr name a) (TConstr name' b) = if length a == length b + then name == name' && and (zipWith typeEq a b) + else False typeEq (TPol _) (TPol _) = True typeEq _ _ = False From 05313652f9951a157bd9599118502a5f1793e620 Mon Sep 17 00:00:00 2001 From: sebastianselander Date: Tue, 28 Feb 2023 17:15:48 +0100 Subject: [PATCH 056/372] unit tests, started on pattern matching --- Grammar.cf | 41 +++++------- language.cabal | 2 +- src/Main.hs | 24 +++---- src/Renamer/Renamer.hs | 1 - src/TypeChecker/CheckInj.hs | 27 ++++++++ src/TypeChecker/TypeChecker.hs | 78 ++++++++++++----------- src/TypeChecker/TypeCheckerIr.hs | 44 ++++++++++--- test_program | 22 +++---- tests/Tests.hs | 106 +++++++++++++++++++++---------- 9 files changed, 212 insertions(+), 133 deletions(-) create mode 100644 src/TypeChecker/CheckInj.hs diff --git a/Grammar.cf b/Grammar.cf index 96554bb..dda87b4 100644 --- a/Grammar.cf +++ b/Grammar.cf @@ -8,6 +8,18 @@ separator Def ";" ; Bind. Bind ::= Ident ":" Type ";" Ident [Ident] "=" Exp ; +Data. Data ::= "data" Type "where" "{" + [Constructor] "}" ; + +separator nonempty Constructor "" ; + +Constructor. Constructor ::= Ident ":" Type ; + +TMono. Type1 ::= "_" Ident ; +TPol. Type1 ::= "'" Ident ; +TConstr. Type1 ::= Ident "(" [Type] ")" ; +TArr. Type ::= Type1 "->" Type ; + EAnn. Exp5 ::= "(" Exp ":" Type ")" ; EId. Exp4 ::= Ident ; ELit. Exp4 ::= Literal ; @@ -15,43 +27,24 @@ EApp. Exp3 ::= Exp3 Exp4 ; EAdd. Exp1 ::= Exp1 "+" Exp2 ; ELet. Exp ::= "let" Ident "=" Exp "in" Exp ; EAbs. Exp ::= "\\" Ident "." Exp ; -ECase. Exp ::= "case" Exp "of" "{" [Inj] "}"; +ECase. Exp ::= "case" Exp "of" "{" [Inj] "}"; LInt. Literal ::= Integer ; Inj. Inj ::= Init "=>" Exp ; -terminator Inj ";" ; +separator nonempty Inj ";" ; -InitLit. Init ::= Literal ; -InitConstr. Init ::= Ident [Match] ; -InitCatch. Init ::= "_" ; - -LMatch. Match ::= Literal ; -IMatch. Match ::= Ident ; -InitMatch. Match ::= Ident Match ; -separator Match " " ; - -TMono. Type1 ::= "_" Ident ; -TPol. Type1 ::= "'" Ident ; -TConstr. Type1 ::= Ident "(" [Type] ")" ; -TArr. Type ::= Type1 "->" Type ; +InitLit. Init ::= Literal ; +InitConstr. Init ::= Ident [Ident] ; +InitCatch. Init ::= "_" ; separator Type " " ; coercions Type 2 ; --- shift/reduce problem here -Data. Data ::= "data" Type "where" ";" - [Constructor]; - -separator Constructor "," ; - -Constructor. Constructor ::= Ident ":" Type ; - -- This doesn't seem to work so we'll have to live with ugly keywords for now -- token Poly upper (letter | digit | '_')* ; -- token Mono lower (letter | digit | '_')* ; -separator Bind ";" ; separator Ident " "; coercions Exp 5 ; diff --git a/language.cabal b/language.cabal index 3556367..637d9f7 100644 --- a/language.cabal +++ b/language.cabal @@ -47,7 +47,6 @@ executable language , either , extra , array - , QuickCheck default-language: GHC2021 @@ -76,6 +75,7 @@ Test-suite language-testsuite , either , extra , array + , hspec , QuickCheck default-language: GHC2021 diff --git a/src/Main.hs b/src/Main.hs index 316c599..8e62f2b 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -3,7 +3,6 @@ module Main where -- import Codegen.Codegen (compile) -import GHC.IO.Handle.Text (hPutStrLn) import Grammar.ErrM (Err) import Grammar.Par (myLexer, pProgram) import Grammar.Print (printTree) @@ -12,7 +11,6 @@ import Grammar.Print (printTree) import Renamer.Renamer (rename) import System.Environment (getArgs) import System.Exit (exitFailure, exitSuccess) -import System.IO (stderr) import TypeChecker.TypeChecker (typecheck) main :: IO () @@ -25,32 +23,28 @@ main' :: String -> IO () main' s = do file <- readFile s - printToErr "-- Parse Tree -- " + putStrLn "-- Parse Tree -- " parsed <- fromSyntaxErr . pProgram $ myLexer file - printToErr $ printTree parsed + putStrLn $ printTree parsed - printToErr "\n-- Renamer --" + putStrLn "\n-- Renamer --" let renamed = rename parsed - printToErr $ printTree renamed + putStrLn $ printTree renamed - printToErr "\n-- TypeChecker --" + putStrLn "\n-- TypeChecker --" typechecked <- fromTypeCheckerErr $ typecheck renamed - printToErr $ printTree typechecked + putStrLn $ printTree typechecked - -- printToErr "\n-- Lambda Lifter --" + -- putStrLn "\n-- Lambda Lifter --" -- let lifted = lambdaLift typechecked - -- printToErr $ printTree lifted + -- putStrLn $ printTree lifted - -- printToErr "\n -- Printing compiler output to stdout --" + -- putStrLn "\n -- Printing compiler output to stdout --" -- compiled <- fromCompilerErr $ compile lifted -- putStrLn compiled - -- writeFile "llvm.ll" compiled exitSuccess -printToErr :: String -> IO () -printToErr = hPutStrLn stderr - fromCompilerErr :: Err a -> IO a fromCompilerErr = either diff --git a/src/Renamer/Renamer.hs b/src/Renamer/Renamer.hs index 1ea892c..24582f6 100644 --- a/src/Renamer/Renamer.hs +++ b/src/Renamer/Renamer.hs @@ -28,7 +28,6 @@ rename (Program bs) = Program $ evalState (runRn $ mapM (renameSc initNames) bs) pure . DBind $ Bind name t name parms' rhs' renameSc _ def = pure def --- -- | Rename monad. State holds the number of renamed names. newtype Rn a = Rn { runRn :: State Int a } diff --git a/src/TypeChecker/CheckInj.hs b/src/TypeChecker/CheckInj.hs new file mode 100644 index 0000000..c5845df --- /dev/null +++ b/src/TypeChecker/CheckInj.hs @@ -0,0 +1,27 @@ +{-# OPTIONS_GHC -Wno-unused-imports #-} +module TypeChecker.CheckInj where + +import TypeChecker.TypeChecker +import qualified TypeChecker.TypeCheckerIr as T +import TypeChecker.TypeCheckerIr (Infer) + +import Control.Monad.Except +import Control.Monad.Reader +import Control.Monad.State +import Data.Functor.Identity (Identity, runIdentity) +import Data.Map (Map) +import qualified Data.Map as M + +import Grammar.Abs +import Grammar.Print (printTree) + + +checkInj :: Inj -> Infer T.Inj +checkInj (Inj it expr) = do + (_, e') <- inferExp expr + t' <- initType it + return $ T.Inj (it, t') e' + +initType :: Init -> Infer Type +initType = undefined + diff --git a/src/TypeChecker/TypeChecker.hs b/src/TypeChecker/TypeChecker.hs index b938477..80a5289 100644 --- a/src/TypeChecker/TypeChecker.hs +++ b/src/TypeChecker/TypeChecker.hs @@ -1,10 +1,7 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} -{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} -{-# HLINT ignore "Use traverse_" #-} -{-# OPTIONS_GHC -Wno-overlapping-patterns #-} -{-# HLINT ignore "Use zipWithM" #-} +-- | A module for type checking and inference using algorithm W, Hindley-Milner module TypeChecker.TypeChecker where import Control.Monad.Except @@ -21,23 +18,9 @@ import Data.Foldable (traverse_) import Grammar.Abs import Grammar.Print (printTree) import qualified TypeChecker.TypeCheckerIr as T +import TypeChecker.TypeCheckerIr (Ctx (..), Env (..), Error, Infer, + Poly (..), Subst) --- | A data type representing type variables -data Poly = Forall [Ident] Type - deriving Show - -newtype Ctx = Ctx { vars :: Map Ident Poly - } - -data Env = Env { count :: Int - , sigs :: Map Ident Type - , dtypes :: Map Ident Type - } - -type Error = String -type Subst = Map Ident Type - -type Infer = StateT Env (ReaderT Ctx (ExceptT Error Identity)) initCtx = Ctx mempty initEnv = Env 0 mempty mempty @@ -98,7 +81,11 @@ checkBind (Bind n t _ args e) = do (t', e') <- inferExp $ makeLambda e (reverse args) s <- unify t t' let t'' = apply s t - unless (t `typeEq` t'') (throwError $ unwords ["Top level signature", printTree t, "does not match body with type:", printTree t'']) + unless (t `typeEq` t'') (throwError $ unwords ["Top level signature" + , printTree t + , "does not match body with inferred type:" + , printTree t'' + ]) return $ T.Bind (n, t) [] e' where makeLambda :: Exp -> [Ident] -> Exp @@ -109,12 +96,17 @@ checkBind (Bind n t _ args e) = do typeEq :: Type -> Type -> Bool typeEq (TArr l r) (TArr l' r') = typeEq l l' && typeEq r r' typeEq (TMono a) (TMono b) = a == b -typeEq (TConstr name a) (TConstr name' b) = if length a == length b - then name == name' && and (zipWith typeEq a b) - else False +typeEq (TConstr name a) (TConstr name' b) = length a == length b + && name == name' + && and (zipWith typeEq a b) typeEq (TPol _) (TPol _) = True typeEq _ _ = False +isMoreGeneral :: Type -> Type -> Bool +isMoreGeneral _ (TPol _) = True +isMoreGeneral (TArr a b) (TArr c d) = isMoreGeneral a c && isMoreGeneral b d +isMoreGeneral a b = a == b + inferExp :: Exp -> Infer (Type, T.Exp) inferExp e = do (s, t, e') <- algoW e @@ -123,24 +115,30 @@ inferExp e = do replace :: Type -> T.Exp -> T.Exp replace t = \case - T.ELit _ e -> T.ELit t e - T.EId (n, _) -> T.EId (n, t) - T.EAbs _ name e -> T.EAbs t name e - T.EApp _ e1 e2 -> T.EApp t e1 e2 - T.EAdd _ e1 e2 -> T.EAdd t e1 e2 + T.ELit _ e -> T.ELit t e + T.EId (n, _) -> T.EId (n, t) + T.EAbs _ name e -> T.EAbs t name e + T.EApp _ e1 e2 -> T.EApp t e1 e2 + T.EAdd _ e1 e2 -> T.EAdd t e1 e2 T.ELet (T.Bind (n, _) args e1) e2 -> T.ELet (T.Bind (n, t) args e1) e2 algoW :: Exp -> Infer (Subst, Type, T.Exp) algoW = \case + -- | TODO: Reason more about this one. Could be wrong EAnn e t -> do (s1, t', e') <- algoW e + unless (t `isMoreGeneral` t') (throwError $ unwords + ["Annotated type:" + , printTree t + , "does not match inferred type:" + , printTree t' ]) applySt s1 $ do - s2 <- unify (apply s1 t) t' + s2 <- unify t t' return (s2 `compose` s1, t, e') -- | ------------------ --- | Γ ⊢ e₀ : Int, ∅ +-- | Γ ⊢ i : Int, ∅ ELit (LInt n) -> return (nullSubst, TMono "Int", T.ELit (TMono "Int") (LInt n)) @@ -159,7 +157,7 @@ algoW = \case case M.lookup i sig of Just t -> return (nullSubst, t, T.EId (i, t)) Nothing -> do - constr <- gets dtypes + constr <- gets constructors case M.lookup i constr of Just t -> return (nullSubst, t, T.EId (i, t)) Nothing -> throwError $ "Unbound variable: " ++ show i @@ -220,9 +218,9 @@ algoW = \case (s2, t2, e1') <- algoW e1 return (s2 `compose` s1, t2, T.ELet (T.Bind (name,t2) [] e0') e1' ) - ECase a b -> error $ "NOT IMPLEMENTED YET: ECase" ++ show a ++ " " ++ show b + ECase e0 injs -> undefined --- | Unify two types producing a new substitution (constraint) +-- | Unify two types producing a new substitution unify :: Type -> Type -> Infer Subst unify t0 t1 = case (t0, t1) of (TArr a b, TArr c d) -> do @@ -235,9 +233,15 @@ unify t0 t1 = case (t0, t1) of -- | TODO: Figure out a cleaner way to express the same thing (TConstr name t, TConstr name' t') -> if name == name' && length t == length t' then do - xs <- sequence $ zipWith unify t t' + xs <- zipWithM unify t t' return $ foldr compose nullSubst xs - else throwError $ unwords ["Type constructor:", printTree name, "(" ++ printTree t ++ ")", "does not match with:", printTree name', "(" ++ printTree t' ++ ")"] + else throwError $ unwords + ["Type constructor:" + , printTree name + , "(" ++ printTree t ++ ")" + , "does not match with:" + , printTree name' + , "(" ++ printTree t' ++ ")"] (a, b) -> throwError . unwords $ ["Type:", printTree a, "can't be unified with:", printTree b] -- | Check if a type is contained in another type. @@ -324,4 +328,4 @@ insertSig i t = modify (\st -> st { sigs = M.insert i t (sigs st) }) -- | Insert a constructor with its data type insertConstr :: Ident -> Type -> Infer () -insertConstr i t = modify (\st -> st { dtypes = M.insert i t (dtypes st) }) +insertConstr i t = modify (\st -> st { constructors = M.insert i t (constructors st) }) diff --git a/src/TypeChecker/TypeCheckerIr.hs b/src/TypeChecker/TypeCheckerIr.hs index ee02416..82956b8 100644 --- a/src/TypeChecker/TypeCheckerIr.hs +++ b/src/TypeChecker/TypeCheckerIr.hs @@ -1,14 +1,33 @@ {-# LANGUAGE LambdaCase #-} -module TypeChecker.TypeCheckerIr - ( module Grammar.Abs - , module TypeChecker.TypeCheckerIr - ) where +module TypeChecker.TypeCheckerIr where -import Grammar.Abs (Data (..), Ident (..), Literal (..), Type (..)) +import Control.Monad.Except +import Control.Monad.Reader +import Control.Monad.State +import Data.Functor.Identity (Identity) +import Data.Map (Map) +import Grammar.Abs (Data (..), Ident (..), Init (..), + Literal (..), Type (..)) import Grammar.Print import Prelude -import qualified Prelude as C (Eq, Ord, Read, Show) +import qualified Prelude as C (Eq, Ord, Read, Show) + +-- | A data type representing type variables +data Poly = Forall [Ident] Type + deriving Show + +newtype Ctx = Ctx { vars :: Map Ident Poly } + +data Env = Env { count :: Int + , sigs :: Map Ident Type + , constructors :: Map Ident Type + } + +type Error = String +type Subst = Map Ident Type + +type Infer = StateT Env (ReaderT Ctx (ExceptT Error Identity)) newtype Program = Program [Def] deriving (C.Eq, C.Ord, C.Show, C.Read) @@ -22,6 +41,9 @@ data Exp | EAbs Type Id Exp deriving (C.Eq, C.Ord, C.Read, C.Show) +data Inj = Inj (Init, Type) Exp + deriving (C.Eq, C.Ord, C.Read, C.Show) + data Def = DBind Bind | DData Data deriving (C.Eq, C.Ord, C.Read, C.Show) @@ -30,6 +52,10 @@ type Id = (Ident, Type) data Bind = Bind Id [Id] Exp deriving (C.Eq, C.Ord, C.Show, C.Read) +instance Print [Def] where + prt _ [] = concatD [] + prt _ (x:xs) = concatD [prt 0 x, doc (showString "\n"), prt 0 xs] + instance Print Def where prt i (DBind bind) = prt i bind prt i (DData d) = prt i d @@ -41,16 +67,16 @@ instance Print Bind where prt i (Bind (t, name) parms rhs) = prPrec i 0 $ concatD [ prt 0 name , doc $ showString ":" - , prt 0 t + , prt 1 t , prtIdPs 0 parms , doc $ showString "=" - , prt 0 rhs + , prt 2 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] + prt _ (x:xs) = concatD [prt 0 x, doc (showString ";"), doc (showString "\n"), prt 0 xs] prtIdPs :: Int -> [Id] -> Doc prtIdPs i = prPrec i 0 . concatD . map (prtIdP i) diff --git a/test_program b/test_program index 5c2a164..0cc17b3 100644 --- a/test_program +++ b/test_program @@ -1,14 +1,12 @@ -data List ('a) where; - Nil : List ('a), - Cons : 'a -> List ('a) -> List ('a) ; +data List ('a) where { + Nil : List ('a) + Cons : 'a -> List ('a) -> List ('a) +}; -main : List (_Int) ; +data Bool () where { + True : Bool () + False : Bool () +}; + +main : List ('a) ; main = Cons 1 (Cons 0 Nil) ; - -data Bool () where; - True : Bool (), - False : Bool (); - -boolean : Bool (_Int); -boolean = True ; - diff --git a/tests/Tests.hs b/tests/Tests.hs index 46a9a3f..5c52939 100644 --- a/tests/Tests.hs +++ b/tests/Tests.hs @@ -1,56 +1,94 @@ {-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} {-# HLINT ignore "Use <$>" #-} +{-# HLINT ignore "Use camelCase" #-} module Main where -import Control.Monad.Except +import Data.Either (isLeft, isRight) +import Data.Map (Map) +import qualified Data.Map as M import Grammar.Abs +import Test.Hspec import Test.QuickCheck import TypeChecker.TypeChecker import qualified TypeChecker.TypeCheckerIr as T +import TypeChecker.TypeCheckerIr (Ctx (..), Env (..), Error, Infer, + Poly (..)) main :: IO () -main = do - quickCheck prop_isInt - quickCheck prop_idAbs_generic +main = hspec $ do + infer_elit + infer_eann + infer_eid + infer_eabs + infer_eapp -newtype AbsExp = AE Exp deriving Show -newtype EIntExp = EI Exp deriving Show +infer_elit = describe "algoW used on ELit" $ do + it "infers the type mono Int" $ do + getType (ELit (LInt 0)) `shouldBe` Right (TMono "Int") -instance Arbitrary EIntExp where - arbitrary = genInt + it "infers the type mono Int" $ do + getType (ELit (LInt 9999)) `shouldBe` Right (TMono "Int") -instance Arbitrary AbsExp where - arbitrary = genLambda +infer_eann = describe "algoW used on EAnn" $ do + it "infers the type and checks if the annotated type matches" $ do + getType (EAnn (ELit $ LInt 0) (TMono "Int")) `shouldBe` Right (TMono "Int") -getType :: Infer (Type, T.Exp) -> Either Error Type -getType ie = case run ie of - Left err -> Left err - Right (t,e) -> return t + it "fails if the annotated type does not match with the inferred type" $ do + getType (EAnn (ELit $ LInt 0) (TPol "a")) `shouldSatisfy` isLeft -genInt :: Gen EIntExp -genInt = EI . ELit . LInt <$> arbitrary + it "should be possible to annotate with a more specific type" $ do + let annotated_lambda = EAnn (EAbs "x" (EId "x")) (TArr (TMono "Int") (TMono "Int")) + in getType annotated_lambda `shouldBe` Right (TArr (TMono "Int") (TMono "Int")) -genLambda :: Gen AbsExp -genLambda = do - str <- arbitrary @String - let str' = Ident str - return $ AE $ EAbs str' (EId str') + it "should fail if the annotated type is more general than the inferred type" $ do + getType (EAnn (ELit (LInt 0)) (TPol "a")) `shouldSatisfy` isLeft -prop_idAbs_generic :: AbsExp -> Bool -prop_idAbs_generic (AE e) = case getType (inferExp e) of - Left _ -> False - Right t -> isGenericArr t + it "should fail if the annotated type is an arrow but the annotated type is not" $ do + getType (EAnn (EAbs "x" (EId "x")) (TPol "a")) `shouldSatisfy` isLeft -prop_isInt :: EIntExp -> Bool -prop_isInt (EI e) = case getType (inferExp e) of - Left _ -> False - Right t -> t == int +infer_eid = describe "algoW used on EId" $ do + it "should fail if the variable is not added to the environment" $ do + property $ \x -> getType (EId (Ident (x :: String))) `shouldSatisfy` isLeft -int :: Type -int = TMono "Int" + it "should succeed if the type exist in the environment" $ do + property $ \x -> do + let env = Env 0 mempty mempty + let t = Forall [] (TPol "a") + let ctx = Ctx (M.singleton (Ident (x :: String)) t) + getTypeC env ctx (EId (Ident x)) `shouldBe` Right (TPol "a") -isGenericArr :: Type -> Bool -isGenericArr (TArr (TPol a) (TPol b)) = a == b -isGenericArr _ = False +infer_eabs = describe "algoW used on EAbs" $ do + it "should infer the argument type as int if the variable is used as an int" $ do + let lambda = EAbs "x" (EAdd (EId "x") (ELit (LInt 0))) + getType lambda `shouldBe` Right (TArr (TMono "Int") (TMono "Int")) + + it "should infer the argument type as polymorphic if it is not used in the lambda" $ do + let lambda = EAbs "x" (ELit (LInt 0)) + getType lambda `shouldSatisfy` isArrowPolyToMono + it "should infer a variable as function if used as one" $ do + let lambda = EAbs "f" (EAbs "x" (EApp (EId "f") (EId "x"))) + let isOk (Right (TArr (TArr (TPol _) (TPol _)) (TArr (TPol _) (TPol _)))) = True + isOk _ = False + getType lambda `shouldSatisfy` isOk + +infer_eapp = describe "algoW used on EApp" $ do + it "should fail if a variable is applied to itself (occurs check)" $ do + property $ \x -> do + let env = Env 0 mempty mempty + let t = Forall [] (TPol "a") + let ctx = Ctx (M.singleton (Ident (x :: String)) t) + getTypeC env ctx (EApp (EId (Ident x)) (EId (Ident x))) `shouldBe` Left "Occurs check failed" + +isArrowPolyToMono :: Either Error Type -> Bool +isArrowPolyToMono (Right (TArr (TPol _) (TMono _))) = True +isArrowPolyToMono _ = False + +-- | Empty environment +getType :: Exp -> Either Error Type +getType e = pure fst <*> run (inferExp e) + +-- | Custom environment +getTypeC :: Env -> Ctx -> Exp -> Either Error Type +getTypeC env ctx e = pure fst <*> runC env ctx (inferExp e) From 514d79bd6ce0759450ac8481f817d66390c1f86e Mon Sep 17 00:00:00 2001 From: Rakarake Date: Wed, 1 Mar 2023 13:50:01 +0100 Subject: [PATCH 057/372] 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 2401b6437bc3f49f078b9cf19ec20ad0f9514c11 Mon Sep 17 00:00:00 2001 From: sebastianselander Date: Thu, 2 Mar 2023 16:05:43 +0100 Subject: [PATCH 058/372] continued work pattern matching --- Grammar.cf | 16 +++----- Justfile | 17 ++++++++ src/TypeChecker/CheckInj.hs | 27 ------------ src/TypeChecker/TypeChecker.hs | 70 ++++++++++++++++++++++++-------- src/TypeChecker/TypeCheckerIr.hs | 5 +-- test_program | 2 +- 6 files changed, 79 insertions(+), 58 deletions(-) create mode 100644 Justfile delete mode 100644 src/TypeChecker/CheckInj.hs diff --git a/Grammar.cf b/Grammar.cf index dda87b4..37305e2 100644 --- a/Grammar.cf +++ b/Grammar.cf @@ -8,18 +8,19 @@ separator Def ";" ; Bind. Bind ::= Ident ":" Type ";" Ident [Ident] "=" Exp ; -Data. Data ::= "data" Type "where" "{" - [Constructor] "}" ; - -separator nonempty Constructor "" ; +Data. Data ::= "data" Constr "where" "{" [Constructor] "}" ; Constructor. Constructor ::= Ident ":" Type ; +separator nonempty Constructor "" ; TMono. Type1 ::= "_" Ident ; TPol. Type1 ::= "'" Ident ; -TConstr. Type1 ::= Ident "(" [Type] ")" ; +TConstr. Type1 ::= Constr ; TArr. Type ::= Type1 "->" Type ; +Constr. Constr ::= Ident "(" [Type] ")" ; + +-- TODO: Move literal to its own thing since it's reused in Init as well. EAnn. Exp5 ::= "(" Exp ":" Type ")" ; EId. Exp4 ::= Ident ; ELit. Exp4 ::= Literal ; @@ -41,14 +42,9 @@ InitCatch. Init ::= "_" ; separator Type " " ; coercions Type 2 ; --- This doesn't seem to work so we'll have to live with ugly keywords for now --- token Poly upper (letter | digit | '_')* ; --- token Mono lower (letter | digit | '_')* ; - separator Ident " "; coercions Exp 5 ; comment "--" ; comment "{-" "-}" ; - diff --git a/Justfile b/Justfile new file mode 100644 index 0000000..a625e71 --- /dev/null +++ b/Justfile @@ -0,0 +1,17 @@ +alias b := build + +build: + bnfc -o src -d Grammar.cf + +# clean the generated directories +clean: + rm -r src/Grammar + rm language + +# run all tests +test: + cabal test + +# compile a specific file +run FILE: + cabal run language {{FILE}} diff --git a/src/TypeChecker/CheckInj.hs b/src/TypeChecker/CheckInj.hs deleted file mode 100644 index c5845df..0000000 --- a/src/TypeChecker/CheckInj.hs +++ /dev/null @@ -1,27 +0,0 @@ -{-# OPTIONS_GHC -Wno-unused-imports #-} -module TypeChecker.CheckInj where - -import TypeChecker.TypeChecker -import qualified TypeChecker.TypeCheckerIr as T -import TypeChecker.TypeCheckerIr (Infer) - -import Control.Monad.Except -import Control.Monad.Reader -import Control.Monad.State -import Data.Functor.Identity (Identity, runIdentity) -import Data.Map (Map) -import qualified Data.Map as M - -import Grammar.Abs -import Grammar.Print (printTree) - - -checkInj :: Inj -> Infer T.Inj -checkInj (Inj it expr) = do - (_, e') <- inferExp expr - t' <- initType it - return $ T.Inj (it, t') e' - -initType :: Init -> Infer Type -initType = undefined - diff --git a/src/TypeChecker/TypeChecker.hs b/src/TypeChecker/TypeChecker.hs index 80a5289..73139f4 100644 --- a/src/TypeChecker/TypeChecker.hs +++ b/src/TypeChecker/TypeChecker.hs @@ -7,7 +7,7 @@ module TypeChecker.TypeChecker where import Control.Monad.Except import Control.Monad.Reader import Control.Monad.State -import Data.Functor.Identity (Identity, runIdentity) +import Data.Functor.Identity (runIdentity) import Data.List (foldl') import Data.Map (Map) import qualified Data.Map as M @@ -21,7 +21,6 @@ import qualified TypeChecker.TypeCheckerIr as T import TypeChecker.TypeCheckerIr (Ctx (..), Env (..), Error, Infer, Poly (..), Subst) - initCtx = Ctx mempty initEnv = Env 0 mempty mempty @@ -39,9 +38,10 @@ typecheck = run . checkPrg checkData :: Data -> Infer () checkData d = case d of - (Data typ@(TConstr name _) constrs) -> do + (Data typ@(Constr name ts) constrs) -> do + unless (all isPoly ts) (throwError $ unwords ["Data type incorrectly declared"]) traverse_ (\(Constructor name' t') - -> if typ == retType t' + -> if TConstr typ == retType t' then insertConstr name' t' else throwError $ unwords @@ -51,11 +51,9 @@ checkData d = case d of , printTree (retType t') , "does not match data: " , printTree typ]) constrs - _ -> throwError "Data type incorrectly declared" - where - retType :: Type -> Type - retType (TArr _ t2) = retType t2 - retType a = a +retType :: Type -> Type +retType (TArr _ t2) = retType t2 +retType a = a checkPrg :: Program -> Infer T.Program checkPrg (Program bs) = do @@ -86,7 +84,7 @@ checkBind (Bind n t _ args e) = do , "does not match body with inferred type:" , printTree t'' ]) - return $ T.Bind (n, t) [] e' + return $ T.Bind (n, t) e' where makeLambda :: Exp -> [Ident] -> Exp makeLambda = foldl (flip EAbs) @@ -96,7 +94,7 @@ checkBind (Bind n t _ args e) = do typeEq :: Type -> Type -> Bool typeEq (TArr l r) (TArr l' r') = typeEq l l' && typeEq r r' typeEq (TMono a) (TMono b) = a == b -typeEq (TConstr name a) (TConstr name' b) = length a == length b +typeEq (TConstr (Constr name a)) (TConstr (Constr name' b)) = length a == length b && name == name' && and (zipWith typeEq a b) typeEq (TPol _) (TPol _) = True @@ -107,6 +105,10 @@ isMoreGeneral _ (TPol _) = True isMoreGeneral (TArr a b) (TArr c d) = isMoreGeneral a c && isMoreGeneral b d isMoreGeneral a b = a == b +isPoly :: Type -> Bool +isPoly (TPol _) = True +isPoly _ = False + inferExp :: Exp -> Infer (Type, T.Exp) inferExp e = do (s, t, e') <- algoW e @@ -120,7 +122,7 @@ replace t = \case T.EAbs _ name e -> T.EAbs t name e T.EApp _ e1 e2 -> T.EApp t e1 e2 T.EAdd _ e1 e2 -> T.EAdd t e1 e2 - T.ELet (T.Bind (n, _) args e1) e2 -> T.ELet (T.Bind (n, t) args e1) e2 + T.ELet (T.Bind (n, _) e1) e2 -> T.ELet (T.Bind (n, t) e1) e2 algoW :: Exp -> Infer (Subst, Type, T.Exp) algoW = \case @@ -216,9 +218,9 @@ algoW = \case let t' = generalize (apply s1 env) t1 withBinding name t' $ do (s2, t2, e1') <- algoW e1 - return (s2 `compose` s1, t2, T.ELet (T.Bind (name,t2) [] e0') e1' ) + return (s2 `compose` s1, t2, T.ELet (T.Bind (name,t2) e0') e1' ) - ECase e0 injs -> undefined + ECase _ _ -> undefined -- | Unify two types producing a new substitution unify :: Type -> Type -> Infer Subst @@ -231,7 +233,7 @@ unify t0 t1 = case (t0, t1) of (a, TPol b) -> occurs b a (TMono a, TMono b) -> if a == b then return M.empty else throwError "Types do not unify" -- | TODO: Figure out a cleaner way to express the same thing - (TConstr name t, TConstr name' t') -> if name == name' && length t == length t' + (TConstr (Constr name t), TConstr (Constr name' t')) -> if name == name' && length t == length t' then do xs <- zipWithM unify t t' return $ foldr compose nullSubst xs @@ -280,7 +282,7 @@ instance FreeVars Type where free (TMono _) = mempty free (TArr a b) = free a `S.union` free b -- | Not guaranteed to be correct - free (TConstr _ a) = foldl' (\acc x -> free x `S.union` acc) S.empty a + free (TConstr (Constr _ a)) = foldl' (\acc x -> free x `S.union` acc) S.empty a apply :: Subst -> Type -> Type apply sub t = do case t of @@ -289,7 +291,7 @@ instance FreeVars Type where Nothing -> TPol a Just t -> t TArr a b -> TArr (apply sub a) (apply sub b) - TConstr name a -> TConstr name (map (apply sub) a) + TConstr (Constr name a) -> TConstr (Constr name (map (apply sub) a)) instance FreeVars Poly where free :: Poly -> Set Ident @@ -329,3 +331,37 @@ insertSig i t = modify (\st -> st { sigs = M.insert i t (sigs st) }) -- | Insert a constructor with its data type insertConstr :: Ident -> Type -> Infer () insertConstr i t = modify (\st -> st { constructors = M.insert i t (constructors st) }) + + +-------- PATTERN MATCHING --------- + +checkInj :: Inj -> Infer T.Inj +checkInj (Inj it expr) = do + (_, e') <- inferExp expr + t' <- initType it + return $ T.Inj (it, t') e' + +initType :: Init -> Infer Type +initType = \case + InitLit lit -> return $ litType lit + InitConstr c args -> do + st <- gets constructors + case M.lookup c st of + Nothing -> throwError $ unwords ["Constructor:", printTree c, "does not exist"] + Just t -> do + let flat = flattenType t + let returnType = last flat + if length (init flat) == length args + then return returnType + else throwError $ "Can't partially match on the constructor: " ++ printTree c + -- Ignoring the variables for now, they can not be used in the expression to the + -- right of '=>' + + InitCatch -> return $ TPol "catch" + +flattenType :: Type -> [Type] +flattenType (TArr a b) = flattenType a ++ flattenType b +flattenType a = [a] + +litType :: Literal -> Type +litType (LInt i) = TMono "Int" diff --git a/src/TypeChecker/TypeCheckerIr.hs b/src/TypeChecker/TypeCheckerIr.hs index 82956b8..ea2b902 100644 --- a/src/TypeChecker/TypeCheckerIr.hs +++ b/src/TypeChecker/TypeCheckerIr.hs @@ -49,7 +49,7 @@ data Def = DBind Bind | DData Data type Id = (Ident, Type) -data Bind = Bind Id [Id] Exp +data Bind = Bind Id Exp deriving (C.Eq, C.Ord, C.Show, C.Read) instance Print [Def] where @@ -64,11 +64,10 @@ 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 i (Bind (t, name) rhs) = prPrec i 0 $ concatD [ prt 0 name , doc $ showString ":" , prt 1 t - , prtIdPs 0 parms , doc $ showString "=" , prt 2 rhs ] diff --git a/test_program b/test_program index 0cc17b3..c5af112 100644 --- a/test_program +++ b/test_program @@ -8,5 +8,5 @@ data Bool () where { False : Bool () }; -main : List ('a) ; +main : List (_Int) ; main = Cons 1 (Cons 0 Nil) ; From dbc77ec5f3153fc190f9f63a81d6095f0a9aa619 Mon Sep 17 00:00:00 2001 From: Rakarake Date: Thu, 2 Mar 2023 18:36:50 +0100 Subject: [PATCH 059/372] 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 7656b46e3f052a7360b339b196e1c74b840bfc08 Mon Sep 17 00:00:00 2001 From: sebastian Date: Thu, 2 Mar 2023 22:07:38 +0100 Subject: [PATCH 060/372] a bit more work on pattern match + case expr --- Justfile | 2 -- src/TypeChecker/TypeChecker.hs | 32 +++++++++++++++++++++----------- src/TypeChecker/TypeCheckerIr.hs | 1 + 3 files changed, 22 insertions(+), 13 deletions(-) diff --git a/Justfile b/Justfile index a625e71..ea2d031 100644 --- a/Justfile +++ b/Justfile @@ -1,5 +1,3 @@ -alias b := build - build: bnfc -o src -d Grammar.cf diff --git a/src/TypeChecker/TypeChecker.hs b/src/TypeChecker/TypeChecker.hs index 73139f4..7a2b96b 100644 --- a/src/TypeChecker/TypeChecker.hs +++ b/src/TypeChecker/TypeChecker.hs @@ -220,7 +220,12 @@ algoW = \case (s2, t2, e1') <- algoW e1 return (s2 `compose` s1, t2, T.ELet (T.Bind (name,t2) e0') e1' ) - ECase _ _ -> undefined + ECase caseExpr injs -> do + (s0, t0, e0') <- algoW caseExpr + injs' <- mapM (checkInj t0) injs + undefined + + -- | Unify two types producing a new substitution unify :: Type -> Type -> Infer Subst @@ -335,15 +340,19 @@ insertConstr i t = modify (\st -> st { constructors = M.insert i t (constructors -------- PATTERN MATCHING --------- -checkInj :: Inj -> Infer T.Inj -checkInj (Inj it expr) = do +-- case expr of, the type of 'expr' is caseType +checkInj :: Type -> Inj -> Infer T.Inj +checkInj caseType (Inj it expr) = do (_, e') <- inferExp expr - t' <- initType it + t' <- initType caseType it return $ T.Inj (it, t') e' -initType :: Init -> Infer Type -initType = \case - InitLit lit -> return $ litType lit +initType :: Type -> Init -> Infer Type +initType expected = \case + InitLit lit -> let returnType = litType lit + in if expected == returnType + then return expected + else throwError $ unwords ["Inferred type", printTree returnType, "does not match expected type:", printTree expected] InitConstr c args -> do st <- gets constructors case M.lookup c st of @@ -351,13 +360,14 @@ initType = \case Just t -> do let flat = flattenType t let returnType = last flat - if length (init flat) == length args - then return returnType - else throwError $ "Can't partially match on the constructor: " ++ printTree c + case (length (init flat) == length args, returnType == expected) of + (True, True) -> return returnType + (False, _) -> throwError $ "Can't partially match on the constructor: " ++ printTree c + (_, False) -> throwError $ unwords ["Inferred type", printTree returnType, "does not match expected type:", printTree expected] -- Ignoring the variables for now, they can not be used in the expression to the -- right of '=>' - InitCatch -> return $ TPol "catch" + InitCatch -> return expected flattenType :: Type -> [Type] flattenType (TArr a b) = flattenType a ++ flattenType b diff --git a/src/TypeChecker/TypeCheckerIr.hs b/src/TypeChecker/TypeCheckerIr.hs index ea2b902..a2c86f7 100644 --- a/src/TypeChecker/TypeCheckerIr.hs +++ b/src/TypeChecker/TypeCheckerIr.hs @@ -39,6 +39,7 @@ data Exp | EApp Type Exp Exp | EAdd Type Exp Exp | EAbs Type Id Exp + | ECase Type Exp [Inj] deriving (C.Eq, C.Ord, C.Read, C.Show) data Inj = Inj (Init, Type) Exp From 03d7080396bcd24b91506c5fb808e3759ef564e8 Mon Sep 17 00:00:00 2001 From: sebastianselander Date: Fri, 3 Mar 2023 11:46:54 +0100 Subject: [PATCH 061/372] pattern matching works? have to test more --- src/Main.hs | 2 +- src/Renamer/Renamer.hs | 4 +- src/TypeChecker/TypeChecker.hs | 63 +++++++++++++++++++------------- src/TypeChecker/TypeCheckerIr.hs | 11 ++++++ test_program | 30 ++++++++++++--- 5 files changed, 76 insertions(+), 34 deletions(-) diff --git a/src/Main.hs b/src/Main.hs index 8e62f2b..bef4a3b 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -33,7 +33,7 @@ main' s = do putStrLn "\n-- TypeChecker --" typechecked <- fromTypeCheckerErr $ typecheck renamed - putStrLn $ printTree typechecked + putStrLn $ show typechecked -- putStrLn "\n-- Lambda Lifter --" -- let lifted = lambdaLift typechecked diff --git a/src/Renamer/Renamer.hs b/src/Renamer/Renamer.hs index 24582f6..d471553 100644 --- a/src/Renamer/Renamer.hs +++ b/src/Renamer/Renamer.hs @@ -73,7 +73,9 @@ renameExp old_names = \case (new_names, e') <- renameExp old_names e pure (new_names, EAnn e' t) - ECase _ _ -> error "ECase NOT IMPLEMENTED YET" + ECase e injs -> do + (new_names, e') <- renameExp old_names e + pure (new_names, ECase e' injs) -- | Create a new name and add it to name environment. newName :: Names -> Ident -> Rn (Names, Ident) diff --git a/src/TypeChecker/TypeChecker.hs b/src/TypeChecker/TypeChecker.hs index 7a2b96b..9c55388 100644 --- a/src/TypeChecker/TypeChecker.hs +++ b/src/TypeChecker/TypeChecker.hs @@ -1,5 +1,8 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -Wno-unused-matches #-} +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} +{-# HLINT ignore "Use mapAndUnzipM" #-} -- | A module for type checking and inference using algorithm W, Hindley-Milner module TypeChecker.TypeChecker where @@ -100,10 +103,12 @@ typeEq (TConstr (Constr name a)) (TConstr (Constr name' b)) = length a == length typeEq (TPol _) (TPol _) = True typeEq _ _ = False -isMoreGeneral :: Type -> Type -> Bool -isMoreGeneral _ (TPol _) = True -isMoreGeneral (TArr a b) (TArr c d) = isMoreGeneral a c && isMoreGeneral b d -isMoreGeneral a b = a == b +isMoreSpecificOrEq :: Type -> Type -> Bool +isMoreSpecificOrEq _ (TPol _) = True +isMoreSpecificOrEq (TArr a b) (TArr c d) = isMoreSpecificOrEq a c && isMoreSpecificOrEq b d +isMoreSpecificOrEq (TConstr (Constr n1 ts1)) (TConstr (Constr n2 ts2)) + = n1 == n2 && length ts1 == length ts2 && and (zipWith isMoreSpecificOrEq ts1 ts2) +isMoreSpecificOrEq a b = a == b isPoly :: Type -> Bool isPoly (TPol _) = True @@ -117,12 +122,13 @@ inferExp e = do replace :: Type -> T.Exp -> T.Exp replace t = \case - T.ELit _ e -> T.ELit t e - T.EId (n, _) -> T.EId (n, t) - T.EAbs _ name e -> T.EAbs t name e - T.EApp _ e1 e2 -> T.EApp t e1 e2 - T.EAdd _ e1 e2 -> T.EAdd t e1 e2 + T.ELit _ e -> T.ELit t e + T.EId (n, _) -> T.EId (n, t) + T.EAbs _ name e -> T.EAbs t name e + T.EApp _ e1 e2 -> T.EApp t e1 e2 + T.EAdd _ e1 e2 -> T.EAdd t e1 e2 T.ELet (T.Bind (n, _) e1) e2 -> T.ELet (T.Bind (n, t) e1) e2 + T.ECase _ expr injs -> T.ECase t expr injs algoW :: Exp -> Infer (Subst, Type, T.Exp) algoW = \case @@ -130,7 +136,7 @@ algoW = \case -- | TODO: Reason more about this one. Could be wrong EAnn e t -> do (s1, t', e') <- algoW e - unless (t `isMoreGeneral` t') (throwError $ unwords + unless (t `isMoreSpecificOrEq` t') (throwError $ unwords ["Annotated type:" , printTree t , "does not match inferred type:" @@ -218,13 +224,18 @@ algoW = \case let t' = generalize (apply s1 env) t1 withBinding name t' $ do (s2, t2, e1') <- algoW e1 - return (s2 `compose` s1, t2, T.ELet (T.Bind (name,t2) e0') e1' ) + return (s2 `compose` s1, t2, T.ELet (T.Bind (name,t2) e0') e1') ECase caseExpr injs -> do (s0, t0, e0') <- algoW caseExpr - injs' <- mapM (checkInj t0) injs - undefined - + (injs', ts) <- unzip <$> mapM (checkInj t0) injs + case ts of + [] -> throwError "Case expression missing any matches" + ts -> do + unified <- zipWithM unify ts (tail ts) + let unified' = foldl' compose mempty unified + let typ = apply unified' (head ts) + return (unified', typ, T.ECase typ e0' injs') -- | Unify two types producing a new substitution @@ -340,19 +351,19 @@ insertConstr i t = modify (\st -> st { constructors = M.insert i t (constructors -------- PATTERN MATCHING --------- --- case expr of, the type of 'expr' is caseType -checkInj :: Type -> Inj -> Infer T.Inj +-- "case expr of", the type of 'expr' is caseType +checkInj :: Type -> Inj -> Infer (T.Inj, Type) checkInj caseType (Inj it expr) = do - (_, e') <- inferExp expr - t' <- initType caseType it - return $ T.Inj (it, t') e' + (args, t') <- initType caseType it + (s, t, e') <- local (\st -> st { vars = args }) (algoW expr) + return (T.Inj (it, t') e', t) -initType :: Type -> Init -> Infer Type +initType :: Type -> Init -> Infer (Map Ident Poly, Type) initType expected = \case InitLit lit -> let returnType = litType lit in if expected == returnType - then return expected - else throwError $ unwords ["Inferred type", printTree returnType, "does not match expected type:", printTree expected] + then return (mempty,expected) + else throwError $ unwords ["Inferred type", printTree returnType, "does not match expected type:", printTree expected] InitConstr c args -> do st <- gets constructors case M.lookup c st of @@ -360,14 +371,14 @@ initType expected = \case Just t -> do let flat = flattenType t let returnType = last flat - case (length (init flat) == length args, returnType == expected) of - (True, True) -> return returnType + case (length (init flat) == length args, returnType `isMoreSpecificOrEq` expected) of + (True, True) -> return (M.fromList $ zip args (map (Forall []) flat), expected) (False, _) -> throwError $ "Can't partially match on the constructor: " ++ printTree c - (_, False) -> throwError $ unwords ["Inferred type", printTree returnType, "does not match expected type:", printTree expected] + (_, False) -> throwError $ unwords ["Inferred type", printTree returnType, "does not match expected type:", printTree expected] -- Ignoring the variables for now, they can not be used in the expression to the -- right of '=>' - InitCatch -> return expected + InitCatch -> return (mempty, expected) flattenType :: Type -> [Type] flattenType (TArr a b) = flattenType a ++ flattenType b diff --git a/src/TypeChecker/TypeCheckerIr.hs b/src/TypeChecker/TypeCheckerIr.hs index a2c86f7..c07da96 100644 --- a/src/TypeChecker/TypeCheckerIr.hs +++ b/src/TypeChecker/TypeCheckerIr.hs @@ -127,6 +127,17 @@ instance Print Exp where , doc $ showString "." , prt 0 e ] + ECase t exp injs -> prPrec i 0 (concatD [doc (showString "case"), prt 0 exp, doc (showString "of"), doc (showString "{"), prt 0 injs, doc (showString "}"), doc (showString ":"), prt 0 t]) + +instance Print Inj where + prt i = \case + Inj (init,t) exp -> prPrec i 0 (concatD [prt 0 init, doc (showString ":"), prt 0 t, doc (showString "=>"), prt 0 exp]) + +instance Print [Inj] where + prt _ [] = concatD [] + prt _ [x] = concatD [prt 0 x] + prt _ (x:xs) = concatD [prt 0 x, doc (showString ";"), prt 0 xs] + diff --git a/test_program b/test_program index c5af112..26220e3 100644 --- a/test_program +++ b/test_program @@ -1,12 +1,30 @@ +-- data Bool () where { +-- True : Bool () +-- False : Bool () +-- }; +-- +-- main : _Int ; +-- main = case True of { +-- False => 0 ; +-- True => 1 +-- }; + data List ('a) where { Nil : List ('a) - Cons : 'a -> List ('a) -> List ('a) + Cons : ('a) -> List ('a) -> List ('a) }; -data Bool () where { - True : Bool () - False : Bool () +data Maybe ('a) where { + Nothing : Maybe ('a) + Just : 'a -> Maybe ('a) }; -main : List (_Int) ; -main = Cons 1 (Cons 0 Nil) ; +safeHead : List ('a) -> Maybe ('a) ; +safeHead xs = + case xs of { + Nil => Nothing ; + Cons x xs => Just x + }; + +main : Maybe (_Int) ; +main = safeHead (Cons 0 (Cons 1 Nil)) ; From fecb71bc0799f0a6eb181d83cca53de5197ab3f7 Mon Sep 17 00:00:00 2001 From: sebastianselander Date: Fri, 3 Mar 2023 18:17:51 +0100 Subject: [PATCH 062/372] Found a bug. --- cabal.project.local | 2 ++ cabal.project.local~ | 2 ++ llvm.ll | 16 +++++++++++++++ src/TypeChecker/TypeChecker.hs | 36 +++++++++++++++++++++++++--------- test_program | 33 +++++++++++++++++++++---------- 5 files changed, 70 insertions(+), 19 deletions(-) create mode 100644 cabal.project.local create mode 100644 cabal.project.local~ create mode 100644 llvm.ll diff --git a/cabal.project.local b/cabal.project.local new file mode 100644 index 0000000..0432756 --- /dev/null +++ b/cabal.project.local @@ -0,0 +1,2 @@ +ignore-project: False +tests: True diff --git a/cabal.project.local~ b/cabal.project.local~ new file mode 100644 index 0000000..40fdf41 --- /dev/null +++ b/cabal.project.local~ @@ -0,0 +1,2 @@ +ignore-project: False +tests: False diff --git a/llvm.ll b/llvm.ll new file mode 100644 index 0000000..9f414c7 --- /dev/null +++ b/llvm.ll @@ -0,0 +1,16 @@ +@.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)) (EApp (TMono (Ident "Int")) (EId (Ident "sc_0",TArr (TPol (Ident "t1")) (TPol (Ident "t1")))) (ELit (TMono (Ident "Int")) (LInt 3))) +define i64 @main() { + %1 = call i64 @sc_0(i64 3) + %2 = add i64 3, %1 + call i32 (ptr, ...) @printf(ptr noundef @.str, i64 noundef %2) + ret i64 0 +} + +; Ident "sc_0": EId (Ident "x_0",TPol (Ident "t1")) +define "TPol (Ident "t1")" @sc_0("TPol (Ident "t1")" %x_0) { + ret i64 %x_0 +} diff --git a/src/TypeChecker/TypeChecker.hs b/src/TypeChecker/TypeChecker.hs index 9c55388..09d5204 100644 --- a/src/TypeChecker/TypeChecker.hs +++ b/src/TypeChecker/TypeChecker.hs @@ -18,12 +18,18 @@ import Data.Set (Set) import qualified Data.Set as S import Data.Foldable (traverse_) +import Debug.Trace (trace) import Grammar.Abs import Grammar.Print (printTree) import qualified TypeChecker.TypeCheckerIr as T import TypeChecker.TypeCheckerIr (Ctx (..), Env (..), Error, Infer, Poly (..), Subst) +{- BUGS TODO: + Occurs fails on data types, e.g declared Maybe a, used in fn as Maybe (a -> a) +-} + + initCtx = Ctx mempty initEnv = Env 0 mempty mempty @@ -237,10 +243,9 @@ algoW = \case let typ = apply unified' (head ts) return (unified', typ, T.ECase typ e0' injs') - -- | Unify two types producing a new substitution unify :: Type -> Type -> Infer Subst -unify t0 t1 = case (t0, t1) of +unify t0 t1 = case (trace ("LEFT: " ++ show t0) t0, trace ("RIGHT: " ++ show t1) t1) of (TArr a b, TArr c d) -> do s1 <- unify a c s2 <- unify (apply s1 b) (apply s1 d) @@ -299,6 +304,7 @@ instance FreeVars Type where free (TArr a b) = free a `S.union` free b -- | Not guaranteed to be correct free (TConstr (Constr _ a)) = foldl' (\acc x -> free x `S.union` acc) S.empty a + apply :: Subst -> Type -> Type apply sub t = do case t of @@ -334,7 +340,7 @@ fresh :: Infer Type fresh = do n <- gets count modify (\st -> st { count = n + 1 }) - return . TPol . Ident $ "t" ++ show n + return . TPol . Ident $ show n -- | Run the monadic action with an additional binding withBinding :: (Monad m, MonadReader Ctx m) => Ident -> Poly -> m a -> m a @@ -352,7 +358,7 @@ insertConstr i t = modify (\st -> st { constructors = M.insert i t (constructors -------- PATTERN MATCHING --------- -- "case expr of", the type of 'expr' is caseType -checkInj :: Type -> Inj -> Infer (T.Inj, Type) +checkInj :: Type -> Inj -> Infer (T.Inj, Type); checkInj caseType (Inj it expr) = do (args, t') <- initType caseType it (s, t, e') <- local (\st -> st { vars = args }) (algoW expr) @@ -360,23 +366,34 @@ checkInj caseType (Inj it expr) = do initType :: Type -> Init -> Infer (Map Ident Poly, Type) initType expected = \case + InitLit lit -> let returnType = litType lit in if expected == returnType then return (mempty,expected) - else throwError $ unwords ["Inferred type", printTree returnType, "does not match expected type:", printTree expected] + else throwError $ unwords [ "Inferred type" + , printTree returnType + , "does not match expected type:" + , printTree expected + ] + InitConstr c args -> do st <- gets constructors case M.lookup c st of - Nothing -> throwError $ unwords ["Constructor:", printTree c, "does not exist"] + Nothing -> throwError $ unwords ["Constructor:" + , printTree c + , "does not exist" + ] Just t -> do let flat = flattenType t let returnType = last flat case (length (init flat) == length args, returnType `isMoreSpecificOrEq` expected) of (True, True) -> return (M.fromList $ zip args (map (Forall []) flat), expected) (False, _) -> throwError $ "Can't partially match on the constructor: " ++ printTree c - (_, False) -> throwError $ unwords ["Inferred type", printTree returnType, "does not match expected type:", printTree expected] - -- Ignoring the variables for now, they can not be used in the expression to the - -- right of '=>' + (_, False) -> throwError $ unwords [ "Inferred type" + , printTree returnType + , "does not match expected type:" + , printTree expected + ] InitCatch -> return (mempty, expected) @@ -386,3 +403,4 @@ flattenType a = [a] litType :: Literal -> Type litType (LInt i) = TMono "Int" + diff --git a/test_program b/test_program index 26220e3..5f6cce9 100644 --- a/test_program +++ b/test_program @@ -1,13 +1,7 @@ --- data Bool () where { --- True : Bool () --- False : Bool () --- }; --- --- main : _Int ; --- main = case True of { --- False => 0 ; --- True => 1 --- }; +data Bool () where { + True : Bool () + False : Bool () +}; data List ('a) where { Nil : List ('a) @@ -19,6 +13,11 @@ data Maybe ('a) where { Just : 'a -> Maybe ('a) }; +data Either ('a 'b) where { + Left : 'a -> Either ('a 'b) + Right : 'b -> Either ('a 'b) +}; + safeHead : List ('a) -> Maybe ('a) ; safeHead xs = case xs of { @@ -28,3 +27,17 @@ safeHead xs = main : Maybe (_Int) ; main = safeHead (Cons 0 (Cons 1 Nil)) ; + +maybeToEither : Either ('a 'b) -> Maybe ('a) ; +maybeToEither e = + case e of { + Left y => Nothing ; + Right x => Just x + }; + +id : 'a -> 'a ; +id x = x ; + +-- Bug, occurs check failed +holdFn : Maybe ('b -> 'b) ; +holdFn = Just id ; From fe63fa62157048026a8c3778d39607b8a58c36a7 Mon Sep 17 00:00:00 2001 From: sebastianselander Date: Sun, 5 Mar 2023 13:24:56 +0100 Subject: [PATCH 063/372] Improved error message and created document for known bugs. --- src/TypeChecker/Bugs.md | 43 +++++++++++++++++++ src/TypeChecker/TypeChecker.hs | 2 +- test_program | 75 +++++++++++++++++++--------------- 3 files changed, 85 insertions(+), 35 deletions(-) create mode 100644 src/TypeChecker/Bugs.md diff --git a/src/TypeChecker/Bugs.md b/src/TypeChecker/Bugs.md new file mode 100644 index 0000000..ce95446 --- /dev/null +++ b/src/TypeChecker/Bugs.md @@ -0,0 +1,43 @@ +## Bugs + +### Polymorphic type variables are global? + +This doesn't work (occurs check failed, can't unify `(a -> a) = a` +```hs +data Maybe ('a) where { + Nothing : Maybe ('a) + Just : 'a -> Maybe ('a) +}; + +id : 'a -> 'a ; +id x = x ; + +main : Maybe ('a -> 'a) ; +main = Just id; +``` + +But this does +```hs +data Maybe ('a) where { + Nothing : Maybe ('a) + Just : 'a -> Maybe ('a) +}; + +id : 'b -> 'b ; +id x = x ; + +main : Maybe ('a -> 'a) ; +main = Just id; +``` + +### The function f is not carried into the case-expression + +Code example that does not type check +```hs +fmap : ('a -> 'b) -> Maybe ('a) -> Maybe ('b) ; +fmap f x = + case x of { + Just x => Just (f x) ; + Nothing => Nothing + } +``` diff --git a/src/TypeChecker/TypeChecker.hs b/src/TypeChecker/TypeChecker.hs index 09d5204..53e3678 100644 --- a/src/TypeChecker/TypeChecker.hs +++ b/src/TypeChecker/TypeChecker.hs @@ -272,7 +272,7 @@ unify t0 t1 = case (trace ("LEFT: " ++ show t0) t0, trace ("RIGHT: " ++ show t1) occurs :: Ident -> Type -> Infer Subst occurs _ (TPol _) = return nullSubst occurs i t = if S.member i (free t) - then throwError "Occurs check failed" + then throwError $ unwords ["Occurs check failed, can't unify", printTree (TPol i), "with", printTree t] else return $ M.singleton i t -- | Generalize a type over all free variables in the substitution set diff --git a/test_program b/test_program index 5f6cce9..f8dd9bc 100644 --- a/test_program +++ b/test_program @@ -1,43 +1,50 @@ -data Bool () where { - True : Bool () - False : Bool () -}; - -data List ('a) where { - Nil : List ('a) - Cons : ('a) -> List ('a) -> List ('a) -}; +-- data Bool () where { +-- True : Bool () +-- False : Bool () +-- }; +-- +-- data List ('a) where { +-- Nil : List ('a) +-- Cons : ('a) -> List ('a) -> List ('a) +-- }; data Maybe ('a) where { Nothing : Maybe ('a) Just : 'a -> Maybe ('a) }; -data Either ('a 'b) where { - Left : 'a -> Either ('a 'b) - Right : 'b -> Either ('a 'b) -}; - -safeHead : List ('a) -> Maybe ('a) ; -safeHead xs = - case xs of { - Nil => Nothing ; - Cons x xs => Just x - }; - -main : Maybe (_Int) ; -main = safeHead (Cons 0 (Cons 1 Nil)) ; - -maybeToEither : Either ('a 'b) -> Maybe ('a) ; -maybeToEither e = - case e of { - Left y => Nothing ; - Right x => Just x - }; - id : 'a -> 'a ; id x = x ; --- Bug, occurs check failed -holdFn : Maybe ('b -> 'b) ; -holdFn = Just id ; +main : Maybe ('a -> 'a) ; +main = Just id; + +-- data Either ('a 'b) where { +-- Left : 'a -> Either ('a 'b) +-- Right : 'b -> Either ('a 'b) +-- }; + +-- safeHead : List ('a) -> Maybe ('a) ; +-- safeHead xs = +-- case xs of { +-- Nil => Nothing ; +-- Cons x xs => Just x +-- }; + +-- main : Maybe (_Int) ; +-- main = safeHead (Cons 0 (Cons 1 Nil)) ; +-- +-- maybeToEither : Either ('a 'b) -> Maybe ('a) ; +-- maybeToEither e = +-- case e of { +-- Left y => Nothing ; +-- Right x => Just x +-- }; +-- +-- -- Bug. f not included in the case-expression context +-- fmap : ('a -> 'b) -> Maybe ('a) -> Maybe ('b) ; +-- fmap f x = +-- case x of { +-- Just x => Just (f x) ; +-- Nothing => Nothing +-- } From 778fec3dc4b01d2011e21f0622a36009583e3786 Mon Sep 17 00:00:00 2001 From: sebastianselander Date: Sun, 5 Mar 2023 14:34:39 +0100 Subject: [PATCH 064/372] Implemented potential fix for one of the bugs --- src/TypeChecker/Bugs.md | 1 + src/TypeChecker/TypeChecker.hs | 454 +++++++++++++++++++-------------- test_program | 2 +- 3 files changed, 262 insertions(+), 195 deletions(-) diff --git a/src/TypeChecker/Bugs.md b/src/TypeChecker/Bugs.md index ce95446..616f0fe 100644 --- a/src/TypeChecker/Bugs.md +++ b/src/TypeChecker/Bugs.md @@ -29,6 +29,7 @@ id x = x ; main : Maybe ('a -> 'a) ; main = Just id; ``` +UPDATE: Might have found a fix. Need to be tested. ### The function f is not carried into the case-expression diff --git a/src/TypeChecker/TypeChecker.hs b/src/TypeChecker/TypeChecker.hs index 53e3678..c490c27 100644 --- a/src/TypeChecker/TypeChecker.hs +++ b/src/TypeChecker/TypeChecker.hs @@ -1,40 +1,42 @@ -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} -{-# OPTIONS_GHC -Wno-unused-matches #-} -{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} {-# HLINT ignore "Use mapAndUnzipM" #-} +{-# OPTIONS_GHC -Wno-overlapping-patterns #-} +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} +{-# OPTIONS_GHC -Wno-unused-matches #-} -- | A module for type checking and inference using algorithm W, Hindley-Milner module TypeChecker.TypeChecker where -import Control.Monad.Except -import Control.Monad.Reader -import Control.Monad.State -import Data.Functor.Identity (runIdentity) -import Data.List (foldl') -import Data.Map (Map) -import qualified Data.Map as M -import Data.Set (Set) -import qualified Data.Set as S - -import Data.Foldable (traverse_) -import Debug.Trace (trace) -import Grammar.Abs -import Grammar.Print (printTree) -import qualified TypeChecker.TypeCheckerIr as T -import TypeChecker.TypeCheckerIr (Ctx (..), Env (..), Error, Infer, - Poly (..), Subst) - -{- BUGS TODO: - Occurs fails on data types, e.g declared Maybe a, used in fn as Maybe (a -> a) --} - +import Control.Monad.Except +import Control.Monad.Reader +import Control.Monad.State +import Data.Foldable (traverse_) +import Data.Functor.Identity (runIdentity) +import Data.List (foldl') +import Data.Map (Map) +import Data.Map qualified as M +import Data.Set (Set) +import Data.Set qualified as S +import Debug.Trace (trace) +import Grammar.Abs +import Grammar.Print (printTree) +import TypeChecker.TypeCheckerIr ( + Ctx (..), + Env (..), + Error, + Infer, + Poly (..), + Subst, + ) +import TypeChecker.TypeCheckerIr qualified as T initCtx = Ctx mempty + initEnv = Env 0 mempty mempty runPretty :: Exp -> Either Error String -runPretty = fmap (printTree . fst). run . inferExp +runPretty = fmap (printTree . fst) . run . inferExp run :: Infer a -> Either Error a run = runC initEnv initCtx @@ -45,24 +47,60 @@ runC e c = runIdentity . runExceptT . flip runReaderT c . flip evalStateT e typecheck :: Program -> Either Error T.Program typecheck = run . checkPrg +{- | Start by freshening the type variable of data types to avoid clash with +other user defined polymorphic types +-} +freshenData :: Data -> Infer Data +freshenData (Data (Constr name ts) constrs) = do + fr <- fresh + let fr' = case fr of + TPol a -> a + -- Meh, this part assumes fresh generates a polymorphic type + _ -> error "Bug: implementation of fresh and freshenData are not compatible" + let new_ts = map (freshenType fr') ts + let new_constrs = map (freshenConstr fr') constrs + return $ Data (Constr name new_ts) new_constrs + where + freshenType :: Ident -> Type -> Type + freshenType iden = \case + (TPol a) -> TPol iden + (TArr a b) -> TArr (freshenType iden a) (freshenType iden b) + (TConstr (Constr a ts)) -> TConstr (Constr a (map (freshenType iden) ts)) + rest -> rest + + freshenConstr :: Ident -> Constructor -> Constructor + freshenConstr iden (Constructor name t) = Constructor name (freshenType iden t) + checkData :: Data -> Infer () -checkData d = case d of - (Data typ@(Constr name ts) constrs) -> do - unless (all isPoly ts) (throwError $ unwords ["Data type incorrectly declared"]) - traverse_ (\(Constructor name' t') - -> if TConstr typ == retType t' - then insertConstr name' t' else - throwError $ - unwords - [ "return type of constructor:" - , printTree name - , "with type:" - , printTree (retType t') - , "does not match data: " - , printTree typ]) constrs +checkData d = do + trace ("OLD: " ++ show d) return () + d' <- freshenData d + trace ("NEW: " ++ show d') return () + case d' of + (Data typ@(Constr name ts) constrs) -> do + unless + (all isPoly ts) + (throwError $ unwords ["Data type incorrectly declared"]) + traverse_ + ( \(Constructor name' t') -> + if TConstr typ == retType t' + then insertConstr name' t' + else + throwError $ + unwords + [ "return type of constructor:" + , printTree name + , "with type:" + , printTree (retType t') + , "does not match data: " + , printTree typ + ] + ) + constrs + retType :: Type -> Type retType (TArr _ t2) = retType t2 -retType a = a +retType a = a checkPrg :: Program -> Infer T.Program checkPrg (Program bs) = do @@ -71,54 +109,62 @@ checkPrg (Program bs) = do where preRun :: [Def] -> Infer () preRun [] = return () - preRun (x:xs) = case x of - DBind (Bind n t _ _ _ ) -> insertSig n t >> preRun xs - DData d@(Data _ _) -> checkData d >> preRun xs + preRun (x : xs) = case x of + DBind (Bind n t _ _ _) -> insertSig n t >> preRun xs + DData d@(Data _ _) -> checkData d >> preRun xs checkDef :: [Def] -> Infer [T.Def] checkDef [] = return [] - checkDef (x:xs) = case x of + checkDef (x : xs) = case x of (DBind b) -> do b' <- checkBind b fmap (T.DBind b' :) (checkDef xs) - (DData d) -> fmap (T.DData d :) (checkDef xs) + (DData d) -> fmap (T.DData d :) (checkDef xs) checkBind :: Bind -> Infer T.Bind checkBind (Bind n t _ args e) = do (t', e') <- inferExp $ makeLambda e (reverse args) s <- unify t t' let t'' = apply s t - unless (t `typeEq` t'') (throwError $ unwords ["Top level signature" - , printTree t - , "does not match body with inferred type:" - , printTree t'' - ]) + unless + (t `typeEq` t'') + ( throwError $ + unwords + [ "Top level signature" + , printTree t + , "does not match body with inferred type:" + , printTree t'' + ] + ) return $ T.Bind (n, t) e' where makeLambda :: Exp -> [Ident] -> Exp makeLambda = foldl (flip EAbs) --- | Check if two types are considered equal --- For the purpose of the algorithm two polymorphic types are always considered equal +{- | Check if two types are considered equal + For the purpose of the algorithm two polymorphic types are always considered + equal +-} typeEq :: Type -> Type -> Bool -typeEq (TArr l r) (TArr l' r') = typeEq l l' && typeEq r r' -typeEq (TMono a) (TMono b) = a == b -typeEq (TConstr (Constr name a)) (TConstr (Constr name' b)) = length a == length b - && name == name' - && and (zipWith typeEq a b) -typeEq (TPol _) (TPol _) = True -typeEq _ _ = False +typeEq (TArr l r) (TArr l' r') = typeEq l l' && typeEq r r' +typeEq (TMono a) (TMono b) = a == b +typeEq (TConstr (Constr name a)) (TConstr (Constr name' b)) = + length a == length b + && name == name' + && and (zipWith typeEq a b) +typeEq (TPol _) (TPol _) = True +typeEq _ _ = False isMoreSpecificOrEq :: Type -> Type -> Bool -isMoreSpecificOrEq _ (TPol _) = True +isMoreSpecificOrEq _ (TPol _) = True isMoreSpecificOrEq (TArr a b) (TArr c d) = isMoreSpecificOrEq a c && isMoreSpecificOrEq b d -isMoreSpecificOrEq (TConstr (Constr n1 ts1)) (TConstr (Constr n2 ts2)) - = n1 == n2 && length ts1 == length ts2 && and (zipWith isMoreSpecificOrEq ts1 ts2) -isMoreSpecificOrEq a b = a == b +isMoreSpecificOrEq (TConstr (Constr n1 ts1)) (TConstr (Constr n2 ts2)) = + n1 == n2 && length ts1 == length ts2 && and (zipWith isMoreSpecificOrEq ts1 ts2) +isMoreSpecificOrEq a b = a == b isPoly :: Type -> Bool isPoly (TPol _) = True -isPoly _ = False +isPoly _ = False inferExp :: Exp -> Infer (Type, T.Exp) inferExp e = do @@ -128,57 +174,59 @@ inferExp e = do replace :: Type -> T.Exp -> T.Exp replace t = \case - T.ELit _ e -> T.ELit t e - T.EId (n, _) -> T.EId (n, t) - T.EAbs _ name e -> T.EAbs t name e - T.EApp _ e1 e2 -> T.EApp t e1 e2 - T.EAdd _ e1 e2 -> T.EAdd t e1 e2 + T.ELit _ e -> T.ELit t e + T.EId (n, _) -> T.EId (n, t) + T.EAbs _ name e -> T.EAbs t name e + T.EApp _ e1 e2 -> T.EApp t e1 e2 + T.EAdd _ e1 e2 -> T.EAdd t e1 e2 T.ELet (T.Bind (n, _) e1) e2 -> T.ELet (T.Bind (n, t) e1) e2 - T.ECase _ expr injs -> T.ECase t expr injs + T.ECase _ expr injs -> T.ECase t expr injs algoW :: Exp -> Infer (Subst, Type, T.Exp) algoW = \case - - -- | TODO: Reason more about this one. Could be wrong + -- \| TODO: More testing need to be done. Unsure of the correctness of this EAnn e t -> do (s1, t', e') <- algoW e - unless (t `isMoreSpecificOrEq` t') (throwError $ unwords - ["Annotated type:" - , printTree t - , "does not match inferred type:" - , printTree t' ]) + unless + (t `isMoreSpecificOrEq` t') + ( throwError $ + unwords + [ "Annotated type:" + , printTree t + , "does not match inferred type:" + , printTree t' + ] + ) applySt s1 $ do s2 <- unify t t' return (s2 `compose` s1, t, e') --- | ------------------ --- | Γ ⊢ i : Int, ∅ - - ELit (LInt n) -> return (nullSubst, TMono "Int", T.ELit (TMono "Int") (LInt n)) + -- \| ------------------ + -- \| Γ ⊢ i : Int, ∅ + ELit (LInt n) -> return (nullSubst, TMono "Int", T.ELit (TMono "Int") (LInt n)) ELit a -> error $ "NOT IMPLEMENTED YET: ELit " ++ show a - --- | x : σ ∈ Γ   τ = inst(σ) --- | ---------------------- --- | Γ ⊢ x : τ, ∅ + -- \| x : σ ∈ Γ   τ = inst(σ) + -- \| ---------------------- + -- \| Γ ⊢ x : τ, ∅ EId i -> do var <- asks vars case M.lookup i var of - Just t -> inst t >>= \x -> return (nullSubst, x, T.EId (i, x)) - Nothing -> do - sig <- gets sigs - case M.lookup i sig of - Just t -> return (nullSubst, t, T.EId (i, t)) - Nothing -> do - constr <- gets constructors - case M.lookup i constr of - Just t -> return (nullSubst, t, T.EId (i, t)) - Nothing -> throwError $ "Unbound variable: " ++ show i + Just t -> inst t >>= \x -> return (nullSubst, x, T.EId (i, x)) + Nothing -> do + sig <- gets sigs + case M.lookup i sig of + Just t -> return (nullSubst, t, T.EId (i, t)) + Nothing -> do + constr <- gets constructors + case M.lookup i constr of + Just t -> return (nullSubst, t, T.EId (i, t)) + Nothing -> throwError $ "Unbound variable: " ++ show i --- | τ = newvar Γ, x : τ ⊢ e : τ', S --- | --------------------------------- --- | Γ ⊢ w λx. e : Sτ → τ', S + -- \| τ = newvar Γ, x : τ ⊢ e : τ', S + -- \| --------------------------------- + -- \| Γ ⊢ w λx. e : Sτ → τ', S EAbs name e -> do fr <- fresh @@ -188,11 +236,11 @@ algoW = \case let newArr = TArr varType t' return (s1, newArr, T.EAbs newArr (name, varType) e') --- | Γ ⊢ e₀ : τ₀, S₀ S₀Γ ⊢ e₁ : τ₁, S₁ --- | s₂ = mgu(s₁τ₀, Int) s₃ = mgu(s₂τ₁, Int) --- | ------------------------------------------ --- | Γ ⊢ e₀ + e₁ : Int, S₃S₂S₁S₀ --- This might be wrong + -- \| Γ ⊢ e₀ : τ₀, S₀ S₀Γ ⊢ e₁ : τ₁, S₁ + -- \| s₂ = mgu(s₁τ₀, Int) s₃ = mgu(s₂τ₁, Int) + -- \| ------------------------------------------ + -- \| Γ ⊢ e₀ + e₁ : Int, S₃S₂S₁S₀ + -- This might be wrong EAdd e0 e1 -> do (s1, t0, e0') <- algoW e0 @@ -203,10 +251,10 @@ algoW = \case s4 <- unify (apply s3 t1) (TMono "Int") return (s4 `compose` s3 `compose` s2 `compose` s1, TMono "Int", T.EAdd (TMono "Int") e0' e1') --- | Γ ⊢ e₀ : τ₀, S₀ S₀Γ ⊢ e₁ : τ₁, S1 --- | τ' = newvar S₂ = mgu(S₁τ₀, τ₁ → τ') --- | -------------------------------------- --- | Γ ⊢ e₀ e₁ : S₂τ', S₂S₁S₀ + -- \| Γ ⊢ e₀ : τ₀, S₀ S₀Γ ⊢ e₁ : τ₁, S1 + -- \| τ' = newvar S₂ = mgu(S₁τ₀, τ₁ → τ') + -- \| -------------------------------------- + -- \| Γ ⊢ e₀ e₁ : S₂τ', S₂S₁S₀ EApp e0 e1 -> do fr <- fresh @@ -218,11 +266,11 @@ algoW = \case let t = apply s2 fr return (s2 `compose` s1 `compose` s0, t, T.EApp t e0' e1') --- | Γ ⊢ e₀ : τ, S₀ S₀Γ, x : S̅₀Γ̅(τ) ⊢ e₁ : τ', S₁ --- | ---------------------------------------------- --- | Γ ⊢ let x = e₀ in e₁ : τ', S₁S₀ + -- \| Γ ⊢ e₀ : τ, S₀ S₀Γ, x : S̅₀Γ̅(τ) ⊢ e₁ : τ', S₁ + -- \| ---------------------------------------------- + -- \| Γ ⊢ let x = e₀ in e₁ : τ', S₁S₀ --- The bar over S₀ and Γ means "generalize" + -- The bar over S₀ and Γ means "generalize" ELet name e0 e1 -> do (s1, t1, e0') <- algoW e0 @@ -230,18 +278,17 @@ algoW = \case let t' = generalize (apply s1 env) t1 withBinding name t' $ do (s2, t2, e1') <- algoW e1 - return (s2 `compose` s1, t2, T.ELet (T.Bind (name,t2) e0') e1') - + return (s2 `compose` s1, t2, T.ELet (T.Bind (name, t2) e0') e1') ECase caseExpr injs -> do (s0, t0, e0') <- algoW caseExpr (injs', ts) <- unzip <$> mapM (checkInj t0) injs case ts of - [] -> throwError "Case expression missing any matches" - ts -> do - unified <- zipWithM unify ts (tail ts) - let unified' = foldl' compose mempty unified - let typ = apply unified' (head ts) - return (unified', typ, T.ECase typ e0' injs') + [] -> throwError "Case expression missing any matches" + ts -> do + unified <- zipWithM unify ts (tail ts) + let unified' = foldl' compose mempty unified + let typ = apply unified' (head ts) + return (unified', typ, T.ECase typ e0' injs') -- | Unify two types producing a new substitution unify :: Type -> Type -> Infer Subst @@ -253,27 +300,40 @@ unify t0 t1 = case (trace ("LEFT: " ++ show t0) t0, trace ("RIGHT: " ++ show t1) (TPol a, b) -> occurs a b (a, TPol b) -> occurs b a (TMono a, TMono b) -> if a == b then return M.empty else throwError "Types do not unify" - -- | TODO: Figure out a cleaner way to express the same thing - (TConstr (Constr name t), TConstr (Constr name' t')) -> if name == name' && length t == length t' - then do - xs <- zipWithM unify t t' - return $ foldr compose nullSubst xs - else throwError $ unwords - ["Type constructor:" - , printTree name - , "(" ++ printTree t ++ ")" - , "does not match with:" - , printTree name' - , "(" ++ printTree t' ++ ")"] + -- \| TODO: Figure out a cleaner way to express the same thing + (TConstr (Constr name t), TConstr (Constr name' t')) -> + if name == name' && length t == length t' + then do + xs <- zipWithM unify t t' + return $ foldr compose nullSubst xs + else + throwError $ + unwords + [ "Type constructor:" + , printTree name + , "(" ++ printTree t ++ ")" + , "does not match with:" + , printTree name' + , "(" ++ printTree t' ++ ")" + ] (a, b) -> throwError . unwords $ ["Type:", printTree a, "can't be unified with:", printTree b] --- | Check if a type is contained in another type. --- I.E. { a = a -> b } is an unsolvable constraint since there is no substitution such that these are equal +{- | Check if a type is contained in another type. +I.E. { a = a -> b } is an unsolvable constraint since there is no substitution such that these are equal +-} occurs :: Ident -> Type -> Infer Subst occurs _ (TPol _) = return nullSubst -occurs i t = if S.member i (free t) - then throwError $ unwords ["Occurs check failed, can't unify", printTree (TPol i), "with", printTree t] - else return $ M.singleton i t +occurs i t = + if S.member i (free t) + then + throwError $ + unwords + [ "Occurs check failed, can't unify" + , printTree (TPol i) + , "with" + , printTree t + ] + else return $ M.singleton i t -- | Generalize a type over all free variables in the substitution set generalize :: Map Ident Poly -> Type -> Poly @@ -292,44 +352,45 @@ compose m1 m2 = M.map (apply m1) m2 `M.union` m1 -- | A class representing free variables functions class FreeVars t where - -- | Get all free variables from t - free :: t -> Set Ident - -- | Apply a substitution to t - apply :: Subst -> t -> t + -- | Get all free variables from t + free :: t -> Set Ident + + -- | Apply a substitution to t + apply :: Subst -> t -> t instance FreeVars Type where - free :: Type -> Set Ident - free (TPol a) = S.singleton a - free (TMono _) = mempty - free (TArr a b) = free a `S.union` free b - -- | Not guaranteed to be correct - free (TConstr (Constr _ a)) = foldl' (\acc x -> free x `S.union` acc) S.empty a + free :: Type -> Set Ident + free (TPol a) = S.singleton a + free (TMono _) = mempty + free (TArr a b) = free a `S.union` free b + -- \| Not guaranteed to be correct + free (TConstr (Constr _ a)) = foldl' (\acc x -> free x `S.union` acc) S.empty a - apply :: Subst -> Type -> Type - apply sub t = do - case t of - TMono a -> TMono a - TPol a -> case M.lookup a sub of - Nothing -> TPol a - Just t -> t - TArr a b -> TArr (apply sub a) (apply sub b) - TConstr (Constr name a) -> TConstr (Constr name (map (apply sub) a)) + apply :: Subst -> Type -> Type + apply sub t = do + case t of + TMono a -> TMono a + TPol a -> case M.lookup a sub of + Nothing -> TPol a + Just t -> t + TArr a b -> TArr (apply sub a) (apply sub b) + TConstr (Constr name a) -> TConstr (Constr name (map (apply sub) a)) instance FreeVars Poly where - free :: Poly -> Set Ident - free (Forall xs t) = free t S.\\ S.fromList xs - apply :: Subst -> Poly -> Poly - apply s (Forall xs t) = Forall xs (apply (foldr M.delete s xs) t) + free :: Poly -> Set Ident + free (Forall xs t) = free t S.\\ S.fromList xs + apply :: Subst -> Poly -> Poly + apply s (Forall xs t) = Forall xs (apply (foldr M.delete s xs) t) instance FreeVars (Map Ident Poly) where - free :: Map Ident Poly -> Set Ident - free m = foldl' S.union S.empty (map free $ M.elems m) - apply :: Subst -> Map Ident Poly -> Map Ident Poly - apply s = M.map (apply s) + free :: Map Ident Poly -> Set Ident + free m = foldl' S.union S.empty (map free $ M.elems m) + apply :: Subst -> Map Ident Poly -> Map Ident Poly + apply s = M.map (apply s) -- | Apply substitutions to the environment. applySt :: Subst -> Infer a -> Infer a -applySt s = local (\st -> st { vars = apply s (vars st) }) +applySt s = local (\st -> st {vars = apply s (vars st)}) -- | Represents the empty substition set nullSubst :: Subst @@ -339,68 +400,73 @@ nullSubst = M.empty fresh :: Infer Type fresh = do n <- gets count - modify (\st -> st { count = n + 1 }) + modify (\st -> st {count = n + 1}) return . TPol . Ident $ show n -- | Run the monadic action with an additional binding withBinding :: (Monad m, MonadReader Ctx m) => Ident -> Poly -> m a -> m a -withBinding i p = local (\st -> st { vars = M.insert i p (vars st) }) +withBinding i p = local (\st -> st {vars = M.insert i p (vars st)}) -- | Insert a function signature into the environment insertSig :: Ident -> Type -> Infer () -insertSig i t = modify (\st -> st { sigs = M.insert i t (sigs st) }) +insertSig i t = modify (\st -> st {sigs = M.insert i t (sigs st)}) -- | Insert a constructor with its data type insertConstr :: Ident -> Type -> Infer () -insertConstr i t = modify (\st -> st { constructors = M.insert i t (constructors st) }) - +insertConstr i t = modify (\st -> st {constructors = M.insert i t (constructors st)}) -------- PATTERN MATCHING --------- -- "case expr of", the type of 'expr' is caseType -checkInj :: Type -> Inj -> Infer (T.Inj, Type); +checkInj :: Type -> Inj -> Infer (T.Inj, Type) checkInj caseType (Inj it expr) = do (args, t') <- initType caseType it - (s, t, e') <- local (\st -> st { vars = args }) (algoW expr) + (s, t, e') <- local (\st -> st {vars = args}) (algoW expr) return (T.Inj (it, t') e', t) initType :: Type -> Init -> Infer (Map Ident Poly, Type) initType expected = \case - - InitLit lit -> let returnType = litType lit - in if expected == returnType - then return (mempty,expected) - else throwError $ unwords [ "Inferred type" - , printTree returnType - , "does not match expected type:" - , printTree expected - ] - + InitLit lit -> + let returnType = litType lit + in if expected == returnType + then return (mempty, expected) + else + throwError $ + unwords + [ "Inferred type" + , printTree returnType + , "does not match expected type:" + , printTree expected + ] InitConstr c args -> do st <- gets constructors case M.lookup c st of - Nothing -> throwError $ unwords ["Constructor:" - , printTree c - , "does not exist" - ] + Nothing -> + throwError $ + unwords + [ "Constructor:" + , printTree c + , "does not exist" + ] Just t -> do let flat = flattenType t let returnType = last flat case (length (init flat) == length args, returnType `isMoreSpecificOrEq` expected) of (True, True) -> return (M.fromList $ zip args (map (Forall []) flat), expected) (False, _) -> throwError $ "Can't partially match on the constructor: " ++ printTree c - (_, False) -> throwError $ unwords [ "Inferred type" - , printTree returnType - , "does not match expected type:" - , printTree expected - ] - + (_, False) -> + throwError $ + unwords + [ "Inferred type" + , printTree returnType + , "does not match expected type:" + , printTree expected + ] InitCatch -> return (mempty, expected) flattenType :: Type -> [Type] flattenType (TArr a b) = flattenType a ++ flattenType b -flattenType a = [a] +flattenType a = [a] litType :: Literal -> Type litType (LInt i) = TMono "Int" - diff --git a/test_program b/test_program index f8dd9bc..db0c77d 100644 --- a/test_program +++ b/test_program @@ -16,7 +16,7 @@ data Maybe ('a) where { id : 'a -> 'a ; id x = x ; -main : Maybe ('a -> 'a) ; +main : Maybe ('a -> 'a) ; main = Just id; -- data Either ('a 'b) where { From 8ca876a1014955a7ef6842537a722cc2ffe57a28 Mon Sep 17 00:00:00 2001 From: Rakarake Date: Mon, 6 Mar 2023 10:47:52 +0100 Subject: [PATCH 065/372] 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 9c2f52f8bb2b07dcf9750b813cb215023da8c6f3 Mon Sep 17 00:00:00 2001 From: sebastianselander Date: Mon, 6 Mar 2023 11:27:17 +0100 Subject: [PATCH 066/372] fixed bug where bound variable didn't exist in case --- src/Renamer/Renamer.hs | 71 +++++++++++++++++++--------------- src/TypeChecker/TypeChecker.hs | 44 +++++++++++++-------- test_program | 24 ++++++------ 3 files changed, 79 insertions(+), 60 deletions(-) diff --git a/src/Renamer/Renamer.hs b/src/Renamer/Renamer.hs index d471553..e8e6c38 100644 --- a/src/Renamer/Renamer.hs +++ b/src/Renamer/Renamer.hs @@ -2,16 +2,20 @@ module Renamer.Renamer where -import Auxiliary (mapAccumM) -import Control.Monad.State (MonadState, State, evalState, gets, - modify) -import Data.List (foldl') -import Data.Map (Map) -import qualified Data.Map as Map -import Data.Maybe (fromMaybe) -import Data.Tuple.Extra (dupe) -import Grammar.Abs - +import Auxiliary (mapAccumM) +import Control.Monad.State ( + MonadState, + State, + evalState, + gets, + modify, + ) +import Data.List (foldl') +import Data.Map (Map) +import Data.Map qualified as Map +import Data.Maybe (fromMaybe) +import Data.Tuple.Extra (dupe) +import Grammar.Abs -- | Rename all variables and local binds rename :: Program -> Program @@ -20,62 +24,65 @@ rename (Program bs) = Program $ evalState (runRn $ mapM (renameSc initNames) bs) -- initNames = Map.fromList $ map (\(Bind name _ _ _ _) -> dupe name) bs initNames = Map.fromList $ foldl' saveIfBind [] bs saveIfBind acc (DBind (Bind name _ _ _ _)) = dupe name : acc - saveIfBind acc _ = acc + saveIfBind acc _ = acc renameSc :: Names -> Def -> Rn Def renameSc old_names (DBind (Bind name t _ parms rhs)) = do (new_names, parms') <- newNames old_names parms - rhs' <- snd <$> renameExp new_names rhs + rhs' <- snd <$> renameExp new_names rhs pure . DBind $ Bind name t name parms' rhs' renameSc _ def = pure def - -- | Rename monad. State holds the number of renamed names. -newtype Rn a = Rn { runRn :: State Int a } - deriving (Functor, Applicative, Monad, MonadState Int) +newtype Rn a = Rn {runRn :: State Int a} + deriving (Functor, Applicative, Monad, MonadState Int) -- | Maps old to new name type Names = Map Ident Ident renameLocalBind :: Names -> Bind -> Rn (Names, Bind) renameLocalBind old_names (Bind name t _ parms rhs) = do - (new_names, name') <- newName old_names name + (new_names, name') <- newName old_names name (new_names', parms') <- newNames new_names parms - (new_names'', rhs') <- renameExp new_names' rhs + (new_names'', rhs') <- renameExp new_names' rhs pure (new_names'', Bind name' t name' parms' rhs') renameExp :: Names -> Exp -> Rn (Names, Exp) renameExp old_names = \case - EId n -> pure (old_names, EId . fromMaybe n $ Map.lookup n old_names) - - ELit (LInt i1) -> pure (old_names, ELit (LInt i1)) - + EId n -> pure (old_names, EId . fromMaybe n $ Map.lookup n old_names) + ELit (LInt i1) -> pure (old_names, ELit (LInt i1)) EApp e1 e2 -> do (env1, e1') <- renameExp old_names e1 (env2, e2') <- renameExp old_names e2 pure (Map.union env1 env2, EApp e1' e2') - EAdd e1 e2 -> do (env1, e1') <- renameExp old_names e1 (env2, e2') <- renameExp old_names e2 pure (Map.union env1 env2, EAdd e1' e2') - - ELet i e1 e2 -> do - (new_names, e1') <- renameExp old_names e1 + ELet i e1 e2 -> do + (new_names, e1') <- renameExp old_names e1 (new_names', e2') <- renameExp new_names e2 pure (new_names', ELet i e1' e2') - - EAbs par e -> do + EAbs par e -> do (new_names, par') <- newName old_names par - (new_names', e') <- renameExp new_names e + (new_names', e') <- renameExp new_names e pure (new_names', EAbs par' e') - EAnn e t -> do (new_names, e') <- renameExp old_names e pure (new_names, EAnn e' t) - ECase e injs -> do - (new_names, e') <- renameExp old_names e - pure (new_names, ECase e' injs) + (_, e') <- renameExp old_names e + (new_names, injs') <- renameInjs old_names injs + pure (new_names, ECase e' injs') + +renameInjs :: Names -> [Inj] -> Rn (Names, [Inj]) +renameInjs ns xs = do + (new_names, xs') <- unzip <$> mapM (renameInj ns) xs + if null new_names then return (mempty, xs') else return (head new_names, xs') + +renameInj :: Names -> Inj -> Rn (Names, Inj) +renameInj ns (Inj init e) = do + (new_names, e') <- renameExp ns e + return (new_names, Inj init e') -- | Create a new name and add it to name environment. newName :: Names -> Ident -> Rn (Names, Ident) diff --git a/src/TypeChecker/TypeChecker.hs b/src/TypeChecker/TypeChecker.hs index c490c27..afd2e1c 100644 --- a/src/TypeChecker/TypeChecker.hs +++ b/src/TypeChecker/TypeChecker.hs @@ -1,9 +1,7 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} + {-# HLINT ignore "Use mapAndUnzipM" #-} -{-# OPTIONS_GHC -Wno-overlapping-patterns #-} -{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} -{-# OPTIONS_GHC -Wno-unused-matches #-} -- | A module for type checking and inference using algorithm W, Hindley-Milner module TypeChecker.TypeChecker where @@ -73,9 +71,7 @@ freshenData (Data (Constr name ts) constrs) = do checkData :: Data -> Infer () checkData d = do - trace ("OLD: " ++ show d) return () d' <- freshenData d - trace ("NEW: " ++ show d') return () case d' of (Data typ@(Constr name ts) constrs) -> do unless @@ -249,7 +245,11 @@ algoW = \case -- applySt s2 $ do s3 <- unify (apply s2 t0) (TMono "Int") s4 <- unify (apply s3 t1) (TMono "Int") - return (s4 `compose` s3 `compose` s2 `compose` s1, TMono "Int", T.EAdd (TMono "Int") e0' e1') + return + ( s4 `compose` s3 `compose` s2 `compose` s1 + , TMono "Int" + , T.EAdd (TMono "Int") e0' e1' + ) -- \| Γ ⊢ e₀ : τ₀, S₀ S₀Γ ⊢ e₁ : τ₁, S1 -- \| τ' = newvar S₂ = mgu(S₁τ₀, τ₁ → τ') @@ -280,7 +280,7 @@ algoW = \case (s2, t2, e1') <- algoW e1 return (s2 `compose` s1, t2, T.ELet (T.Bind (name, t2) e0') e1') ECase caseExpr injs -> do - (s0, t0, e0') <- algoW caseExpr + (_, t0, e0') <- algoW caseExpr (injs', ts) <- unzip <$> mapM (checkInj t0) injs case ts of [] -> throwError "Case expression missing any matches" @@ -292,14 +292,15 @@ algoW = \case -- | Unify two types producing a new substitution unify :: Type -> Type -> Infer Subst -unify t0 t1 = case (trace ("LEFT: " ++ show t0) t0, trace ("RIGHT: " ++ show t1) t1) of +unify t0 t1 = case (t0, t1) of (TArr a b, TArr c d) -> do s1 <- unify a c s2 <- unify (apply s1 b) (apply s1 d) return $ s1 `compose` s2 (TPol a, b) -> occurs a b (a, TPol b) -> occurs b a - (TMono a, TMono b) -> if a == b then return M.empty else throwError "Types do not unify" + (TMono a, TMono b) -> + if a == b then return M.empty else throwError "Types do not unify" -- \| TODO: Figure out a cleaner way to express the same thing (TConstr (Constr name t), TConstr (Constr name' t')) -> if name == name' && length t == length t' @@ -316,10 +317,17 @@ unify t0 t1 = case (trace ("LEFT: " ++ show t0) t0, trace ("RIGHT: " ++ show t1) , printTree name' , "(" ++ printTree t' ++ ")" ] - (a, b) -> throwError . unwords $ ["Type:", printTree a, "can't be unified with:", printTree b] + (a, b) -> + throwError . unwords $ + [ "Type:" + , printTree a + , "can't be unified with:" + , printTree b + ] {- | Check if a type is contained in another type. -I.E. { a = a -> b } is an unsolvable constraint since there is no substitution such that these are equal +I.E. { a = a -> b } is an unsolvable constraint since there is no substitution +such that these are equal -} occurs :: Ident -> Type -> Infer Subst occurs _ (TPol _) = return nullSubst @@ -339,7 +347,9 @@ occurs i t = generalize :: Map Ident Poly -> Type -> Poly generalize env t = Forall (S.toList $ free t S.\\ free env) t --- | Instantiate a polymorphic type. The free type variables are substituted with fresh ones. +{- | Instantiate a polymorphic type. The free type variables are substituted +with fresh ones. +-} inst :: Poly -> Infer Type inst (Forall xs t) = do xs' <- mapM (const fresh) xs @@ -364,7 +374,8 @@ instance FreeVars Type where free (TMono _) = mempty free (TArr a b) = free a `S.union` free b -- \| Not guaranteed to be correct - free (TConstr (Constr _ a)) = foldl' (\acc x -> free x `S.union` acc) S.empty a + free (TConstr (Constr _ a)) = + foldl' (\acc x -> free x `S.union` acc) S.empty a apply :: Subst -> Type -> Type apply sub t = do @@ -413,7 +424,8 @@ insertSig i t = modify (\st -> st {sigs = M.insert i t (sigs st)}) -- | Insert a constructor with its data type insertConstr :: Ident -> Type -> Infer () -insertConstr i t = modify (\st -> st {constructors = M.insert i t (constructors st)}) +insertConstr i t = + modify (\st -> st {constructors = M.insert i t (constructors st)}) -------- PATTERN MATCHING --------- @@ -421,7 +433,7 @@ insertConstr i t = modify (\st -> st {constructors = M.insert i t (constructors checkInj :: Type -> Inj -> Infer (T.Inj, Type) checkInj caseType (Inj it expr) = do (args, t') <- initType caseType it - (s, t, e') <- local (\st -> st {vars = args}) (algoW expr) + (_, t, e') <- local (\st -> st {vars = args `M.union` vars st}) (algoW expr) return (T.Inj (it, t') e', t) initType :: Type -> Init -> Infer (Map Ident Poly, Type) @@ -469,4 +481,4 @@ flattenType (TArr a b) = flattenType a ++ flattenType b flattenType a = [a] litType :: Literal -> Type -litType (LInt i) = TMono "Int" +litType (LInt _) = TMono "Int" diff --git a/test_program b/test_program index db0c77d..efa8eea 100644 --- a/test_program +++ b/test_program @@ -13,11 +13,11 @@ data Maybe ('a) where { Just : 'a -> Maybe ('a) }; -id : 'a -> 'a ; -id x = x ; +-- id : 'a -> 'a ; +-- id x = x ; -main : Maybe ('a -> 'a) ; -main = Just id; +-- main : Maybe ('a -> 'a) ; +-- main = Just id; -- data Either ('a 'b) where { -- Left : 'a -> Either ('a 'b) @@ -40,11 +40,11 @@ main = Just id; -- Left y => Nothing ; -- Right x => Just x -- }; --- --- -- Bug. f not included in the case-expression context --- fmap : ('a -> 'b) -> Maybe ('a) -> Maybe ('b) ; --- fmap f x = --- case x of { --- Just x => Just (f x) ; --- Nothing => Nothing --- } + +-- Bug. f not included in the case-expression context +fmap : ('a -> 'b) -> Maybe ('a) -> Maybe ('b) ; +fmap f x = + case x of { + Just x => Just (f x) ; + Nothing => Nothing + } From f5b5f11903bddff75e0b6236433db2027388d886 Mon Sep 17 00:00:00 2001 From: sebastianselander Date: Mon, 6 Mar 2023 11:38:25 +0100 Subject: [PATCH 067/372] fixed formatting --- src/TypeChecker/TypeChecker.hs | 45 +++++++++++++++++++++++----------- 1 file changed, 31 insertions(+), 14 deletions(-) diff --git a/src/TypeChecker/TypeChecker.hs b/src/TypeChecker/TypeChecker.hs index afd2e1c..e1a6a2c 100644 --- a/src/TypeChecker/TypeChecker.hs +++ b/src/TypeChecker/TypeChecker.hs @@ -1,8 +1,6 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} -{-# HLINT ignore "Use mapAndUnzipM" #-} - -- | A module for type checking and inference using algorithm W, Hindley-Milner module TypeChecker.TypeChecker where @@ -16,7 +14,6 @@ import Data.Map (Map) import Data.Map qualified as M import Data.Set (Set) import Data.Set qualified as S -import Debug.Trace (trace) import Grammar.Abs import Grammar.Print (printTree) import TypeChecker.TypeCheckerIr ( @@ -54,7 +51,10 @@ freshenData (Data (Constr name ts) constrs) = do let fr' = case fr of TPol a -> a -- Meh, this part assumes fresh generates a polymorphic type - _ -> error "Bug: implementation of fresh and freshenData are not compatible" + _ -> + error + "Bug: implementation of \ + \ fresh and freshenData are not compatible" let new_ts = map (freshenType fr') ts let new_constrs = map (freshenConstr fr') constrs return $ Data (Constr name new_ts) new_constrs @@ -63,11 +63,13 @@ freshenData (Data (Constr name ts) constrs) = do freshenType iden = \case (TPol a) -> TPol iden (TArr a b) -> TArr (freshenType iden a) (freshenType iden b) - (TConstr (Constr a ts)) -> TConstr (Constr a (map (freshenType iden) ts)) + (TConstr (Constr a ts)) -> + TConstr (Constr a (map (freshenType iden) ts)) rest -> rest freshenConstr :: Ident -> Constructor -> Constructor - freshenConstr iden (Constructor name t) = Constructor name (freshenType iden t) + freshenConstr iden (Constructor name t) = + Constructor name (freshenType iden t) checkData :: Data -> Infer () checkData d = do @@ -153,9 +155,12 @@ typeEq _ _ = False isMoreSpecificOrEq :: Type -> Type -> Bool isMoreSpecificOrEq _ (TPol _) = True -isMoreSpecificOrEq (TArr a b) (TArr c d) = isMoreSpecificOrEq a c && isMoreSpecificOrEq b d +isMoreSpecificOrEq (TArr a b) (TArr c d) = + isMoreSpecificOrEq a c && isMoreSpecificOrEq b d isMoreSpecificOrEq (TConstr (Constr n1 ts1)) (TConstr (Constr n2 ts2)) = - n1 == n2 && length ts1 == length ts2 && and (zipWith isMoreSpecificOrEq ts1 ts2) + n1 == n2 + && length ts1 == length ts2 + && and (zipWith isMoreSpecificOrEq ts1 ts2) isMoreSpecificOrEq a b = a == b isPoly :: Type -> Bool @@ -200,7 +205,8 @@ algoW = \case -- \| ------------------ -- \| Γ ⊢ i : Int, ∅ - ELit (LInt n) -> return (nullSubst, TMono "Int", T.ELit (TMono "Int") (LInt n)) + ELit (LInt n) -> + return (nullSubst, TMono "Int", T.ELit (TMono "Int") (LInt n)) ELit a -> error $ "NOT IMPLEMENTED YET: ELit " ++ show a -- \| x : σ ∈ Γ   τ = inst(σ) -- \| ---------------------- @@ -218,7 +224,9 @@ algoW = \case constr <- gets constructors case M.lookup i constr of Just t -> return (nullSubst, t, T.EId (i, t)) - Nothing -> throwError $ "Unbound variable: " ++ show i + Nothing -> + throwError $ + "Unbound variable: " ++ show i -- \| τ = newvar Γ, x : τ ⊢ e : τ', S -- \| --------------------------------- @@ -281,7 +289,7 @@ algoW = \case return (s2 `compose` s1, t2, T.ELet (T.Bind (name, t2) e0') e1') ECase caseExpr injs -> do (_, t0, e0') <- algoW caseExpr - (injs', ts) <- unzip <$> mapM (checkInj t0) injs + (injs', ts) <- mapAndUnzipM (checkInj t0) injs case ts of [] -> throwError "Case expression missing any matches" ts -> do @@ -463,9 +471,18 @@ initType expected = \case Just t -> do let flat = flattenType t let returnType = last flat - case (length (init flat) == length args, returnType `isMoreSpecificOrEq` expected) of - (True, True) -> return (M.fromList $ zip args (map (Forall []) flat), expected) - (False, _) -> throwError $ "Can't partially match on the constructor: " ++ printTree c + case ( length (init flat) == length args + , returnType `isMoreSpecificOrEq` expected + ) of + (True, True) -> + return + ( M.fromList $ zip args (map (Forall []) flat) + , expected + ) + (False, _) -> + throwError $ + "Can't partially match on the constructor: " + ++ printTree c (_, False) -> throwError $ unwords From 6947614fba8aec3c85b7a367f06426ab0827703f Mon Sep 17 00:00:00 2001 From: sebastianselander Date: Mon, 6 Mar 2023 13:04:07 +0100 Subject: [PATCH 068/372] Updated bug list & started working on more tests --- Justfile | 7 ++++++ fourmolu.yaml | 13 ---------- sample-programs/basic-1 | 4 ++-- sample-programs/basic-2 | 4 +++- sample-programs/basic-3 | 4 ++-- sample-programs/basic-4 | 2 +- sample-programs/basic-5 | 15 ++++++++---- src/Main.hs | 14 +++++------ src/TypeChecker/Bugs.md | 31 ++++++++++++------------ src/TypeChecker/TypeChecker.hs | 2 +- tests/Tests.hs | 43 ++++++++++++++++++++++++---------- 11 files changed, 80 insertions(+), 59 deletions(-) diff --git a/Justfile b/Justfile index ea2d031..8079213 100644 --- a/Justfile +++ b/Justfile @@ -10,6 +10,13 @@ clean: test: cabal test +ctest: + cabal run language sample-programs/basic-1 + cabal run language sample-programs/basic-2 + cabal run language sample-programs/basic-3 + cabal run language sample-programs/basic-4 + cabal run language sample-programs/basic-5 + # compile a specific file run FILE: cabal run language {{FILE}} diff --git a/fourmolu.yaml b/fourmolu.yaml index cf7ab2f..8b96b58 100644 --- a/fourmolu.yaml +++ b/fourmolu.yaml @@ -1,14 +1 @@ -indentation: 4 -function-arrows: trailing -comma-style: leading -import-export-style: diff-friendly indent-wheres: false -record-brace-space: true -newlines-between-decls: 1 -haddock-style: multi-line -haddock-style-module: -let-style: auto -in-style: right-align -respectful: false -fixities: [] -unicode: never diff --git a/sample-programs/basic-1 b/sample-programs/basic-1 index f109950..5cb2b2a 100644 --- a/sample-programs/basic-1 +++ b/sample-programs/basic-1 @@ -1,2 +1,2 @@ - -f = \x. x+1; +f : _Int -> _Int ; +f = \x. x+1 ; diff --git a/sample-programs/basic-2 b/sample-programs/basic-2 index f7d0807..2f0448c 100644 --- a/sample-programs/basic-2 +++ b/sample-programs/basic-2 @@ -1,3 +1,5 @@ +add : _Int -> _Int -> _Int ; add x = \y. x+y; -main = (\z. z+z) ((add 4) 6); +main : _Int ; +main = (\z. z+z) ((add 4) 6) ; diff --git a/sample-programs/basic-3 b/sample-programs/basic-3 index 9443439..7ba4971 100644 --- a/sample-programs/basic-3 +++ b/sample-programs/basic-3 @@ -1,2 +1,2 @@ - -main = (\x. x+x+3) ((\x. x) 2) +main : _Int ; +main = (\x. x+x+3) ((\x. x) 2) ; diff --git a/sample-programs/basic-4 b/sample-programs/basic-4 index 1de7a8c..365e4cb 100644 --- a/sample-programs/basic-4 +++ b/sample-programs/basic-4 @@ -1,2 +1,2 @@ - +f : _Int -> _Int ; f x = let g = (\y. y+1) in g (g x) diff --git a/sample-programs/basic-5 b/sample-programs/basic-5 index 9984ddd..e42b5f9 100644 --- a/sample-programs/basic-5 +++ b/sample-programs/basic-5 @@ -1,9 +1,14 @@ -id x = x; +-- double : _Int -> _Int ; +-- double n = n + n; -add x y = x + y; +apply : ('a -> 'b -> 'c) -> 'a -> 'b -> 'c ; +apply f x = \y. f x y ; -double n = n + n; +id : 'a -> 'a ; +id x = x ; -apply f x = \y. f x y; +add : _Int -> _Int -> _Int ; +add x y = x + y ; -main = apply (id add) ((\x. x + 1) 1) (double 3); +main : _Int -> _Int -> _Int ; +main = (id add) 1 2 ; diff --git a/src/Main.hs b/src/Main.hs index bef4a3b..7e3922d 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -3,15 +3,15 @@ module Main where -- import Codegen.Codegen (compile) -import Grammar.ErrM (Err) -import Grammar.Par (myLexer, pProgram) -import Grammar.Print (printTree) +import Grammar.ErrM (Err) +import Grammar.Par (myLexer, pProgram) +import Grammar.Print (printTree) -- import LambdaLifter.LambdaLifter (lambdaLift) -import Renamer.Renamer (rename) -import System.Environment (getArgs) -import System.Exit (exitFailure, exitSuccess) -import TypeChecker.TypeChecker (typecheck) +import Renamer.Renamer (rename) +import System.Environment (getArgs) +import System.Exit (exitFailure, exitSuccess) +import TypeChecker.TypeChecker (typecheck) main :: IO () main = diff --git a/src/TypeChecker/Bugs.md b/src/TypeChecker/Bugs.md index 616f0fe..a7875d1 100644 --- a/src/TypeChecker/Bugs.md +++ b/src/TypeChecker/Bugs.md @@ -1,8 +1,22 @@ ## Bugs -### Polymorphic type variables are global? +None known at this moment + +## Fixed bugs + +* 1 + +```hs +fmap : ('a -> 'b) -> Maybe ('a) -> Maybe ('b) ; +fmap f x = + case x of { + Just x => Just (f x) ; + Nothing => Nothing + } +``` + +* 2 -This doesn't work (occurs check failed, can't unify `(a -> a) = a` ```hs data Maybe ('a) where { Nothing : Maybe ('a) @@ -29,16 +43,3 @@ id x = x ; main : Maybe ('a -> 'a) ; main = Just id; ``` -UPDATE: Might have found a fix. Need to be tested. - -### The function f is not carried into the case-expression - -Code example that does not type check -```hs -fmap : ('a -> 'b) -> Maybe ('a) -> Maybe ('b) ; -fmap f x = - case x of { - Just x => Just (f x) ; - Nothing => Nothing - } -``` diff --git a/src/TypeChecker/TypeChecker.hs b/src/TypeChecker/TypeChecker.hs index e1a6a2c..607dcfe 100644 --- a/src/TypeChecker/TypeChecker.hs +++ b/src/TypeChecker/TypeChecker.hs @@ -61,7 +61,7 @@ freshenData (Data (Constr name ts) constrs) = do where freshenType :: Ident -> Type -> Type freshenType iden = \case - (TPol a) -> TPol iden + (TPol _) -> TPol iden (TArr a b) -> TArr (freshenType iden a) (freshenType iden b) (TConstr (Constr a ts)) -> TConstr (Constr a (map (freshenType iden) ts)) diff --git a/tests/Tests.hs b/tests/Tests.hs index 5c52939..6e20745 100644 --- a/tests/Tests.hs +++ b/tests/Tests.hs @@ -1,20 +1,26 @@ {-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} + {-# HLINT ignore "Use <$>" #-} {-# HLINT ignore "Use camelCase" #-} module Main where -import Data.Either (isLeft, isRight) -import Data.Map (Map) -import qualified Data.Map as M -import Grammar.Abs -import Test.Hspec -import Test.QuickCheck -import TypeChecker.TypeChecker -import qualified TypeChecker.TypeCheckerIr as T -import TypeChecker.TypeCheckerIr (Ctx (..), Env (..), Error, Infer, - Poly (..)) +import Data.Either (isLeft, isRight) +import Data.Map (Map) +import Data.Map qualified as M +import Grammar.Abs +import Test.Hspec +import Test.QuickCheck +import TypeChecker.TypeChecker +import TypeChecker.TypeCheckerIr ( + Ctx (..), + Env (..), + Error, + Infer, + Poly (..), + ) +import TypeChecker.TypeCheckerIr qualified as T main :: IO () main = hspec $ do @@ -67,10 +73,11 @@ infer_eabs = describe "algoW used on EAbs" $ do it "should infer the argument type as polymorphic if it is not used in the lambda" $ do let lambda = EAbs "x" (ELit (LInt 0)) getType lambda `shouldSatisfy` isArrowPolyToMono + it "should infer a variable as function if used as one" $ do let lambda = EAbs "f" (EAbs "x" (EApp (EId "f") (EId "x"))) let isOk (Right (TArr (TArr (TPol _) (TPol _)) (TArr (TPol _) (TPol _)))) = True - isOk _ = False + isOk _ = False getType lambda `shouldSatisfy` isOk infer_eapp = describe "algoW used on EApp" $ do @@ -81,9 +88,21 @@ infer_eapp = describe "algoW used on EApp" $ do let ctx = Ctx (M.singleton (Ident (x :: String)) t) getTypeC env ctx (EApp (EId (Ident x)) (EId (Ident x))) `shouldBe` Left "Occurs check failed" +churf_id :: Bind +churf_id = Bind "id" (TArr (TPol "a") (TPol "a")) "id" ["x"] (EId "x") + +churf_add :: Bind +churf_add = Bind "add" (TArr (TMono "Int") (TArr (TMono "Int") (TMono "Int"))) "add" ["x", "y"] (EAdd (EId "x") (EId "y")) + +churf_main :: Bind +churf_main = Bind "main" (TArr (TMono "Int") (TArr (TMono "Int") (TMono "Int"))) "main" [] (EApp (EId "id") (EId "add")) + +test_bug :: IO () +test_bug = undefined + isArrowPolyToMono :: Either Error Type -> Bool isArrowPolyToMono (Right (TArr (TPol _) (TMono _))) = True -isArrowPolyToMono _ = False +isArrowPolyToMono _ = False -- | Empty environment getType :: Exp -> Either Error Type From eef6fa76683fc3aab2aedcd6ad1b6dc6afef3a92 Mon Sep 17 00:00:00 2001 From: sebastianselander Date: Mon, 6 Mar 2023 16:25:03 +0100 Subject: [PATCH 069/372] added new test and found another bug --- sample-programs/basic-5 | 7 +- src/TypeChecker/Bugs.md | 38 ++++++ src/TypeChecker/TypeChecker.hs | 80 +++++++------ src/TypeChecker/TypeCheckerIr.hs | 193 ++++++++++++++++++------------- tests/Tests.hs | 16 ++- 5 files changed, 210 insertions(+), 124 deletions(-) diff --git a/sample-programs/basic-5 b/sample-programs/basic-5 index e42b5f9..7175091 100644 --- a/sample-programs/basic-5 +++ b/sample-programs/basic-5 @@ -2,7 +2,7 @@ -- double n = n + n; apply : ('a -> 'b -> 'c) -> 'a -> 'b -> 'c ; -apply f x = \y. f x y ; +apply f x y = f x y ; id : 'a -> 'a ; id x = x ; @@ -11,4 +11,7 @@ add : _Int -> _Int -> _Int ; add x y = x + y ; main : _Int -> _Int -> _Int ; -main = (id add) 1 2 ; +main = apply (id add) ; + +idadd : _Int -> _Int -> _Int ; +idadd = id add ; diff --git a/src/TypeChecker/Bugs.md b/src/TypeChecker/Bugs.md index a7875d1..a265cde 100644 --- a/src/TypeChecker/Bugs.md +++ b/src/TypeChecker/Bugs.md @@ -2,6 +2,44 @@ None known at this moment +main\_bug should not typecheck + +```hs +apply : ('a -> 'b -> 'c) -> 'a -> 'b -> 'c ; +apply f x = \y. f x y ; + +id : 'a -> 'a ; +id x = x ; + +add : _Int -> _Int -> _Int ; +add x y = x + y ; + +main_bug : _Int -> _Int -> _Int ; +main_bug= (apply id) add ; + +idadd : _Int -> _Int -> _Int ; +idadd = id add ; +``` + +main\_bug should typecheck + +```hs +apply : ('a -> 'b -> 'c) -> 'a -> 'b -> 'c ; +apply f x = \y. f x y ; + +id : 'a -> 'a ; +id x = x ; + +add : _Int -> _Int -> _Int ; +add x y = x + y ; + +main_bug : _Int -> _Int -> _Int ; +main_bug = apply (id add) ; + +idadd : _Int -> _Int -> _Int ; +idadd = id add ; +``` + ## Fixed bugs * 1 diff --git a/src/TypeChecker/TypeChecker.hs b/src/TypeChecker/TypeChecker.hs index 607dcfe..b99313d 100644 --- a/src/TypeChecker/TypeChecker.hs +++ b/src/TypeChecker/TypeChecker.hs @@ -14,6 +14,7 @@ import Data.Map (Map) import Data.Map qualified as M import Data.Set (Set) import Data.Set qualified as S +import Debug.Trace (trace) import Grammar.Abs import Grammar.Print (printTree) import TypeChecker.TypeCheckerIr ( @@ -300,38 +301,41 @@ algoW = \case -- | Unify two types producing a new substitution unify :: Type -> Type -> Infer Subst -unify t0 t1 = case (t0, t1) of - (TArr a b, TArr c d) -> do - s1 <- unify a c - s2 <- unify (apply s1 b) (apply s1 d) - return $ s1 `compose` s2 - (TPol a, b) -> occurs a b - (a, TPol b) -> occurs b a - (TMono a, TMono b) -> - if a == b then return M.empty else throwError "Types do not unify" - -- \| TODO: Figure out a cleaner way to express the same thing - (TConstr (Constr name t), TConstr (Constr name' t')) -> - if name == name' && length t == length t' - then do - xs <- zipWithM unify t t' - return $ foldr compose nullSubst xs - else - throwError $ - unwords - [ "Type constructor:" - , printTree name - , "(" ++ printTree t ++ ")" - , "does not match with:" - , printTree name' - , "(" ++ printTree t' ++ ")" - ] - (a, b) -> - throwError . unwords $ - [ "Type:" - , printTree a - , "can't be unified with:" - , printTree b - ] +unify t0 t1 = do + trace ("t0: " ++ show t0) return () + trace ("t1: " ++ show t1) return () + case (t0, t1) of + (TArr a b, TArr c d) -> do + s1 <- unify a c + s2 <- unify (apply s1 b) (apply s1 d) + return $ s1 `compose` s2 + (TPol a, b) -> occurs a b + (a, TPol b) -> occurs b a + (TMono a, TMono b) -> + if a == b then return M.empty else throwError "Types do not unify" + -- \| TODO: Figure out a cleaner way to express the same thing + (TConstr (Constr name t), TConstr (Constr name' t')) -> + if name == name' && length t == length t' + then do + xs <- zipWithM unify t t' + return $ foldr compose nullSubst xs + else + throwError $ + unwords + [ "Type constructor:" + , printTree name + , "(" ++ printTree t ++ ")" + , "does not match with:" + , printTree name' + , "(" ++ printTree t' ++ ")" + ] + (a, b) -> + throwError . unwords $ + [ "Type:" + , printTree a + , "can't be unified with:" + , printTree b + ] {- | Check if a type is contained in another type. I.E. { a = a -> b } is an unsolvable constraint since there is no substitution @@ -409,7 +413,7 @@ instance FreeVars (Map Ident Poly) where -- | Apply substitutions to the environment. applySt :: Subst -> Infer a -> Infer a -applySt s = local (\st -> st {vars = apply s (vars st)}) +applySt s = local (\st -> st{vars = apply s (vars st)}) -- | Represents the empty substition set nullSubst :: Subst @@ -419,21 +423,21 @@ nullSubst = M.empty fresh :: Infer Type fresh = do n <- gets count - modify (\st -> st {count = n + 1}) + modify (\st -> st{count = n + 1}) return . TPol . Ident $ show n -- | Run the monadic action with an additional binding withBinding :: (Monad m, MonadReader Ctx m) => Ident -> Poly -> m a -> m a -withBinding i p = local (\st -> st {vars = M.insert i p (vars st)}) +withBinding i p = local (\st -> st{vars = M.insert i p (vars st)}) -- | Insert a function signature into the environment insertSig :: Ident -> Type -> Infer () -insertSig i t = modify (\st -> st {sigs = M.insert i t (sigs st)}) +insertSig i t = modify (\st -> st{sigs = M.insert i t (sigs st)}) -- | Insert a constructor with its data type insertConstr :: Ident -> Type -> Infer () insertConstr i t = - modify (\st -> st {constructors = M.insert i t (constructors st)}) + modify (\st -> st{constructors = M.insert i t (constructors st)}) -------- PATTERN MATCHING --------- @@ -441,7 +445,7 @@ insertConstr i t = checkInj :: Type -> Inj -> Infer (T.Inj, Type) checkInj caseType (Inj it expr) = do (args, t') <- initType caseType it - (_, t, e') <- local (\st -> st {vars = args `M.union` vars st}) (algoW expr) + (_, t, e') <- local (\st -> st{vars = args `M.union` vars st}) (algoW expr) return (T.Inj (it, t') e', t) initType :: Type -> Init -> Infer (Map Ident Poly, Type) diff --git a/src/TypeChecker/TypeCheckerIr.hs b/src/TypeChecker/TypeCheckerIr.hs index c07da96..475201e 100644 --- a/src/TypeChecker/TypeCheckerIr.hs +++ b/src/TypeChecker/TypeCheckerIr.hs @@ -2,27 +2,33 @@ module TypeChecker.TypeCheckerIr where -import Control.Monad.Except -import Control.Monad.Reader -import Control.Monad.State -import Data.Functor.Identity (Identity) -import Data.Map (Map) -import Grammar.Abs (Data (..), Ident (..), Init (..), - Literal (..), Type (..)) -import Grammar.Print -import Prelude -import qualified Prelude as C (Eq, Ord, Read, Show) +import Control.Monad.Except +import Control.Monad.Reader +import Control.Monad.State +import Data.Functor.Identity (Identity) +import Data.Map (Map) +import Grammar.Abs ( + Data (..), + Ident (..), + Init (..), + Literal (..), + Type (..), + ) +import Grammar.Print +import Prelude +import Prelude qualified as C (Eq, Ord, Read, Show) -- | A data type representing type variables data Poly = Forall [Ident] Type - deriving Show + deriving (Show) -newtype Ctx = Ctx { vars :: Map Ident Poly } +newtype Ctx = Ctx {vars :: Map Ident Poly} -data Env = Env { count :: Int - , sigs :: Map Ident Type - , constructors :: Map Ident Type - } +data Env = Env + { count :: Int + , sigs :: Map Ident Type + , constructors :: Map Ident Type + } type Error = String type Subst = Map Ident Type @@ -30,17 +36,17 @@ type Subst = Map Ident Type type Infer = StateT Env (ReaderT Ctx (ExceptT Error Identity)) newtype Program = Program [Def] - deriving (C.Eq, C.Ord, C.Show, C.Read) + deriving (C.Eq, C.Ord, C.Show, C.Read) data Exp - = EId Id + = EId Id | ELit Type Literal | ELet Bind Exp | EApp Type Exp Exp | EAdd Type Exp Exp | EAbs Type Id Exp | ECase Type Exp [Inj] - deriving (C.Eq, C.Ord, C.Read, C.Show) + deriving (C.Eq, C.Ord, C.Read, C.Show) data Inj = Inj (Init, Type) Exp deriving (C.Eq, C.Ord, C.Read, C.Show) @@ -54,90 +60,119 @@ data Bind = Bind Id Exp deriving (C.Eq, C.Ord, C.Show, C.Read) instance Print [Def] where - prt _ [] = concatD [] - prt _ (x:xs) = concatD [prt 0 x, doc (showString "\n"), prt 0 xs] + prt _ [] = concatD [] + prt _ (x : xs) = concatD [prt 0 x, doc (showString "\n"), prt 0 xs] instance Print Def where - prt i (DBind bind) = prt i bind - prt i (DData d) = prt i d + prt i (DBind bind) = prt i bind + prt i (DData d) = prt i d instance Print Program where prt i (Program sc) = prPrec i 0 $ prt 0 sc instance Print Bind where - prt i (Bind (t, name) rhs) = prPrec i 0 $ concatD - [ prt 0 name - , doc $ showString ":" - , prt 1 t - , doc $ showString "=" - , prt 2 rhs - ] + prt i (Bind (t, name) rhs) = + prPrec i 0 $ + concatD + [ prt 0 name + , doc $ showString ":" + , prt 0 t + , doc $ showString "\n" + , prt 0 name + , 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 ";"), doc (showString "\n"), prt 0 xs] + prt _ [] = concatD [] + prt _ [x] = concatD [prt 0 x] + prt _ (x : xs) = concatD [prt 0 x, doc (showString ";"), doc (showString "\n"), 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 - ] +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 ")" - ] - +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 + prt i = \case + EId n -> prPrec i 3 $ concatD [prtId 0 n, doc $ showString "\n"] + ELit _ (LInt i1) -> prPrec i 3 $ concatD [prt 0 i1, doc $ showString "\n"] + ELet bs e -> + prPrec i 3 $ + concatD [ doc $ showString "let" , prt 0 bs , doc $ showString "in" , prt 0 e + , doc $ showString "\n" ] - EApp _ 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 - ] - ECase t exp injs -> prPrec i 0 (concatD [doc (showString "case"), prt 0 exp, doc (showString "of"), doc (showString "{"), prt 0 injs, doc (showString "}"), doc (showString ":"), prt 0 t]) + EApp _ 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 + , doc $ showString "\n" + ] + EAbs t n e -> + prPrec i 0 $ + concatD + [ doc $ showString "@" + , prt 0 t + , doc $ showString "\\" + , prtId 0 n + , doc $ showString "." + , prt 0 e + , doc $ showString "\n" + ] + ECase t exp injs -> + prPrec + i + 0 + ( concatD + [ doc (showString "case") + , prt 0 exp + , doc (showString "of") + , doc (showString "{") + , prt 0 injs + , doc (showString "}") + , doc (showString ":") + , prt 0 t + , doc $ showString "\n" + ] + ) instance Print Inj where - prt i = \case - Inj (init,t) exp -> prPrec i 0 (concatD [prt 0 init, doc (showString ":"), prt 0 t, doc (showString "=>"), prt 0 exp]) + prt i = \case + Inj (init, t) exp -> prPrec i 0 (concatD [prt 0 init, doc (showString ":"), prt 0 t, doc (showString "=>"), prt 0 exp]) instance Print [Inj] where - prt _ [] = concatD [] - prt _ [x] = concatD [prt 0 x] - prt _ (x:xs) = concatD [prt 0 x, doc (showString ";"), prt 0 xs] - - - - + prt _ [] = concatD [] + prt _ [x] = concatD [prt 0 x] + prt _ (x : xs) = concatD [prt 0 x, doc (showString ";"), prt 0 xs] diff --git a/tests/Tests.hs b/tests/Tests.hs index 6e20745..655c086 100644 --- a/tests/Tests.hs +++ b/tests/Tests.hs @@ -29,6 +29,7 @@ main = hspec $ do infer_eid infer_eabs infer_eapp + test_id_function infer_elit = describe "algoW used on ELit" $ do it "infers the type mono Int" $ do @@ -86,19 +87,24 @@ infer_eapp = describe "algoW used on EApp" $ do let env = Env 0 mempty mempty let t = Forall [] (TPol "a") let ctx = Ctx (M.singleton (Ident (x :: String)) t) - getTypeC env ctx (EApp (EId (Ident x)) (EId (Ident x))) `shouldBe` Left "Occurs check failed" + getTypeC env ctx (EApp (EId (Ident x)) (EId (Ident x))) `shouldSatisfy` isLeft -churf_id :: Bind +churf_id :: Bind churf_id = Bind "id" (TArr (TPol "a") (TPol "a")) "id" ["x"] (EId "x") churf_add :: Bind churf_add = Bind "add" (TArr (TMono "Int") (TArr (TMono "Int") (TMono "Int"))) "add" ["x", "y"] (EAdd (EId "x") (EId "y")) churf_main :: Bind -churf_main = Bind "main" (TArr (TMono "Int") (TArr (TMono "Int") (TMono "Int"))) "main" [] (EApp (EId "id") (EId "add")) +churf_main = Bind "main" (TArr (TMono "Int") (TMono "Int")) "main" [] (EApp (EApp (EId "id") (EId "add")) (ELit (LInt 0))) -test_bug :: IO () -test_bug = undefined +prg = Program [DBind churf_main, DBind churf_add, DBind churf_id] + +test_id_function :: SpecWith () +test_id_function = + describe "typechecking a program with id, add and main, where id is applied to add in main" $ do + it "should succeed to find the correct type" $ do + typecheck prg `shouldSatisfy` isRight isArrowPolyToMono :: Either Error Type -> Bool isArrowPolyToMono (Right (TArr (TPol _) (TMono _))) = True From fce54e789996970dfe1bd71914f0c6f6669415a0 Mon Sep 17 00:00:00 2001 From: sebastianselander Date: Mon, 6 Mar 2023 16:41:59 +0100 Subject: [PATCH 070/372] documented possible bad functions --- sample-programs/basic-5 | 13 ++----------- src/TypeChecker/TypeChecker.hs | 26 +++++++++++++++----------- 2 files changed, 17 insertions(+), 22 deletions(-) diff --git a/sample-programs/basic-5 b/sample-programs/basic-5 index 7175091..9a9a723 100644 --- a/sample-programs/basic-5 +++ b/sample-programs/basic-5 @@ -1,17 +1,8 @@ -- double : _Int -> _Int ; -- double n = n + n; -apply : ('a -> 'b -> 'c) -> 'a -> 'b -> 'c ; -apply f x y = f x y ; - id : 'a -> 'a ; id x = x ; -add : _Int -> _Int -> _Int ; -add x y = x + y ; - -main : _Int -> _Int -> _Int ; -main = apply (id add) ; - -idadd : _Int -> _Int -> _Int ; -idadd = id add ; +main : ('a -> 'b -> 'c) ; +main = id ; diff --git a/src/TypeChecker/TypeChecker.hs b/src/TypeChecker/TypeChecker.hs index b99313d..af4734d 100644 --- a/src/TypeChecker/TypeChecker.hs +++ b/src/TypeChecker/TypeChecker.hs @@ -45,6 +45,7 @@ typecheck = run . checkPrg {- | Start by freshening the type variable of data types to avoid clash with other user defined polymorphic types +This might be wrong for type constructors that work over several variables -} freshenData :: Data -> Infer Data freshenData (Data (Constr name ts) constrs) = do @@ -59,18 +60,21 @@ freshenData (Data (Constr name ts) constrs) = do let new_ts = map (freshenType fr') ts let new_constrs = map (freshenConstr fr') constrs return $ Data (Constr name new_ts) new_constrs - where - freshenType :: Ident -> Type -> Type - freshenType iden = \case - (TPol _) -> TPol iden - (TArr a b) -> TArr (freshenType iden a) (freshenType iden b) - (TConstr (Constr a ts)) -> - TConstr (Constr a (map (freshenType iden) ts)) - rest -> rest - freshenConstr :: Ident -> Constructor -> Constructor - freshenConstr iden (Constructor name t) = - Constructor name (freshenType iden t) +{- | Freshen all polymorphic variables, regardless of name +| freshenType "d" (a -> b -> c) becomes (d -> d -> d) +-} +freshenType :: Ident -> Type -> Type +freshenType iden = \case + (TPol _) -> TPol iden + (TArr a b) -> TArr (freshenType iden a) (freshenType iden b) + (TConstr (Constr a ts)) -> + TConstr (Constr a (map (freshenType iden) ts)) + rest -> rest + +freshenConstr :: Ident -> Constructor -> Constructor +freshenConstr iden (Constructor name t) = + Constructor name (freshenType iden t) checkData :: Data -> Infer () checkData d = do From 887c3b83913bf5cf69d5c91f42d56bda239d512c Mon Sep 17 00:00:00 2001 From: Rakarake Date: Tue, 7 Mar 2023 16:42:56 +0100 Subject: [PATCH 071/372] 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 072/372] 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 bff75bb00bf44cd0d8bfa6d1cdb8b018d318495f Mon Sep 17 00:00:00 2001 From: Samuel Hammersberg Date: Wed, 8 Mar 2023 10:22:21 +0100 Subject: [PATCH 073/372] Switched an Int to Integer. --- src/Compiler.hs | 59 ++++++++++++++++++++++++++++++++++++------------- src/LlvmIr.hs | 2 +- 2 files changed, 45 insertions(+), 16 deletions(-) diff --git a/src/Compiler.hs b/src/Compiler.hs index 3b57dbe..b6bc408 100644 --- a/src/Compiler.hs +++ b/src/Compiler.hs @@ -4,8 +4,10 @@ module Compiler (compile) where import Auxiliary (snoc) -import Control.Monad.State (StateT, execStateT, gets, modify) +import Control.Monad.State (StateT, execStateT, foldM, foldM_, gets, + modify) import qualified Data.Bifunctor as BI +import Data.Foldable (traverse_) import Data.List.Extra (trim) import Data.Map (Map) import qualified Data.Map as Map @@ -19,7 +21,6 @@ import LlvmIr (CallingConvention (..), LLVMComp (..), import System.Process.Extra (readCreateProcess, shell) import TypeCheckerIr (Bind (..), Case (..), Exp (..), Id, Ident (..), Program (..), Type (..)) - -- | The record used as the code generator state data CodeGenerator = CodeGenerator { instructions :: [LLVMIr] @@ -89,8 +90,8 @@ getConstructors :: [Bind] -> Map Id ConstructorInfo getConstructors bs = Map.fromList $ go bs where go [] = [] - go (DataStructure n cons : xs) = do - fst (foldl (\(acc,i) (id, xs) -> (((id, TPol n), ConstructorInfo { + go (DataStructure (Ident n) cons : xs) = do + fst (foldl (\(acc,i) (Ident id, xs) -> (((Ident (n <> "_" <> id), TPol (Ident n)), ConstructorInfo { numArgsCI=length xs, argumentsCI=createArgs xs, numCI=i @@ -117,12 +118,12 @@ run s = do test :: Integer -> Program test v = Program [ DataStructure (Ident "Craig") [ - (Ident "Bob", [TInt]), - (Ident "Alice", [TInt, TInt]) + (Ident "Bob", [TInt])--, + --(Ident "Alice", [TInt, TInt]) ], Bind (Ident "fibonacci", TInt) [(Ident "x", TInt)] (EId ("x",TInt)), Bind (Ident "main", TInt) [] ( - EApp TInt (EId (Ident "fibonacci", TInt)) (EInt v) -- (EInt 92) + EApp (TPol "Craig") (EId (Ident "Craig_Bob", TPol "Craig")) (EInt v) -- (EInt 92) ) ] @@ -140,18 +141,46 @@ compileScs [] = do -- as a last step create all the constructors c <- gets (Map.toList . constructors) mapM_ (\((id, t), ci) -> do + let t' = type2LlvmType t let x = BI.second type2LlvmType <$> argumentsCI ci - emit $ Define FastCC (type2LlvmType t) id x + emit $ Define FastCC t' id x top <- Ident . show <$> getNewVar ptr <- Ident . show <$> getNewVar - emit $ SetVariable top (Alloca (type2LlvmType t)) - -- %0 = getelementptr inbounds %Foo, %Foo* %x, i32 0, i32 0 + -- allocated the primary type + emit $ SetVariable top (Alloca t') + + -- set the first byte to the index of the constructor emit $ SetVariable ptr $ - GetElementPtrInbounds (type2LlvmType t) (Ref $ type2LlvmType t) + GetElementPtrInbounds t' (Ref t') (VIdent top I8) I32 (VInteger 0) I32 (VInteger 0) emit $ Store I8 (VInteger $ numCI ci ) (Ref I8) ptr - -- store i8 1, i8* %0 - emit $ Ret I64 (VInteger 0) + + -- get a pointer of the correct type + ptr' <- Ident . show <$> getNewVar + emit $ SetVariable ptr' (Bitcast (Ref t') ptr (Ref $ CustomType id)) + + --emit $ UnsafeRaw "\n" + + foldM_ (\i (Ident arg_n, arg_t)-> do + let arg_t' = type2LlvmType arg_t + emit $ Comment (show arg_t' <>" "<> arg_n <> " " <> show i ) + elemPtr <- Ident . show <$> getNewVar + emit $ SetVariable elemPtr ( + GetElementPtrInbounds (CustomType id) (Ref (CustomType id)) + (VIdent ptr' Ptr) I32 + (VInteger 0) I32 (VInteger i)) + emit $ Store arg_t' (VIdent (Ident arg_n) arg_t') Ptr elemPtr + -- %2 = getelementptr inbounds %Foo_AInteger, %Foo_AInteger* %1, i32 0, i32 1 + -- store i32 42, i32* %2 + pure $ i + 1-- + typeByteSize arg_t' + ) 1 (argumentsCI ci) + + --emit $ UnsafeRaw "\n" + + -- load and return the constructed value + load <- Ident . show <$> getNewVar + emit $ SetVariable load (Load t' Ptr top) + emit $ Ret t' (VIdent load t') emit DefineEnd modify $ \s -> s { variableCount = 0 } @@ -398,10 +427,10 @@ getType (ECase t _ _) = type2LlvmType t valueGetType :: LLVMValue -> LLVMType valueGetType (VInteger _) = I64 valueGetType (VIdent _ t) = t -valueGetType (VConstant s) = Array (length s) I8 +valueGetType (VConstant s) = Array (fromIntegral $ length s) I8 valueGetType (VFunction _ _ t) = t -typeByteSize :: LLVMType -> Int +typeByteSize :: LLVMType -> Integer typeByteSize I1 = 1 typeByteSize I8 = 1 typeByteSize I32 = 4 diff --git a/src/LlvmIr.hs b/src/LlvmIr.hs index 8f07346..f0cbf12 100644 --- a/src/LlvmIr.hs +++ b/src/LlvmIr.hs @@ -30,7 +30,7 @@ data LLVMType | Ptr | Ref LLVMType | Function LLVMType [LLVMType] - | Array Int LLVMType + | Array Integer LLVMType | CustomType Ident instance Show LLVMType where From 832efbcdd8ea5164c7fa90008a60156d37d8e090 Mon Sep 17 00:00:00 2001 From: Samuel Hammersberg Date: Wed, 8 Mar 2023 10:24:52 +0100 Subject: [PATCH 074/372] Gave the code generator a proper module name. --- language.cabal | 4 ++-- src/{Compiler.hs => Codegen/Codegen.hs} | 10 +++++----- src/{ => Codegen}/LlvmIr.hs | 2 +- src/Main.hs | 2 +- 4 files changed, 9 insertions(+), 9 deletions(-) rename src/{Compiler.hs => Codegen/Codegen.hs} (99%) rename src/{ => Codegen}/LlvmIr.hs (99%) diff --git a/language.cabal b/language.cabal index bddbd21..6a89860 100644 --- a/language.cabal +++ b/language.cabal @@ -38,8 +38,8 @@ executable language TypeChecker TypeCheckerIr -- Interpreter - Compiler - LlvmIr + Codegen.Codegen + Codegen.LlvmIr hs-source-dirs: src build-depends: diff --git a/src/Compiler.hs b/src/Codegen/Codegen.hs similarity index 99% rename from src/Compiler.hs rename to src/Codegen/Codegen.hs index b6bc408..b32f73f 100644 --- a/src/Compiler.hs +++ b/src/Codegen/Codegen.hs @@ -1,9 +1,13 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} -module Compiler (compile) where +module Codegen.Codegen (compile) where import Auxiliary (snoc) +import Codegen.LlvmIr (CallingConvention (..), LLVMComp (..), + LLVMIr (..), LLVMType (..), + LLVMValue (..), Visibility (..), + llvmIrToString) import Control.Monad.State (StateT, execStateT, foldM, foldM_, gets, modify) import qualified Data.Bifunctor as BI @@ -14,10 +18,6 @@ import qualified Data.Map as Map import Data.Tuple.Extra (dupe, first, second) import qualified Grammar.Abs as GA import Grammar.ErrM (Err) -import LlvmIr (CallingConvention (..), LLVMComp (..), - LLVMIr (..), LLVMType (..), - LLVMValue (..), Visibility (..), - llvmIrToString) import System.Process.Extra (readCreateProcess, shell) import TypeCheckerIr (Bind (..), Case (..), Exp (..), Id, Ident (..), Program (..), Type (..)) diff --git a/src/LlvmIr.hs b/src/Codegen/LlvmIr.hs similarity index 99% rename from src/LlvmIr.hs rename to src/Codegen/LlvmIr.hs index f0cbf12..e412273 100644 --- a/src/LlvmIr.hs +++ b/src/Codegen/LlvmIr.hs @@ -1,6 +1,6 @@ {-# LANGUAGE LambdaCase #-} -module LlvmIr ( +module Codegen.LlvmIr ( LLVMType (..), LLVMIr (..), llvmIrToString, diff --git a/src/Main.hs b/src/Main.hs index 29b7158..313d952 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -2,7 +2,7 @@ module Main where -import Compiler (compile) +import Codegen.Codegen (compile) import GHC.IO.Handle.Text (hPutStrLn) import Grammar.ErrM (Err) import Grammar.Par (myLexer, pProgram) From 2af00da48266b4bfc2cc560c4103bd4ea93b58a3 Mon Sep 17 00:00:00 2001 From: Samuel Hammersberg Date: Wed, 8 Mar 2023 10:25:53 +0100 Subject: [PATCH 075/372] Renamed the `compile` function to generate `code` --- src/Codegen/Codegen.hs | 6 +++--- src/Main.hs | 4 ++-- 2 files changed, 5 insertions(+), 5 deletions(-) diff --git a/src/Codegen/Codegen.hs b/src/Codegen/Codegen.hs index b32f73f..8c7c1d3 100644 --- a/src/Codegen/Codegen.hs +++ b/src/Codegen/Codegen.hs @@ -1,7 +1,7 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} -module Codegen.Codegen (compile) where +module Codegen.Codegen (generateCode) where import Auxiliary (snoc) import Codegen.LlvmIr (CallingConvention (..), LLVMComp (..), @@ -131,8 +131,8 @@ test v = Program [ An easy way to actually "compile" this output is to Simply pipe it to LLI -} -compile :: Program -> Err String -compile (Program scs) = do +generateCode :: Program -> Err String +generateCode (Program scs) = do let codegen = initCodeGenerator scs llvmIrToString . instructions <$> execStateT (compileScs scs) codegen diff --git a/src/Main.hs b/src/Main.hs index 313d952..01d4f1d 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -2,7 +2,7 @@ module Main where -import Codegen.Codegen (compile) +import Codegen.Codegen (generateCode) import GHC.IO.Handle.Text (hPutStrLn) import Grammar.ErrM (Err) import Grammar.Par (myLexer, pProgram) @@ -51,7 +51,7 @@ main' debug s = do printToErr $ printTree lifted printToErr "\n -- Printing compiler output to stdout --" - compiled <- fromCompilerErr $ compile lifted + compiled <- fromCompilerErr $ generateCode lifted --putStrLn compiled check <- doesPathExist "output" From ac0ac2dac7fcd763fc908b9947a4cd8c8062baee Mon Sep 17 00:00:00 2001 From: Samuel Hammersberg Date: Wed, 8 Mar 2023 10:27:39 +0100 Subject: [PATCH 076/372] Removed a few imports. --- src/Codegen/Codegen.hs | 4 +--- src/Main.hs | 4 ++-- 2 files changed, 3 insertions(+), 5 deletions(-) diff --git a/src/Codegen/Codegen.hs b/src/Codegen/Codegen.hs index 8c7c1d3..ffa1af5 100644 --- a/src/Codegen/Codegen.hs +++ b/src/Codegen/Codegen.hs @@ -8,10 +8,8 @@ import Codegen.LlvmIr (CallingConvention (..), LLVMComp (..), LLVMIr (..), LLVMType (..), LLVMValue (..), Visibility (..), llvmIrToString) -import Control.Monad.State (StateT, execStateT, foldM, foldM_, gets, - modify) +import Control.Monad.State (StateT, execStateT, foldM_, gets, modify) import qualified Data.Bifunctor as BI -import Data.Foldable (traverse_) import Data.List.Extra (trim) import Data.Map (Map) import qualified Data.Map as Map diff --git a/src/Main.hs b/src/Main.hs index 01d4f1d..e3a924a 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -9,12 +9,12 @@ import Grammar.Par (myLexer, pProgram) import Grammar.Print (printTree) -- import Interpreter (interpret) -import Control.Monad (unless, when) +import Control.Monad (when) import Data.List.Extra (isSuffixOf) import LambdaLifter (lambdaLift) import Renamer (rename) import System.Directory (createDirectory, doesPathExist, - getDirectoryContents, removeDirectory, + getDirectoryContents, removeDirectoryRecursive, setCurrentDirectory) import System.Environment (getArgs) From d5dd7896d8ea1f948a54f2add15d438824508fbd Mon Sep 17 00:00:00 2001 From: Samuel Hammersberg Date: Wed, 8 Mar 2023 10:35:07 +0100 Subject: [PATCH 077/372] Moved modules into a proper folder structure. --- language.cabal | 8 +- src/Codegen/Codegen.hs | 33 +++---- src/Codegen/LlvmIr.hs | 4 +- src/Interpreter.hs | 116 ------------------------- src/{ => LambdaLifter}/LambdaLifter.hs | 23 ++--- src/Main.hs | 36 ++++---- src/{ => Renamer}/Renamer.hs | 2 +- src/{ => TypeChecker}/TypeChecker.hs | 20 ++--- src/{ => TypeChecker}/TypeCheckerIr.hs | 4 +- 9 files changed, 66 insertions(+), 180 deletions(-) delete mode 100644 src/Interpreter.hs rename src/{ => LambdaLifter}/LambdaLifter.hs (91%) rename src/{ => Renamer}/Renamer.hs (98%) rename src/{ => TypeChecker}/TypeChecker.hs (91%) rename src/{ => TypeChecker}/TypeCheckerIr.hs (98%) diff --git a/language.cabal b/language.cabal index 6a89860..e190a7e 100644 --- a/language.cabal +++ b/language.cabal @@ -32,11 +32,11 @@ executable language Grammar.Print Grammar.Skel Grammar.ErrM - LambdaLifter + LambdaLifter.LambdaLifter Auxiliary - Renamer - TypeChecker - TypeCheckerIr + Renamer.Renamer + TypeChecker.TypeChecker + TypeChecker.TypeCheckerIr -- Interpreter Codegen.Codegen Codegen.LlvmIr diff --git a/src/Codegen/Codegen.hs b/src/Codegen/Codegen.hs index ffa1af5..174d0b1 100644 --- a/src/Codegen/Codegen.hs +++ b/src/Codegen/Codegen.hs @@ -3,22 +3,23 @@ module Codegen.Codegen (generateCode) where -import Auxiliary (snoc) -import Codegen.LlvmIr (CallingConvention (..), LLVMComp (..), - LLVMIr (..), LLVMType (..), - LLVMValue (..), Visibility (..), - llvmIrToString) -import Control.Monad.State (StateT, execStateT, foldM_, gets, modify) -import qualified Data.Bifunctor as BI -import Data.List.Extra (trim) -import Data.Map (Map) -import qualified Data.Map as Map -import Data.Tuple.Extra (dupe, first, second) -import qualified Grammar.Abs as GA -import Grammar.ErrM (Err) -import System.Process.Extra (readCreateProcess, shell) -import TypeCheckerIr (Bind (..), Case (..), Exp (..), Id, - Ident (..), Program (..), Type (..)) +import Auxiliary (snoc) +import Codegen.LlvmIr (CallingConvention (..), + LLVMComp (..), LLVMIr (..), + LLVMType (..), LLVMValue (..), + Visibility (..), llvmIrToString) +import Control.Monad.State (StateT, execStateT, foldM_, gets, + modify) +import qualified Data.Bifunctor as BI +import Data.List.Extra (trim) +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Tuple.Extra (dupe, first, second) +import qualified Grammar.Abs as GA +import Grammar.ErrM (Err) +import System.Process.Extra (readCreateProcess, shell) +import TypeChecker.TypeCheckerIr (Bind (..), Case (..), Exp (..), Id, + Ident (..), Program (..), Type (..)) -- | The record used as the code generator state data CodeGenerator = CodeGenerator { instructions :: [LLVMIr] diff --git a/src/Codegen/LlvmIr.hs b/src/Codegen/LlvmIr.hs index e412273..08cd69d 100644 --- a/src/Codegen/LlvmIr.hs +++ b/src/Codegen/LlvmIr.hs @@ -10,8 +10,8 @@ module Codegen.LlvmIr ( CallingConvention (..) ) where -import Data.List (intercalate) -import TypeCheckerIr +import Data.List (intercalate) +import TypeChecker.TypeCheckerIr data CallingConvention = TailCC | FastCC | CCC | ColdCC instance Show CallingConvention where diff --git a/src/Interpreter.hs b/src/Interpreter.hs deleted file mode 100644 index 37d46a7..0000000 --- a/src/Interpreter.hs +++ /dev/null @@ -1,116 +0,0 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedRecordDot #-} -{-# LANGUAGE OverloadedStrings #-} -module Interpreter where - -import Auxiliary (maybeToRightM) -import Control.Applicative (Applicative) -import Control.Monad.Except (Except, MonadError (throwError), - liftEither) -import Control.Monad.State (MonadState, StateT, evalStateT) -import Data.Either.Combinators (maybeToRight) -import Data.Map (Map) -import qualified Data.Map as Map -import Data.Maybe (maybe) -import Grammar.Abs -import Grammar.ErrM (Err) -import Grammar.Print (printTree) - -interpret :: Program -> Err Integer -interpret (Program scs) = do - main <- findMain scs - eval (initCxt scs) main >>= - \case - VClosure {} -> throwError "main evaluated to a function" - VInt i -> pure i - - -initCxt :: [Bind] -> Cxt -initCxt scs = - Cxt { env = mempty - , sig = foldr insert mempty $ map expandLambdas scs - } - where insert (Bind name _ rhs) = Map.insert name rhs - -expandLambdas :: Bind -> Bind -expandLambdas (Bind name parms rhs) = Bind name [] $ foldr EAbs rhs parms - -findMain :: [Bind] -> Err Exp -findMain [] = throwError "No main!" -findMain (sc:scs) = case sc of - Bind "main" _ rhs -> pure rhs - _ -> findMain scs - -data Val = VInt Integer - | VClosure Env Ident Exp - deriving (Show, Eq) - -type Env = Map Ident Val -type Sig = Map Ident Exp - -data Cxt = Cxt - { env :: Map Ident Val - , sig :: Map Ident Exp - } deriving (Show, Eq) - -eval :: Cxt -> Exp -> Err Val -eval cxt = \case - - -- ------------ x ∈ γ - -- γ ⊢ x ⇓ γ(x) - - EId x -> do - case Map.lookup x cxt.env of - Just e -> pure e - Nothing -> - case Map.lookup x cxt.sig of - Just e -> eval (emptyEnv cxt) e - Nothing -> throwError ("Unbound variable: " ++ printTree x) - - -- --------- - -- γ ⊢ i ⇓ i - - EInt i -> pure $ VInt i - - -- γ ⊢ e ⇓ let δ in λx. f - -- γ ⊢ e₁ ⇓ v - -- δ,x=v ⊢ f ⇓ v₁ - -- ------------------------------ - -- γ ⊢ e e₁ ⇓ v₁ - - EApp e e1 -> - eval cxt e >>= \case - VInt _ -> throwError "Not a function" - VClosure delta x f -> do - v <- eval cxt e1 - let cxt' = putEnv (Map.insert x v delta) cxt - eval cxt' f - - - -- - -- ----------------------------- - -- γ ⊢ λx. f ⇓ let γ in λx. f - - EAbs par e -> pure $ VClosure cxt.env par e - - - -- γ ⊢ e ⇓ v - -- γ ⊢ e₁ ⇓ v₁ - -- ------------------ - -- γ ⊢ e e₁ ⇓ v + v₁ - - EAdd e e1 -> do - v <- eval cxt e - v1 <- eval cxt e1 - case (v, v1) of - (VInt i, VInt i1) -> pure $ VInt (i + i1) - _ -> throwError "Can't add a function" - - ELet _ _ -> throwError "ELet pattern match should never occur!" - - -emptyEnv :: Cxt -> Cxt -emptyEnv cxt = cxt { env = mempty } - -putEnv :: Env -> Cxt -> Cxt -putEnv env cxt = cxt { env = env } diff --git a/src/LambdaLifter.hs b/src/LambdaLifter/LambdaLifter.hs similarity index 91% rename from src/LambdaLifter.hs rename to src/LambdaLifter/LambdaLifter.hs index 6522bba..661b95a 100644 --- a/src/LambdaLifter.hs +++ b/src/LambdaLifter/LambdaLifter.hs @@ -2,18 +2,19 @@ {-# LANGUAGE OverloadedStrings #-} -module LambdaLifter (lambdaLift, freeVars, abstract, rename, collectScs) where +module LambdaLifter.LambdaLifter (lambdaLift, freeVars, abstract, rename, collectScs) where -import Auxiliary (snoc) -import Control.Applicative (Applicative (liftA2)) -import Control.Monad.State (MonadState (get, put), State, evalState) -import Data.Set (Set) -import qualified Data.Set as Set -import Debug.Trace (trace) -import qualified Grammar.Abs as GA -import Prelude hiding (exp) -import Renamer -import TypeCheckerIr +import Auxiliary (snoc) +import Control.Applicative (Applicative (liftA2)) +import Control.Monad.State (MonadState (get, put), State, + evalState) +import Data.Set (Set) +import qualified Data.Set as Set +import Debug.Trace (trace) +import qualified Grammar.Abs as GA +import Prelude hiding (exp) +import Renamer.Renamer +import TypeChecker.TypeCheckerIr -- | Lift lambdas and let expression into supercombinators. diff --git a/src/Main.hs b/src/Main.hs index e3a924a..7390341 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -2,26 +2,26 @@ module Main where -import Codegen.Codegen (generateCode) -import GHC.IO.Handle.Text (hPutStrLn) -import Grammar.ErrM (Err) -import Grammar.Par (myLexer, pProgram) -import Grammar.Print (printTree) +import Codegen.Codegen (generateCode) +import GHC.IO.Handle.Text (hPutStrLn) +import Grammar.ErrM (Err) +import Grammar.Par (myLexer, pProgram) +import Grammar.Print (printTree) -- import Interpreter (interpret) -import Control.Monad (when) -import Data.List.Extra (isSuffixOf) -import LambdaLifter (lambdaLift) -import Renamer (rename) -import System.Directory (createDirectory, doesPathExist, - getDirectoryContents, - removeDirectoryRecursive, - setCurrentDirectory) -import System.Environment (getArgs) -import System.Exit (exitFailure, exitSuccess) -import System.IO (stderr) -import System.Process.Extra (spawnCommand, waitForProcess) -import TypeChecker (typecheck) +import Control.Monad (when) +import Data.List.Extra (isSuffixOf) +import LambdaLifter.LambdaLifter (lambdaLift) +import Renamer.Renamer (rename) +import System.Directory (createDirectory, doesPathExist, + getDirectoryContents, + removeDirectoryRecursive, + setCurrentDirectory) +import System.Environment (getArgs) +import System.Exit (exitFailure, exitSuccess) +import System.IO (stderr) +import System.Process.Extra (spawnCommand, waitForProcess) +import TypeChecker.TypeChecker (typecheck) main :: IO () main = diff --git a/src/Renamer.hs b/src/Renamer/Renamer.hs similarity index 98% rename from src/Renamer.hs rename to src/Renamer/Renamer.hs index a91615b..3c426b4 100644 --- a/src/Renamer.hs +++ b/src/Renamer/Renamer.hs @@ -1,6 +1,6 @@ {-# LANGUAGE LambdaCase #-} -module Renamer (module Renamer) where +module Renamer.Renamer (module Renamer.Renamer) where import Auxiliary (mapAccumM) import Control.Monad (foldM) diff --git a/src/TypeChecker.hs b/src/TypeChecker/TypeChecker.hs similarity index 91% rename from src/TypeChecker.hs rename to src/TypeChecker/TypeChecker.hs index bb31a2f..3d6bba8 100644 --- a/src/TypeChecker.hs +++ b/src/TypeChecker/TypeChecker.hs @@ -1,18 +1,18 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedRecordDot #-} -module TypeChecker (typecheck, partitionType) where +module TypeChecker.TypeChecker (typecheck, partitionType) where -import Auxiliary (maybeToRightM, snoc) -import Control.Monad.Except (throwError, unless) -import Data.Map (Map) -import qualified Data.Map as Map +import Auxiliary (maybeToRightM, snoc) +import Control.Monad.Except (throwError, unless) +import Data.Map (Map) +import qualified Data.Map as Map import Grammar.Abs -import Grammar.ErrM (Err) -import Grammar.Print (Print (prt), concatD, doc, printTree, - render) -import Prelude hiding (exp, id) -import qualified TypeCheckerIr as T +import Grammar.ErrM (Err) +import Grammar.Print (Print (prt), concatD, doc, + printTree, render) +import Prelude hiding (exp, id) +import qualified TypeChecker.TypeCheckerIr as T -- NOTE: this type checker is poorly tested diff --git a/src/TypeCheckerIr.hs b/src/TypeChecker/TypeCheckerIr.hs similarity index 98% rename from src/TypeCheckerIr.hs rename to src/TypeChecker/TypeCheckerIr.hs index 8053bd1..7dfe3be 100644 --- a/src/TypeCheckerIr.hs +++ b/src/TypeChecker/TypeCheckerIr.hs @@ -1,8 +1,8 @@ {-# LANGUAGE LambdaCase #-} -module TypeCheckerIr +module TypeChecker.TypeCheckerIr ( module Grammar.Abs - , module TypeCheckerIr + , module TypeChecker.TypeCheckerIr ) where import Grammar.Abs (Ident (..), Type (..)) From 350cd3b0e911888ee3497ab18e3a9479a2c8c87b Mon Sep 17 00:00:00 2001 From: Samuel Hammersberg Date: Wed, 8 Mar 2023 11:01:07 +0100 Subject: [PATCH 078/372] Started importing Sebastian's new typechecker. --- Grammar.cf | 68 ++- sample-programs/basic-1 | 87 +-- src/Codegen/Codegen.hs | 882 ++++++++++++++++--------------- src/Codegen/LlvmIr.hs | 480 ++++++++--------- src/LambdaLifter/LambdaLifter.hs | 367 ++++++------- src/Main.hs | 58 +- src/Renamer/Renamer.hs | 74 +-- src/TypeChecker/TypeChecker.hs | 686 +++++++++++++++++------- src/TypeChecker/TypeCheckerIr.hs | 255 +++++---- 9 files changed, 1611 insertions(+), 1346 deletions(-) diff --git a/Grammar.cf b/Grammar.cf index dddab37..a55e8c4 100644 --- a/Grammar.cf +++ b/Grammar.cf @@ -1,33 +1,51 @@ -Program. Program ::= [Bind]; -EId. Exp3 ::= Ident; -EInt. Exp3 ::= Integer; -EAnn. Exp3 ::= "(" Exp ":" Type ")"; -ELet. Exp3 ::= "let" Bind "in" Exp; -EApp. Exp2 ::= Exp2 Exp3; -EAdd. Exp1 ::= Exp1 "+" Exp2; -ESub. Exp1 ::= Exp1 "-" Exp2; -EAbs. Exp ::= "\\" Ident ":" Type "." Exp; -ECase. Exp ::= "case" Exp "of" "{" [CaseMatch] "}" ":" Type; -CaseMatch. CaseMatch ::= Case "=>" Exp ; -separator CaseMatch ","; +Program. Program ::= [Def] ; - -CInt. Case ::= Integer ; -CatchAll. Case ::= "_" ; +DBind. Def ::= Bind ; +DData. Def ::= Data ; +separator Def ";" ; Bind. Bind ::= Ident ":" Type ";" - Ident [Ident] "=" Exp; + Ident [Ident] "=" Exp ; -separator Bind ";"; -separator Ident ""; +Data. Data ::= "data" Constr "where" "{" [Constructor] "}" ; -coercions Exp 3; +Constructor. Constructor ::= Ident ":" Type ; +separator nonempty Constructor "" ; -TInt. Type1 ::= "Int" ; -TPol. Type1 ::= Ident ; -TFun. Type ::= Type1 "->" Type ; -coercions Type 1 ; +TMono. Type1 ::= "_" Ident ; +TPol. Type1 ::= "'" Ident ; +TConstr. Type1 ::= Constr ; +TArr. Type ::= Type1 "->" Type ; -comment "--"; -comment "{-" "-}"; \ No newline at end of file +Constr. Constr ::= Ident "(" [Type] ")" ; + +-- TODO: Move literal to its own thing since it's reused in Init as well. +EAnn. Exp5 ::= "(" Exp ":" Type ")" ; +EId. Exp4 ::= Ident ; +ELit. Exp4 ::= Literal ; +EApp. Exp3 ::= Exp3 Exp4 ; +EAdd. Exp1 ::= Exp1 "+" Exp2 ; +ESub. Exp1 ::= Exp1 "-" Exp2 ; +ELet. Exp ::= "let" Ident "=" Exp "in" Exp ; +EAbs. Exp ::= "\\" Ident "." Exp ; +ECase. Exp ::= "case" Exp "of" "{" [Inj] "}"; + +LInt. Literal ::= Integer ; + +Inj. Inj ::= Init "=>" Exp ; +separator nonempty Inj ";" ; + +InitLit. Init ::= Literal ; +InitConstr. Init ::= Ident [Ident] ; +InitCatch. Init ::= "_" ; + +separator Type " " ; +coercions Type 2 ; + +separator Ident " "; + +coercions Exp 5 ; + +comment "--" ; +comment "{-" "-}" ; diff --git a/sample-programs/basic-1 b/sample-programs/basic-1 index 113c8b7..57ce1d9 100644 --- a/sample-programs/basic-1 +++ b/sample-programs/basic-1 @@ -1,87 +1,26 @@ - --- tripplemagic : Int -> Int -> Int -> Int; --- tripplemagic x y z = ((\x:Int. x+x) x) + y + z; --- main : Int; --- main = tripplemagic ((\x:Int. x+x+3) ((\x:Int. x) 2)) 5 3 --- answer: 22 - --- apply : (Int -> Int) -> Int -> Int; --- apply f x = f x; --- main : Int; --- main = apply (\x : Int . x + 5) 5 --- answer: 10 - --- apply : (Int -> Int -> Int) -> Int -> Int -> Int; --- apply f x y = f x y; --- krimp: Int -> Int -> Int; --- krimp x y = x + y; --- main : Int; --- main = apply (krimp) 2 3; --- answer: 5 - --- fibbonaci : Int -> Int; --- fibbonaci x = case x of { --- 0 => 0, --- 1 => 1, --- -- abusing overflows to represent negatives like a boss --- _ => (fibbonaci (x - 2)) --- + (fibbonaci (x - 1)) --- } : Int; --- main : Int; --- main = fibbonaci 10; --- answer: 55 - --- succ : Int -> Int; --- succ x = x - 1; --- --- isZero : Int -> Int; --- isZero x = case x of { --- 0 => 1, --- _ => 0 --- } : Int; --- --- minimization : (Int -> Int) -> Int -> Int; --- minimization p x = case p x of { --- 1 => 0, --- _ => minimization p (succ x) --- } : Int; --- --- main : Int; --- main = minimization isZero 10; --- answer: 0 - -posMul : Int -> Int -> Int; +posMul : _Int -> _Int -> _Int; posMul a b = case b of { - 0 => 0, + 0 => 0; _ => a + posMul a (b - 1) -} : Int; +}; -facc : Int -> Int; +facc : _Int -> _Int; facc a = case a of { - 1 => 1, + 1 => 1; _ => posMul a (facc (a - 1)) -} : Int; --- main : Int; --- main = facc 5 --- answer: 120 +}; --- pow : Int -> Int -> Int; --- pow a b = case b of { --- 0 => 1, --- _ => posMul a (pow a (b-1)) --- } : Int; - -minimization : (Int -> Int) -> Int -> Int; +minimization : (_Int -> _Int) -> _Int -> _Int; minimization p x = case p x of { - 1 => x, + 1 => x; _ => minimization p (x + 1) -} : Int; +}; -checkFac : Int -> Int; +checkFac : _Int -> _Int; checkFac x = case facc x of { - 0 => 1, + 0 => 1; _ => 0 -} : Int; +}; -main : Int; +main : _Int; main = minimization checkFac 1 \ No newline at end of file diff --git a/src/Codegen/Codegen.hs b/src/Codegen/Codegen.hs index 174d0b1..9d3b034 100644 --- a/src/Codegen/Codegen.hs +++ b/src/Codegen/Codegen.hs @@ -1,441 +1,443 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} - -module Codegen.Codegen (generateCode) where - -import Auxiliary (snoc) -import Codegen.LlvmIr (CallingConvention (..), - LLVMComp (..), LLVMIr (..), - LLVMType (..), LLVMValue (..), - Visibility (..), llvmIrToString) -import Control.Monad.State (StateT, execStateT, foldM_, gets, - modify) -import qualified Data.Bifunctor as BI -import Data.List.Extra (trim) -import Data.Map (Map) -import qualified Data.Map as Map -import Data.Tuple.Extra (dupe, first, second) -import qualified Grammar.Abs as GA -import Grammar.ErrM (Err) -import System.Process.Extra (readCreateProcess, shell) -import TypeChecker.TypeCheckerIr (Bind (..), Case (..), Exp (..), Id, - Ident (..), Program (..), Type (..)) --- | The record used as the code generator state -data CodeGenerator = CodeGenerator - { instructions :: [LLVMIr] - , functions :: Map Id FunctionInfo - , constructors :: Map Id ConstructorInfo - , variableCount :: Integer - , labelCount :: Integer - } - --- | A state type synonym -type CompilerState a = StateT CodeGenerator Err a - -data FunctionInfo = FunctionInfo - { numArgs :: Int - , arguments :: [Id] - } -data ConstructorInfo = ConstructorInfo - { numArgsCI :: Int - , argumentsCI :: [Id] - , numCI :: Integer - } - - --- | Adds a instruction to the CodeGenerator state -emit :: LLVMIr -> CompilerState () -emit l = modify $ \t -> t { instructions = Auxiliary.snoc l $ instructions t } - --- | Increases the variable counter in the CodeGenerator state -increaseVarCount :: CompilerState () -increaseVarCount = modify $ \t -> t { variableCount = variableCount t + 1 } - --- | Returns the variable count from the CodeGenerator state -getVarCount :: CompilerState Integer -getVarCount = gets variableCount - --- | Increases the variable count and returns it from the CodeGenerator state -getNewVar :: CompilerState Integer -getNewVar = increaseVarCount >> getVarCount - --- | Increses the label count and returns a label from the CodeGenerator state -getNewLabel :: CompilerState Integer -getNewLabel = do - modify (\t -> t{labelCount = labelCount t + 1}) - gets labelCount - --- | Produces a map of functions infos from a list of binds, --- which contains useful data for code generation. -getFunctions :: [Bind] -> Map Id FunctionInfo -getFunctions bs = Map.fromList $ go bs - where - go [] = [] - go (Bind id args _ : xs) = - (id, FunctionInfo { numArgs=length args, arguments=args }) - : go xs - go (DataStructure n cons : xs) = do - map (\(id, xs) -> ((id, TPol n), FunctionInfo { - numArgs=length xs, arguments=createArgs xs - })) cons - <> go xs - -createArgs :: [Type] -> [Id] -createArgs xs = fst $ foldl (\(acc, l) t -> (acc ++ [(Ident ("arg_" <> show l) , t)],l+1)) ([], 0) xs - --- | Produces a map of functions infos from a list of binds, --- which contains useful data for code generation. -getConstructors :: [Bind] -> Map Id ConstructorInfo -getConstructors bs = Map.fromList $ go bs - where - go [] = [] - go (DataStructure (Ident n) cons : xs) = do - fst (foldl (\(acc,i) (Ident id, xs) -> (((Ident (n <> "_" <> id), TPol (Ident n)), ConstructorInfo { - numArgsCI=length xs, - argumentsCI=createArgs xs, - numCI=i - }) : acc, i+1)) ([],0) cons) - <> go xs - go (_: xs) = go xs - -initCodeGenerator :: [Bind] -> CodeGenerator -initCodeGenerator scs = CodeGenerator { instructions = defaultStart - , functions = getFunctions scs - , constructors = getConstructors scs - , variableCount = 0 - , labelCount = 0 - } - -run :: Err String -> IO () -run s = do - let s' = case s of - Right s -> s - Left _ -> error "yo" - writeFile "output/llvm.ll" s' - putStrLn . trim =<< readCreateProcess (shell "lli") s' - -test :: Integer -> Program -test v = Program [ - DataStructure (Ident "Craig") [ - (Ident "Bob", [TInt])--, - --(Ident "Alice", [TInt, TInt]) - ], - Bind (Ident "fibonacci", TInt) [(Ident "x", TInt)] (EId ("x",TInt)), - Bind (Ident "main", TInt) [] ( - EApp (TPol "Craig") (EId (Ident "Craig_Bob", TPol "Craig")) (EInt v) -- (EInt 92) - ) - ] - -{- | Compiles an AST and produces a LLVM Ir string. - An easy way to actually "compile" this output is to - Simply pipe it to LLI --} -generateCode :: Program -> Err String -generateCode (Program scs) = do - let codegen = initCodeGenerator scs - llvmIrToString . instructions <$> execStateT (compileScs scs) codegen - -compileScs :: [Bind] -> CompilerState () -compileScs [] = do - -- as a last step create all the constructors - c <- gets (Map.toList . constructors) - mapM_ (\((id, t), ci) -> do - let t' = type2LlvmType t - let x = BI.second type2LlvmType <$> argumentsCI ci - emit $ Define FastCC t' id x - top <- Ident . show <$> getNewVar - ptr <- Ident . show <$> getNewVar - -- allocated the primary type - emit $ SetVariable top (Alloca t') - - -- set the first byte to the index of the constructor - emit $ SetVariable ptr $ - GetElementPtrInbounds t' (Ref t') - (VIdent top I8) I32 (VInteger 0) I32 (VInteger 0) - emit $ Store I8 (VInteger $ numCI ci ) (Ref I8) ptr - - -- get a pointer of the correct type - ptr' <- Ident . show <$> getNewVar - emit $ SetVariable ptr' (Bitcast (Ref t') ptr (Ref $ CustomType id)) - - --emit $ UnsafeRaw "\n" - - foldM_ (\i (Ident arg_n, arg_t)-> do - let arg_t' = type2LlvmType arg_t - emit $ Comment (show arg_t' <>" "<> arg_n <> " " <> show i ) - elemPtr <- Ident . show <$> getNewVar - emit $ SetVariable elemPtr ( - GetElementPtrInbounds (CustomType id) (Ref (CustomType id)) - (VIdent ptr' Ptr) I32 - (VInteger 0) I32 (VInteger i)) - emit $ Store arg_t' (VIdent (Ident arg_n) arg_t') Ptr elemPtr - -- %2 = getelementptr inbounds %Foo_AInteger, %Foo_AInteger* %1, i32 0, i32 1 - -- store i32 42, i32* %2 - pure $ i + 1-- + typeByteSize arg_t' - ) 1 (argumentsCI ci) - - --emit $ UnsafeRaw "\n" - - -- load and return the constructed value - load <- Ident . show <$> getNewVar - emit $ SetVariable load (Load t' Ptr top) - emit $ Ret t' (VIdent load t') - emit DefineEnd - - modify $ \s -> s { variableCount = 0 } - ) c -compileScs (Bind (name, _t) args exp : xs) = do - emit $ UnsafeRaw "\n" - emit . Comment $ show name <> ": " <> show exp - let args' = map (second type2LlvmType) args - emit $ Define FastCC I64 {-(type2LlvmType t_return)-} name args' - functionBody <- exprToValue exp - if name == "main" - then mapM_ emit $ mainContent functionBody - else emit $ Ret I64 functionBody - emit DefineEnd - modify $ \s -> s { variableCount = 0 } - compileScs xs -compileScs (DataStructure id@(Ident outer_id) ts : xs) = do - let biggest_variant = maximum ((\(_, t) -> sum $ typeByteSize . type2LlvmType <$> t) <$> ts) - emit $ Type id [I8, Array biggest_variant I8] - mapM_ (\(Ident inner_id, fi) -> do - emit $ Type (Ident $ outer_id <> "_" <> inner_id) (I8 : map type2LlvmType fi) - ) ts - compileScs xs - - -- where - -- _t_return = snd $ partitionType (length args) t - -mainContent :: LLVMValue -> [LLVMIr] -mainContent var = - [ UnsafeRaw $ - "call i32 (ptr, ...) @printf(ptr noundef @.str, i64 noundef " <> show var <> ")\n" - , -- , SetVariable (Ident "p") (Icmp LLEq I64 (VInteger 2) (VInteger 2)) - -- , BrCond (VIdent (Ident "p")) (Ident "b_1") (Ident "b_2") - -- , Label (Ident "b_1") - -- , UnsafeRaw - -- "call i32 (ptr, ...) @printf(ptr noundef @.str, i64 noundef 1)\n" - -- , Br (Ident "end") - -- , Label (Ident "b_2") - -- , UnsafeRaw - -- "call i32 (ptr, ...) @printf(ptr noundef @.str, i64 noundef 2)\n" - -- , Br (Ident "end") - -- , Label (Ident "end") - Ret I64 (VInteger 0) - ] - -defaultStart :: [LLVMIr] -defaultStart = [ UnsafeRaw "target triple = \"x86_64-pc-linux-gnu\"\n" - , UnsafeRaw "target datalayout = \"e-m:o-i64:64-f80:128-n8:16:32:64-S128\"\n" - , UnsafeRaw "@.str = private unnamed_addr constant [3 x i8] c\"%i\n\", align 1\n" - , UnsafeRaw "declare i32 @printf(ptr noalias nocapture, ...)\n" - ] - -compileExp :: Exp -> CompilerState () -compileExp (EInt int) = emitInt int -compileExp (EAdd t e1 e2) = emitAdd t e1 e2 -compileExp (ESub t e1 e2) = emitSub t e1 e2 -compileExp (EId (name, _)) = emitIdent name -compileExp (EApp t e1 e2) = emitApp t e1 e2 -compileExp (EAbs t ti e) = emitAbs t ti e -compileExp (ELet binds e) = emitLet binds e -compileExp (ECase t e cs) = emitECased t e cs - -- go (EMul e1 e2) = emitMul e1 e2 - -- go (EDiv e1 e2) = emitDiv e1 e2 - -- go (EMod e1 e2) = emitMod e1 e2 - ---- aux functions --- -emitECased :: Type -> Exp -> [(Type, Case)] -> CompilerState () -emitECased t e cases = do - let cs = snd <$> cases - let ty = type2LlvmType t - vs <- exprToValue e - lbl <- getNewLabel - let label = Ident $ "escape_" <> show lbl - stackPtr <- getNewVar - emit $ SetVariable (Ident $ show stackPtr) (Alloca ty) - mapM_ (emitCases ty label stackPtr vs) cs - emit $ Label label - res <- getNewVar - emit $ SetVariable (Ident $ show res) (Load ty Ptr (Ident $ show stackPtr)) - where - emitCases :: LLVMType -> Ident -> Integer -> LLVMValue -> Case -> CompilerState () - emitCases ty label stackPtr vs (Case (GA.CInt i) exp) = do - ns <- getNewVar - lbl_failPos <- (\x -> Ident $ "failed_" <> show x) <$> getNewLabel - lbl_succPos <- (\x -> Ident $ "success_" <> show x) <$> getNewLabel - emit $ SetVariable (Ident $ show ns) (Icmp LLEq ty vs (VInteger i)) - emit $ BrCond (VIdent (Ident $ show ns) ty) lbl_succPos lbl_failPos - emit $ Label lbl_succPos - val <- exprToValue exp - emit $ Store ty val Ptr (Ident . show $ stackPtr) - emit $ Br label - emit $ Label lbl_failPos - emitCases ty label stackPtr _ (Case GA.CatchAll exp) = do - val <- exprToValue exp - emit $ Store ty val Ptr (Ident . show $ stackPtr) - emit $ Br label - - -emitAbs :: Type -> Id -> Exp -> CompilerState () -emitAbs _t tid e = do - emit . Comment $ - "Lambda escaped previous stages: \\" <> show tid <> " . " <> show e -emitLet :: Bind -> Exp -> CompilerState () -emitLet xs e = do - emit $ - Comment $ - concat - [ "ELet (" - , show xs - , " = " - , show e - , ") is not implemented!" - ] - -emitApp :: Type -> Exp -> Exp -> CompilerState () -emitApp t e1 e2 = appEmitter t e1 e2 [] - where - appEmitter :: Type -> Exp -> Exp -> [Exp] -> CompilerState () - appEmitter t e1 e2 stack = do - let newStack = e2 : stack - case e1 of - EApp _ e1' e2' -> appEmitter t e1' e2' newStack - EId id@(name, _) -> do - args <- traverse exprToValue newStack - vs <- getNewVar - funcs <- gets functions - let visibility = maybe Local (const Global) $ Map.lookup id funcs - args' = map (first valueGetType . dupe) args - call = Call FastCC (type2LlvmType t) visibility name args' - emit $ SetVariable (Ident $ show vs) call - x -> do - emit . Comment $ "The unspeakable happened: " - emit . Comment $ show x - -emitIdent :: Ident -> CompilerState () -emitIdent id = do - -- !!this should never happen!! - emit $ Comment "This should not have happened!" - emit $ Variable id - emit $ UnsafeRaw "\n" - -emitInt :: Integer -> CompilerState () -emitInt i = do - -- !!this should never happen!! - varCount <- getNewVar - emit $ Comment "This should not have happened!" - emit $ SetVariable (Ident (show varCount)) (Add I64 (VInteger i) (VInteger 0)) - -emitAdd :: Type -> Exp -> Exp -> CompilerState () -emitAdd t e1 e2 = do - v1 <- exprToValue e1 - v2 <- exprToValue e2 - v <- getNewVar - emit $ SetVariable (Ident $ show v) (Add (type2LlvmType t) v1 v2) - -emitSub :: Type -> Exp -> Exp -> CompilerState () -emitSub t e1 e2 = do - v1 <- exprToValue e1 - v2 <- exprToValue e2 - v <- getNewVar - emit $ SetVariable (Ident $ show v) (Sub (type2LlvmType t) v1 v2) - --- emitMul :: Exp -> Exp -> CompilerState () --- emitMul e1 e2 = do --- (v1,v2) <- binExprToValues e1 e2 --- increaseVarCount --- v <- gets variableCount --- emit $ SetVariable $ Ident $ show v --- emit $ Mul I64 v1 v2 - --- emitMod :: Exp -> Exp -> CompilerState () --- emitMod e1 e2 = do --- -- `let m a b = rem (abs $ b + a) b` --- (v1,v2) <- binExprToValues e1 e2 --- increaseVarCount --- vadd <- gets variableCount --- emit $ SetVariable $ Ident $ show vadd --- emit $ Add I64 v1 v2 +module Codegen.Codegen where +-- {-# LANGUAGE LambdaCase #-} +-- {-# LANGUAGE OverloadedStrings #-} +-- +-- module Codegen.Codegen (generateCode) where +-- +-- import Auxiliary (snoc) +-- import Codegen.LlvmIr (CallingConvention (..), +-- LLVMComp (..), LLVMIr (..), +-- LLVMType (..), LLVMValue (..), +-- Visibility (..), llvmIrToString) +-- import Control.Monad.State (StateT, execStateT, foldM_, gets, +-- modify) +-- import qualified Data.Bifunctor as BI +-- import Data.List.Extra (trim) +-- import Data.Map (Map) +-- import qualified Data.Map as Map +-- import Data.Tuple.Extra (dupe, first, second) +-- import qualified Grammar.Abs as GA +-- import Grammar.ErrM (Err) +-- import System.Process.Extra (readCreateProcess, shell) +-- import TypeChecker.TypeCheckerIr (Bind (..), Case (..), Exp (..), Id, +-- Ident (..), Program (..), Type (..)) +-- -- | The record used as the code generator state +-- data CodeGenerator = CodeGenerator +-- { instructions :: [LLVMIr] +-- , functions :: Map Id FunctionInfo +-- , constructors :: Map Id ConstructorInfo +-- , variableCount :: Integer +-- , labelCount :: Integer +-- } +-- +-- -- | A state type synonym +-- type CompilerState a = StateT CodeGenerator Err a +-- +-- data FunctionInfo = FunctionInfo +-- { numArgs :: Int +-- , arguments :: [Id] +-- } +-- data ConstructorInfo = ConstructorInfo +-- { numArgsCI :: Int +-- , argumentsCI :: [Id] +-- , numCI :: Integer +-- } +-- +-- +-- -- | Adds a instruction to the CodeGenerator state +-- emit :: LLVMIr -> CompilerState () +-- emit l = modify $ \t -> t { instructions = Auxiliary.snoc l $ instructions t } +-- +-- -- | Increases the variable counter in the CodeGenerator state +-- increaseVarCount :: CompilerState () +-- increaseVarCount = modify $ \t -> t { variableCount = variableCount t + 1 } +-- +-- -- | Returns the variable count from the CodeGenerator state +-- getVarCount :: CompilerState Integer +-- getVarCount = gets variableCount +-- +-- -- | Increases the variable count and returns it from the CodeGenerator state +-- getNewVar :: CompilerState Integer +-- getNewVar = increaseVarCount >> getVarCount +-- +-- -- | Increses the label count and returns a label from the CodeGenerator state +-- getNewLabel :: CompilerState Integer +-- getNewLabel = do +-- modify (\t -> t{labelCount = labelCount t + 1}) +-- gets labelCount +-- +-- -- | Produces a map of functions infos from a list of binds, +-- -- which contains useful data for code generation. +-- getFunctions :: [Bind] -> Map Id FunctionInfo +-- getFunctions bs = Map.fromList $ go bs +-- where +-- go [] = [] +-- go (Bind id args _ : xs) = +-- (id, FunctionInfo { numArgs=length args, arguments=args }) +-- : go xs +-- go (DataStructure n cons : xs) = do +-- map (\(id, xs) -> ((id, TPol n), FunctionInfo { +-- numArgs=length xs, arguments=createArgs xs +-- })) cons +-- <> go xs +-- +-- createArgs :: [Type] -> [Id] +-- createArgs xs = fst $ foldl (\(acc, l) t -> (acc ++ [(Ident ("arg_" <> show l) , t)],l+1)) ([], 0) xs +-- +-- -- | Produces a map of functions infos from a list of binds, +-- -- which contains useful data for code generation. +-- getConstructors :: [Bind] -> Map Id ConstructorInfo +-- getConstructors bs = Map.fromList $ go bs +-- where +-- go [] = [] +-- go (DataStructure (Ident n) cons : xs) = do +-- fst (foldl (\(acc,i) (Ident id, xs) -> (((Ident (n <> "_" <> id), TPol (Ident n)), ConstructorInfo { +-- numArgsCI=length xs, +-- argumentsCI=createArgs xs, +-- numCI=i +-- }) : acc, i+1)) ([],0) cons) +-- <> go xs +-- go (_: xs) = go xs +-- +-- initCodeGenerator :: [Bind] -> CodeGenerator +-- initCodeGenerator scs = CodeGenerator { instructions = defaultStart +-- , functions = getFunctions scs +-- , constructors = getConstructors scs +-- , variableCount = 0 +-- , labelCount = 0 +-- } +-- +-- run :: Err String -> IO () +-- run s = do +-- let s' = case s of +-- Right s -> s +-- Left _ -> error "yo" +-- writeFile "output/llvm.ll" s' +-- putStrLn . trim =<< readCreateProcess (shell "lli") s' +-- +-- test :: Integer -> Program +-- test v = Program [ +-- DataStructure (Ident "Craig") [ +-- (Ident "Bob", [TInt])--, +-- --(Ident "Alice", [TInt, TInt]) +-- ], +-- Bind (Ident "fibonacci", TInt) [(Ident "x", TInt)] (EId ("x",TInt)), +-- Bind (Ident "main", TInt) [] ( +-- EApp (TPol "Craig") (EId (Ident "Craig_Bob", TPol "Craig")) (EInt v) -- (EInt 92) +-- ) +-- ] +-- +-- {- | Compiles an AST and produces a LLVM Ir string. +-- An easy way to actually "compile" this output is to +-- Simply pipe it to LLI +-- -} +-- generateCode :: Program -> Err String +-- generateCode (Program scs) = do +-- let codegen = initCodeGenerator scs +-- llvmIrToString . instructions <$> execStateT (compileScs scs) codegen +-- +-- compileScs :: [Bind] -> CompilerState () +-- compileScs [] = do +-- -- as a last step create all the constructors +-- c <- gets (Map.toList . constructors) +-- mapM_ (\((id, t), ci) -> do +-- let t' = type2LlvmType t +-- let x = BI.second type2LlvmType <$> argumentsCI ci +-- emit $ Define FastCC t' id x +-- top <- Ident . show <$> getNewVar +-- ptr <- Ident . show <$> getNewVar +-- -- allocated the primary type +-- emit $ SetVariable top (Alloca t') +-- +-- -- set the first byte to the index of the constructor +-- emit $ SetVariable ptr $ +-- GetElementPtrInbounds t' (Ref t') +-- (VIdent top I8) I32 (VInteger 0) I32 (VInteger 0) +-- emit $ Store I8 (VInteger $ numCI ci ) (Ref I8) ptr +-- +-- -- get a pointer of the correct type +-- ptr' <- Ident . show <$> getNewVar +-- emit $ SetVariable ptr' (Bitcast (Ref t') ptr (Ref $ CustomType id)) +-- +-- --emit $ UnsafeRaw "\n" +-- +-- foldM_ (\i (Ident arg_n, arg_t)-> do +-- let arg_t' = type2LlvmType arg_t +-- emit $ Comment (show arg_t' <>" "<> arg_n <> " " <> show i ) +-- elemPtr <- Ident . show <$> getNewVar +-- emit $ SetVariable elemPtr ( +-- GetElementPtrInbounds (CustomType id) (Ref (CustomType id)) +-- (VIdent ptr' Ptr) I32 +-- (VInteger 0) I32 (VInteger i)) +-- emit $ Store arg_t' (VIdent (Ident arg_n) arg_t') Ptr elemPtr +-- -- %2 = getelementptr inbounds %Foo_AInteger, %Foo_AInteger* %1, i32 0, i32 1 +-- -- store i32 42, i32* %2 +-- pure $ i + 1-- + typeByteSize arg_t' +-- ) 1 (argumentsCI ci) +-- +-- --emit $ UnsafeRaw "\n" +-- +-- -- load and return the constructed value +-- load <- Ident . show <$> getNewVar +-- emit $ SetVariable load (Load t' Ptr top) +-- emit $ Ret t' (VIdent load t') +-- emit DefineEnd +-- +-- modify $ \s -> s { variableCount = 0 } +-- ) c +-- compileScs (Bind (name, _t) args exp : xs) = do +-- emit $ UnsafeRaw "\n" +-- emit . Comment $ show name <> ": " <> show exp +-- let args' = map (second type2LlvmType) args +-- emit $ Define FastCC I64 {-(type2LlvmType t_return)-} name args' +-- functionBody <- exprToValue exp +-- if name == "main" +-- then mapM_ emit $ mainContent functionBody +-- else emit $ Ret I64 functionBody +-- emit DefineEnd +-- modify $ \s -> s { variableCount = 0 } +-- compileScs xs +-- compileScs (DataStructure id@(Ident outer_id) ts : xs) = do +-- let biggest_variant = maximum ((\(_, t) -> sum $ typeByteSize . type2LlvmType <$> t) <$> ts) +-- emit $ Type id [I8, Array biggest_variant I8] +-- mapM_ (\(Ident inner_id, fi) -> do +-- emit $ Type (Ident $ outer_id <> "_" <> inner_id) (I8 : map type2LlvmType fi) +-- ) ts +-- compileScs xs +-- +-- -- where +-- -- _t_return = snd $ partitionType (length args) t +-- +-- mainContent :: LLVMValue -> [LLVMIr] +-- mainContent var = +-- [ UnsafeRaw $ +-- "call i32 (ptr, ...) @printf(ptr noundef @.str, i64 noundef " <> show var <> ")\n" +-- , -- , SetVariable (Ident "p") (Icmp LLEq I64 (VInteger 2) (VInteger 2)) +-- -- , BrCond (VIdent (Ident "p")) (Ident "b_1") (Ident "b_2") +-- -- , Label (Ident "b_1") +-- -- , UnsafeRaw +-- -- "call i32 (ptr, ...) @printf(ptr noundef @.str, i64 noundef 1)\n" +-- -- , Br (Ident "end") +-- -- , Label (Ident "b_2") +-- -- , UnsafeRaw +-- -- "call i32 (ptr, ...) @printf(ptr noundef @.str, i64 noundef 2)\n" +-- -- , Br (Ident "end") +-- -- , Label (Ident "end") +-- Ret I64 (VInteger 0) +-- ] +-- +-- defaultStart :: [LLVMIr] +-- defaultStart = [ UnsafeRaw "target triple = \"x86_64-pc-linux-gnu\"\n" +-- , UnsafeRaw "target datalayout = \"e-m:o-i64:64-f80:128-n8:16:32:64-S128\"\n" +-- , UnsafeRaw "@.str = private unnamed_addr constant [3 x i8] c\"%i\n\", align 1\n" +-- , UnsafeRaw "declare i32 @printf(ptr noalias nocapture, ...)\n" +-- ] +-- +-- compileExp :: Exp -> CompilerState () +-- compileExp (EInt int) = emitInt int +-- compileExp (EAdd t e1 e2) = emitAdd t e1 e2 +-- compileExp (ESub t e1 e2) = emitSub t e1 e2 +-- compileExp (EId (name, _)) = emitIdent name +-- compileExp (EApp t e1 e2) = emitApp t e1 e2 +-- compileExp (EAbs t ti e) = emitAbs t ti e +-- compileExp (ELet binds e) = emitLet binds e +-- compileExp (ECase t e cs) = emitECased t e cs +-- -- go (EMul e1 e2) = emitMul e1 e2 +-- -- go (EDiv e1 e2) = emitDiv e1 e2 +-- -- go (EMod e1 e2) = emitMod e1 e2 +-- +-- --- aux functions --- +-- emitECased :: Type -> Exp -> [(Type, Case)] -> CompilerState () +-- emitECased t e cases = do +-- let cs = snd <$> cases +-- let ty = type2LlvmType t +-- vs <- exprToValue e +-- lbl <- getNewLabel +-- let label = Ident $ "escape_" <> show lbl +-- stackPtr <- getNewVar +-- emit $ SetVariable (Ident $ show stackPtr) (Alloca ty) +-- mapM_ (emitCases ty label stackPtr vs) cs +-- emit $ Label label +-- res <- getNewVar +-- emit $ SetVariable (Ident $ show res) (Load ty Ptr (Ident $ show stackPtr)) +-- where +-- emitCases :: LLVMType -> Ident -> Integer -> LLVMValue -> Case -> CompilerState () +-- emitCases ty label stackPtr vs (Case (GA.CInt i) exp) = do +-- ns <- getNewVar +-- lbl_failPos <- (\x -> Ident $ "failed_" <> show x) <$> getNewLabel +-- lbl_succPos <- (\x -> Ident $ "success_" <> show x) <$> getNewLabel +-- emit $ SetVariable (Ident $ show ns) (Icmp LLEq ty vs (VInteger i)) +-- emit $ BrCond (VIdent (Ident $ show ns) ty) lbl_succPos lbl_failPos +-- emit $ Label lbl_succPos +-- val <- exprToValue exp +-- emit $ Store ty val Ptr (Ident . show $ stackPtr) +-- emit $ Br label +-- emit $ Label lbl_failPos +-- emitCases ty label stackPtr _ (Case GA.CatchAll exp) = do +-- val <- exprToValue exp +-- emit $ Store ty val Ptr (Ident . show $ stackPtr) +-- emit $ Br label +-- +-- +-- emitAbs :: Type -> Id -> Exp -> CompilerState () +-- emitAbs _t tid e = do +-- emit . Comment $ +-- "Lambda escaped previous stages: \\" <> show tid <> " . " <> show e +-- emitLet :: Bind -> Exp -> CompilerState () +-- emitLet xs e = do +-- emit $ +-- Comment $ +-- concat +-- [ "ELet (" +-- , show xs +-- , " = " +-- , show e +-- , ") is not implemented!" +-- ] +-- +-- emitApp :: Type -> Exp -> Exp -> CompilerState () +-- emitApp t e1 e2 = appEmitter t e1 e2 [] +-- where +-- appEmitter :: Type -> Exp -> Exp -> [Exp] -> CompilerState () +-- appEmitter t e1 e2 stack = do +-- let newStack = e2 : stack +-- case e1 of +-- EApp _ e1' e2' -> appEmitter t e1' e2' newStack +-- EId id@(name, _) -> do +-- args <- traverse exprToValue newStack +-- vs <- getNewVar +-- funcs <- gets functions +-- let visibility = maybe Local (const Global) $ Map.lookup id funcs +-- args' = map (first valueGetType . dupe) args +-- call = Call FastCC (type2LlvmType t) visibility name args' +-- emit $ SetVariable (Ident $ show vs) call +-- x -> do +-- emit . Comment $ "The unspeakable happened: " +-- emit . Comment $ show x +-- +-- emitIdent :: Ident -> CompilerState () +-- emitIdent id = do +-- -- !!this should never happen!! +-- emit $ Comment "This should not have happened!" +-- emit $ Variable id +-- emit $ UnsafeRaw "\n" +-- +-- emitInt :: Integer -> CompilerState () +-- emitInt i = do +-- -- !!this should never happen!! +-- varCount <- getNewVar +-- emit $ Comment "This should not have happened!" +-- emit $ SetVariable (Ident (show varCount)) (Add I64 (VInteger i) (VInteger 0)) +-- +-- emitAdd :: Type -> Exp -> Exp -> CompilerState () +-- emitAdd t e1 e2 = do +-- v1 <- exprToValue e1 +-- v2 <- exprToValue e2 +-- v <- getNewVar +-- emit $ SetVariable (Ident $ show v) (Add (type2LlvmType t) v1 v2) +-- +-- emitSub :: Type -> Exp -> Exp -> CompilerState () +-- emitSub t e1 e2 = do +-- v1 <- exprToValue e1 +-- v2 <- exprToValue e2 +-- v <- getNewVar +-- emit $ SetVariable (Ident $ show v) (Sub (type2LlvmType t) v1 v2) +-- +-- -- emitMul :: Exp -> Exp -> CompilerState () +-- -- emitMul e1 e2 = do +-- -- (v1,v2) <- binExprToValues e1 e2 +-- -- increaseVarCount +-- -- v <- gets variableCount +-- -- emit $ SetVariable $ Ident $ show v +-- -- emit $ Mul I64 v1 v2 +-- +-- -- emitMod :: Exp -> Exp -> CompilerState () +-- -- emitMod e1 e2 = do +-- -- -- `let m a b = rem (abs $ b + a) b` +-- -- (v1,v2) <- binExprToValues e1 e2 +-- -- increaseVarCount +-- -- vadd <- gets variableCount +-- -- emit $ SetVariable $ Ident $ show vadd +-- -- emit $ Add I64 v1 v2 +-- -- +-- -- increaseVarCount +-- -- vabs <- gets variableCount +-- -- emit $ SetVariable $ Ident $ show vabs +-- -- emit $ Call I64 (Ident "llvm.abs.i64") +-- -- [ (I64, VIdent (Ident $ show vadd)) +-- -- , (I1, VInteger 1) +-- -- ] +-- -- increaseVarCount +-- -- v <- gets variableCount +-- -- emit $ SetVariable $ Ident $ show v +-- -- emit $ Srem I64 (VIdent (Ident $ show vabs)) v2 +-- +-- -- emitDiv :: Exp -> Exp -> CompilerState () +-- -- emitDiv e1 e2 = do +-- -- (v1,v2) <- binExprToValues e1 e2 +-- -- increaseVarCount +-- -- v <- gets variableCount +-- -- emit $ SetVariable $ Ident $ show v +-- -- emit $ Div I64 v1 v2 +-- +-- exprToValue :: Exp -> CompilerState LLVMValue +-- exprToValue = \case +-- EInt i -> pure $ VInteger i +-- +-- EId id@(name, t) -> do +-- funcs <- gets functions +-- case Map.lookup id funcs of +-- Just fi -> do +-- if numArgs fi == 0 +-- then do +-- vc <- getNewVar +-- emit $ SetVariable (Ident $ show vc) +-- (Call FastCC (type2LlvmType t) Global name []) +-- pure $ VIdent (Ident $ show vc) (type2LlvmType t) +-- else pure $ VFunction name Global (type2LlvmType t) +-- Nothing -> pure $ VIdent name (type2LlvmType t) +-- +-- e -> do +-- compileExp e +-- v <- getVarCount +-- pure $ VIdent (Ident $ show v) (getType e) +-- +-- type2LlvmType :: Type -> LLVMType +-- type2LlvmType = \case +-- TInt -> I64 +-- TFun t xs -> do +-- let (t', xs') = function2LLVMType xs [type2LlvmType t] +-- Function t' xs' +-- TPol t -> CustomType t +-- where +-- function2LLVMType :: Type -> [LLVMType] -> (LLVMType, [LLVMType]) +-- function2LLVMType (TFun t xs) s = function2LLVMType xs (type2LlvmType t : s) +-- function2LLVMType x s = (type2LlvmType x, s) +-- +-- getType :: Exp -> LLVMType +-- getType (EInt _) = I64 +-- getType (EAdd t _ _) = type2LlvmType t +-- getType (ESub t _ _) = type2LlvmType t +-- getType (EId (_, t)) = type2LlvmType t +-- getType (EApp t _ _) = type2LlvmType t +-- getType (EAbs t _ _) = type2LlvmType t +-- getType (ELet _ e) = getType e +-- getType (ECase t _ _) = type2LlvmType t +-- +-- valueGetType :: LLVMValue -> LLVMType +-- valueGetType (VInteger _) = I64 +-- valueGetType (VIdent _ t) = t +-- valueGetType (VConstant s) = Array (fromIntegral $ length s) I8 +-- valueGetType (VFunction _ _ t) = t +-- +-- typeByteSize :: LLVMType -> Integer +-- typeByteSize I1 = 1 +-- typeByteSize I8 = 1 +-- typeByteSize I32 = 4 +-- typeByteSize I64 = 8 +-- typeByteSize Ptr = 8 +-- typeByteSize (Ref _) = 8 +-- typeByteSize (Function _ _) = 8 +-- typeByteSize (Array n t) = n * typeByteSize t +-- typeByteSize (CustomType _) = 8 -- --- increaseVarCount --- vabs <- gets variableCount --- emit $ SetVariable $ Ident $ show vabs --- emit $ Call I64 (Ident "llvm.abs.i64") --- [ (I64, VIdent (Ident $ show vadd)) --- , (I1, VInteger 1) --- ] --- increaseVarCount --- v <- gets variableCount --- emit $ SetVariable $ Ident $ show v --- emit $ Srem I64 (VIdent (Ident $ show vabs)) v2 - --- emitDiv :: Exp -> Exp -> CompilerState () --- emitDiv e1 e2 = do --- (v1,v2) <- binExprToValues e1 e2 --- increaseVarCount --- v <- gets variableCount --- emit $ SetVariable $ Ident $ show v --- emit $ Div I64 v1 v2 - -exprToValue :: Exp -> CompilerState LLVMValue -exprToValue = \case - EInt i -> pure $ VInteger i - - EId id@(name, t) -> do - funcs <- gets functions - case Map.lookup id funcs of - Just fi -> do - if numArgs fi == 0 - then do - vc <- getNewVar - emit $ SetVariable (Ident $ show vc) - (Call FastCC (type2LlvmType t) Global name []) - pure $ VIdent (Ident $ show vc) (type2LlvmType t) - else pure $ VFunction name Global (type2LlvmType t) - Nothing -> pure $ VIdent name (type2LlvmType t) - - e -> do - compileExp e - v <- getVarCount - pure $ VIdent (Ident $ show v) (getType e) - -type2LlvmType :: Type -> LLVMType -type2LlvmType = \case - TInt -> I64 - TFun t xs -> do - let (t', xs') = function2LLVMType xs [type2LlvmType t] - Function t' xs' - TPol t -> CustomType t - where - function2LLVMType :: Type -> [LLVMType] -> (LLVMType, [LLVMType]) - function2LLVMType (TFun t xs) s = function2LLVMType xs (type2LlvmType t : s) - function2LLVMType x s = (type2LlvmType x, s) - -getType :: Exp -> LLVMType -getType (EInt _) = I64 -getType (EAdd t _ _) = type2LlvmType t -getType (ESub t _ _) = type2LlvmType t -getType (EId (_, t)) = type2LlvmType t -getType (EApp t _ _) = type2LlvmType t -getType (EAbs t _ _) = type2LlvmType t -getType (ELet _ e) = getType e -getType (ECase t _ _) = type2LlvmType t - -valueGetType :: LLVMValue -> LLVMType -valueGetType (VInteger _) = I64 -valueGetType (VIdent _ t) = t -valueGetType (VConstant s) = Array (fromIntegral $ length s) I8 -valueGetType (VFunction _ _ t) = t - -typeByteSize :: LLVMType -> Integer -typeByteSize I1 = 1 -typeByteSize I8 = 1 -typeByteSize I32 = 4 -typeByteSize I64 = 8 -typeByteSize Ptr = 8 -typeByteSize (Ref _) = 8 -typeByteSize (Function _ _) = 8 -typeByteSize (Array n t) = n * typeByteSize t -typeByteSize (CustomType _) = 8 diff --git a/src/Codegen/LlvmIr.hs b/src/Codegen/LlvmIr.hs index 08cd69d..4a649c3 100644 --- a/src/Codegen/LlvmIr.hs +++ b/src/Codegen/LlvmIr.hs @@ -1,239 +1,241 @@ -{-# LANGUAGE LambdaCase #-} - -module Codegen.LlvmIr ( - LLVMType (..), - LLVMIr (..), - llvmIrToString, - LLVMValue (..), - LLVMComp (..), - Visibility (..), - CallingConvention (..) -) where - -import Data.List (intercalate) -import TypeChecker.TypeCheckerIr - -data CallingConvention = TailCC | FastCC | CCC | ColdCC -instance Show CallingConvention where - show :: CallingConvention -> String - show TailCC = "tailcc" - show FastCC = "fastcc" - show CCC = "ccc" - show ColdCC = "coldcc" - --- | A datatype which represents some basic LLVM types -data LLVMType - = I1 - | I8 - | I32 - | I64 - | Ptr - | Ref LLVMType - | Function LLVMType [LLVMType] - | Array Integer LLVMType - | CustomType Ident - -instance Show LLVMType where - show :: LLVMType -> String - show = \case - I1 -> "i1" - I8 -> "i8" - I32 -> "i32" - I64 -> "i64" - Ptr -> "ptr" - Ref ty -> show ty <> "*" - Function t xs -> show t <> " (" <> intercalate ", " (map show xs) <> ")*" - Array n ty -> concat ["[", show n, " x ", show ty, "]"] - CustomType (Ident ty) -> "%" <> ty - -data LLVMComp - = LLEq - | LLNe - | LLUgt - | LLUge - | LLUlt - | LLUle - | LLSgt - | LLSge - | LLSlt - | LLSle -instance Show LLVMComp where - show :: LLVMComp -> String - show = \case - LLEq -> "eq" - LLNe -> "ne" - LLUgt -> "ugt" - LLUge -> "uge" - LLUlt -> "ult" - LLUle -> "ule" - LLSgt -> "sgt" - LLSge -> "sge" - LLSlt -> "slt" - LLSle -> "sle" - -data Visibility = Local | Global -instance Show Visibility where - show :: Visibility -> String - show Local = "%" - show Global = "@" - --- | Represents a LLVM "value", as in an integer, a register variable, --- or a string contstant -data LLVMValue - = VInteger Integer - | VIdent Ident LLVMType - | VConstant String - | VFunction Ident Visibility LLVMType - -instance Show LLVMValue where - show :: LLVMValue -> String - show v = case v of - VInteger i -> show i - VIdent (Ident n) _ -> "%" <> n - VFunction (Ident n) vis _ -> show vis <> n - VConstant s -> "c" <> show s - -type Params = [(Ident, LLVMType)] -type Args = [(LLVMType, LLVMValue)] - --- | A datatype which represents different instructions in LLVM -data LLVMIr - = Type Ident [LLVMType] - | Define CallingConvention LLVMType Ident Params - | DefineEnd - | Declare LLVMType Ident Params - | SetVariable Ident LLVMIr - | Variable Ident - | GetElementPtrInbounds LLVMType LLVMType LLVMValue LLVMType LLVMValue LLVMType LLVMValue - | Add LLVMType LLVMValue LLVMValue - | Sub LLVMType LLVMValue LLVMValue - | Div LLVMType LLVMValue LLVMValue - | Mul LLVMType LLVMValue LLVMValue - | Srem LLVMType LLVMValue LLVMValue - | Icmp LLVMComp LLVMType LLVMValue LLVMValue - | Br Ident - | BrCond LLVMValue Ident Ident - | Label Ident - | Call CallingConvention LLVMType Visibility Ident Args - | Alloca LLVMType - | Store LLVMType LLVMValue LLVMType Ident - | Load LLVMType LLVMType Ident - | Bitcast LLVMType Ident LLVMType - | Ret LLVMType LLVMValue - | Comment String - | UnsafeRaw String -- This should generally be avoided, and proper - -- instructions should be used in its place - deriving (Show) - --- | Converts a list of LLVMIr instructions to a string -llvmIrToString :: [LLVMIr] -> String -llvmIrToString = go 0 - where - go :: Int -> [LLVMIr] -> String - go _ [] = mempty - go i (x : xs) = do - let (i', n) = case x of - Define{} -> (i + 1, 0) - DefineEnd -> (i - 1, 0) - _ -> (i, i) - insToString n x <> go i' xs - -{- | Converts a LLVM inststruction to a String, allowing for printing etc. - The integer represents the indentation --} -{- FOURMOLU_DISABLE -} - insToString :: Int -> LLVMIr -> String - insToString i l = - replicate i '\t' <> case l of - (GetElementPtrInbounds t1 t2 p t3 v1 t4 v2) -> do - -- getelementptr inbounds %Foo, %Foo* %x, i32 0, i32 0 - concat - [ "getelementptr inbounds ", show t1, ", " , show t2 - , " ", show p, ", ", show t3, " ", show v1, - ", ", show t4, " ", show v2, "\n" ] - (Type (Ident n) types) -> - concat - [ "%", n, " = type { " - , intercalate ", " (map show types) - , " }\n" - ] - (Define c t (Ident i) params) -> - concat - [ "define ", show c, " ", show t, " @", i - , "(", intercalate ", " (map (\(Ident y, x) -> unwords [show x, "%" <> y]) params) - , ") {\n" - ] - DefineEnd -> "}\n" - (Declare _t (Ident _i) _params) -> undefined - (SetVariable (Ident i) ir) -> concat ["%", i, " = ", insToString 0 ir] - (Add t v1 v2) -> - concat - [ "add ", show t, " ", show v1 - , ", ", show v2, "\n" - ] - (Sub t v1 v2) -> - concat - [ "sub ", show t, " ", show v1, ", " - , show v2, "\n" - ] - (Div t v1 v2) -> - concat - [ "sdiv ", show t, " ", show v1, ", " - , show v2, "\n" - ] - (Mul t v1 v2) -> - concat - [ "mul ", show t, " ", show v1 - , ", ", show v2, "\n" - ] - (Srem t v1 v2) -> - concat - [ "srem ", show t, " ", show v1, ", " - , show v2, "\n" - ] - (Call c t vis (Ident i) arg) -> - concat - [ "call ", show c, " ", show t, " ", show vis, i, "(" - , intercalate ", " $ Prelude.map (\(x, y) -> show x <> " " <> show y) arg - , ")\n" - ] - (Alloca t) -> unwords ["alloca", show t, "\n"] - (Store t1 val t2 (Ident id2)) -> - concat - [ "store ", show t1, " ", show val - , ", ", show t2 , " %", id2, "\n" - ] - (Load t1 t2 (Ident addr)) -> - concat - [ "load ", show t1, ", " - , show t2, " %", addr, "\n" - ] - (Bitcast t1 (Ident i) t2) -> - concat - [ "bitcast ", show t1, " %" - , i, " to ", show t2, "\n" - ] - (Icmp comp t v1 v2) -> - concat - [ "icmp ", show comp, " ", show t - , " ", show v1, ", ", show v2, "\n" - ] - (Ret t v) -> - concat - [ "ret ", show t, " " - , show v, "\n" - ] - (UnsafeRaw s) -> s - (Label (Ident s)) -> "\n" <> lblPfx <> s <> ":\n" - (Br (Ident s)) -> "br label %" <> lblPfx <> s <> "\n" - (BrCond val (Ident s1) (Ident s2)) -> - concat - [ "br i1 ", show val, ", ", "label %" - , lblPfx, s1, ", ", "label %", lblPfx, s2, "\n" - ] - (Comment s) -> "; " <> s <> "\n" - (Variable (Ident id)) -> "%" <> id -{- FOURMOLU_ENABLE -} - -lblPfx :: String -lblPfx = "lbl_" +module Codegen.LlvmIr where +-- {-# LANGUAGE LambdaCase #-} +-- +-- module Codegen.LlvmIr ( +-- LLVMType (..), +-- LLVMIr (..), +-- llvmIrToString, +-- LLVMValue (..), +-- LLVMComp (..), +-- Visibility (..), +-- CallingConvention (..) +-- ) where +-- +-- import Data.List (intercalate) +-- import TypeChecker.TypeCheckerIr +-- +-- data CallingConvention = TailCC | FastCC | CCC | ColdCC +-- instance Show CallingConvention where +-- show :: CallingConvention -> String +-- show TailCC = "tailcc" +-- show FastCC = "fastcc" +-- show CCC = "ccc" +-- show ColdCC = "coldcc" +-- +-- -- | A datatype which represents some basic LLVM types +-- data LLVMType +-- = I1 +-- | I8 +-- | I32 +-- | I64 +-- | Ptr +-- | Ref LLVMType +-- | Function LLVMType [LLVMType] +-- | Array Integer LLVMType +-- | CustomType Ident +-- +-- instance Show LLVMType where +-- show :: LLVMType -> String +-- show = \case +-- I1 -> "i1" +-- I8 -> "i8" +-- I32 -> "i32" +-- I64 -> "i64" +-- Ptr -> "ptr" +-- Ref ty -> show ty <> "*" +-- Function t xs -> show t <> " (" <> intercalate ", " (map show xs) <> ")*" +-- Array n ty -> concat ["[", show n, " x ", show ty, "]"] +-- CustomType (Ident ty) -> "%" <> ty +-- +-- data LLVMComp +-- = LLEq +-- | LLNe +-- | LLUgt +-- | LLUge +-- | LLUlt +-- | LLUle +-- | LLSgt +-- | LLSge +-- | LLSlt +-- | LLSle +-- instance Show LLVMComp where +-- show :: LLVMComp -> String +-- show = \case +-- LLEq -> "eq" +-- LLNe -> "ne" +-- LLUgt -> "ugt" +-- LLUge -> "uge" +-- LLUlt -> "ult" +-- LLUle -> "ule" +-- LLSgt -> "sgt" +-- LLSge -> "sge" +-- LLSlt -> "slt" +-- LLSle -> "sle" +-- +-- data Visibility = Local | Global +-- instance Show Visibility where +-- show :: Visibility -> String +-- show Local = "%" +-- show Global = "@" +-- +-- -- | Represents a LLVM "value", as in an integer, a register variable, +-- -- or a string contstant +-- data LLVMValue +-- = VInteger Integer +-- | VIdent Ident LLVMType +-- | VConstant String +-- | VFunction Ident Visibility LLVMType +-- +-- instance Show LLVMValue where +-- show :: LLVMValue -> String +-- show v = case v of +-- VInteger i -> show i +-- VIdent (Ident n) _ -> "%" <> n +-- VFunction (Ident n) vis _ -> show vis <> n +-- VConstant s -> "c" <> show s +-- +-- type Params = [(Ident, LLVMType)] +-- type Args = [(LLVMType, LLVMValue)] +-- +-- -- | A datatype which represents different instructions in LLVM +-- data LLVMIr +-- = Type Ident [LLVMType] +-- | Define CallingConvention LLVMType Ident Params +-- | DefineEnd +-- | Declare LLVMType Ident Params +-- | SetVariable Ident LLVMIr +-- | Variable Ident +-- | GetElementPtrInbounds LLVMType LLVMType LLVMValue LLVMType LLVMValue LLVMType LLVMValue +-- | Add LLVMType LLVMValue LLVMValue +-- | Sub LLVMType LLVMValue LLVMValue +-- | Div LLVMType LLVMValue LLVMValue +-- | Mul LLVMType LLVMValue LLVMValue +-- | Srem LLVMType LLVMValue LLVMValue +-- | Icmp LLVMComp LLVMType LLVMValue LLVMValue +-- | Br Ident +-- | BrCond LLVMValue Ident Ident +-- | Label Ident +-- | Call CallingConvention LLVMType Visibility Ident Args +-- | Alloca LLVMType +-- | Store LLVMType LLVMValue LLVMType Ident +-- | Load LLVMType LLVMType Ident +-- | Bitcast LLVMType Ident LLVMType +-- | Ret LLVMType LLVMValue +-- | Comment String +-- | UnsafeRaw String -- This should generally be avoided, and proper +-- -- instructions should be used in its place +-- deriving (Show) +-- +-- -- | Converts a list of LLVMIr instructions to a string +-- llvmIrToString :: [LLVMIr] -> String +-- llvmIrToString = go 0 +-- where +-- go :: Int -> [LLVMIr] -> String +-- go _ [] = mempty +-- go i (x : xs) = do +-- let (i', n) = case x of +-- Define{} -> (i + 1, 0) +-- DefineEnd -> (i - 1, 0) +-- _ -> (i, i) +-- insToString n x <> go i' xs +-- +-- {- | Converts a LLVM inststruction to a String, allowing for printing etc. +-- The integer represents the indentation +-- -} +-- {- FOURMOLU_DISABLE -} +-- insToString :: Int -> LLVMIr -> String +-- insToString i l = +-- replicate i '\t' <> case l of +-- (GetElementPtrInbounds t1 t2 p t3 v1 t4 v2) -> do +-- -- getelementptr inbounds %Foo, %Foo* %x, i32 0, i32 0 +-- concat +-- [ "getelementptr inbounds ", show t1, ", " , show t2 +-- , " ", show p, ", ", show t3, " ", show v1, +-- ", ", show t4, " ", show v2, "\n" ] +-- (Type (Ident n) types) -> +-- concat +-- [ "%", n, " = type { " +-- , intercalate ", " (map show types) +-- , " }\n" +-- ] +-- (Define c t (Ident i) params) -> +-- concat +-- [ "define ", show c, " ", show t, " @", i +-- , "(", intercalate ", " (map (\(Ident y, x) -> unwords [show x, "%" <> y]) params) +-- , ") {\n" +-- ] +-- DefineEnd -> "}\n" +-- (Declare _t (Ident _i) _params) -> undefined +-- (SetVariable (Ident i) ir) -> concat ["%", i, " = ", insToString 0 ir] +-- (Add t v1 v2) -> +-- concat +-- [ "add ", show t, " ", show v1 +-- , ", ", show v2, "\n" +-- ] +-- (Sub t v1 v2) -> +-- concat +-- [ "sub ", show t, " ", show v1, ", " +-- , show v2, "\n" +-- ] +-- (Div t v1 v2) -> +-- concat +-- [ "sdiv ", show t, " ", show v1, ", " +-- , show v2, "\n" +-- ] +-- (Mul t v1 v2) -> +-- concat +-- [ "mul ", show t, " ", show v1 +-- , ", ", show v2, "\n" +-- ] +-- (Srem t v1 v2) -> +-- concat +-- [ "srem ", show t, " ", show v1, ", " +-- , show v2, "\n" +-- ] +-- (Call c t vis (Ident i) arg) -> +-- concat +-- [ "call ", show c, " ", show t, " ", show vis, i, "(" +-- , intercalate ", " $ Prelude.map (\(x, y) -> show x <> " " <> show y) arg +-- , ")\n" +-- ] +-- (Alloca t) -> unwords ["alloca", show t, "\n"] +-- (Store t1 val t2 (Ident id2)) -> +-- concat +-- [ "store ", show t1, " ", show val +-- , ", ", show t2 , " %", id2, "\n" +-- ] +-- (Load t1 t2 (Ident addr)) -> +-- concat +-- [ "load ", show t1, ", " +-- , show t2, " %", addr, "\n" +-- ] +-- (Bitcast t1 (Ident i) t2) -> +-- concat +-- [ "bitcast ", show t1, " %" +-- , i, " to ", show t2, "\n" +-- ] +-- (Icmp comp t v1 v2) -> +-- concat +-- [ "icmp ", show comp, " ", show t +-- , " ", show v1, ", ", show v2, "\n" +-- ] +-- (Ret t v) -> +-- concat +-- [ "ret ", show t, " " +-- , show v, "\n" +-- ] +-- (UnsafeRaw s) -> s +-- (Label (Ident s)) -> "\n" <> lblPfx <> s <> ":\n" +-- (Br (Ident s)) -> "br label %" <> lblPfx <> s <> "\n" +-- (BrCond val (Ident s1) (Ident s2)) -> +-- concat +-- [ "br i1 ", show val, ", ", "label %" +-- , lblPfx, s1, ", ", "label %", lblPfx, s2, "\n" +-- ] +-- (Comment s) -> "; " <> s <> "\n" +-- (Variable (Ident id)) -> "%" <> id +-- {- FOURMOLU_ENABLE -} +-- +-- lblPfx :: String +-- lblPfx = "lbl_" +-- diff --git a/src/LambdaLifter/LambdaLifter.hs b/src/LambdaLifter/LambdaLifter.hs index 661b95a..271cc70 100644 --- a/src/LambdaLifter/LambdaLifter.hs +++ b/src/LambdaLifter/LambdaLifter.hs @@ -1,235 +1,192 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} +--{-# LANGUAGE LambdaCase #-} +--{-# LANGUAGE OverloadedStrings #-} -module LambdaLifter.LambdaLifter (lambdaLift, freeVars, abstract, rename, collectScs) where +module LambdaLifter.LambdaLifter where -import Auxiliary (snoc) -import Control.Applicative (Applicative (liftA2)) -import Control.Monad.State (MonadState (get, put), State, - evalState) -import Data.Set (Set) -import qualified Data.Set as Set -import Debug.Trace (trace) -import qualified Grammar.Abs as GA -import Prelude hiding (exp) -import Renamer.Renamer -import TypeChecker.TypeCheckerIr +--import Auxiliary (snoc) +--import Control.Applicative (Applicative (liftA2)) +--import Control.Monad.State (MonadState (get, put), State, +-- evalState) +--import Data.Set (Set) +--import qualified Data.Set as Set +--import Prelude hiding (exp) +--import Renamer.Renamer +--import TypeChecker.TypeCheckerIr --- | Lift lambdas and let expression into supercombinators. --- Three phases: --- @freeVars@ annotatss all the free variables. --- @abstract@ converts lambdas into let expressions. --- @collectScs@ moves every non-constant let expression to a top-level function. -lambdaLift :: Program -> Program -lambdaLift = collectScs . abstract . freeVars - --- | Annotate free variables -freeVars :: Program -> AnnProgram -freeVars (Program ds) = [ (n, xs, freeVarsExp (Set.fromList xs) e) - | Bind n xs e <- ds - ] - -freeVarsExp :: Set Id -> Exp -> AnnExp -freeVarsExp localVars = \case - EId n | Set.member n localVars -> (Set.singleton n, AId n) - | otherwise -> (mempty, AId n) - - EInt i -> (mempty, AInt i) - - EApp t e1 e2 -> (Set.union (freeVarsOf e1') (freeVarsOf e2'), AApp t e1' e2') - where - e1' = freeVarsExp localVars e1 - e2' = freeVarsExp localVars e2 - - EAdd t e1 e2 -> (Set.union (freeVarsOf e1') (freeVarsOf e2'), AAdd t e1' e2') - where - e1' = freeVarsExp localVars e1 - e2' = freeVarsExp localVars e2 - - ESub t e1 e2 -> (Set.union (freeVarsOf e1') (freeVarsOf e2'), ASub t e1' e2') - where - e1' = freeVarsExp localVars e1 - e2' = freeVarsExp localVars e2 +---- | Lift lambdas and let expression into supercombinators. +---- Three phases: +---- @freeVars@ annotatss all the free variables. +---- @abstract@ converts lambdas into let expressions. +---- @collectScs@ moves every non-constant let expression to a top-level function. +--lambdaLift :: Program -> Program +--lambdaLift = collectScs . abstract . freeVars - EAbs t par e -> (Set.delete par $ freeVarsOf e', AAbs t par e') - where - e' = freeVarsExp (Set.insert par localVars) e +---- | Annotate free variables +--freeVars :: Program -> AnnProgram +--freeVars (Program ds) = [ (n, xs, freeVarsExp (Set.fromList xs) e) +-- | Bind n xs e <- ds +-- ] - -- Sum free variables present in bind and the expression - ELet (Bind name parms rhs) e -> (Set.union binders_frees e_free, ALet new_bind e') - where - binders_frees = Set.delete name $ freeVarsOf rhs' - e_free = Set.delete name $ freeVarsOf e' +--freeVarsExp :: Set Id -> Exp -> AnnExp +--freeVarsExp localVars = \case +-- EId n | Set.member n localVars -> (Set.singleton n, AId n) +-- | otherwise -> (mempty, AId n) - rhs' = freeVarsExp e_localVars rhs - new_bind = ABind name parms rhs' +-- ELit _ (LInt i) -> (mempty, AInt i) - e' = freeVarsExp e_localVars e - e_localVars = Set.insert name localVars +-- EApp t e1 e2 -> (Set.union (freeVarsOf e1') (freeVarsOf e2'), AApp t e1' e2') +-- where +-- e1' = freeVarsExp localVars e1 +-- e2' = freeVarsExp localVars e2 - (ECase t e cs) -> do - let e' = freeVarsExp localVars e - let vars = freeVarsOf e' - let (vars', cs') = foldr (\(_, Case c e) (vars,acc) -> do - let e' = freeVarsExp vars e - let vars' = freeVarsOf e' - (Set.union vars vars', AnnCase c e' : acc) - ) (vars, []) cs - (vars', ACase t e' (reverse cs')) +-- EAdd t e1 e2 -> (Set.union (freeVarsOf e1') (freeVarsOf e2'), AAdd t e1' e2') +-- where +-- e1' = freeVarsExp localVars e1 +-- e2' = freeVarsExp localVars e2 + +-- EAbs t par e -> (Set.delete par $ freeVarsOf e', AAbs t par e') +-- where +-- e' = freeVarsExp (Set.insert par localVars) e + +-- -- Sum free variables present in bind and the expression +-- ELet (Bind name parms rhs) e -> (Set.union binders_frees e_free, ALet new_bind e') +-- where +-- binders_frees = Set.delete name $ freeVarsOf rhs' +-- e_free = Set.delete name $ freeVarsOf e' + +-- rhs' = freeVarsExp e_localVars rhs +-- new_bind = ABind name parms rhs' + +-- e' = freeVarsExp e_localVars e +-- e_localVars = Set.insert name localVars -freeVarsOf :: AnnExp -> Set Id -freeVarsOf = fst +--freeVarsOf :: AnnExp -> Set Id +--freeVarsOf = fst --- AST annotated with free variables -type AnnProgram = [(Id, [Id], AnnExp)] +---- AST annotated with free variables +--type AnnProgram = [(Id, [Id], AnnExp)] -type AnnExp = (Set Id, AnnExp') +--type AnnExp = (Set Id, AnnExp') -data ABind = ABind Id [Id] AnnExp deriving Show +--data ABind = ABind Id [Id] AnnExp deriving Show -data AnnExp' = AId Id - | AInt Integer - | ALet ABind AnnExp - | AApp Type AnnExp AnnExp - | AAdd Type AnnExp AnnExp - | ASub Type AnnExp AnnExp - | AAbs Type Id AnnExp - | ACase Type AnnExp [AnnCase] - deriving Show -data AnnCase = AnnCase GA.Case AnnExp - deriving Show +--data AnnExp' = AId Id +-- | AInt Integer +-- | ALet ABind AnnExp +-- | AApp Type AnnExp AnnExp +-- | AAdd Type AnnExp AnnExp +-- | AAbs Type Id AnnExp +-- deriving Show +---- | Lift lambdas to let expression of the form @let sc = \v₁ x₁ -> e₁@. +---- Free variables are @v₁ v₂ .. vₙ@ are bound. +--abstract :: AnnProgram -> Program +--abstract prog = Program $ evalState (mapM go prog) 0 +-- where +-- go :: (Id, [Id], AnnExp) -> State Int Bind +-- go (name, parms, rhs) = Bind name (parms ++ parms1) <$> abstractExp rhs' +-- where +-- (rhs', parms1) = flattenLambdasAnn rhs --- | Lift lambdas to let expression of the form @let sc = \v₁ x₁ -> e₁@. --- Free variables are @v₁ v₂ .. vₙ@ are bound. -abstract :: AnnProgram -> Program -abstract prog = Program $ evalState (mapM go prog) 0 - where - go :: (Id, [Id], AnnExp) -> State Int Bind - go (name, parms, rhs) = Bind name (parms ++ parms1) <$> abstractExp rhs' - where - (rhs', parms1) = flattenLambdasAnn rhs +---- | Flatten nested lambdas and collect the parameters +---- @\x.\y.\z. ae → (ae, [x,y,z])@ +--flattenLambdasAnn :: AnnExp -> (AnnExp, [Id]) +--flattenLambdasAnn ae = go (ae, []) +-- where +-- go :: (AnnExp, [Id]) -> (AnnExp, [Id]) +-- go ((free, e), acc) = +-- case e of +-- AAbs _ par (free1, e1) -> +-- go ((Set.delete par free1, e1), snoc par acc) +-- _ -> ((free, e), acc) + +--abstractExp :: AnnExp -> State Int Exp +--abstractExp (free, exp) = case exp of +-- AId n -> pure $ EId n +-- AInt i -> pure $ ELit (TMono "Int") (LInt i) +-- AApp t e1 e2 -> liftA2 (EApp t) (abstractExp e1) (abstractExp e2) +-- AAdd t e1 e2 -> liftA2 (EAdd t) (abstractExp e1) (abstractExp e2) +-- ALet b e -> liftA2 ELet (go b) (abstractExp e) +-- where +-- go (ABind name parms rhs) = do +-- (rhs', parms1) <- flattenLambdas <$> skipLambdas abstractExp rhs +-- pure $ Bind name (parms ++ parms1) rhs' + +-- skipLambdas :: (AnnExp -> State Int Exp) -> AnnExp -> State Int Exp +-- skipLambdas f (free, ae) = case ae of +-- AAbs t par ae1 -> EAbs t par <$> skipLambdas f ae1 +-- _ -> f (free, ae) + +-- -- Lift lambda into let and bind free variables +-- AAbs t parm e -> do +-- i <- nextNumber +-- rhs <- abstractExp e + +-- let sc_name = Ident ("sc_" ++ show i) +-- sc = ELet (Bind (sc_name, t) parms rhs) $ EId (sc_name, t) + +-- pure $ foldl (EApp $ TMono "Int") sc $ map EId freeList +-- where +-- freeList = Set.toList free +-- parms = snoc parm freeList --- | Flatten nested lambdas and collect the parameters --- @\x.\y.\z. ae → (ae, [x,y,z])@ -flattenLambdasAnn :: AnnExp -> (AnnExp, [Id]) -flattenLambdasAnn ae = go (ae, []) - where - go :: (AnnExp, [Id]) -> (AnnExp, [Id]) - go ((free, e), acc) = - case e of - AAbs _ par (free1, e1) -> - go ((Set.delete par free1, e1), snoc par acc) - _ -> ((free, e), acc) +--nextNumber :: State Int Int +--nextNumber = do +-- i <- get +-- put $ succ i +-- pure i -abstractExp :: AnnExp -> State Int Exp -abstractExp (free, exp) = case exp of - AId n -> pure $ EId n - AInt i -> pure $ EInt i - AApp t e1 e2 -> liftA2 (EApp t) (abstractExp e1) (abstractExp e2) - AAdd t e1 e2 -> liftA2 (EAdd t) (abstractExp e1) (abstractExp e2) - ASub t e1 e2 -> liftA2 (ESub t) (abstractExp e1) (abstractExp e2) - ALet b e -> liftA2 ELet (go b) (abstractExp e) - where - go (ABind name parms rhs) = do - (rhs', parms1) <- flattenLambdas <$> skipLambdas abstractExp rhs - pure $ Bind name (parms ++ parms1) rhs' - - skipLambdas :: (AnnExp -> State Int Exp) -> AnnExp -> State Int Exp - skipLambdas f (free, ae) = case ae of - AAbs t par ae1 -> EAbs t par <$> skipLambdas f ae1 - _ -> f (free, ae) +---- | Collects supercombinators by lifting non-constant let expressions +--collectScs :: Program -> Program +--collectScs (Program scs) = Program $ concatMap collectFromRhs scs +-- where +-- collectFromRhs (Bind name parms rhs) = +-- let (rhs_scs, rhs') = collectScsExp rhs +-- in Bind name parms rhs' : rhs_scs - ACase t e cs -> do - e' <- abstractExp e - cs' <- mapM (\(AnnCase c e) -> do - e' <- abstractExp e - pure (t,Case c e')) cs - pure $ ECase t e' cs' +--collectScsExp :: Exp -> ([Bind], Exp) +--collectScsExp = \case +-- EId n -> ([], EId n) +-- ELit _ (LInt i) -> ([], ELit (TMono "Int") (LInt i)) - -- Lift lambda into let and bind free variables - AAbs t parm e -> do - i <- nextNumber - rhs <- abstractExp e +-- EApp t e1 e2 -> (scs1 ++ scs2, EApp t e1' e2') +-- where +-- (scs1, e1') = collectScsExp e1 +-- (scs2, e2') = collectScsExp e2 - let sc_name = Ident ("sc_" ++ show i) - sc = ELet (Bind (sc_name, t) parms rhs) $ EId (sc_name, t) +-- EAdd t e1 e2 -> (scs1 ++ scs2, EAdd t e1' e2') +-- where +-- (scs1, e1') = collectScsExp e1 +-- (scs2, e2') = collectScsExp e2 - pure $ foldl (EApp TInt) sc $ map EId freeList - where - freeList = Set.toList free - parms = snoc parm freeList +-- EAbs t par e -> (scs, EAbs t par e') +-- where +-- (scs, e') = collectScsExp e + +-- -- Collect supercombinators from bind, the rhss, and the expression. +-- -- +-- -- > f = let sc x y = rhs in e +-- -- +-- ELet (Bind name parms rhs) e -> if null parms +-- then ( rhs_scs ++ e_scs, ELet bind e') +-- else (bind : rhs_scs ++ e_scs, e') +-- where +-- bind = Bind name parms rhs' +-- (rhs_scs, rhs') = collectScsExp rhs +-- (e_scs, e') = collectScsExp e -nextNumber :: State Int Int -nextNumber = do - i <- get - put $ succ i - pure i +---- @\x.\y.\z. e → (e, [x,y,z])@ +--flattenLambdas :: Exp -> (Exp, [Id]) +--flattenLambdas = go . (, []) +-- where +-- go (e, acc) = case e of +-- EAbs _ par e1 -> go (e1, snoc par acc) +-- _ -> (e, acc) --- | Collects supercombinators by lifting non-constant let expressions -collectScs :: Program -> Program -collectScs (Program scs) = Program $ concatMap collectFromRhs scs - where - collectFromRhs (Bind name parms rhs) = - let (rhs_scs, rhs') = collectScsExp rhs - in Bind name parms rhs' : rhs_scs - - -collectScsExp :: Exp -> ([Bind], Exp) -collectScsExp = \case - EId n -> ([], EId n) - EInt i -> ([], EInt i) - - EApp t e1 e2 -> (scs1 ++ scs2, EApp t e1' e2') - where - (scs1, e1') = collectScsExp e1 - (scs2, e2') = collectScsExp e2 - - EAdd t e1 e2 -> (scs1 ++ scs2, EAdd t e1' e2') - where - (scs1, e1') = collectScsExp e1 - (scs2, e2') = collectScsExp e2 - - ESub t e1 e2 -> (scs1 ++ scs2, ESub t e1' e2') - where - (scs1, e1') = collectScsExp e1 - (scs2, e2') = collectScsExp e2 - - EAbs t par e -> (scs, EAbs t par e') - where - (scs, e') = collectScsExp e - - -- Collect supercombinators from bind, the rhss, and the expression. - -- - -- > f = let sc x y = rhs in e - -- - ELet (Bind name parms rhs) e -> if null parms - then ( rhs_scs ++ e_scs, ELet bind e') - else (bind : rhs_scs ++ e_scs, e') - where - bind = Bind name parms rhs' - (rhs_scs, rhs') = collectScsExp rhs - (e_scs, e') = collectScsExp e - ECase t e cs -> do - let (scs, e') = collectScsExp e - let (scs',cs') = foldr (\(t, Case c e) (scs, acc) -> do - let (scs', e') = collectScsExp e - (scs ++ scs', (t,Case c e') : acc) - ) (scs,[]) cs - (scs', ECase t e' cs') - - --- @\x.\y.\z. e → (e, [x,y,z])@ -flattenLambdas :: Exp -> (Exp, [Id]) -flattenLambdas = go . (, []) - where - go (e, acc) = case e of - EAbs _ par e1 -> go (e1, snoc par acc) - _ -> (e, acc) diff --git a/src/Main.hs b/src/Main.hs index 7390341..c82f6a5 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -2,26 +2,26 @@ module Main where -import Codegen.Codegen (generateCode) -import GHC.IO.Handle.Text (hPutStrLn) -import Grammar.ErrM (Err) -import Grammar.Par (myLexer, pProgram) -import Grammar.Print (printTree) +--import Codegen.Codegen (generateCode) +import GHC.IO.Handle.Text (hPutStrLn) +import Grammar.ErrM (Err) +import Grammar.Par (myLexer, pProgram) +import Grammar.Print (printTree) -- import Interpreter (interpret) -import Control.Monad (when) -import Data.List.Extra (isSuffixOf) -import LambdaLifter.LambdaLifter (lambdaLift) -import Renamer.Renamer (rename) -import System.Directory (createDirectory, doesPathExist, - getDirectoryContents, - removeDirectoryRecursive, - setCurrentDirectory) -import System.Environment (getArgs) -import System.Exit (exitFailure, exitSuccess) -import System.IO (stderr) -import System.Process.Extra (spawnCommand, waitForProcess) -import TypeChecker.TypeChecker (typecheck) +import Control.Monad (when) +import Data.List.Extra (isSuffixOf) +--import LambdaLifter.LambdaLifter (lambdaLift) +import Renamer.Renamer (rename) +import System.Directory (createDirectory, doesPathExist, + getDirectoryContents, + removeDirectoryRecursive, + setCurrentDirectory) +import System.Environment (getArgs) +import System.Exit (exitFailure, exitSuccess) +import System.IO (stderr) +import System.Process.Extra (spawnCommand, waitForProcess) +import TypeChecker.TypeChecker (typecheck) main :: IO () main = @@ -46,19 +46,19 @@ main' debug s = do typechecked <- fromTypeCheckerErr $ typecheck renamed printToErr $ printTree typechecked - printToErr "\n-- Lambda Lifter --" - let lifted = lambdaLift typechecked - printToErr $ printTree lifted - - printToErr "\n -- Printing compiler output to stdout --" - compiled <- fromCompilerErr $ generateCode lifted + -- printToErr "\n-- Lambda Lifter --" + -- let lifted = lambdaLift typechecked + -- printToErr $ printTree lifted +-- + -- printToErr "\n -- Printing compiler output to stdout --" + -- compiled <- fromCompilerErr $ generateCode lifted --putStrLn compiled - check <- doesPathExist "output" - when check (removeDirectoryRecursive "output") - createDirectory "output" - writeFile "output/llvm.ll" compiled - if debug then debugDotViz else putStrLn compiled + -- check <- doesPathExist "output" + -- when check (removeDirectoryRecursive "output") + -- createDirectory "output" + -- writeFile "output/llvm.ll" compiled + -- if debug then debugDotViz else putStrLn compiled -- interpred <- fromInterpreterErr $ interpret lifted diff --git a/src/Renamer/Renamer.hs b/src/Renamer/Renamer.hs index 3c426b4..1def35e 100644 --- a/src/Renamer/Renamer.hs +++ b/src/Renamer/Renamer.hs @@ -1,86 +1,87 @@ {-# LANGUAGE LambdaCase #-} -module Renamer.Renamer (module Renamer.Renamer) where +module Renamer.Renamer where import Auxiliary (mapAccumM) -import Control.Monad (foldM) import Control.Monad.State (MonadState, State, evalState, gets, modify) +import Data.List (foldl') import Data.Map (Map) import qualified Data.Map as Map import Data.Maybe (fromMaybe) import Data.Tuple.Extra (dupe) import Grammar.Abs - -- | Rename all variables and local binds rename :: Program -> Program rename (Program bs) = Program $ evalState (runRn $ mapM (renameSc initNames) bs) 0 where - initNames = Map.fromList $ map (\(Bind name _ _ _ _) -> dupe name) bs - renameSc :: Names -> Bind -> Rn Bind - renameSc old_names (Bind name t _ parms rhs) = do + -- initNames = Map.fromList $ map (\(Bind name _ _ _ _) -> dupe name) bs + initNames = Map.fromList $ foldl' saveIfBind [] bs + saveIfBind acc (DBind (Bind name _ _ _ _)) = dupe name : acc + saveIfBind acc _ = acc + renameSc :: Names -> Def -> Rn Def + renameSc old_names (DBind (Bind name t _ parms rhs)) = do (new_names, parms') <- newNames old_names parms - rhs' <- snd <$> renameExp new_names rhs - pure $ Bind name t name parms' rhs' - + rhs' <- snd <$> renameExp new_names rhs + pure . DBind $ Bind name t name parms' rhs' + renameSc _ def = pure def -- | Rename monad. State holds the number of renamed names. -newtype Rn a = Rn { runRn :: State Int a } - deriving (Functor, Applicative, Monad, MonadState Int) +newtype Rn a = Rn {runRn :: State Int a} + deriving (Functor, Applicative, Monad, MonadState Int) -- | Maps old to new name type Names = Map Ident Ident renameLocalBind :: Names -> Bind -> Rn (Names, Bind) renameLocalBind old_names (Bind name t _ parms rhs) = do - (new_names, name') <- newName old_names name + (new_names, name') <- newName old_names name (new_names', parms') <- newNames new_names parms - (new_names'', rhs') <- renameExp new_names' rhs + (new_names'', rhs') <- renameExp new_names' rhs pure (new_names'', Bind name' t name' parms' rhs') renameExp :: Names -> Exp -> Rn (Names, Exp) renameExp old_names = \case - EId n -> pure (old_names, EId . fromMaybe n $ Map.lookup n old_names) - - EInt i1 -> pure (old_names, EInt i1) - + EId n -> pure (old_names, EId . fromMaybe n $ Map.lookup n old_names) + ELit (LInt i1) -> pure (old_names, ELit (LInt i1)) EApp e1 e2 -> do (env1, e1') <- renameExp old_names e1 (env2, e2') <- renameExp old_names e2 pure (Map.union env1 env2, EApp e1' e2') - EAdd e1 e2 -> do (env1, e1') <- renameExp old_names e1 (env2, e2') <- renameExp old_names e2 pure (Map.union env1 env2, EAdd e1' e2') - ESub e1 e2 -> do (env1, e1') <- renameExp old_names e1 (env2, e2') <- renameExp old_names e2 pure (Map.union env1 env2, ESub e1' e2') - - ELet b e -> do - (new_names, b) <- renameLocalBind old_names b - (new_names', e') <- renameExp new_names e - pure (new_names', ELet b e') - - EAbs par t e -> do + ELet i e1 e2 -> do + (new_names, e1') <- renameExp old_names e1 + (new_names', e2') <- renameExp new_names e2 + pure (new_names', ELet i e1' e2') + EAbs par e -> do (new_names, par') <- newName old_names par - (new_names', e') <- renameExp new_names e - pure (new_names', EAbs par' t e') - + (new_names', e') <- renameExp new_names e + pure (new_names', EAbs par' e') EAnn e t -> do (new_names, e') <- renameExp old_names e pure (new_names, EAnn e' t) + ECase e injs -> do + (_, e') <- renameExp old_names e + (new_names, injs') <- renameInjs old_names injs + pure (new_names, ECase e' injs') - ECase e cs t -> do - (new_names, e') <- renameExp old_names e - (new_names', cs') <- foldM (\(names, stack) (CaseMatch c exp) -> do - (nm,exp') <- renameExp names exp - pure (nm,CaseMatch c exp' : stack) - ) (new_names, []) cs - pure (new_names', ECase e' cs' t) +renameInjs :: Names -> [Inj] -> Rn (Names, [Inj]) +renameInjs ns xs = do + (new_names, xs') <- unzip <$> mapM (renameInj ns) xs + if null new_names then return (mempty, xs') else return (head new_names, xs') + +renameInj :: Names -> Inj -> Rn (Names, Inj) +renameInj ns (Inj init e) = do + (new_names, e') <- renameExp ns e + return (new_names, Inj init e') -- | Create a new name and add it to name environment. newName :: Names -> Ident -> Rn (Names, Ident) @@ -95,4 +96,3 @@ newNames = mapAccumM newName -- | Annotate name with number and increment the number @prefix ⇒ prefix_number@. makeName :: Ident -> Rn Ident makeName (Ident prefix) = gets (\i -> Ident $ prefix ++ "_" ++ show i) <* modify succ - diff --git a/src/TypeChecker/TypeChecker.hs b/src/TypeChecker/TypeChecker.hs index 3d6bba8..c9a4ac4 100644 --- a/src/TypeChecker/TypeChecker.hs +++ b/src/TypeChecker/TypeChecker.hs @@ -1,215 +1,517 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} -module TypeChecker.TypeChecker (typecheck, partitionType) where +-- | A module for type checking and inference using algorithm W, Hindley-Milner +module TypeChecker.TypeChecker where -import Auxiliary (maybeToRightM, snoc) -import Control.Monad.Except (throwError, unless) +import Control.Monad.Except +import Control.Monad.Reader +import Control.Monad.State +import Data.Foldable (traverse_) +import Data.Functor.Identity (runIdentity) +import Data.List (foldl') import Data.Map (Map) -import qualified Data.Map as Map +import qualified Data.Map as M +import Data.Set (Set) +import qualified Data.Set as S +import Debug.Trace (trace) import Grammar.Abs -import Grammar.ErrM (Err) -import Grammar.Print (Print (prt), concatD, doc, - printTree, render) -import Prelude hiding (exp, id) +import Grammar.Print (printTree) import qualified TypeChecker.TypeCheckerIr as T +import TypeChecker.TypeCheckerIr (Ctx (..), Env (..), Error, Infer, + Poly (..), Subst) --- NOTE: this type checker is poorly tested +initCtx = Ctx mempty --- TODO --- Coercion --- Type inference +initEnv = Env 0 mempty mempty -data Cxt = Cxt - { env :: Map Ident Type -- ^ Local scope signature - , sig :: Map Ident Type -- ^ Top-level signatures - } +runPretty :: Exp -> Either Error String +runPretty = fmap (printTree . fst) . run . inferExp -initCxt :: [Bind] -> Cxt -initCxt sc = Cxt { env = mempty - , sig = Map.fromList $ map (\(Bind n t _ _ _) -> (n, t)) sc - } +run :: Infer a -> Either Error a +run = runC initEnv initCtx -typecheck :: Program -> Err T.Program -typecheck (Program sc) = T.Program <$> mapM (checkBind $ initCxt sc) sc +runC :: Env -> Ctx -> Infer a -> Either Error a +runC e c = runIdentity . runExceptT . flip runReaderT c . flip evalStateT e --- | Check if infered rhs type matches type signature. -checkBind :: Cxt -> Bind -> Err T.Bind -checkBind cxt b = - case expandLambdas b of - Bind name t _ parms rhs -> do - (rhs', t_rhs) <- infer cxt rhs - unless (typeEq t_rhs t) . throwError $ typeErr name t t_rhs - pure $ T.Bind (name, t) (zip parms ts_parms) rhs' - where - ts_parms = fst $ partitionType (length parms) t +typecheck :: Program -> Either Error T.Program +typecheck = run . checkPrg --- | @ f x y = rhs ⇒ f = \x.\y. rhs @ -expandLambdas :: Bind -> Bind -expandLambdas (Bind name t _ parms rhs) = Bind name t name [] rhs' +{- | Start by freshening the type variable of data types to avoid clash with +other user defined polymorphic types +This might be wrong for type constructors that work over several variables +-} +freshenData :: Data -> Infer Data +freshenData (Data (Constr name ts) constrs) = do + fr <- fresh + let fr' = case fr of + TPol a -> a + -- Meh, this part assumes fresh generates a polymorphic type + _ -> + error + "Bug: implementation of \ + \ fresh and freshenData are not compatible" + let new_ts = map (freshenType fr') ts + let new_constrs = map (freshenConstr fr') constrs + return $ Data (Constr name new_ts) new_constrs + +{- | Freshen all polymorphic variables, regardless of name +| freshenType "d" (a -> b -> c) becomes (d -> d -> d) +-} +freshenType :: Ident -> Type -> Type +freshenType iden = \case + (TPol _) -> TPol iden + (TArr a b) -> TArr (freshenType iden a) (freshenType iden b) + (TConstr (Constr a ts)) -> + TConstr (Constr a (map (freshenType iden) ts)) + rest -> rest + +freshenConstr :: Ident -> Constructor -> Constructor +freshenConstr iden (Constructor name t) = + Constructor name (freshenType iden t) + +checkData :: Data -> Infer () +checkData d = do + d' <- freshenData d + case d' of + (Data typ@(Constr name ts) constrs) -> do + unless + (all isPoly ts) + (throwError $ unwords ["Data type incorrectly declared"]) + traverse_ + ( \(Constructor name' t') -> + if TConstr typ == retType t' + then insertConstr name' t' + else + throwError $ + unwords + [ "return type of constructor:" + , printTree name + , "with type:" + , printTree (retType t') + , "does not match data: " + , printTree typ + ] + ) + constrs + +retType :: Type -> Type +retType (TArr _ t2) = retType t2 +retType a = a + +checkPrg :: Program -> Infer T.Program +checkPrg (Program bs) = do + preRun bs + T.Program <$> checkDef bs where - rhs' = foldr ($) rhs $ zipWith EAbs parms ts_parms - ts_parms = fst $ partitionType (length parms) t + preRun :: [Def] -> Infer () + preRun [] = return () + preRun (x : xs) = case x of + DBind (Bind n t _ _ _) -> insertSig n t >> preRun xs + DData d@(Data _ _) -> checkData d >> preRun xs --- | Infer type of expression. -infer :: Cxt -> Exp -> Err (T.Exp, Type) -infer cxt = \case - EId x -> - case lookupEnv x cxt of - Nothing -> - case lookupSig x cxt of - Nothing -> throwError ("Unbound variable:" ++ printTree x) - Just t -> pure (T.EId (x, t), t) - Just t -> pure (T.EId (x, t), t) + checkDef :: [Def] -> Infer [T.Def] + checkDef [] = return [] + checkDef (x : xs) = case x of + (DBind b) -> do + b' <- checkBind b + fmap (T.DBind b' :) (checkDef xs) + (DData d) -> fmap (T.DData d :) (checkDef xs) - EInt i -> pure (T.EInt i, T.TInt) +checkBind :: Bind -> Infer T.Bind +checkBind (Bind n t _ args e) = do + (t', e') <- inferExp $ makeLambda e (reverse args) + s <- unify t t' + let t'' = apply s t + unless + (t `typeEq` t'') + ( throwError $ + unwords + [ "Top level signature" + , printTree t + , "does not match body with inferred type:" + , printTree t'' + ] + ) + return $ T.Bind (n, t) e' + where + makeLambda :: Exp -> [Ident] -> Exp + makeLambda = foldl (flip EAbs) - EApp e e1 -> do - (e', t) <- infer cxt e - case t of - TFun t1 t2 -> do - e1' <- check cxt e1 t1 - pure (T.EApp t2 e' e1', t2) - _ -> do - throwError ("Not a function: " ++ show e) - - EAdd e e1 -> do - e' <- check cxt e T.TInt - e1' <- check cxt e1 T.TInt - pure (T.EAdd T.TInt e' e1', T.TInt) - - ESub e e1 -> do - e' <- check cxt e T.TInt - e1' <- check cxt e1 T.TInt - pure (T.ESub T.TInt e' e1', T.TInt) - - EAbs x t e -> do - (e', t1) <- infer (insertEnv x t cxt) e - let t_abs = TFun t t1 - pure (T.EAbs t_abs (x, t) e', t_abs) - - ELet b e -> do - let cxt' = insertBind b cxt - b' <- checkBind cxt' b - (e', t) <- infer cxt' e - pure (T.ELet b' e', t) - - EAnn e t -> do - (e', t1) <- infer cxt e - unless (typeEq t t1) $ - throwError "Inferred type and type annotation doesn't match" - pure (e', t1) - - ECase e cs t -> do - (e',t1) <- infer cxt e - unless (typeEq t t1) $ - throwError "Inferred type and type annotation doesn't match" - case traverse (\(CaseMatch c e) -> do - -- //TODO check c as well - e' <- check cxt e t - unless (typeEq t t1) $ - throwError "Inferred type and type annotation doesn't match" - pure (t1, T.Case c e') - ) cs of - Right cs -> pure (T.ECase t1 e' cs,t1) - Left e -> throwError e - --- | Check infered type matches the supplied type. -check :: Cxt -> Exp -> Type -> Err T.Exp -check cxt exp typ = case exp of - EId x -> do - t <- case lookupEnv x cxt of - Nothing -> maybeToRightM - ("Unbound variable:" ++ printTree x) - (lookupSig x cxt) - Just t -> pure t - unless (typeEq t typ) . throwError $ typeErr x typ t - pure $ T.EId (x, t) - - EInt i -> do - unless (typeEq typ TInt) $ throwError $ typeErr i TInt typ - pure $ T.EInt i - - EApp e e1 -> do - (e', t) <- infer cxt e - case t of - TFun t1 t2 -> do - e1' <- check cxt e1 t1 - pure $ T.EApp t2 e' e1' - _ -> throwError ("Not a function 2: " ++ printTree e) - - EAdd e e1 -> do - e' <- check cxt e T.TInt - e1' <- check cxt e1 T.TInt - pure $ T.EAdd T.TInt e' e1' - - ESub e e1 -> do - e' <- check cxt e T.TInt - e1' <- check cxt e1 T.TInt - pure $ T.ESub T.TInt e' e1' - - EAbs x t e -> do - (e', t_e) <- infer (insertEnv x t cxt) e - let t1 = TFun t t_e - unless (typeEq t1 typ) $ throwError "Wrong lamda type!" - pure $ T.EAbs t1 (x, t) e' - - ECase e cs t -> do - (e',t1) <- infer cxt e - unless (typeEq t t1) $ - throwError "Inferred type and type annotation doesn't match" - case traverse (\(CaseMatch c e) -> do - -- //TODO check c as well - e' <- check cxt e t - unless (typeEq t t1) $ - throwError "Inferred type and type annotation doesn't match" - pure (t1, T.Case c e') - ) cs of - Right cs -> pure $ T.ECase t1 e' cs - Left e -> throwError e - - ELet b e -> do - let cxt' = insertBind b cxt - b' <- checkBind cxt' b - e' <- check cxt' e typ - pure $ T.ELet b' e' - - EAnn e t -> do - unless (typeEq t typ) $ - throwError "Inferred type and type annotation doesn't match" - check cxt e t - --- | Check if types are equivalent. Doesn't handle coercion or polymorphism. +{- | Check if two types are considered equal + For the purpose of the algorithm two polymorphic types are always considered + equal +-} typeEq :: Type -> Type -> Bool -typeEq (TFun t t1) (TFun q q1) = typeEq t q && typeEq t1 q1 -typeEq t t1 = t == t1 +typeEq (TArr l r) (TArr l' r') = typeEq l l' && typeEq r r' +typeEq (TMono a) (TMono b) = a == b +typeEq (TConstr (Constr name a)) (TConstr (Constr name' b)) = + length a == length b + && name == name' + && and (zipWith typeEq a b) +typeEq (TPol _) (TPol _) = True +typeEq _ _ = False --- | Partion type into types of parameters and return type. -partitionType :: Int -- Number of parameters to apply - -> Type - -> ([Type], Type) -partitionType = go [] - where - go acc 0 t = (acc, t) - go acc i t = case t of - TFun t1 t2 -> go (snoc t1 acc) (i - 1) t2 - _ -> error "Number of parameters and type doesn't match" +isMoreSpecificOrEq :: Type -> Type -> Bool +isMoreSpecificOrEq _ (TPol _) = True +isMoreSpecificOrEq (TArr a b) (TArr c d) = + isMoreSpecificOrEq a c && isMoreSpecificOrEq b d +isMoreSpecificOrEq (TConstr (Constr n1 ts1)) (TConstr (Constr n2 ts2)) = + n1 == n2 + && length ts1 == length ts2 + && and (zipWith isMoreSpecificOrEq ts1 ts2) +isMoreSpecificOrEq a b = a == b -insertBind :: Bind -> Cxt -> Cxt -insertBind (Bind n t _ _ _) = insertEnv n t +isPoly :: Type -> Bool +isPoly (TPol _) = True +isPoly _ = False -lookupEnv :: Ident -> Cxt -> Maybe Type -lookupEnv x = Map.lookup x . env +inferExp :: Exp -> Infer (Type, T.Exp) +inferExp e = do + (s, t, e') <- algoW e + let subbed = apply s t + return (subbed, replace subbed e') -insertEnv :: Ident -> Type -> Cxt -> Cxt -insertEnv x t cxt = cxt { env = Map.insert x t cxt.env } +replace :: Type -> T.Exp -> T.Exp +replace t = \case + T.ELit _ e -> T.ELit t e + T.EId (n, _) -> T.EId (n, t) + T.EAbs _ name e -> T.EAbs t name e + T.EApp _ e1 e2 -> T.EApp t e1 e2 + T.EAdd _ e1 e2 -> T.EAdd t e1 e2 + T.ESub _ e1 e2 -> T.ESub t e1 e2 + T.ELet (T.Bind (n, _) e1) e2 -> T.ELet (T.Bind (n, t) e1) e2 + T.ECase _ expr injs -> T.ECase t expr injs -lookupSig :: Ident -> Cxt -> Maybe Type -lookupSig x = Map.lookup x . sig +algoW :: Exp -> Infer (Subst, Type, T.Exp) +algoW = \case + -- \| TODO: More testing need to be done. Unsure of the correctness of this + EAnn e t -> do + (s1, t', e') <- algoW e + unless + (t `isMoreSpecificOrEq` t') + ( throwError $ + unwords + [ "Annotated type:" + , printTree t + , "does not match inferred type:" + , printTree t' + ] + ) + applySt s1 $ do + s2 <- unify t t' + return (s2 `compose` s1, t, e') -typeErr :: Print a => a -> Type -> Type -> String -typeErr p expected actual = render $ concatD - [ doc $ showString "Wrong type:", prt 0 p , doc $ showString "\n" - , doc $ showString "Expected:" , prt 0 expected, doc $ showString "\n" - , doc $ showString "Actual: " , prt 0 actual - ] + -- \| ------------------ + -- \| Γ ⊢ i : Int, ∅ + + ELit (LInt n) -> + return (nullSubst, TMono "Int", T.ELit (TMono "Int") (LInt n)) + ELit a -> error $ "NOT IMPLEMENTED YET: ELit " ++ show a + -- \| x : σ ∈ Γ   τ = inst(σ) + -- \| ---------------------- + -- \| Γ ⊢ x : τ, ∅ + + EId i -> do + var <- asks vars + case M.lookup i var of + Just t -> inst t >>= \x -> return (nullSubst, x, T.EId (i, x)) + Nothing -> do + sig <- gets sigs + case M.lookup i sig of + Just t -> return (nullSubst, t, T.EId (i, t)) + Nothing -> do + constr <- gets constructors + case M.lookup i constr of + Just t -> return (nullSubst, t, T.EId (i, t)) + Nothing -> + throwError $ + "Unbound variable: " ++ show i + + -- \| τ = newvar Γ, x : τ ⊢ e : τ', S + -- \| --------------------------------- + -- \| Γ ⊢ w λx. e : Sτ → τ', S + + EAbs name e -> do + fr <- fresh + withBinding name (Forall [] fr) $ do + (s1, t', e') <- algoW e + let varType = apply s1 fr + let newArr = TArr varType t' + return (s1, newArr, T.EAbs newArr (name, varType) e') + + -- \| Γ ⊢ e₀ : τ₀, S₀ S₀Γ ⊢ e₁ : τ₁, S₁ + -- \| s₂ = mgu(s₁τ₀, Int) s₃ = mgu(s₂τ₁, Int) + -- \| ------------------------------------------ + -- \| Γ ⊢ e₀ + e₁ : Int, S₃S₂S₁S₀ + -- This might be wrong + + EAdd e0 e1 -> do + (s1, t0, e0') <- algoW e0 + applySt s1 $ do + (s2, t1, e1') <- algoW e1 + -- applySt s2 $ do + s3 <- unify (apply s2 t0) (TMono "Int") + s4 <- unify (apply s3 t1) (TMono "Int") + return + ( s4 `compose` s3 `compose` s2 `compose` s1 + , TMono "Int" + , T.EAdd (TMono "Int") e0' e1' + ) + + ESub e0 e1 -> do + (s1, t0, e0') <- algoW e0 + applySt s1 $ do + (s2, t1, e1') <- algoW e1 + -- applySt s2 $ do + s3 <- unify (apply s2 t0) (TMono "Int") + s4 <- unify (apply s3 t1) (TMono "Int") + return + ( s4 `compose` s3 `compose` s2 `compose` s1 + , TMono "Int" + , T.ESub (TMono "Int") e0' e1' + ) + + -- \| Γ ⊢ e₀ : τ₀, S₀ S₀Γ ⊢ e₁ : τ₁, S1 + -- \| τ' = newvar S₂ = mgu(S₁τ₀, τ₁ → τ') + -- \| -------------------------------------- + -- \| Γ ⊢ e₀ e₁ : S₂τ', S₂S₁S₀ + + EApp e0 e1 -> do + fr <- fresh + (s0, t0, e0') <- algoW e0 + applySt s0 $ do + (s1, t1, e1') <- algoW e1 + -- applySt s1 $ do + s2 <- unify (apply s1 t0) (TArr t1 fr) + let t = apply s2 fr + return (s2 `compose` s1 `compose` s0, t, T.EApp t e0' e1') + + -- \| Γ ⊢ e₀ : τ, S₀ S₀Γ, x : S̅₀Γ̅(τ) ⊢ e₁ : τ', S₁ + -- \| ---------------------------------------------- + -- \| Γ ⊢ let x = e₀ in e₁ : τ', S₁S₀ + + -- The bar over S₀ and Γ means "generalize" + + ELet name e0 e1 -> do + (s1, t1, e0') <- algoW e0 + env <- asks vars + let t' = generalize (apply s1 env) t1 + withBinding name t' $ do + (s2, t2, e1') <- algoW e1 + return (s2 `compose` s1, t2, T.ELet (T.Bind (name, t2) e0') e1') + ECase caseExpr injs -> do + (_, t0, e0') <- algoW caseExpr + (injs', ts) <- mapAndUnzipM (checkInj t0) injs + case ts of + [] -> throwError "Case expression missing any matches" + ts -> do + unified <- zipWithM unify ts (tail ts) + let unified' = foldl' compose mempty unified + let typ = apply unified' (head ts) + return (unified', typ, T.ECase typ e0' injs') + +-- | Unify two types producing a new substitution +unify :: Type -> Type -> Infer Subst +unify t0 t1 = do + trace ("t0: " ++ show t0) return () + trace ("t1: " ++ show t1) return () + case (t0, t1) of + (TArr a b, TArr c d) -> do + s1 <- unify a c + s2 <- unify (apply s1 b) (apply s1 d) + return $ s1 `compose` s2 + (TPol a, b) -> occurs a b + (a, TPol b) -> occurs b a + (TMono a, TMono b) -> + if a == b then return M.empty else throwError "Types do not unify" + -- \| TODO: Figure out a cleaner way to express the same thing + (TConstr (Constr name t), TConstr (Constr name' t')) -> + if name == name' && length t == length t' + then do + xs <- zipWithM unify t t' + return $ foldr compose nullSubst xs + else + throwError $ + unwords + [ "Type constructor:" + , printTree name + , "(" ++ printTree t ++ ")" + , "does not match with:" + , printTree name' + , "(" ++ printTree t' ++ ")" + ] + (a, b) -> + throwError . unwords $ + [ "Type:" + , printTree a + , "can't be unified with:" + , printTree b + ] + +{- | Check if a type is contained in another type. +I.E. { a = a -> b } is an unsolvable constraint since there is no substitution +such that these are equal +-} +occurs :: Ident -> Type -> Infer Subst +occurs _ (TPol _) = return nullSubst +occurs i t = + if S.member i (free t) + then + throwError $ + unwords + [ "Occurs check failed, can't unify" + , printTree (TPol i) + , "with" + , printTree t + ] + else return $ M.singleton i t + +-- | Generalize a type over all free variables in the substitution set +generalize :: Map Ident Poly -> Type -> Poly +generalize env t = Forall (S.toList $ free t S.\\ free env) t + +{- | Instantiate a polymorphic type. The free type variables are substituted +with fresh ones. +-} +inst :: Poly -> Infer Type +inst (Forall xs t) = do + xs' <- mapM (const fresh) xs + let s = M.fromList $ zip xs xs' + return $ apply s t + +-- | Compose two substitution sets +compose :: Subst -> Subst -> Subst +compose m1 m2 = M.map (apply m1) m2 `M.union` m1 + +-- | A class representing free variables functions +class FreeVars t where + -- | Get all free variables from t + free :: t -> Set Ident + + -- | Apply a substitution to t + apply :: Subst -> t -> t + +instance FreeVars Type where + free :: Type -> Set Ident + free (TPol a) = S.singleton a + free (TMono _) = mempty + free (TArr a b) = free a `S.union` free b + -- \| Not guaranteed to be correct + free (TConstr (Constr _ a)) = + foldl' (\acc x -> free x `S.union` acc) S.empty a + + apply :: Subst -> Type -> Type + apply sub t = do + case t of + TMono a -> TMono a + TPol a -> case M.lookup a sub of + Nothing -> TPol a + Just t -> t + TArr a b -> TArr (apply sub a) (apply sub b) + TConstr (Constr name a) -> TConstr (Constr name (map (apply sub) a)) + +instance FreeVars Poly where + free :: Poly -> Set Ident + free (Forall xs t) = free t S.\\ S.fromList xs + apply :: Subst -> Poly -> Poly + apply s (Forall xs t) = Forall xs (apply (foldr M.delete s xs) t) + +instance FreeVars (Map Ident Poly) where + free :: Map Ident Poly -> Set Ident + free m = foldl' S.union S.empty (map free $ M.elems m) + apply :: Subst -> Map Ident Poly -> Map Ident Poly + apply s = M.map (apply s) + +-- | Apply substitutions to the environment. +applySt :: Subst -> Infer a -> Infer a +applySt s = local (\st -> st{vars = apply s (vars st)}) + +-- | Represents the empty substition set +nullSubst :: Subst +nullSubst = M.empty + +-- | Generate a new fresh variable and increment the state counter +fresh :: Infer Type +fresh = do + n <- gets count + modify (\st -> st{count = n + 1}) + return . TPol . Ident $ show n + +-- | Run the monadic action with an additional binding +withBinding :: (Monad m, MonadReader Ctx m) => Ident -> Poly -> m a -> m a +withBinding i p = local (\st -> st{vars = M.insert i p (vars st)}) + +-- | Insert a function signature into the environment +insertSig :: Ident -> Type -> Infer () +insertSig i t = modify (\st -> st{sigs = M.insert i t (sigs st)}) + +-- | Insert a constructor with its data type +insertConstr :: Ident -> Type -> Infer () +insertConstr i t = + modify (\st -> st{constructors = M.insert i t (constructors st)}) + +-------- PATTERN MATCHING --------- + +-- "case expr of", the type of 'expr' is caseType +checkInj :: Type -> Inj -> Infer (T.Inj, Type) +checkInj caseType (Inj it expr) = do + (args, t') <- initType caseType it + (_, t, e') <- local (\st -> st{vars = args `M.union` vars st}) (algoW expr) + return (T.Inj (it, t') e', t) + +initType :: Type -> Init -> Infer (Map Ident Poly, Type) +initType expected = \case + InitLit lit -> + let returnType = litType lit + in if expected == returnType + then return (mempty, expected) + else + throwError $ + unwords + [ "Inferred type" + , printTree returnType + , "does not match expected type:" + , printTree expected + ] + InitConstr c args -> do + st <- gets constructors + case M.lookup c st of + Nothing -> + throwError $ + unwords + [ "Constructor:" + , printTree c + , "does not exist" + ] + Just t -> do + let flat = flattenType t + let returnType = last flat + case ( length (init flat) == length args + , returnType `isMoreSpecificOrEq` expected + ) of + (True, True) -> + return + ( M.fromList $ zip args (map (Forall []) flat) + , expected + ) + (False, _) -> + throwError $ + "Can't partially match on the constructor: " + ++ printTree c + (_, False) -> + throwError $ + unwords + [ "Inferred type" + , printTree returnType + , "does not match expected type:" + , printTree expected + ] + InitCatch -> return (mempty, expected) + +flattenType :: Type -> [Type] +flattenType (TArr a b) = flattenType a ++ flattenType b +flattenType a = [a] + +litType :: Literal -> Type +litType (LInt _) = TMono "Int" diff --git a/src/TypeChecker/TypeCheckerIr.hs b/src/TypeChecker/TypeCheckerIr.hs index 7dfe3be..31d89b4 100644 --- a/src/TypeChecker/TypeCheckerIr.hs +++ b/src/TypeChecker/TypeCheckerIr.hs @@ -1,139 +1,184 @@ {-# LANGUAGE LambdaCase #-} -module TypeChecker.TypeCheckerIr - ( module Grammar.Abs - , module TypeChecker.TypeCheckerIr - ) where +module TypeChecker.TypeCheckerIr where -import Grammar.Abs (Ident (..), Type (..)) -import qualified Grammar.Abs as GA +import Control.Monad.Except +import Control.Monad.Reader +import Control.Monad.State +import Data.Functor.Identity (Identity) +import Data.Map (Map) +import Grammar.Abs (Data (..), Ident (..), Init (..), + Literal (..), Type (..)) import Grammar.Print import Prelude -import qualified Prelude as C (Eq, Ord, Read, Show) +import qualified Prelude as C (Eq, Ord, Read, Show) -newtype Program = Program [Bind] - deriving (C.Eq, C.Ord, C.Show, C.Read) +-- | A data type representing type variables +data Poly = Forall [Ident] Type + deriving (Show) + +newtype Ctx = Ctx {vars :: Map Ident Poly} + +data Env = Env + { count :: Int + , sigs :: Map Ident Type + , constructors :: Map Ident Type + } + +type Error = String +type Subst = Map Ident Type + +type Infer = StateT Env (ReaderT Ctx (ExceptT Error Identity)) + +newtype Program = Program [Def] + deriving (C.Eq, C.Ord, C.Show, C.Read) data Exp - = EId Id - | EInt Integer + = EId Id + | ELit Type Literal | ELet Bind Exp | EApp Type Exp Exp | EAdd Type Exp Exp | ESub Type Exp Exp - | EAbs Type Id Exp - | ECase Type Exp [(Type, Case)] - deriving (C.Eq, C.Ord, C.Show, C.Read) + | EAbs Type Id Exp + | ECase Type Exp [Inj] + deriving (C.Eq, C.Ord, C.Read, C.Show) -data Case = Case GA.Case Exp - deriving (C.Eq, C.Ord, C.Show, C.Read) +data Inj = Inj (Init, Type) Exp + deriving (C.Eq, C.Ord, C.Read, C.Show) + +data Def = DBind Bind | DData Data + deriving (C.Eq, C.Ord, C.Read, C.Show) type Id = (Ident, Type) -data Bind = Bind Id [Id] Exp | DataStructure Ident [(Ident, [Type])] +data Bind = Bind Id Exp deriving (C.Eq, C.Ord, C.Show, C.Read) +instance Print [Def] where + prt _ [] = concatD [] + prt _ (x : xs) = concatD [prt 0 x, doc (showString "\n"), prt 0 xs] + +instance Print Def where + prt i (DBind bind) = prt i bind + prt i (DData d) = prt i d + instance Print Program where prt i (Program sc) = prPrec i 0 $ prt 0 sc instance Print Bind where - prt i (Bind name@(n, _) parms rhs) = prPrec i 0 $ concatD - [ prtId 0 name - , doc $ showString ";" - , prt 0 n - , prtIdPs 0 parms - , doc $ showString "=" - , prt 0 rhs - ] - prt i (DataStructure (Ident n) xs) = prPrec i 0 $ concatD - [ prt 0 n - , doc $ showString "{" - , doc . showString . show $ xs - , doc $ showString "}" - ] + prt i (Bind (t, name) rhs) = + prPrec i 0 $ + concatD + [ prt 0 name + , doc $ showString ":" + , prt 0 t + , doc $ showString "\n" + , prt 0 name + , 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] + prt _ [] = concatD [] + prt _ [x] = concatD [prt 0 x] + prt _ (x : xs) = concatD [prt 0 x, doc (showString ";"), doc (showString "\n"), 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 - ] +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 ")" - ] - +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 [prtIdP 0 n] - EInt 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 - [ doc $ showString "@" - , prt 0 t - , 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 - ] - ESub 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 "\\" - , prtIdP 0 n - , doc $ showString "." - , prt 0 e - ] - ECase t e cs -> prPrec i 0 $ concatD - [ doc $ showString "@" - , prt 0 t - , doc $ showString "(" - , prt 0 e - , doc $ showString ")" - , prPrec i 0 $ concatD . printCases $ cs - ] + prt i = \case + EId n -> prPrec i 3 $ concatD [prtId 0 n, doc $ showString "\n"] + ELit _ (LInt i1) -> prPrec i 3 $ concatD [prt 0 i1, doc $ showString "\n"] + ELet bs e -> + prPrec i 3 $ + concatD + [ doc $ showString "let" + , prt 0 bs + , doc $ showString "in" + , prt 0 e + , doc $ showString "\n" + ] + EApp _ 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 + , doc $ showString "\n" + ] + ESub t e1 e2 -> + prPrec i 1 $ + concatD + [ doc $ showString "@" + , prt 0 t + , prt 1 e1 + , doc $ showString "-" + , prt 2 e2 + , doc $ showString "\n" + ] + EAbs t n e -> + prPrec i 0 $ + concatD + [ doc $ showString "@" + , prt 0 t + , doc $ showString "\\" + , prtId 0 n + , doc $ showString "." + , prt 0 e + , doc $ showString "\n" + ] + ECase t exp injs -> + prPrec + i + 0 + ( concatD + [ doc (showString "case") + , prt 0 exp + , doc (showString "of") + , doc (showString "{") + , prt 0 injs + , doc (showString "}") + , doc (showString ":") + , prt 0 t + , doc $ showString "\n" + ] + ) - where - printCases :: [(Type, Case)] -> [Doc] - printCases [] = [] - printCases ((t, Case c e):xs) = concatD - [ doc $ showString "@" - , prt 0 t - , doc $ showString "(" - , doc . showString . show $ c - , doc $ showString ")" - , doc $ showString "=>" - , prt 0 e - , doc $ showString "\n" - ] : printCases xs +instance Print Inj where + prt i = \case + Inj (init, t) exp -> prPrec i 0 (concatD [prt 0 init, doc (showString ":"), prt 0 t, doc (showString "=>"), prt 0 exp]) + +instance Print [Inj] where + prt _ [] = concatD [] + prt _ [x] = concatD [prt 0 x] + prt _ (x : xs) = concatD [prt 0 x, doc (showString ";"), prt 0 xs] From 62724964d7144256c1c456a71f50a7af7539b3bf Mon Sep 17 00:00:00 2001 From: sebastian Date: Wed, 8 Mar 2023 15:22:42 +0100 Subject: [PATCH 079/372] fixed Maybe ('a -> 'a) bug. Pattern matching still wonky, will have to redo --- "\\" | 511 +++++++++++++++++++++++++++++++++ src/TypeChecker/TypeChecker.hs | 117 ++++---- test_program | 48 +--- 3 files changed, 579 insertions(+), 97 deletions(-) create mode 100644 "\\" diff --git "a/\\" "b/\\" new file mode 100644 index 0000000..90c24ff --- /dev/null +++ "b/\\" @@ -0,0 +1,511 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | A module for type checking and inference using algorithm W, Hindley-Milner +module TypeChecker.TypeChecker where + +import Control.Monad.Except +import Control.Monad.Reader +import Control.Monad.State +import Data.Foldable (traverse_) +import Data.Functor.Identity (runIdentity) +import Debug.Trace (trace) +import Data.List (foldl') +import Data.Map (Map) +import Data.Map qualified as M +import Data.Set (Set) +import Data.Set qualified as S +import Data.Maybe (fromMaybe) +import Grammar.Abs +import Grammar.Print (printTree) +import TypeChecker.TypeCheckerIr ( + Ctx (..), + Env (..), + Error, + Infer, + Poly (..), + Subst, + ) +import TypeChecker.TypeCheckerIr qualified as T + +initCtx = Ctx mempty + +initEnv = Env 0 mempty mempty + +runPretty :: Exp -> Either Error String +runPretty = fmap (printTree . fst) . run . inferExp + +run :: Infer a -> Either Error a +run = runC initEnv initCtx + +runC :: Env -> Ctx -> Infer a -> Either Error a +runC e c = runIdentity . runExceptT . flip runReaderT c . flip evalStateT e + +typecheck :: Program -> Either Error T.Program +typecheck = run . checkPrg + +{- | Start by freshening the type variable of data types to avoid clash with +other user defined polymorphic types +This might be wrong for type constructors that work over several variables +-} +-- freshenData :: Data -> Infer Data +-- freshenData (Data (Constr name ts) constrs) = do +-- new_ts <- traverse freshenType ts +-- new_constrs <- traverse freshenConstr constrs +-- return $ Data (Constr name new_ts) new_constrs +--TODO: Fix incorrect behavior here + +{- | Freshen all polymorphic variables, regardless of name +| freshenType "d" (a -> b -> c) becomes (d -> d -> d) +-} +-- freshenType :: Type -> Infer Type +-- freshenType t = do +-- let freeVars = (S.toList $ free t) +-- frs <- sequenceA $ map (const fresh) freeVars +-- let remaps = M.fromList $ zip freeVars frs +-- return $ go remaps t +-- where +-- go :: Map Ident Type -> Type -> Type +-- go m t = case t of +-- TPol a -> fromMaybe (error "bug in \'free\'") (M.lookup a m ) +-- TMono a -> TMono a +-- TArr t1 t2 -> TArr (go m t1) (go m t2) +-- TConstr (Constr ident ts) -> TConstr (Constr ident (map (go m) ts)) + +-- freshenConstr :: Constructor -> Infer Constructor +-- freshenConstr (Constructor name t) = do +-- t' <- freshenType t +-- return $ Constructor name t' + +checkData :: Data -> Infer () +checkData d = do + case d of + (Data typ@(Constr name ts) constrs) -> do + unless + (all isPoly ts) + (throwError $ unwords ["Data type incorrectly declared"]) + traverse_ + ( \(Constructor name' t') -> + if TConstr typ == retType t' + then insertConstr name' t' + else + throwError $ + unwords + [ "return type of constructor:" + , printTree name + , "with type:" + , printTree (retType t') + , "does not match data: " + , printTree typ + ] + ) + constrs + +retType :: Type -> Type +retType (TArr _ t2) = retType t2 +retType a = a + +checkPrg :: Program -> Infer T.Program +checkPrg (Program bs) = do + preRun bs + bs' <- checkDef bs + return $ T.Program bs' + where + preRun :: [Def] -> Infer () + preRun [] = return () + preRun (x : xs) = case x of + DBind (Bind n t _ _ _) -> insertSig n t >> preRun xs + DData d@(Data _ _) -> checkData d >> preRun xs + + checkDef :: [Def] -> Infer [T.Def] + checkDef [] = return [] + checkDef (x : xs) = case x of + (DBind b) -> do + b' <- checkBind b + fmap (T.DBind b' :) (checkDef xs) + (DData d) -> fmap (T.DData d :) (checkDef xs) + +checkBind :: Bind -> Infer T.Bind +checkBind (Bind n t _ args e) = do + (t', e') <- inferExp $ makeLambda e (reverse args) + s <- unify t t' + let t'' = apply s t + unless + (t `typeEq` t'') + ( throwError $ + unwords + [ "Top level signature" + , printTree t + , "does not match body with inferred type:" + , printTree t'' + ] + ) + return $ T.Bind (n, t) e' + where + makeLambda :: Exp -> [Ident] -> Exp + makeLambda = foldl (flip EAbs) + +{- | Check if two types are considered equal + For the purpose of the algorithm two polymorphic types are always considered + equal +-} +typeEq :: Type -> Type -> Bool +typeEq (TArr l r) (TArr l' r') = typeEq l l' && typeEq r r' +typeEq (TMono a) (TMono b) = a == b +typeEq (TConstr (Constr name a)) (TConstr (Constr name' b)) = + length a == length b + && name == name' + && and (zipWith typeEq a b) +typeEq (TPol _) (TPol _) = True +typeEq _ _ = False + +isMoreSpecificOrEq :: Type -> Type -> Bool +isMoreSpecificOrEq _ (TPol _) = True +isMoreSpecificOrEq (TArr a b) (TArr c d) = + isMoreSpecificOrEq a c && isMoreSpecificOrEq b d +isMoreSpecificOrEq (TConstr (Constr n1 ts1)) (TConstr (Constr n2 ts2)) = + n1 == n2 + && length ts1 == length ts2 + && and (zipWith isMoreSpecificOrEq ts1 ts2) +isMoreSpecificOrEq a b = a == b + +isPoly :: Type -> Bool +isPoly (TPol _) = True +isPoly _ = False + +inferExp :: Exp -> Infer (Type, T.Exp) +inferExp e = do + (s, t, e') <- algoW e + let subbed = apply s t + return (subbed, replace subbed e') + +replace :: Type -> T.Exp -> T.Exp +replace t = \case + T.ELit _ e -> T.ELit t e + T.EId (n, _) -> T.EId (n, t) + T.EAbs _ name e -> T.EAbs t name e + T.EApp _ e1 e2 -> T.EApp t e1 e2 + T.EAdd _ e1 e2 -> T.EAdd t e1 e2 + T.ELet (T.Bind (n, _) e1) e2 -> T.ELet (T.Bind (n, t) e1) e2 + T.ECase _ expr injs -> T.ECase t expr injs + +algoW :: Exp -> Infer (Subst, Type, T.Exp) +algoW = \case + -- \| TODO: More testing need to be done. Unsure of the correctness of this + EAnn e t -> do + (s1, t', e') <- algoW e + unless + (t `isMoreSpecificOrEq` t') + ( throwError $ + unwords + [ "Annotated type:" + , printTree t + , "does not match inferred type:" + , printTree t' + ] + ) + applySt s1 $ do + s2 <- unify t t' + return (s2 `compose` s1, t, e') + + -- \| ------------------ + -- \| Γ ⊢ i : Int, ∅ + + ELit (LInt n) -> + return (nullSubst, TMono "Int", T.ELit (TMono "Int") (LInt n)) + ELit a -> error $ "NOT IMPLEMENTED YET: ELit " ++ show a + -- \| x : σ ∈ Γ   τ = inst(σ) + -- \| ---------------------- + -- \| Γ ⊢ x : τ, ∅ + + EId i -> do + var <- asks vars + case M.lookup i var of + Just t -> inst t >>= \x -> return (nullSubst, x, T.EId (i, x)) + Nothing -> do + sig <- gets sigs + case M.lookup i sig of + Just t -> return (nullSubst, t, T.EId (i, t)) + Nothing -> do + constr <- gets constructors + case M.lookup i constr of + Just t -> return (nullSubst, t, T.EId (i, t)) + Nothing -> + throwError $ + "Unbound variable: " ++ show i + + -- \| τ = newvar Γ, x : τ ⊢ e : τ', S + -- \| --------------------------------- + -- \| Γ ⊢ w λx. e : Sτ → τ', S + + EAbs name e -> do + fr <- fresh + withBinding name (Forall [] fr) $ do + (s1, t', e') <- algoW e + let varType = apply s1 fr + let newArr = TArr varType t' + return (s1, newArr, T.EAbs newArr (name, varType) e') + + -- \| Γ ⊢ e₀ : τ₀, S₀ S₀Γ ⊢ e₁ : τ₁, S₁ + -- \| s₂ = mgu(s₁τ₀, Int) s₃ = mgu(s₂τ₁, Int) + -- \| ------------------------------------------ + -- \| Γ ⊢ e₀ + e₁ : Int, S₃S₂S₁S₀ + -- This might be wrong + + EAdd e0 e1 -> do + (s1, t0, e0') <- algoW e0 + applySt s1 $ do + (s2, t1, e1') <- algoW e1 + -- applySt s2 $ do + s3 <- unify (apply s2 t0) (TMono "Int") + s4 <- unify (apply s3 t1) (TMono "Int") + return + ( s4 `compose` s3 `compose` s2 `compose` s1 + , TMono "Int" + , T.EAdd (TMono "Int") e0' e1' + ) + + -- \| Γ ⊢ e₀ : τ₀, S₀ S₀Γ ⊢ e₁ : τ₁, S1 + -- \| τ' = newvar S₂ = mgu(S₁τ₀, τ₁ → τ') + -- \| -------------------------------------- + -- \| Γ ⊢ e₀ e₁ : S₂τ', S₂S₁S₀ + + EApp e0 e1 -> do + fr <- fresh + (s0, t0, e0') <- algoW e0 + applySt s0 $ do + (s1, t1, e1') <- algoW e1 + -- applySt s1 $ do + s2 <- unify (apply s1 t0) (TArr t1 fr) + let t = apply s2 fr + return (s2 `compose` s1 `compose` s0, t, T.EApp t e0' e1') + + -- \| Γ ⊢ e₀ : τ, S₀ S₀Γ, x : S̅₀Γ̅(τ) ⊢ e₁ : τ', S₁ + -- \| ---------------------------------------------- + -- \| Γ ⊢ let x = e₀ in e₁ : τ', S₁S₀ + + -- The bar over S₀ and Γ means "generalize" + + ELet name e0 e1 -> do + (s1, t1, e0') <- algoW e0 + env <- asks vars + let t' = generalize (apply s1 env) t1 + withBinding name t' $ do + (s2, t2, e1') <- algoW e1 + return (s2 `compose` s1, t2, T.ELet (T.Bind (name, t2) e0') e1') + ECase caseExpr injs -> do + (_, t0, e0') <- algoW caseExpr + (injs', ts) <- mapAndUnzipM (checkInj t0) injs + case ts of + [] -> throwError "Case expression missing any matches" + ts -> do + unified <- zipWithM unify ts (tail ts) + let unified' = foldl' compose mempty unified + let typ = apply unified' (head ts) + return (unified', typ, T.ECase typ e0' injs') + +-- | Unify two types producing a new substitution +unify :: Type -> Type -> Infer Subst +unify t0 t1 = do + case (t0, t1) of + (TArr a b, TArr c d) -> do + s1 <- unify a c + s2 <- unify (apply s1 b) (apply s1 d) + return $ s1 `compose` s2 + (TPol a, b) -> occurs a b + (a, TPol b) -> occurs b a + (TMono a, TMono b) -> + if a == b then return M.empty else throwError "Types do not unify" + -- \| TODO: Figure out a cleaner way to express the same thing + (TConstr (Constr name t), TConstr (Constr name' t')) -> + if name == name' && length t == length t' + then do + xs <- zipWithM unify t t' + return $ foldr compose nullSubst xs + else + throwError $ + unwords + [ "Type constructor:" + , printTree name + , "(" ++ printTree t ++ ")" + , "does not match with:" + , printTree name' + , "(" ++ printTree t' ++ ")" + ] + (a, b) -> + throwError . unwords $ + [ "Type:" + , printTree a + , "can't be unified with:" + , printTree b + ] + +{- | Check if a type is contained in another type. +I.E. { a = a -> b } is an unsolvable constraint since there is no substitution +such that these are equal +-} +occurs :: Ident -> Type -> Infer Subst +occurs _ (TPol _) = return nullSubst +occurs i t = + if S.member i (free t) + then + throwError $ + unwords + [ "Occurs check failed, can't unify" + , printTree (TPol i) + , "with" + , printTree t + ] + else return $ M.singleton i t + +-- | Generalize a type over all free variables in the substitution set +generalize :: Map Ident Poly -> Type -> Poly +generalize env t = Forall (S.toList $ free t S.\\ free env) t + +{- | Instantiate a polymorphic type. The free type variables are substituted +with fresh ones. +-} +inst :: Poly -> Infer Type +inst (Forall xs t) = do + xs' <- mapM (const fresh) xs + let s = M.fromList $ zip xs xs' + return $ apply s t + +-- | Compose two substitution sets +compose :: Subst -> Subst -> Subst +compose m1 m2 = M.map (apply m1) m2 `M.union` m1 + +-- | A class representing free variables functions +class FreeVars t where + -- | Get all free variables from t + free :: t -> Set Ident + + -- | Apply a substitution to t + apply :: Subst -> t -> t + +instance FreeVars Type where + free :: Type -> Set Ident + free (TPol a) = S.singleton a + free (TMono _) = mempty + free (TArr a b) = free a `S.union` free b + -- \| Not guaranteed to be correct + free (TConstr (Constr _ a)) = + foldl' (\acc x -> free x `S.union` acc) S.empty a + + apply :: Subst -> Type -> Type + apply sub t = do + case t of + TMono a -> TMono a + TPol a -> case M.lookup a sub of + Nothing -> TPol a + Just t -> t + TArr a b -> TArr (apply sub a) (apply sub b) + TConstr (Constr name a) -> TConstr (Constr name (map (apply sub) a)) + +instance FreeVars Poly where + free :: Poly -> Set Ident + free (Forall xs t) = free t S.\\ S.fromList xs + apply :: Subst -> Poly -> Poly + apply s (Forall xs t) = Forall xs (apply (foldr M.delete s xs) t) + +instance FreeVars (Map Ident Poly) where + free :: Map Ident Poly -> Set Ident + free m = foldl' S.union S.empty (map free $ M.elems m) + apply :: Subst -> Map Ident Poly -> Map Ident Poly + apply s = M.map (apply s) + +-- | Apply substitutions to the environment. +applySt :: Subst -> Infer a -> Infer a +applySt s = local (\st -> st{vars = apply s (vars st)}) + +-- | Represents the empty substition set +nullSubst :: Subst +nullSubst = M.empty + +-- | Generate a new fresh variable and increment the state counter +fresh :: Infer Type +fresh = do + n <- gets count + modify (\st -> st{count = n + 1}) + return . TPol . Ident $ show n + +-- | Run the monadic action with an additional binding +withBinding :: (Monad m, MonadReader Ctx m) => Ident -> Poly -> m a -> m a +withBinding i p = local (\st -> st{vars = M.insert i p (vars st)}) + +-- | Insert a function signature into the environment +insertSig :: Ident -> Type -> Infer () +insertSig i t = modify (\st -> st{sigs = M.insert i t (sigs st)}) + +-- | Insert a constructor with its data type +insertConstr :: Ident -> Type -> Infer () +insertConstr i t = + modify (\st -> st{constructors = M.insert i t (constructors st)}) + +-------- PATTERN MATCHING --------- + +-- "case expr of", the type of 'expr' is caseType +checkInj :: Type -> Inj -> Infer (T.Inj, Type) +checkInj caseType (Inj it expr) = do + (args, t') <- initType caseType it + subst <- unify caseType t' + trace ("SUBST: " ++ show subst) return () + applySt subst $ do + (_, t, e') <- local (\st -> st { vars = args `M.union` vars st }) (algoW expr) + return (T.Inj (it, t') e', t) + +initType :: Type -> Init -> Infer (Map Ident Poly, Type) +initType expected = \case + InitLit lit -> do + trace (show "EXPECTED: " ++ show expected ++ "\nreturnType: " ++ show (litType lit)) return () + if litType lit `isMoreSpecificOrEq` expected + then return (mempty, litType lit) + else + throwError $ + unwords + [ "Inferred type" + , printTree $ litType lit + , "does not match expected type:" + , printTree expected + ] + InitConstr c args -> do + st <- gets constructors + case M.lookup c st of + Nothing -> + throwError $ + unwords + [ "Constructor:" + , printTree c + , "does not exist" + ] + Just t -> do + let flat = flattenType t + let returnType = last flat + case ( length (init flat) == length args + , returnType `isMoreSpecificOrEq` expected + ) of + (True, True) -> + return + ( M.fromList $ zip args (map (Forall []) flat) + , expected + ) + (False, _) -> + throwError $ + "Can't partially match on the constructor: " + ++ printTree c + (_, False) -> + throwError $ + unwords + [ "Inferred type" + , printTree returnType + , "does not match expected type:" + , printTree expected + ] + InitCatch -> return (mempty, expected) + +flattenType :: Type -> [Type] +flattenType (TArr a b) = flattenType a ++ flattenType b +flattenType a = [a] + +litType :: Literal -> Type +litType (LInt _) = TMono "Int" diff --git a/src/TypeChecker/TypeChecker.hs b/src/TypeChecker/TypeChecker.hs index af4734d..0c3df12 100644 --- a/src/TypeChecker/TypeChecker.hs +++ b/src/TypeChecker/TypeChecker.hs @@ -9,12 +9,13 @@ import Control.Monad.Reader import Control.Monad.State import Data.Foldable (traverse_) import Data.Functor.Identity (runIdentity) +import Debug.Trace (trace) import Data.List (foldl') import Data.Map (Map) import Data.Map qualified as M import Data.Set (Set) import Data.Set qualified as S -import Debug.Trace (trace) +import Data.Maybe (fromMaybe) import Grammar.Abs import Grammar.Print (printTree) import TypeChecker.TypeCheckerIr ( @@ -45,36 +46,23 @@ typecheck = run . checkPrg {- | Start by freshening the type variable of data types to avoid clash with other user defined polymorphic types -This might be wrong for type constructors that work over several variables -} freshenData :: Data -> Infer Data freshenData (Data (Constr name ts) constrs) = do - fr <- fresh - let fr' = case fr of - TPol a -> a - -- Meh, this part assumes fresh generates a polymorphic type - _ -> - error - "Bug: implementation of \ - \ fresh and freshenData are not compatible" - let new_ts = map (freshenType fr') ts - let new_constrs = map (freshenConstr fr') constrs - return $ Data (Constr name new_ts) new_constrs - + let xs = (S.toList . free) =<< ts + frs <- traverse (const fresh) xs + let m = M.fromList $ zip xs frs + return $ Data (Constr name (map (freshenType m) ts)) (map (\(Constructor ident t) -> Constructor ident (freshenType m t)) constrs) + {- | Freshen all polymorphic variables, regardless of name | freshenType "d" (a -> b -> c) becomes (d -> d -> d) -} -freshenType :: Ident -> Type -> Type -freshenType iden = \case - (TPol _) -> TPol iden - (TArr a b) -> TArr (freshenType iden a) (freshenType iden b) - (TConstr (Constr a ts)) -> - TConstr (Constr a (map (freshenType iden) ts)) - rest -> rest - -freshenConstr :: Ident -> Constructor -> Constructor -freshenConstr iden (Constructor name t) = - Constructor name (freshenType iden t) +freshenType :: Map Ident Type -> Type -> Type +freshenType m t = case t of + TPol poly -> fromMaybe (error "bug in \'free\'") (M.lookup poly m) + TMono mono -> TMono mono + TArr t1 t2 -> TArr (freshenType m t1) (freshenType m t2) + TConstr (Constr ident ts) -> TConstr (Constr ident (map (freshenType m) ts)) checkData :: Data -> Infer () checkData d = do @@ -108,7 +96,8 @@ retType a = a checkPrg :: Program -> Infer T.Program checkPrg (Program bs) = do preRun bs - T.Program <$> checkDef bs + bs' <- checkDef bs + return $ T.Program bs' where preRun :: [Def] -> Infer () preRun [] = return () @@ -122,7 +111,9 @@ checkPrg (Program bs) = do (DBind b) -> do b' <- checkBind b fmap (T.DBind b' :) (checkDef xs) - (DData d) -> fmap (T.DData d :) (checkDef xs) + (DData d) -> do + d' <- freshenData d + fmap (T.DData d' :) (checkDef xs) checkBind :: Bind -> Infer T.Bind checkBind (Bind n t _ args e) = do @@ -205,7 +196,8 @@ algoW = \case ) applySt s1 $ do s2 <- unify t t' - return (s2 `compose` s1, t, e') + let composition = s2 `compose` s1 + return (composition, t, apply composition e') -- \| ------------------ -- \| Γ ⊢ i : Int, ∅ @@ -243,7 +235,7 @@ algoW = \case (s1, t', e') <- algoW e let varType = apply s1 fr let newArr = TArr varType t' - return (s1, newArr, T.EAbs newArr (name, varType) e') + return (s1, newArr, apply s1 $ T.EAbs newArr (name, varType) e') -- \| Γ ⊢ e₀ : τ₀, S₀ S₀Γ ⊢ e₁ : τ₁, S₁ -- \| s₂ = mgu(s₁τ₀, Int) s₃ = mgu(s₂τ₁, Int) @@ -258,10 +250,11 @@ algoW = \case -- applySt s2 $ do s3 <- unify (apply s2 t0) (TMono "Int") s4 <- unify (apply s3 t1) (TMono "Int") + let composition = s4 `compose` s3 `compose` s2 `compose` s1 return - ( s4 `compose` s3 `compose` s2 `compose` s1 + ( composition , TMono "Int" - , T.EAdd (TMono "Int") e0' e1' + , apply composition $ T.EAdd (TMono "Int") e0' e1' ) -- \| Γ ⊢ e₀ : τ₀, S₀ S₀Γ ⊢ e₁ : τ₁, S1 @@ -277,7 +270,8 @@ algoW = \case -- applySt s1 $ do s2 <- unify (apply s1 t0) (TArr t1 fr) let t = apply s2 fr - return (s2 `compose` s1 `compose` s0, t, T.EApp t e0' e1') + let composition = s2 `compose` s1 `compose` s0 + return (composition, t, apply composition $ T.EApp t e0' e1') -- \| Γ ⊢ e₀ : τ, S₀ S₀Γ, x : S̅₀Γ̅(τ) ⊢ e₁ : τ', S₁ -- \| ---------------------------------------------- @@ -291,7 +285,9 @@ algoW = \case let t' = generalize (apply s1 env) t1 withBinding name t' $ do (s2, t2, e1') <- algoW e1 - return (s2 `compose` s1, t2, T.ELet (T.Bind (name, t2) e0') e1') + let composition = s2 `compose` s1 + return (composition, t2, apply composition $ T.ELet (T.Bind (name, t2) e0') e1') + ECase caseExpr injs -> do (_, t0, e0') <- algoW caseExpr (injs', ts) <- mapAndUnzipM (checkInj t0) injs @@ -299,15 +295,13 @@ algoW = \case [] -> throwError "Case expression missing any matches" ts -> do unified <- zipWithM unify ts (tail ts) - let unified' = foldl' compose mempty unified - let typ = apply unified' (head ts) - return (unified', typ, T.ECase typ e0' injs') + let composition = foldl' compose mempty unified + let typ = apply composition (head ts) + return (composition, typ, apply composition $ T.ECase typ e0' injs') -- | Unify two types producing a new substitution unify :: Type -> Type -> Infer Subst unify t0 t1 = do - trace ("t0: " ++ show t0) return () - trace ("t1: " ++ show t1) return () case (t0, t1) of (TArr a b, TArr c d) -> do s1 <- unify a c @@ -343,7 +337,7 @@ unify t0 t1 = do {- | Check if a type is contained in another type. I.E. { a = a -> b } is an unsolvable constraint since there is no substitution -such that these are equal +where these are equal -} occurs :: Ident -> Type -> Infer Subst occurs _ (TPol _) = return nullSubst @@ -415,6 +409,30 @@ instance FreeVars (Map Ident Poly) where apply :: Subst -> Map Ident Poly -> Map Ident Poly apply s = M.map (apply s) +instance FreeVars T.Exp where + free :: T.Exp -> Set Ident + free = error "free not implemented for T.Exp" + apply :: Subst -> T.Exp -> T.Exp + apply s = \case + T.EId (ident, t) -> T.EId (ident, apply s t) + T.ELit t lit -> T.ELit (apply s t) lit + T.ELet (T.Bind (ident, t) e1) e2 -> T.ELet (T.Bind (ident, apply s t) (apply s e1)) (apply s e2) + T.EApp t e1 e2 -> T.EApp (apply s t) (apply s e1) (apply s e2) + T.EAdd t e1 e2 -> T.EAdd (apply s t) (apply s e1) (apply s e2) + T.EAbs t1 (ident, t2) e -> T.EAbs (apply s t1) (ident, apply s t2) (apply s e) + T.ECase t e injs -> T.ECase (apply s t) (apply s e) (apply s injs) + +instance FreeVars T.Inj where + free :: T.Inj -> Set Ident + free = undefined + apply :: Subst -> T.Inj -> T.Inj + apply s (T.Inj (i, t) e) = T.Inj (i, apply s t) (apply s e) + +instance FreeVars [T.Inj] where + free :: [T.Inj] -> Set Ident + free = foldl' (\acc x -> free x `S.union` acc) mempty + apply s = map (apply s) + -- | Apply substitutions to the environment. applySt :: Subst -> Infer a -> Infer a applySt s = local (\st -> st{vars = apply s (vars st)}) @@ -449,23 +467,16 @@ insertConstr i t = checkInj :: Type -> Inj -> Infer (T.Inj, Type) checkInj caseType (Inj it expr) = do (args, t') <- initType caseType it - (_, t, e') <- local (\st -> st{vars = args `M.union` vars st}) (algoW expr) - return (T.Inj (it, t') e', t) + subst <- unify caseType t' + applySt subst $ do + (_, t, e') <- local (\st -> st { vars = args `M.union` vars st }) (algoW expr) + return (T.Inj (it, t') e', t) initType :: Type -> Init -> Infer (Map Ident Poly, Type) initType expected = \case - InitLit lit -> - let returnType = litType lit - in if expected == returnType - then return (mempty, expected) - else - throwError $ - unwords - [ "Inferred type" - , printTree returnType - , "does not match expected type:" - , printTree expected - ] + + InitLit lit -> error "Pattern match on literals not implemented yet" + InitConstr c args -> do st <- gets constructors case M.lookup c st of diff --git a/test_program b/test_program index efa8eea..0d74a4e 100644 --- a/test_program +++ b/test_program @@ -1,50 +1,10 @@ --- data Bool () where { --- True : Bool () --- False : Bool () --- }; --- --- data List ('a) where { --- Nil : List ('a) --- Cons : ('a) -> List ('a) -> List ('a) --- }; - data Maybe ('a) where { Nothing : Maybe ('a) Just : 'a -> Maybe ('a) }; --- id : 'a -> 'a ; --- id x = x ; +id : 'a -> 'a ; +id x = x ; --- main : Maybe ('a -> 'a) ; --- main = Just id; - --- data Either ('a 'b) where { --- Left : 'a -> Either ('a 'b) --- Right : 'b -> Either ('a 'b) --- }; - --- safeHead : List ('a) -> Maybe ('a) ; --- safeHead xs = --- case xs of { --- Nil => Nothing ; --- Cons x xs => Just x --- }; - --- main : Maybe (_Int) ; --- main = safeHead (Cons 0 (Cons 1 Nil)) ; --- --- maybeToEither : Either ('a 'b) -> Maybe ('a) ; --- maybeToEither e = --- case e of { --- Left y => Nothing ; --- Right x => Just x --- }; - --- Bug. f not included in the case-expression context -fmap : ('a -> 'b) -> Maybe ('a) -> Maybe ('b) ; -fmap f x = - case x of { - Just x => Just (f x) ; - Nothing => Nothing - } +main : Maybe ('a -> 'a) ; +main = Just id ; From d377ded7e10987e89422c70a85b0a20d2e72a712 Mon Sep 17 00:00:00 2001 From: Rakarake Date: Wed, 8 Mar 2023 17:38:50 +0100 Subject: [PATCH 080/372] 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 081/372] 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 082/372] 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 083/372] 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 c3ea343d0012e05b6aa9e4f495e1a6c82a6db396 Mon Sep 17 00:00:00 2001 From: sebastianselander Date: Fri, 10 Mar 2023 16:54:29 +0100 Subject: [PATCH 084/372] unified top level type with expression type --- src/TypeChecker/TypeChecker.hs | 45 +++++++++++++++++----------------- test_program | 10 +------- 2 files changed, 23 insertions(+), 32 deletions(-) diff --git a/src/TypeChecker/TypeChecker.hs b/src/TypeChecker/TypeChecker.hs index 0c3df12..779867b 100644 --- a/src/TypeChecker/TypeChecker.hs +++ b/src/TypeChecker/TypeChecker.hs @@ -9,13 +9,13 @@ import Control.Monad.Reader import Control.Monad.State import Data.Foldable (traverse_) import Data.Functor.Identity (runIdentity) -import Debug.Trace (trace) import Data.List (foldl') import Data.Map (Map) import Data.Map qualified as M +import Data.Maybe (fromMaybe) import Data.Set (Set) import Data.Set qualified as S -import Data.Maybe (fromMaybe) +import Debug.Trace (trace) import Grammar.Abs import Grammar.Print (printTree) import TypeChecker.TypeCheckerIr ( @@ -53,16 +53,16 @@ freshenData (Data (Constr name ts) constrs) = do frs <- traverse (const fresh) xs let m = M.fromList $ zip xs frs return $ Data (Constr name (map (freshenType m) ts)) (map (\(Constructor ident t) -> Constructor ident (freshenType m t)) constrs) - + {- | Freshen all polymorphic variables, regardless of name | freshenType "d" (a -> b -> c) becomes (d -> d -> d) -} freshenType :: Map Ident Type -> Type -> Type freshenType m t = case t of - TPol poly -> fromMaybe (error "bug in \'free\'") (M.lookup poly m) - TMono mono -> TMono mono - TArr t1 t2 -> TArr (freshenType m t1) (freshenType m t2) - TConstr (Constr ident ts) -> TConstr (Constr ident (map (freshenType m) ts)) + TPol poly -> fromMaybe (error "bug in \'free\'") (M.lookup poly m) + TMono mono -> TMono mono + TArr t1 t2 -> TArr (freshenType m t1) (freshenType m t2) + TConstr (Constr ident ts) -> TConstr (Constr ident (map (freshenType m) ts)) checkData :: Data -> Infer () checkData d = do @@ -115,10 +115,12 @@ checkPrg (Program bs) = do d' <- freshenData d fmap (T.DData d' :) (checkDef xs) +-- TODO: Unify top level types with the types of the expressions beneath +-- PERHAPS DONE checkBind :: Bind -> Infer T.Bind checkBind (Bind n t _ args e) = do - (t', e') <- inferExp $ makeLambda e (reverse args) - s <- unify t t' + (t', e) <- inferExp $ makeLambda e (reverse args) + s <- unify t' t let t'' = apply s t unless (t `typeEq` t'') @@ -130,7 +132,7 @@ checkBind (Bind n t _ args e) = do , printTree t'' ] ) - return $ T.Bind (n, t) e' + return $ T.Bind (n, t) (apply s e) where makeLambda :: Exp -> [Ident] -> Exp makeLambda = foldl (flip EAbs) @@ -287,7 +289,6 @@ algoW = \case (s2, t2, e1') <- algoW e1 let composition = s2 `compose` s1 return (composition, t2, apply composition $ T.ELet (T.Bind (name, t2) e0') e1') - ECase caseExpr injs -> do (_, t0, e0') <- algoW caseExpr (injs', ts) <- mapAndUnzipM (checkInj t0) injs @@ -340,7 +341,7 @@ I.E. { a = a -> b } is an unsolvable constraint since there is no substitution where these are equal -} occurs :: Ident -> Type -> Infer Subst -occurs _ (TPol _) = return nullSubst +occurs i t@(TPol a) = return (M.singleton i t) occurs i t = if S.member i (free t) then @@ -414,14 +415,14 @@ instance FreeVars T.Exp where free = error "free not implemented for T.Exp" apply :: Subst -> T.Exp -> T.Exp apply s = \case - T.EId (ident, t) -> T.EId (ident, apply s t) - T.ELit t lit -> T.ELit (apply s t) lit - T.ELet (T.Bind (ident, t) e1) e2 -> T.ELet (T.Bind (ident, apply s t) (apply s e1)) (apply s e2) - T.EApp t e1 e2 -> T.EApp (apply s t) (apply s e1) (apply s e2) - T.EAdd t e1 e2 -> T.EAdd (apply s t) (apply s e1) (apply s e2) - T.EAbs t1 (ident, t2) e -> T.EAbs (apply s t1) (ident, apply s t2) (apply s e) - T.ECase t e injs -> T.ECase (apply s t) (apply s e) (apply s injs) - + T.EId (ident, t) -> T.EId (ident, apply s t) + T.ELit t lit -> T.ELit (apply s t) lit + T.ELet (T.Bind (ident, t) e1) e2 -> T.ELet (T.Bind (ident, apply s t) (apply s e1)) (apply s e2) + T.EApp t e1 e2 -> T.EApp (apply s t) (apply s e1) (apply s e2) + T.EAdd t e1 e2 -> T.EAdd (apply s t) (apply s e1) (apply s e2) + T.EAbs t1 (ident, t2) e -> T.EAbs (apply s t1) (ident, apply s t2) (apply s e) + T.ECase t e injs -> T.ECase (apply s t) (apply s e) (apply s injs) + instance FreeVars T.Inj where free :: T.Inj -> Set Ident free = undefined @@ -469,14 +470,12 @@ checkInj caseType (Inj it expr) = do (args, t') <- initType caseType it subst <- unify caseType t' applySt subst $ do - (_, t, e') <- local (\st -> st { vars = args `M.union` vars st }) (algoW expr) + (_, t, e') <- local (\st -> st{vars = args `M.union` vars st}) (algoW expr) return (T.Inj (it, t') e', t) initType :: Type -> Init -> Infer (Map Ident Poly, Type) initType expected = \case - InitLit lit -> error "Pattern match on literals not implemented yet" - InitConstr c args -> do st <- gets constructors case M.lookup c st of diff --git a/test_program b/test_program index 0d74a4e..2470637 100644 --- a/test_program +++ b/test_program @@ -1,10 +1,2 @@ -data Maybe ('a) where { - Nothing : Maybe ('a) - Just : 'a -> Maybe ('a) -}; - id : 'a -> 'a ; -id x = x ; - -main : Maybe ('a -> 'a) ; -main = Just id ; +id = \x. x ; From 96c4a2bddf183b4e45bdef4e20e081d4c877c1d0 Mon Sep 17 00:00:00 2001 From: Rakarake Date: Fri, 10 Mar 2023 17:20:23 +0100 Subject: [PATCH 085/372] 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 086/372] 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 087/372] 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 9cd2cdb511fa0456a0f55cca08f6739617bb05b1 Mon Sep 17 00:00:00 2001 From: sebastianselander Date: Mon, 20 Mar 2023 17:40:09 +0100 Subject: [PATCH 088/372] continued work on pattern matching v2 --- Session.vim | 219 +++++++++++++++++++++++++++++++++ src/TypeChecker/TypeChecker.hs | 109 ++++++++-------- test_program | 11 +- 3 files changed, 279 insertions(+), 60 deletions(-) create mode 100644 Session.vim diff --git a/Session.vim b/Session.vim new file mode 100644 index 0000000..1db0ec6 --- /dev/null +++ b/Session.vim @@ -0,0 +1,219 @@ +let SessionLoad = 1 +let s:so_save = &g:so | let s:siso_save = &g:siso | setg so=0 siso=0 | setl so=-1 siso=-1 +let v:this_session=expand(":p") +silent only +silent tabonly +cd ~/Documents/bachelor_thesis/language +if expand('%') == '' && !&modified && line('$') <= 1 && getline(1) == '' + let s:wipebuf = bufnr('%') +endif +let s:shortmess_save = &shortmess +if &shortmess =~ 'A' + set shortmess=aoOA +else + set shortmess=aoO +endif +badd +1 ~/Documents/bachelor_thesis/language +badd +298 src/TypeChecker/TypeChecker.hs +badd +7 test_program +badd +46 src/TypeChecker/TypeCheckerIr.hs +badd +6 Grammar.cf +badd +1 src/Grammar/Abs.hs +argglobal +%argdel +$argadd ~/Documents/bachelor_thesis/language +set stal=2 +tabnew +setlocal\ bufhidden=wipe +tabnew +setlocal\ bufhidden=wipe +tabnew +setlocal\ bufhidden=wipe +tabrewind +edit src/TypeChecker/TypeChecker.hs +let s:save_splitbelow = &splitbelow +let s:save_splitright = &splitright +set splitbelow splitright +wincmd _ | wincmd | +vsplit +1wincmd h +wincmd w +let &splitbelow = s:save_splitbelow +let &splitright = s:save_splitright +wincmd t +let s:save_winminheight = &winminheight +let s:save_winminwidth = &winminwidth +set winminheight=0 +set winheight=1 +set winminwidth=0 +set winwidth=1 +exe 'vert 1resize ' . ((&columns * 99 + 86) / 173) +exe 'vert 2resize ' . ((&columns * 73 + 86) / 173) +argglobal +setlocal fdm=manual +setlocal fde=0 +setlocal fmr={{{,}}} +setlocal fdi=# +setlocal fdl=0 +setlocal fml=1 +setlocal fdn=20 +setlocal fen +silent! normal! zE +let &fdl = &fdl +let s:l = 298 - ((18 * winheight(0) + 21) / 42) +if s:l < 1 | let s:l = 1 | endif +keepjumps exe s:l +normal! zt +keepjumps 298 +normal! 029| +lcd ~/Documents/bachelor_thesis/language +wincmd w +argglobal +if bufexists(fnamemodify("~/Documents/bachelor_thesis/language/Grammar.cf", ":p")) | buffer ~/Documents/bachelor_thesis/language/Grammar.cf | else | edit ~/Documents/bachelor_thesis/language/Grammar.cf | endif +if &buftype ==# 'terminal' + silent file ~/Documents/bachelor_thesis/language/Grammar.cf +endif +balt ~/Documents/bachelor_thesis/language/src/TypeChecker/TypeChecker.hs +setlocal fdm=manual +setlocal fde=0 +setlocal fmr={{{,}}} +setlocal fdi=# +setlocal fdl=0 +setlocal fml=1 +setlocal fdn=20 +setlocal fen +silent! normal! zE +let &fdl = &fdl +let s:l = 7 - ((6 * winheight(0) + 21) / 42) +if s:l < 1 | let s:l = 1 | endif +keepjumps exe s:l +normal! zt +keepjumps 7 +normal! 0 +lcd ~/Documents/bachelor_thesis/language +wincmd w +exe 'vert 1resize ' . ((&columns * 99 + 86) / 173) +exe 'vert 2resize ' . ((&columns * 73 + 86) / 173) +tabnext +edit ~/Documents/bachelor_thesis/language/src/TypeChecker/TypeCheckerIr.hs +let s:save_splitbelow = &splitbelow +let s:save_splitright = &splitright +set splitbelow splitright +wincmd _ | wincmd | +vsplit +1wincmd h +wincmd w +let &splitbelow = s:save_splitbelow +let &splitright = s:save_splitright +wincmd t +let s:save_winminheight = &winminheight +let s:save_winminwidth = &winminwidth +set winminheight=0 +set winheight=1 +set winminwidth=0 +set winwidth=1 +exe 'vert 1resize ' . ((&columns * 86 + 86) / 173) +exe 'vert 2resize ' . ((&columns * 86 + 86) / 173) +argglobal +balt ~/Documents/bachelor_thesis/language/test_program +setlocal fdm=manual +setlocal fde=0 +setlocal fmr={{{,}}} +setlocal fdi=# +setlocal fdl=0 +setlocal fml=1 +setlocal fdn=20 +setlocal fen +silent! normal! zE +let &fdl = &fdl +let s:l = 1 - ((0 * winheight(0) + 21) / 42) +if s:l < 1 | let s:l = 1 | endif +keepjumps exe s:l +normal! zt +keepjumps 1 +normal! 0 +lcd ~/Documents/bachelor_thesis/language +wincmd w +argglobal +if bufexists(fnamemodify("~/Documents/bachelor_thesis/language/src/Grammar/Abs.hs", ":p")) | buffer ~/Documents/bachelor_thesis/language/src/Grammar/Abs.hs | else | edit ~/Documents/bachelor_thesis/language/src/Grammar/Abs.hs | endif +if &buftype ==# 'terminal' + silent file ~/Documents/bachelor_thesis/language/src/Grammar/Abs.hs +endif +balt ~/Documents/bachelor_thesis/language/src/TypeChecker/TypeCheckerIr.hs +setlocal fdm=manual +setlocal fde=0 +setlocal fmr={{{,}}} +setlocal fdi=# +setlocal fdl=0 +setlocal fml=1 +setlocal fdn=20 +setlocal fen +silent! normal! zE +let &fdl = &fdl +let s:l = 1 - ((0 * winheight(0) + 21) / 42) +if s:l < 1 | let s:l = 1 | endif +keepjumps exe s:l +normal! zt +keepjumps 1 +normal! 0 +lcd ~/Documents/bachelor_thesis/language +wincmd w +exe 'vert 1resize ' . ((&columns * 86 + 86) / 173) +exe 'vert 2resize ' . ((&columns * 86 + 86) / 173) +tabnext +edit ~/Documents/bachelor_thesis/language/Grammar.cf +argglobal +balt ~/Documents/bachelor_thesis/language/src/Grammar/Abs.hs +setlocal fdm=manual +setlocal fde=0 +setlocal fmr={{{,}}} +setlocal fdi=# +setlocal fdl=0 +setlocal fml=1 +setlocal fdn=20 +setlocal fen +silent! normal! zE +let &fdl = &fdl +let s:l = 40 - ((12 * winheight(0) + 21) / 42) +if s:l < 1 | let s:l = 1 | endif +keepjumps exe s:l +normal! zt +keepjumps 40 +normal! 0 +lcd ~/Documents/bachelor_thesis/language +tabnext +edit ~/Documents/bachelor_thesis/language/test_program +argglobal +balt ~/Documents/bachelor_thesis/language/src/TypeChecker/TypeChecker.hs +setlocal fdm=manual +setlocal fde=0 +setlocal fmr={{{,}}} +setlocal fdi=# +setlocal fdl=0 +setlocal fml=1 +setlocal fdn=20 +setlocal fen +silent! normal! zE +let &fdl = &fdl +let s:l = 7 - ((6 * winheight(0) + 21) / 42) +if s:l < 1 | let s:l = 1 | endif +keepjumps exe s:l +normal! zt +keepjumps 7 +normal! 010| +lcd ~/Documents/bachelor_thesis/language +tabnext 1 +set stal=1 +if exists('s:wipebuf') && len(win_findbuf(s:wipebuf)) == 0 && getbufvar(s:wipebuf, '&buftype') isnot# 'terminal' + silent exe 'bwipe ' . s:wipebuf +endif +unlet! s:wipebuf +set winheight=1 winwidth=20 +let &shortmess = s:shortmess_save +let s:sx = expand(":p:r")."x.vim" +if filereadable(s:sx) + exe "source " . fnameescape(s:sx) +endif +let &g:so = s:so_save | let &g:siso = s:siso_save +set hlsearch +nohlsearch +doautoall SessionLoadPost +unlet SessionLoad +" vim: set ft=vim : diff --git a/src/TypeChecker/TypeChecker.hs b/src/TypeChecker/TypeChecker.hs index 779867b..ec7b005 100644 --- a/src/TypeChecker/TypeChecker.hs +++ b/src/TypeChecker/TypeChecker.hs @@ -8,13 +8,16 @@ import Control.Monad.Except import Control.Monad.Reader import Control.Monad.State import Data.Foldable (traverse_) +import Data.Function (on) import Data.Functor.Identity (runIdentity) import Data.List (foldl') +import Data.List.Extra (allSame) import Data.Map (Map) import Data.Map qualified as M import Data.Maybe (fromMaybe) import Data.Set (Set) import Data.Set qualified as S +import Data.Tree (flatten) import Debug.Trace (trace) import Grammar.Abs import Grammar.Print (printTree) @@ -204,9 +207,9 @@ algoW = \case -- \| ------------------ -- \| Γ ⊢ i : Int, ∅ - ELit (LInt n) -> - return (nullSubst, TMono "Int", T.ELit (TMono "Int") (LInt n)) - ELit a -> error $ "NOT IMPLEMENTED YET: ELit " ++ show a + ELit lit -> + let lt = litType lit + in return (nullSubst, lt, T.ELit lt lit) -- \| x : σ ∈ Γ   τ = inst(σ) -- \| ---------------------- -- \| Γ ⊢ x : τ, ∅ @@ -289,16 +292,14 @@ algoW = \case (s2, t2, e1') <- algoW e1 let composition = s2 `compose` s1 return (composition, t2, apply composition $ T.ELet (T.Bind (name, t2) e0') e1') + + -- TODO: give caseExpr a concrete type before proceeding + -- probably by returning substitutions in the functions used in this body ECase caseExpr injs -> do - (_, t0, e0') <- algoW caseExpr - (injs', ts) <- mapAndUnzipM (checkInj t0) injs - case ts of - [] -> throwError "Case expression missing any matches" - ts -> do - unified <- zipWithM unify ts (tail ts) - let composition = foldl' compose mempty unified - let typ = apply composition (head ts) - return (composition, typ, apply composition $ T.ECase typ e0' injs') + (sub, _, e') <- algoW caseExpr + trace ("SUB: " ++ show sub) return () + t <- checkCase caseExpr injs + return (sub, t, T.ECase t e' (map (\(Inj i _) -> T.Inj (i, t) e') injs)) -- | Unify two types producing a new substitution unify :: Type -> Type -> Infer Subst @@ -312,7 +313,6 @@ unify t0 t1 = do (a, TPol b) -> occurs b a (TMono a, TMono b) -> if a == b then return M.empty else throwError "Types do not unify" - -- \| TODO: Figure out a cleaner way to express the same thing (TConstr (Constr name t), TConstr (Constr name' t')) -> if name == name' && length t == length t' then do @@ -464,52 +464,45 @@ insertConstr i t = -------- PATTERN MATCHING --------- --- "case expr of", the type of 'expr' is caseType -checkInj :: Type -> Inj -> Infer (T.Inj, Type) -checkInj caseType (Inj it expr) = do - (args, t') <- initType caseType it - subst <- unify caseType t' - applySt subst $ do - (_, t, e') <- local (\st -> st{vars = args `M.union` vars st}) (algoW expr) - return (T.Inj (it, t') e', t) +unifyAll :: [Type] -> Infer [Subst] +unifyAll [] = return [] +unifyAll [_] = return [] +unifyAll (x : y : xs) = do + uni <- unify x y + all <- unifyAll (y : xs) + return $ uni : all -initType :: Type -> Init -> Infer (Map Ident Poly, Type) -initType expected = \case - InitLit lit -> error "Pattern match on literals not implemented yet" - InitConstr c args -> do - st <- gets constructors - case M.lookup c st of - Nothing -> - throwError $ - unwords - [ "Constructor:" - , printTree c - , "does not exist" - ] - Just t -> do - let flat = flattenType t - let returnType = last flat - case ( length (init flat) == length args - , returnType `isMoreSpecificOrEq` expected - ) of - (True, True) -> - return - ( M.fromList $ zip args (map (Forall []) flat) - , expected - ) - (False, _) -> - throwError $ - "Can't partially match on the constructor: " - ++ printTree c - (_, False) -> - throwError $ - unwords - [ "Inferred type" - , printTree returnType - , "does not match expected type:" - , printTree expected - ] - InitCatch -> return (mempty, expected) +checkCase :: Exp -> [Inj] -> Infer Type +checkCase e injs = do + expT <- fst <$> inferExp e + (injTs, returns) <- mapAndUnzipM checkInj injs + unifyAll (expT : injTs) + subst <- foldl1 compose <$> zipWithM unify returns (tail returns) + let substed = map (apply subst) returns + unless (allSame substed || null substed) (throwError "Different return types of case, or no cases") + return $ head substed + +{- | fst = type of init +| snd = type of expr +-} +checkInj :: Inj -> Infer (Type, Type) +checkInj (Inj it expr) = do + initT <- inferInit it + (exprT, _) <- inferExp expr + return (initT, exprT) + +inferInit :: Init -> Infer Type +inferInit = \case + InitLit lit -> return $ litType lit + InitConstr fn vars -> do + gets (M.lookup fn . constructors) >>= \case + Nothing -> throwError $ "Constructor: " ++ printTree fn ++ " does not exist" + Just a -> do + let ft = init $ flattenType a + case compare (length vars) (length ft) of + EQ -> return . last $ flattenType a + _ -> throwError "Partial pattern match not allowed" + InitCatch -> fresh flattenType :: Type -> [Type] flattenType (TArr a b) = flattenType a ++ flattenType b diff --git a/test_program b/test_program index 2470637..a8accca 100644 --- a/test_program +++ b/test_program @@ -1,2 +1,9 @@ -id : 'a -> 'a ; -id = \x. x ; +data Bool () where { + True : Bool () + False : Bool () +}; + +main : Bool () -> _Int ; +main x = case x of { + 1 => 0 +} From bbf7a47e74310bfa0344768fc0d2ad447f396b1c Mon Sep 17 00:00:00 2001 From: Samuel Hammersberg Date: Tue, 21 Mar 2023 09:39:05 +0100 Subject: [PATCH 089/372] Started updating the Code Generator to the new monomorphizer tree. --- Grammar.cf | 2 +- language.cabal | 2 + sample-programs/basic-1 | 45 +- src/Codegen/Codegen.hs | 891 ++++++++++++++------------- src/Codegen/LlvmIr.hs | 482 +++++++-------- src/Monomorphizer/Monomorphizer.hs | 1 + src/Monomorphizer/MonomorphizerIr.hs | 36 ++ 7 files changed, 753 insertions(+), 706 deletions(-) create mode 100644 src/Monomorphizer/Monomorphizer.hs create mode 100644 src/Monomorphizer/MonomorphizerIr.hs diff --git a/Grammar.cf b/Grammar.cf index a55e8c4..7d52004 100644 --- a/Grammar.cf +++ b/Grammar.cf @@ -13,7 +13,7 @@ Data. Data ::= "data" Constr "where" "{" [Constructor] "}" ; Constructor. Constructor ::= Ident ":" Type ; separator nonempty Constructor "" ; -TMono. Type1 ::= "_" Ident ; +TMono. Type1 ::= Ident ; TPol. Type1 ::= "'" Ident ; TConstr. Type1 ::= Constr ; TArr. Type ::= Type1 "->" Type ; diff --git a/language.cabal b/language.cabal index e190a7e..f74cb18 100644 --- a/language.cabal +++ b/language.cabal @@ -37,6 +37,8 @@ executable language Renamer.Renamer TypeChecker.TypeChecker TypeChecker.TypeCheckerIr + Monomorphizer.Monomorphizer + Monomorphizer.MonomorphizerIr -- Interpreter Codegen.Codegen Codegen.LlvmIr diff --git a/sample-programs/basic-1 b/sample-programs/basic-1 index 57ce1d9..4177ccf 100644 --- a/sample-programs/basic-1 +++ b/sample-programs/basic-1 @@ -1,26 +1,29 @@ posMul : _Int -> _Int -> _Int; -posMul a b = case b of { +posMul a b = a + b; {-case b of { 0 => 0; _ => a + posMul a (b - 1) -}; - -facc : _Int -> _Int; -facc a = case a of { - 1 => 1; - _ => posMul a (facc (a - 1)) -}; - -minimization : (_Int -> _Int) -> _Int -> _Int; -minimization p x = case p x of { - 1 => x; - _ => minimization p (x + 1) -}; - -checkFac : _Int -> _Int; -checkFac x = case facc x of { - 0 => 1; - _ => 0 -}; +};-} main : _Int; -main = minimization checkFac 1 \ No newline at end of file +main = posMul 5 10; +-- +-- facc : _Int -> _Int; +-- facc a = case a of { +-- 1 => 1; +-- _ => posMul a (facc (a - 1)) +-- }; +-- +-- minimization : (_Int -> _Int) -> _Int -> _Int; +-- minimization p x = case p x of { +-- 1 => x; +-- _ => minimization p (x + 1) +-- }; +-- +-- checkFac : _Int -> _Int; +-- checkFac x = case facc x of { +-- 0 => 1; +-- _ => 0 +-- }; +-- +-- main : _Int; +-- main = minimization checkFac 1 \ No newline at end of file diff --git a/src/Codegen/Codegen.hs b/src/Codegen/Codegen.hs index 9d3b034..b67f0c5 100644 --- a/src/Codegen/Codegen.hs +++ b/src/Codegen/Codegen.hs @@ -1,443 +1,448 @@ -module Codegen.Codegen where --- {-# LANGUAGE LambdaCase #-} --- {-# LANGUAGE OverloadedStrings #-} --- --- module Codegen.Codegen (generateCode) where --- --- import Auxiliary (snoc) --- import Codegen.LlvmIr (CallingConvention (..), --- LLVMComp (..), LLVMIr (..), --- LLVMType (..), LLVMValue (..), --- Visibility (..), llvmIrToString) --- import Control.Monad.State (StateT, execStateT, foldM_, gets, --- modify) --- import qualified Data.Bifunctor as BI --- import Data.List.Extra (trim) --- import Data.Map (Map) --- import qualified Data.Map as Map --- import Data.Tuple.Extra (dupe, first, second) --- import qualified Grammar.Abs as GA --- import Grammar.ErrM (Err) --- import System.Process.Extra (readCreateProcess, shell) --- import TypeChecker.TypeCheckerIr (Bind (..), Case (..), Exp (..), Id, --- Ident (..), Program (..), Type (..)) --- -- | The record used as the code generator state --- data CodeGenerator = CodeGenerator --- { instructions :: [LLVMIr] --- , functions :: Map Id FunctionInfo --- , constructors :: Map Id ConstructorInfo --- , variableCount :: Integer --- , labelCount :: Integer --- } --- --- -- | A state type synonym --- type CompilerState a = StateT CodeGenerator Err a --- --- data FunctionInfo = FunctionInfo --- { numArgs :: Int --- , arguments :: [Id] --- } --- data ConstructorInfo = ConstructorInfo --- { numArgsCI :: Int --- , argumentsCI :: [Id] --- , numCI :: Integer --- } --- --- --- -- | Adds a instruction to the CodeGenerator state --- emit :: LLVMIr -> CompilerState () --- emit l = modify $ \t -> t { instructions = Auxiliary.snoc l $ instructions t } --- --- -- | Increases the variable counter in the CodeGenerator state --- increaseVarCount :: CompilerState () --- increaseVarCount = modify $ \t -> t { variableCount = variableCount t + 1 } --- --- -- | Returns the variable count from the CodeGenerator state --- getVarCount :: CompilerState Integer --- getVarCount = gets variableCount --- --- -- | Increases the variable count and returns it from the CodeGenerator state --- getNewVar :: CompilerState Integer --- getNewVar = increaseVarCount >> getVarCount --- --- -- | Increses the label count and returns a label from the CodeGenerator state --- getNewLabel :: CompilerState Integer --- getNewLabel = do --- modify (\t -> t{labelCount = labelCount t + 1}) --- gets labelCount --- --- -- | Produces a map of functions infos from a list of binds, --- -- which contains useful data for code generation. --- getFunctions :: [Bind] -> Map Id FunctionInfo --- getFunctions bs = Map.fromList $ go bs --- where --- go [] = [] --- go (Bind id args _ : xs) = --- (id, FunctionInfo { numArgs=length args, arguments=args }) --- : go xs --- go (DataStructure n cons : xs) = do --- map (\(id, xs) -> ((id, TPol n), FunctionInfo { --- numArgs=length xs, arguments=createArgs xs --- })) cons --- <> go xs --- --- createArgs :: [Type] -> [Id] --- createArgs xs = fst $ foldl (\(acc, l) t -> (acc ++ [(Ident ("arg_" <> show l) , t)],l+1)) ([], 0) xs --- --- -- | Produces a map of functions infos from a list of binds, --- -- which contains useful data for code generation. --- getConstructors :: [Bind] -> Map Id ConstructorInfo --- getConstructors bs = Map.fromList $ go bs --- where --- go [] = [] --- go (DataStructure (Ident n) cons : xs) = do --- fst (foldl (\(acc,i) (Ident id, xs) -> (((Ident (n <> "_" <> id), TPol (Ident n)), ConstructorInfo { --- numArgsCI=length xs, --- argumentsCI=createArgs xs, --- numCI=i --- }) : acc, i+1)) ([],0) cons) --- <> go xs --- go (_: xs) = go xs --- --- initCodeGenerator :: [Bind] -> CodeGenerator --- initCodeGenerator scs = CodeGenerator { instructions = defaultStart --- , functions = getFunctions scs --- , constructors = getConstructors scs --- , variableCount = 0 --- , labelCount = 0 --- } --- --- run :: Err String -> IO () --- run s = do --- let s' = case s of --- Right s -> s --- Left _ -> error "yo" --- writeFile "output/llvm.ll" s' --- putStrLn . trim =<< readCreateProcess (shell "lli") s' --- --- test :: Integer -> Program --- test v = Program [ --- DataStructure (Ident "Craig") [ --- (Ident "Bob", [TInt])--, --- --(Ident "Alice", [TInt, TInt]) --- ], --- Bind (Ident "fibonacci", TInt) [(Ident "x", TInt)] (EId ("x",TInt)), --- Bind (Ident "main", TInt) [] ( --- EApp (TPol "Craig") (EId (Ident "Craig_Bob", TPol "Craig")) (EInt v) -- (EInt 92) --- ) --- ] --- --- {- | Compiles an AST and produces a LLVM Ir string. --- An easy way to actually "compile" this output is to --- Simply pipe it to LLI --- -} --- generateCode :: Program -> Err String --- generateCode (Program scs) = do --- let codegen = initCodeGenerator scs --- llvmIrToString . instructions <$> execStateT (compileScs scs) codegen --- --- compileScs :: [Bind] -> CompilerState () --- compileScs [] = do --- -- as a last step create all the constructors --- c <- gets (Map.toList . constructors) --- mapM_ (\((id, t), ci) -> do --- let t' = type2LlvmType t --- let x = BI.second type2LlvmType <$> argumentsCI ci --- emit $ Define FastCC t' id x --- top <- Ident . show <$> getNewVar --- ptr <- Ident . show <$> getNewVar --- -- allocated the primary type --- emit $ SetVariable top (Alloca t') --- --- -- set the first byte to the index of the constructor --- emit $ SetVariable ptr $ --- GetElementPtrInbounds t' (Ref t') --- (VIdent top I8) I32 (VInteger 0) I32 (VInteger 0) --- emit $ Store I8 (VInteger $ numCI ci ) (Ref I8) ptr --- --- -- get a pointer of the correct type --- ptr' <- Ident . show <$> getNewVar --- emit $ SetVariable ptr' (Bitcast (Ref t') ptr (Ref $ CustomType id)) --- --- --emit $ UnsafeRaw "\n" --- --- foldM_ (\i (Ident arg_n, arg_t)-> do --- let arg_t' = type2LlvmType arg_t --- emit $ Comment (show arg_t' <>" "<> arg_n <> " " <> show i ) --- elemPtr <- Ident . show <$> getNewVar --- emit $ SetVariable elemPtr ( --- GetElementPtrInbounds (CustomType id) (Ref (CustomType id)) --- (VIdent ptr' Ptr) I32 --- (VInteger 0) I32 (VInteger i)) --- emit $ Store arg_t' (VIdent (Ident arg_n) arg_t') Ptr elemPtr --- -- %2 = getelementptr inbounds %Foo_AInteger, %Foo_AInteger* %1, i32 0, i32 1 --- -- store i32 42, i32* %2 --- pure $ i + 1-- + typeByteSize arg_t' --- ) 1 (argumentsCI ci) --- --- --emit $ UnsafeRaw "\n" --- --- -- load and return the constructed value --- load <- Ident . show <$> getNewVar --- emit $ SetVariable load (Load t' Ptr top) --- emit $ Ret t' (VIdent load t') --- emit DefineEnd --- --- modify $ \s -> s { variableCount = 0 } --- ) c --- compileScs (Bind (name, _t) args exp : xs) = do --- emit $ UnsafeRaw "\n" --- emit . Comment $ show name <> ": " <> show exp --- let args' = map (second type2LlvmType) args --- emit $ Define FastCC I64 {-(type2LlvmType t_return)-} name args' --- functionBody <- exprToValue exp --- if name == "main" --- then mapM_ emit $ mainContent functionBody --- else emit $ Ret I64 functionBody --- emit DefineEnd --- modify $ \s -> s { variableCount = 0 } --- compileScs xs --- compileScs (DataStructure id@(Ident outer_id) ts : xs) = do --- let biggest_variant = maximum ((\(_, t) -> sum $ typeByteSize . type2LlvmType <$> t) <$> ts) --- emit $ Type id [I8, Array biggest_variant I8] --- mapM_ (\(Ident inner_id, fi) -> do --- emit $ Type (Ident $ outer_id <> "_" <> inner_id) (I8 : map type2LlvmType fi) --- ) ts --- compileScs xs --- --- -- where --- -- _t_return = snd $ partitionType (length args) t --- --- mainContent :: LLVMValue -> [LLVMIr] --- mainContent var = --- [ UnsafeRaw $ --- "call i32 (ptr, ...) @printf(ptr noundef @.str, i64 noundef " <> show var <> ")\n" --- , -- , SetVariable (Ident "p") (Icmp LLEq I64 (VInteger 2) (VInteger 2)) --- -- , BrCond (VIdent (Ident "p")) (Ident "b_1") (Ident "b_2") --- -- , Label (Ident "b_1") --- -- , UnsafeRaw --- -- "call i32 (ptr, ...) @printf(ptr noundef @.str, i64 noundef 1)\n" --- -- , Br (Ident "end") --- -- , Label (Ident "b_2") --- -- , UnsafeRaw --- -- "call i32 (ptr, ...) @printf(ptr noundef @.str, i64 noundef 2)\n" --- -- , Br (Ident "end") --- -- , Label (Ident "end") --- Ret I64 (VInteger 0) --- ] --- --- defaultStart :: [LLVMIr] --- defaultStart = [ UnsafeRaw "target triple = \"x86_64-pc-linux-gnu\"\n" --- , UnsafeRaw "target datalayout = \"e-m:o-i64:64-f80:128-n8:16:32:64-S128\"\n" --- , UnsafeRaw "@.str = private unnamed_addr constant [3 x i8] c\"%i\n\", align 1\n" --- , UnsafeRaw "declare i32 @printf(ptr noalias nocapture, ...)\n" --- ] --- --- compileExp :: Exp -> CompilerState () --- compileExp (EInt int) = emitInt int --- compileExp (EAdd t e1 e2) = emitAdd t e1 e2 --- compileExp (ESub t e1 e2) = emitSub t e1 e2 --- compileExp (EId (name, _)) = emitIdent name --- compileExp (EApp t e1 e2) = emitApp t e1 e2 --- compileExp (EAbs t ti e) = emitAbs t ti e --- compileExp (ELet binds e) = emitLet binds e --- compileExp (ECase t e cs) = emitECased t e cs --- -- go (EMul e1 e2) = emitMul e1 e2 --- -- go (EDiv e1 e2) = emitDiv e1 e2 --- -- go (EMod e1 e2) = emitMod e1 e2 --- --- --- aux functions --- --- emitECased :: Type -> Exp -> [(Type, Case)] -> CompilerState () --- emitECased t e cases = do --- let cs = snd <$> cases --- let ty = type2LlvmType t --- vs <- exprToValue e --- lbl <- getNewLabel --- let label = Ident $ "escape_" <> show lbl --- stackPtr <- getNewVar --- emit $ SetVariable (Ident $ show stackPtr) (Alloca ty) --- mapM_ (emitCases ty label stackPtr vs) cs --- emit $ Label label --- res <- getNewVar --- emit $ SetVariable (Ident $ show res) (Load ty Ptr (Ident $ show stackPtr)) --- where --- emitCases :: LLVMType -> Ident -> Integer -> LLVMValue -> Case -> CompilerState () --- emitCases ty label stackPtr vs (Case (GA.CInt i) exp) = do --- ns <- getNewVar --- lbl_failPos <- (\x -> Ident $ "failed_" <> show x) <$> getNewLabel --- lbl_succPos <- (\x -> Ident $ "success_" <> show x) <$> getNewLabel --- emit $ SetVariable (Ident $ show ns) (Icmp LLEq ty vs (VInteger i)) --- emit $ BrCond (VIdent (Ident $ show ns) ty) lbl_succPos lbl_failPos --- emit $ Label lbl_succPos --- val <- exprToValue exp --- emit $ Store ty val Ptr (Ident . show $ stackPtr) --- emit $ Br label --- emit $ Label lbl_failPos --- emitCases ty label stackPtr _ (Case GA.CatchAll exp) = do --- val <- exprToValue exp --- emit $ Store ty val Ptr (Ident . show $ stackPtr) --- emit $ Br label --- --- --- emitAbs :: Type -> Id -> Exp -> CompilerState () --- emitAbs _t tid e = do --- emit . Comment $ --- "Lambda escaped previous stages: \\" <> show tid <> " . " <> show e --- emitLet :: Bind -> Exp -> CompilerState () --- emitLet xs e = do --- emit $ --- Comment $ --- concat --- [ "ELet (" --- , show xs --- , " = " --- , show e --- , ") is not implemented!" --- ] --- --- emitApp :: Type -> Exp -> Exp -> CompilerState () --- emitApp t e1 e2 = appEmitter t e1 e2 [] --- where --- appEmitter :: Type -> Exp -> Exp -> [Exp] -> CompilerState () --- appEmitter t e1 e2 stack = do --- let newStack = e2 : stack --- case e1 of --- EApp _ e1' e2' -> appEmitter t e1' e2' newStack --- EId id@(name, _) -> do --- args <- traverse exprToValue newStack --- vs <- getNewVar --- funcs <- gets functions --- let visibility = maybe Local (const Global) $ Map.lookup id funcs --- args' = map (first valueGetType . dupe) args --- call = Call FastCC (type2LlvmType t) visibility name args' --- emit $ SetVariable (Ident $ show vs) call --- x -> do --- emit . Comment $ "The unspeakable happened: " --- emit . Comment $ show x --- --- emitIdent :: Ident -> CompilerState () --- emitIdent id = do --- -- !!this should never happen!! --- emit $ Comment "This should not have happened!" --- emit $ Variable id --- emit $ UnsafeRaw "\n" --- --- emitInt :: Integer -> CompilerState () --- emitInt i = do --- -- !!this should never happen!! --- varCount <- getNewVar --- emit $ Comment "This should not have happened!" --- emit $ SetVariable (Ident (show varCount)) (Add I64 (VInteger i) (VInteger 0)) --- --- emitAdd :: Type -> Exp -> Exp -> CompilerState () --- emitAdd t e1 e2 = do --- v1 <- exprToValue e1 --- v2 <- exprToValue e2 --- v <- getNewVar --- emit $ SetVariable (Ident $ show v) (Add (type2LlvmType t) v1 v2) --- --- emitSub :: Type -> Exp -> Exp -> CompilerState () --- emitSub t e1 e2 = do --- v1 <- exprToValue e1 --- v2 <- exprToValue e2 --- v <- getNewVar --- emit $ SetVariable (Ident $ show v) (Sub (type2LlvmType t) v1 v2) --- --- -- emitMul :: Exp -> Exp -> CompilerState () --- -- emitMul e1 e2 = do --- -- (v1,v2) <- binExprToValues e1 e2 --- -- increaseVarCount --- -- v <- gets variableCount --- -- emit $ SetVariable $ Ident $ show v --- -- emit $ Mul I64 v1 v2 --- --- -- emitMod :: Exp -> Exp -> CompilerState () --- -- emitMod e1 e2 = do --- -- -- `let m a b = rem (abs $ b + a) b` --- -- (v1,v2) <- binExprToValues e1 e2 --- -- increaseVarCount --- -- vadd <- gets variableCount --- -- emit $ SetVariable $ Ident $ show vadd --- -- emit $ Add I64 v1 v2 --- -- --- -- increaseVarCount --- -- vabs <- gets variableCount --- -- emit $ SetVariable $ Ident $ show vabs --- -- emit $ Call I64 (Ident "llvm.abs.i64") --- -- [ (I64, VIdent (Ident $ show vadd)) --- -- , (I1, VInteger 1) --- -- ] --- -- increaseVarCount --- -- v <- gets variableCount --- -- emit $ SetVariable $ Ident $ show v --- -- emit $ Srem I64 (VIdent (Ident $ show vabs)) v2 --- --- -- emitDiv :: Exp -> Exp -> CompilerState () --- -- emitDiv e1 e2 = do --- -- (v1,v2) <- binExprToValues e1 e2 --- -- increaseVarCount --- -- v <- gets variableCount --- -- emit $ SetVariable $ Ident $ show v --- -- emit $ Div I64 v1 v2 --- --- exprToValue :: Exp -> CompilerState LLVMValue --- exprToValue = \case --- EInt i -> pure $ VInteger i --- --- EId id@(name, t) -> do --- funcs <- gets functions --- case Map.lookup id funcs of --- Just fi -> do --- if numArgs fi == 0 --- then do --- vc <- getNewVar --- emit $ SetVariable (Ident $ show vc) --- (Call FastCC (type2LlvmType t) Global name []) --- pure $ VIdent (Ident $ show vc) (type2LlvmType t) --- else pure $ VFunction name Global (type2LlvmType t) --- Nothing -> pure $ VIdent name (type2LlvmType t) --- --- e -> do --- compileExp e --- v <- getVarCount --- pure $ VIdent (Ident $ show v) (getType e) --- --- type2LlvmType :: Type -> LLVMType --- type2LlvmType = \case --- TInt -> I64 --- TFun t xs -> do --- let (t', xs') = function2LLVMType xs [type2LlvmType t] --- Function t' xs' --- TPol t -> CustomType t --- where --- function2LLVMType :: Type -> [LLVMType] -> (LLVMType, [LLVMType]) --- function2LLVMType (TFun t xs) s = function2LLVMType xs (type2LlvmType t : s) --- function2LLVMType x s = (type2LlvmType x, s) --- --- getType :: Exp -> LLVMType --- getType (EInt _) = I64 --- getType (EAdd t _ _) = type2LlvmType t --- getType (ESub t _ _) = type2LlvmType t --- getType (EId (_, t)) = type2LlvmType t --- getType (EApp t _ _) = type2LlvmType t --- getType (EAbs t _ _) = type2LlvmType t --- getType (ELet _ e) = getType e --- getType (ECase t _ _) = type2LlvmType t --- --- valueGetType :: LLVMValue -> LLVMType --- valueGetType (VInteger _) = I64 --- valueGetType (VIdent _ t) = t --- valueGetType (VConstant s) = Array (fromIntegral $ length s) I8 --- valueGetType (VFunction _ _ t) = t --- --- typeByteSize :: LLVMType -> Integer --- typeByteSize I1 = 1 --- typeByteSize I8 = 1 --- typeByteSize I32 = 4 --- typeByteSize I64 = 8 --- typeByteSize Ptr = 8 --- typeByteSize (Ref _) = 8 --- typeByteSize (Function _ _) = 8 --- typeByteSize (Array n t) = n * typeByteSize t --- typeByteSize (CustomType _) = 8 --- +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} + +module Codegen.Codegen (generateCode) where +import Auxiliary (snoc) +import Codegen.LlvmIr (CallingConvention (..), + LLVMComp (..), LLVMIr (..), + LLVMType (..), LLVMValue (..), + Visibility (..), llvmIrToString) +import Codegen.LlvmIr as LIR +import Control.Monad.State (StateT, execStateT, foldM_, + gets, modify) +import qualified Data.Bifunctor as BI +import Data.List.Extra (trim) +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Tuple.Extra (dupe, first, second) +import qualified Grammar.Abs as GA +import Grammar.ErrM (Err) +import Monomorphizer.MonomorphizerIr as MIR +import System.Process.Extra (readCreateProcess, shell) +-- | The record used as the code generator state +data CodeGenerator = CodeGenerator + { instructions :: [LLVMIr] + , functions :: Map Id FunctionInfo + , constructors :: Map Id ConstructorInfo + , variableCount :: Integer + , labelCount :: Integer + } + +-- | A state type synonym +type CompilerState a = StateT CodeGenerator Err a + +data FunctionInfo = FunctionInfo + { numArgs :: Int + , arguments :: [Id] + } +data ConstructorInfo = ConstructorInfo + { numArgsCI :: Int + , argumentsCI :: [Id] + , numCI :: Integer + } + + +-- | Adds a instruction to the CodeGenerator state +emit :: LLVMIr -> CompilerState () +emit l = modify $ \t -> t { instructions = Auxiliary.snoc l $ instructions t } + +-- | Increases the variable counter in the CodeGenerator state +increaseVarCount :: CompilerState () +increaseVarCount = modify $ \t -> t { variableCount = variableCount t + 1 } + +-- | Returns the variable count from the CodeGenerator state +getVarCount :: CompilerState Integer +getVarCount = gets variableCount + +-- | Increases the variable count and returns it from the CodeGenerator state +getNewVar :: CompilerState Integer +getNewVar = increaseVarCount >> getVarCount + +-- | Increses the label count and returns a label from the CodeGenerator state +getNewLabel :: CompilerState Integer +getNewLabel = do + modify (\t -> t{labelCount = labelCount t + 1}) + gets labelCount + +-- | Produces a map of functions infos from a list of binds, +-- which contains useful data for code generation. +getFunctions :: [Bind] -> Map Id FunctionInfo +getFunctions bs = Map.fromList $ go bs + where + go [] = [] + go (Bind id args _ : xs) = + (id, FunctionInfo { numArgs=length args, arguments=args }) + : go xs + go (DataType n cons : xs) = do + map (\(Constructor id xs) -> ((id, MIR.Type n), FunctionInfo { + numArgs=length xs, arguments=createArgs xs + })) cons + <> go xs + +createArgs :: [Type] -> [Id] +createArgs xs = fst $ foldl (\(acc, l) t -> (acc ++ [(GA.Ident ("arg_" <> show l) , t)],l+1)) ([], 0) xs + +-- | Produces a map of functions infos from a list of binds, +-- which contains useful data for code generation. +getConstructors :: [Bind] -> Map Id ConstructorInfo +getConstructors bs = Map.fromList $ go bs + where + go [] = [] + go (DataType (GA.Ident n) cons : xs) = do + fst (foldl (\(acc,i) (Constructor (GA.Ident id) xs) -> (((GA.Ident (n <> "_" <> id), MIR.Type (GA.Ident n)), ConstructorInfo { + numArgsCI=length xs, + argumentsCI=createArgs xs, + numCI=i + }) : acc, i+1)) ([],0) cons) + <> go xs + go (_: xs) = go xs + +initCodeGenerator :: [Bind] -> CodeGenerator +initCodeGenerator scs = CodeGenerator { instructions = defaultStart + , functions = getFunctions scs + , constructors = getConstructors scs + , variableCount = 0 + , labelCount = 0 + } + +run :: Err String -> IO () +run s = do + let s' = case s of + Right s -> s + Left _ -> error "yo" + writeFile "output/llvm.ll" s' + putStrLn . trim =<< readCreateProcess (shell "lli") s' + +test :: Integer -> Program +test v = Program [ + DataType (GA.Ident "Craig") [ + Constructor (GA.Ident "Bob") [MIR.Type (GA.Ident "_Int")]--, + --(GA.Ident "Alice", [TInt, TInt]) + ], + Bind (GA.Ident "fibonacci", MIR.Type (GA.Ident "_Int")) [(GA.Ident "x", MIR.Type (GA.Ident "_Int"))] (EId ("x", MIR.Type (GA.Ident "Craig")), MIR.Type (GA.Ident "Craig")), + Bind (GA.Ident "main", MIR.Type (GA.Ident "_Int")) [] + (EApp (MIR.Type (GA.Ident "Craig")) (EId (GA.Ident "Craig_Bob", MIR.Type (GA.Ident "Craig")), MIR.Type (GA.Ident "Craig")) (ELit (LInt v), MIR.Type (GA.Ident "_Int")), MIR.Type (GA.Ident "Craig"))-- (EInt 92) + ] + +{- | Compiles an AST and produces a LLVM Ir string. + An easy way to actually "compile" this output is to + Simply pipe it to LLI +-} +generateCode :: Program -> Err String +generateCode (Program scs) = do + let codegen = initCodeGenerator scs + llvmIrToString . instructions <$> execStateT (compileScs scs) codegen + +compileScs :: [Bind] -> CompilerState () +compileScs [] = do + -- as a last step create all the constructors + c <- gets (Map.toList . constructors) + mapM_ (\((id, t), ci) -> do + let t' = type2LlvmType t + let x = BI.second type2LlvmType <$> argumentsCI ci + emit $ Define FastCC t' id x + top <- GA.Ident . show <$> getNewVar + ptr <- GA.Ident . show <$> getNewVar + -- allocated the primary type + emit $ SetVariable top (Alloca t') + + -- set the first byte to the index of the constructor + emit $ SetVariable ptr $ + GetElementPtrInbounds t' (Ref t') + (VIdent top I8) I32 (VInteger 0) I32 (VInteger 0) + emit $ Store I8 (VInteger $ numCI ci ) (Ref I8) ptr + + -- get a pointer of the correct type + ptr' <- GA.Ident . show <$> getNewVar + emit $ SetVariable ptr' (Bitcast (Ref t') ptr (Ref $ CustomType id)) + + --emit $ UnsafeRaw "\n" + + foldM_ (\i (GA.Ident arg_n, arg_t)-> do + let arg_t' = type2LlvmType arg_t + emit $ Comment (show arg_t' <>" "<> arg_n <> " " <> show i ) + elemPtr <- GA.Ident . show <$> getNewVar + emit $ SetVariable elemPtr ( + GetElementPtrInbounds (CustomType id) (Ref (CustomType id)) + (VIdent ptr' Ptr) I32 + (VInteger 0) I32 (VInteger i)) + emit $ Store arg_t' (VIdent (GA.Ident arg_n) arg_t') Ptr elemPtr + -- %2 = getelementptr inbounds %Foo_AInteger, %Foo_AInteger* %1, i32 0, i32 1 + -- store i32 42, i32* %2 + pure $ i + 1-- + typeByteSize arg_t' + ) 1 (argumentsCI ci) + + --emit $ UnsafeRaw "\n" + + -- load and return the constructed value + load <- GA.Ident . show <$> getNewVar + emit $ SetVariable load (Load t' Ptr top) + emit $ Ret t' (VIdent load t') + emit DefineEnd + + modify $ \s -> s { variableCount = 0 } + ) c +compileScs (Bind (name, _t) args exp : xs) = do + emit $ UnsafeRaw "\n" + emit . Comment $ show name <> ": " <> show exp + let args' = map (second type2LlvmType) args + emit $ Define FastCC I64 {-(type2LlvmType t_return)-} name args' + functionBody <- exprToValue (fst exp) + if name == "main" + then mapM_ emit $ mainContent functionBody + else emit $ Ret I64 functionBody + emit DefineEnd + modify $ \s -> s { variableCount = 0 } + compileScs xs +compileScs (DataType id@(GA.Ident outer_id) ts : xs) = do + let biggest_variant = maximum ((\(Constructor _ t) -> sum $ typeByteSize . type2LlvmType <$> t) <$> ts) + emit $ LIR.Type id [I8, Array biggest_variant I8] + mapM_ (\(Constructor (GA.Ident inner_id) fi) -> do + emit $ LIR.Type (GA.Ident $ outer_id <> "_" <> inner_id) (I8 : map type2LlvmType fi) + ) ts + compileScs xs + + -- where + -- _t_return = snd $ partitionType (length args) t + +mainContent :: LLVMValue -> [LLVMIr] +mainContent var = + [ UnsafeRaw $ + "call i32 (ptr, ...) @printf(ptr noundef @.str, i64 noundef " <> show var <> ")\n" + , -- , SetVariable (GA.Ident "p") (Icmp LLEq I64 (VInteger 2) (VInteger 2)) + -- , BrCond (VIdent (GA.Ident "p")) (GA.Ident "b_1") (GA.Ident "b_2") + -- , Label (GA.Ident "b_1") + -- , UnsafeRaw + -- "call i32 (ptr, ...) @printf(ptr noundef @.str, i64 noundef 1)\n" + -- , Br (GA.Ident "end") + -- , Label (GA.Ident "b_2") + -- , UnsafeRaw + -- "call i32 (ptr, ...) @printf(ptr noundef @.str, i64 noundef 2)\n" + -- , Br (GA.Ident "end") + -- , Label (GA.Ident "end") + Ret I64 (VInteger 0) + ] + +defaultStart :: [LLVMIr] +defaultStart = [ UnsafeRaw "target triple = \"x86_64-pc-linux-gnu\"\n" + , UnsafeRaw "target datalayout = \"e-m:o-i64:64-f80:128-n8:16:32:64-S128\"\n" + , UnsafeRaw "@.str = private unnamed_addr constant [3 x i8] c\"%i\n\", align 1\n" + , UnsafeRaw "declare i32 @printf(ptr noalias nocapture, ...)\n" + ] + +compileExp :: Exp -> CompilerState () +compileExp (ELit lit) = emitLit lit +compileExp (EAdd t e1 e2) = emitAdd t (fst e1) (fst e2) +--compileExp (ESub t e1 e2) = emitSub t e1 e2 +compileExp (EId (name, _)) = emitIdent name +compileExp (EApp t e1 e2) = emitApp t (fst e1) (fst e2) +--compileExp (EAbs t ti e) = emitAbs t ti e +compileExp (ELet _ binds e) = undefined emitLet binds (fst e) +compileExp (ECase t e cs) = emitECased t (fst e) (map (t,) cs) + -- go (EMul e1 e2) = emitMul e1 e2 + -- go (EDiv e1 e2) = emitDiv e1 e2 + -- go (EMod e1 e2) = emitMod e1 e2 + +--- aux functions --- +emitECased :: Type -> Exp -> [(Type, Injection)] -> CompilerState () +emitECased t e cases = do + let cs = snd <$> cases + let ty = type2LlvmType t + vs <- exprToValue e + lbl <- getNewLabel + let label = GA.Ident $ "escape_" <> show lbl + stackPtr <- getNewVar + emit $ SetVariable (GA.Ident $ show stackPtr) (Alloca ty) + mapM_ (emitCases ty label stackPtr vs) cs + emit $ Label label + res <- getNewVar + emit $ SetVariable (GA.Ident $ show res) (Load ty Ptr (GA.Ident $ show stackPtr)) + where + emitCases :: LLVMType -> GA.Ident -> Integer -> LLVMValue -> Injection -> CompilerState () + emitCases ty label stackPtr vs (Injection (MIR.CLit i) exp) = do + let i' = case i of + LInt i -> VInteger i + LChar i -> VChar i + ns <- getNewVar + lbl_failPos <- (\x -> GA.Ident $ "failed_" <> show x) <$> getNewLabel + lbl_succPos <- (\x -> GA.Ident $ "success_" <> show x) <$> getNewLabel + emit $ SetVariable (GA.Ident $ show ns) (Icmp LLEq ty vs i') + emit $ BrCond (VIdent (GA.Ident $ show ns) ty) lbl_succPos lbl_failPos + emit $ Label lbl_succPos + val <- exprToValue (fst exp) + emit $ Store ty val Ptr (GA.Ident . show $ stackPtr) + emit $ Br label + emit $ Label lbl_failPos + emitCases ty label stackPtr _ (Injection MIR.CatchAll exp) = do + val <- exprToValue (fst exp) + emit $ Store ty val Ptr (GA.Ident . show $ stackPtr) + emit $ Br label + + +emitAbs :: Type -> Id -> Exp -> CompilerState () +emitAbs _t tid e = do + emit . Comment $ + "Lambda escaped previous stages: \\" <> show tid <> " . " <> show e +emitLet :: Bind -> Exp -> CompilerState () +emitLet xs e = do + emit $ + Comment $ + concat + [ "ELet (" + , show xs + , " = " + , show e + , ") is not implemented!" + ] + +emitApp :: Type -> Exp -> Exp -> CompilerState () +emitApp t e1 e2 = appEmitter t e1 e2 [] + where + appEmitter :: Type -> Exp -> Exp -> [Exp] -> CompilerState () + appEmitter t e1 e2 stack = do + let newStack = e2 : stack + case e1 of + EApp _ (e1', _) (e2', _) -> appEmitter t e1' e2' newStack + EId id@(GA.Ident name,_ ) -> do + args <- traverse exprToValue newStack + vs <- getNewVar + funcs <- gets functions + let visibility = maybe Local (const Global) $ Map.lookup id funcs + args' = map (first valueGetType . dupe) args + call = Call FastCC (type2LlvmType t) visibility (GA.Ident name) args' + emit $ SetVariable (GA.Ident $ show vs) call + x -> do + emit . Comment $ "The unspeakable happened: " + emit . Comment $ show x + +emitIdent :: GA.Ident -> CompilerState () +emitIdent id = do + -- !!this should never happen!! + emit $ Comment "This should not have happened!" + emit $ Variable id + emit $ UnsafeRaw "\n" + +emitLit :: Lit -> CompilerState () +emitLit i = do + -- !!this should never happen!! + let (i',t) = case i of + (LInt i'') -> (VInteger i'',I64) + (LChar i'') -> (VChar i'', I8) + varCount <- getNewVar + emit $ Comment "This should not have happened!" + emit $ SetVariable (GA.Ident (show varCount)) (Add t i' (VInteger 0)) + + +emitAdd :: Type -> Exp -> Exp -> CompilerState () +emitAdd t e1 e2 = do + v1 <- exprToValue e1 + v2 <- exprToValue e2 + v <- getNewVar + emit $ SetVariable (GA.Ident $ show v) (Add (type2LlvmType t) v1 v2) + +emitSub :: Type -> Exp -> Exp -> CompilerState () +emitSub t e1 e2 = do + v1 <- exprToValue e1 + v2 <- exprToValue e2 + v <- getNewVar + emit $ SetVariable (GA.Ident $ show v) (Sub (type2LlvmType t) v1 v2) + + -- emitMul :: Exp -> Exp -> CompilerState () + -- emitMul e1 e2 = do + -- (v1,v2) <- binExprToValues e1 e2 + -- increaseVarCount + -- v <- gets variableCount + -- emit $ SetVariable $ GA.Ident $ show v + -- emit $ Mul I64 v1 v2 + + -- emitMod :: Exp -> Exp -> CompilerState () + -- emitMod e1 e2 = do + -- -- `let m a b = rem (abs $ b + a) b` + -- (v1,v2) <- binExprToValues e1 e2 + -- increaseVarCount + -- vadd <- gets variableCount + -- emit $ SetVariable $ GA.Ident $ show vadd + -- emit $ Add I64 v1 v2 + -- + -- increaseVarCount + -- vabs <- gets variableCount + -- emit $ SetVariable $ GA.Ident $ show vabs + -- emit $ Call I64 (GA.Ident "llvm.abs.i64") + -- [ (I64, VIdent (GA.Ident $ show vadd)) + -- , (I1, VInteger 1) + -- ] + -- increaseVarCount + -- v <- gets variableCount + -- emit $ SetVariable $ GA.Ident $ show v + -- emit $ Srem I64 (VIdent (GA.Ident $ show vabs)) v2 + + -- emitDiv :: Exp -> Exp -> CompilerState () + -- emitDiv e1 e2 = do + -- (v1,v2) <- binExprToValues e1 e2 + -- increaseVarCount + -- v <- gets variableCount + -- emit $ SetVariable $ GA.Ident $ show v + -- emit $ Div I64 v1 v2 + +exprToValue :: Exp -> CompilerState LLVMValue +exprToValue = \case + ELit i -> pure $ case i of + (LInt i) -> VInteger i + (LChar i) -> VChar i + EId id@(name, t) -> do + funcs <- gets functions + case Map.lookup id funcs of + Just fi -> do + if numArgs fi == 0 + then do + vc <- getNewVar + emit $ SetVariable (GA.Ident $ show vc) + (Call FastCC (type2LlvmType t) Global name []) + pure $ VIdent (GA.Ident $ show vc) (type2LlvmType t) + else pure $ VFunction name Global (type2LlvmType t) + Nothing -> pure $ VIdent name (type2LlvmType t) + e -> do + compileExp e + v <- getVarCount + pure $ VIdent (GA.Ident $ show v) (getType e) + +type2LlvmType :: Type -> LLVMType +type2LlvmType (MIR.Type (GA.Ident t)) = case t of + "_Int" -> I64 + t -> CustomType (GA.Ident t) + -- TInt -> I64 + -- TFun t xs -> do + -- let (t', xs') = function2LLVMType xs [type2LlvmType t] + -- Function t' xs' + -- TPol t -> CustomType t + --where + -- function2LLVMType :: Type -> [LLVMType] -> (LLVMType, [LLVMType]) + -- function2LLVMType (TFun t xs) s = function2LLVMType xs (type2LlvmType t : s) + -- function2LLVMType x s = (type2LlvmType x, s) + +getType :: Exp -> LLVMType +getType (ELit l) = I64 +getType (EAdd t _ _) = type2LlvmType t +--getType (ESub t _ _) = type2LlvmType t +getType (EId (_, t)) = type2LlvmType t +getType (EApp t _ _) = type2LlvmType t +--getType (EAbs t _ _) = type2LlvmType t +getType (ELet (_, t) _ e) = type2LlvmType t +getType (ECase t _ _) = type2LlvmType t + +valueGetType :: LLVMValue -> LLVMType +valueGetType (VInteger _) = I64 +valueGetType (VIdent _ t) = t +valueGetType (VConstant s) = Array (fromIntegral $ length s) I8 +valueGetType (VFunction _ _ t) = t + +typeByteSize :: LLVMType -> Integer +typeByteSize I1 = 1 +typeByteSize I8 = 1 +typeByteSize I32 = 4 +typeByteSize I64 = 8 +typeByteSize Ptr = 8 +typeByteSize (Ref _) = 8 +typeByteSize (Function _ _) = 8 +typeByteSize (Array n t) = n * typeByteSize t +typeByteSize (CustomType _) = 8 diff --git a/src/Codegen/LlvmIr.hs b/src/Codegen/LlvmIr.hs index 4a649c3..ab2ed90 100644 --- a/src/Codegen/LlvmIr.hs +++ b/src/Codegen/LlvmIr.hs @@ -1,241 +1,241 @@ -module Codegen.LlvmIr where --- {-# LANGUAGE LambdaCase #-} --- --- module Codegen.LlvmIr ( --- LLVMType (..), --- LLVMIr (..), --- llvmIrToString, --- LLVMValue (..), --- LLVMComp (..), --- Visibility (..), --- CallingConvention (..) --- ) where --- --- import Data.List (intercalate) --- import TypeChecker.TypeCheckerIr --- --- data CallingConvention = TailCC | FastCC | CCC | ColdCC --- instance Show CallingConvention where --- show :: CallingConvention -> String --- show TailCC = "tailcc" --- show FastCC = "fastcc" --- show CCC = "ccc" --- show ColdCC = "coldcc" --- --- -- | A datatype which represents some basic LLVM types --- data LLVMType --- = I1 --- | I8 --- | I32 --- | I64 --- | Ptr --- | Ref LLVMType --- | Function LLVMType [LLVMType] --- | Array Integer LLVMType --- | CustomType Ident --- --- instance Show LLVMType where --- show :: LLVMType -> String --- show = \case --- I1 -> "i1" --- I8 -> "i8" --- I32 -> "i32" --- I64 -> "i64" --- Ptr -> "ptr" --- Ref ty -> show ty <> "*" --- Function t xs -> show t <> " (" <> intercalate ", " (map show xs) <> ")*" --- Array n ty -> concat ["[", show n, " x ", show ty, "]"] --- CustomType (Ident ty) -> "%" <> ty --- --- data LLVMComp --- = LLEq --- | LLNe --- | LLUgt --- | LLUge --- | LLUlt --- | LLUle --- | LLSgt --- | LLSge --- | LLSlt --- | LLSle --- instance Show LLVMComp where --- show :: LLVMComp -> String --- show = \case --- LLEq -> "eq" --- LLNe -> "ne" --- LLUgt -> "ugt" --- LLUge -> "uge" --- LLUlt -> "ult" --- LLUle -> "ule" --- LLSgt -> "sgt" --- LLSge -> "sge" --- LLSlt -> "slt" --- LLSle -> "sle" --- --- data Visibility = Local | Global --- instance Show Visibility where --- show :: Visibility -> String --- show Local = "%" --- show Global = "@" --- --- -- | Represents a LLVM "value", as in an integer, a register variable, --- -- or a string contstant --- data LLVMValue --- = VInteger Integer --- | VIdent Ident LLVMType --- | VConstant String --- | VFunction Ident Visibility LLVMType --- --- instance Show LLVMValue where --- show :: LLVMValue -> String --- show v = case v of --- VInteger i -> show i --- VIdent (Ident n) _ -> "%" <> n --- VFunction (Ident n) vis _ -> show vis <> n --- VConstant s -> "c" <> show s --- --- type Params = [(Ident, LLVMType)] --- type Args = [(LLVMType, LLVMValue)] --- --- -- | A datatype which represents different instructions in LLVM --- data LLVMIr --- = Type Ident [LLVMType] --- | Define CallingConvention LLVMType Ident Params --- | DefineEnd --- | Declare LLVMType Ident Params --- | SetVariable Ident LLVMIr --- | Variable Ident --- | GetElementPtrInbounds LLVMType LLVMType LLVMValue LLVMType LLVMValue LLVMType LLVMValue --- | Add LLVMType LLVMValue LLVMValue --- | Sub LLVMType LLVMValue LLVMValue --- | Div LLVMType LLVMValue LLVMValue --- | Mul LLVMType LLVMValue LLVMValue --- | Srem LLVMType LLVMValue LLVMValue --- | Icmp LLVMComp LLVMType LLVMValue LLVMValue --- | Br Ident --- | BrCond LLVMValue Ident Ident --- | Label Ident --- | Call CallingConvention LLVMType Visibility Ident Args --- | Alloca LLVMType --- | Store LLVMType LLVMValue LLVMType Ident --- | Load LLVMType LLVMType Ident --- | Bitcast LLVMType Ident LLVMType --- | Ret LLVMType LLVMValue --- | Comment String --- | UnsafeRaw String -- This should generally be avoided, and proper --- -- instructions should be used in its place --- deriving (Show) --- --- -- | Converts a list of LLVMIr instructions to a string --- llvmIrToString :: [LLVMIr] -> String --- llvmIrToString = go 0 --- where --- go :: Int -> [LLVMIr] -> String --- go _ [] = mempty --- go i (x : xs) = do --- let (i', n) = case x of --- Define{} -> (i + 1, 0) --- DefineEnd -> (i - 1, 0) --- _ -> (i, i) --- insToString n x <> go i' xs --- --- {- | Converts a LLVM inststruction to a String, allowing for printing etc. --- The integer represents the indentation --- -} --- {- FOURMOLU_DISABLE -} --- insToString :: Int -> LLVMIr -> String --- insToString i l = --- replicate i '\t' <> case l of --- (GetElementPtrInbounds t1 t2 p t3 v1 t4 v2) -> do --- -- getelementptr inbounds %Foo, %Foo* %x, i32 0, i32 0 --- concat --- [ "getelementptr inbounds ", show t1, ", " , show t2 --- , " ", show p, ", ", show t3, " ", show v1, --- ", ", show t4, " ", show v2, "\n" ] --- (Type (Ident n) types) -> --- concat --- [ "%", n, " = type { " --- , intercalate ", " (map show types) --- , " }\n" --- ] --- (Define c t (Ident i) params) -> --- concat --- [ "define ", show c, " ", show t, " @", i --- , "(", intercalate ", " (map (\(Ident y, x) -> unwords [show x, "%" <> y]) params) --- , ") {\n" --- ] --- DefineEnd -> "}\n" --- (Declare _t (Ident _i) _params) -> undefined --- (SetVariable (Ident i) ir) -> concat ["%", i, " = ", insToString 0 ir] --- (Add t v1 v2) -> --- concat --- [ "add ", show t, " ", show v1 --- , ", ", show v2, "\n" --- ] --- (Sub t v1 v2) -> --- concat --- [ "sub ", show t, " ", show v1, ", " --- , show v2, "\n" --- ] --- (Div t v1 v2) -> --- concat --- [ "sdiv ", show t, " ", show v1, ", " --- , show v2, "\n" --- ] --- (Mul t v1 v2) -> --- concat --- [ "mul ", show t, " ", show v1 --- , ", ", show v2, "\n" --- ] --- (Srem t v1 v2) -> --- concat --- [ "srem ", show t, " ", show v1, ", " --- , show v2, "\n" --- ] --- (Call c t vis (Ident i) arg) -> --- concat --- [ "call ", show c, " ", show t, " ", show vis, i, "(" --- , intercalate ", " $ Prelude.map (\(x, y) -> show x <> " " <> show y) arg --- , ")\n" --- ] --- (Alloca t) -> unwords ["alloca", show t, "\n"] --- (Store t1 val t2 (Ident id2)) -> --- concat --- [ "store ", show t1, " ", show val --- , ", ", show t2 , " %", id2, "\n" --- ] --- (Load t1 t2 (Ident addr)) -> --- concat --- [ "load ", show t1, ", " --- , show t2, " %", addr, "\n" --- ] --- (Bitcast t1 (Ident i) t2) -> --- concat --- [ "bitcast ", show t1, " %" --- , i, " to ", show t2, "\n" --- ] --- (Icmp comp t v1 v2) -> --- concat --- [ "icmp ", show comp, " ", show t --- , " ", show v1, ", ", show v2, "\n" --- ] --- (Ret t v) -> --- concat --- [ "ret ", show t, " " --- , show v, "\n" --- ] --- (UnsafeRaw s) -> s --- (Label (Ident s)) -> "\n" <> lblPfx <> s <> ":\n" --- (Br (Ident s)) -> "br label %" <> lblPfx <> s <> "\n" --- (BrCond val (Ident s1) (Ident s2)) -> --- concat --- [ "br i1 ", show val, ", ", "label %" --- , lblPfx, s1, ", ", "label %", lblPfx, s2, "\n" --- ] --- (Comment s) -> "; " <> s <> "\n" --- (Variable (Ident id)) -> "%" <> id --- {- FOURMOLU_ENABLE -} --- --- lblPfx :: String --- lblPfx = "lbl_" --- +{-# LANGUAGE LambdaCase #-} + +module Codegen.LlvmIr ( + LLVMType (..), + LLVMIr (..), + llvmIrToString, + LLVMValue (..), + LLVMComp (..), + Visibility (..), + CallingConvention (..) +) where + +import Data.List (intercalate) +import Grammar.Abs (Ident (..)) + +data CallingConvention = TailCC | FastCC | CCC | ColdCC +instance Show CallingConvention where + show :: CallingConvention -> String + show TailCC = "tailcc" + show FastCC = "fastcc" + show CCC = "ccc" + show ColdCC = "coldcc" + +-- | A datatype which represents some basic LLVM types +data LLVMType + = I1 + | I8 + | I32 + | I64 + | Ptr + | Ref LLVMType + | Function LLVMType [LLVMType] + | Array Integer LLVMType + | CustomType Ident + +instance Show LLVMType where + show :: LLVMType -> String + show = \case + I1 -> "i1" + I8 -> "i8" + I32 -> "i32" + I64 -> "i64" + Ptr -> "ptr" + Ref ty -> show ty <> "*" + Function t xs -> show t <> " (" <> intercalate ", " (map show xs) <> ")*" + Array n ty -> concat ["[", show n, " x ", show ty, "]"] + CustomType (Ident ty) -> "%" <> ty + +data LLVMComp + = LLEq + | LLNe + | LLUgt + | LLUge + | LLUlt + | LLUle + | LLSgt + | LLSge + | LLSlt + | LLSle +instance Show LLVMComp where + show :: LLVMComp -> String + show = \case + LLEq -> "eq" + LLNe -> "ne" + LLUgt -> "ugt" + LLUge -> "uge" + LLUlt -> "ult" + LLUle -> "ule" + LLSgt -> "sgt" + LLSge -> "sge" + LLSlt -> "slt" + LLSle -> "sle" + +data Visibility = Local | Global +instance Show Visibility where + show :: Visibility -> String + show Local = "%" + show Global = "@" + +-- | Represents a LLVM "value", as in an integer, a register variable, +-- or a string contstant +data LLVMValue + = VInteger Integer + | VChar Char + | VIdent Ident LLVMType + | VConstant String + | VFunction Ident Visibility LLVMType + +instance Show LLVMValue where + show :: LLVMValue -> String + show v = case v of + VInteger i -> show i + VChar i -> show i + VIdent (Ident n) _ -> "%" <> n + VFunction (Ident n) vis _ -> show vis <> n + VConstant s -> "c" <> show s + +type Params = [(Ident, LLVMType)] +type Args = [(LLVMType, LLVMValue)] + +-- | A datatype which represents different instructions in LLVM +data LLVMIr + = Type Ident [LLVMType] + | Define CallingConvention LLVMType Ident Params + | DefineEnd + | Declare LLVMType Ident Params + | SetVariable Ident LLVMIr + | Variable Ident + | GetElementPtrInbounds LLVMType LLVMType LLVMValue LLVMType LLVMValue LLVMType LLVMValue + | Add LLVMType LLVMValue LLVMValue + | Sub LLVMType LLVMValue LLVMValue + | Div LLVMType LLVMValue LLVMValue + | Mul LLVMType LLVMValue LLVMValue + | Srem LLVMType LLVMValue LLVMValue + | Icmp LLVMComp LLVMType LLVMValue LLVMValue + | Br Ident + | BrCond LLVMValue Ident Ident + | Label Ident + | Call CallingConvention LLVMType Visibility Ident Args + | Alloca LLVMType + | Store LLVMType LLVMValue LLVMType Ident + | Load LLVMType LLVMType Ident + | Bitcast LLVMType Ident LLVMType + | Ret LLVMType LLVMValue + | Comment String + | UnsafeRaw String -- This should generally be avoided, and proper + -- instructions should be used in its place + deriving (Show) + +-- | Converts a list of LLVMIr instructions to a string +llvmIrToString :: [LLVMIr] -> String +llvmIrToString = go 0 + where + go :: Int -> [LLVMIr] -> String + go _ [] = mempty + go i (x : xs) = do + let (i', n) = case x of + Define{} -> (i + 1, 0) + DefineEnd -> (i - 1, 0) + _ -> (i, i) + insToString n x <> go i' xs + {- | Converts a LLVM inststruction to a String, allowing for printing etc. + The integer represents the indentation + -} + {- FOURMOLU_DISABLE -} + insToString :: Int -> LLVMIr -> String + insToString i l = + replicate i '\t' <> case l of + (GetElementPtrInbounds t1 t2 p t3 v1 t4 v2) -> do + -- getelementptr inbounds %Foo, %Foo* %x, i32 0, i32 0 + concat + [ "getelementptr inbounds ", show t1, ", " , show t2 + , " ", show p, ", ", show t3, " ", show v1, + ", ", show t4, " ", show v2, "\n" ] + (Type (Ident n) types) -> + concat + [ "%", n, " = type { " + , intercalate ", " (map show types) + , " }\n" + ] + (Define c t (Ident i) params) -> + concat + [ "define ", show c, " ", show t, " @", i + , "(", intercalate ", " (map (\(Ident y, x) -> unwords [show x, "%" <> y]) params) + , ") {\n" + ] + DefineEnd -> "}\n" + (Declare _t (Ident _i) _params) -> undefined + (SetVariable (Ident i) ir) -> concat ["%", i, " = ", insToString 0 ir] + (Add t v1 v2) -> + concat + [ "add ", show t, " ", show v1 + , ", ", show v2, "\n" + ] + (Sub t v1 v2) -> + concat + [ "sub ", show t, " ", show v1, ", " + , show v2, "\n" + ] + (Div t v1 v2) -> + concat + [ "sdiv ", show t, " ", show v1, ", " + , show v2, "\n" + ] + (Mul t v1 v2) -> + concat + [ "mul ", show t, " ", show v1 + , ", ", show v2, "\n" + ] + (Srem t v1 v2) -> + concat + [ "srem ", show t, " ", show v1, ", " + , show v2, "\n" + ] + (Call c t vis (Ident i) arg) -> + concat + [ "call ", show c, " ", show t, " ", show vis, i, "(" + , intercalate ", " $ Prelude.map (\(x, y) -> show x <> " " <> show y) arg + , ")\n" + ] + (Alloca t) -> unwords ["alloca", show t, "\n"] + (Store t1 val t2 (Ident id2)) -> + concat + [ "store ", show t1, " ", show val + , ", ", show t2 , " %", id2, "\n" + ] + (Load t1 t2 (Ident addr)) -> + concat + [ "load ", show t1, ", " + , show t2, " %", addr, "\n" + ] + (Bitcast t1 (Ident i) t2) -> + concat + [ "bitcast ", show t1, " %" + , i, " to ", show t2, "\n" + ] + (Icmp comp t v1 v2) -> + concat + [ "icmp ", show comp, " ", show t + , " ", show v1, ", ", show v2, "\n" + ] + (Ret t v) -> + concat + [ "ret ", show t, " " + , show v, "\n" + ] + (UnsafeRaw s) -> s + (Label (Ident s)) -> "\n" <> lblPfx <> s <> ":\n" + (Br (Ident s)) -> "br label %" <> lblPfx <> s <> "\n" + (BrCond val (Ident s1) (Ident s2)) -> + concat + [ "br i1 ", show val, ", ", "label %" + , lblPfx, s1, ", ", "label %", lblPfx, s2, "\n" + ] + (Comment s) -> "; " <> s <> "\n" + (Variable (Ident id)) -> "%" <> id +{- FOURMOLU_ENABLE -} + +lblPfx :: String +lblPfx = "lbl_" + diff --git a/src/Monomorphizer/Monomorphizer.hs b/src/Monomorphizer/Monomorphizer.hs new file mode 100644 index 0000000..58a0abc --- /dev/null +++ b/src/Monomorphizer/Monomorphizer.hs @@ -0,0 +1 @@ +module Monomorphizer.Monomorphizer where diff --git a/src/Monomorphizer/MonomorphizerIr.hs b/src/Monomorphizer/MonomorphizerIr.hs new file mode 100644 index 0000000..5bcd5f0 --- /dev/null +++ b/src/Monomorphizer/MonomorphizerIr.hs @@ -0,0 +1,36 @@ +module Monomorphizer.MonomorphizerIr where +import Grammar.Abs (Ident) + +newtype Program = Program [Bind] + deriving (Show, Ord, Eq) + +data Bind = Bind Id [Id] ExpT | DataType Ident [Constructor] + deriving (Show, Ord, Eq) + +data Exp + = EId Id + | ELit Lit + | ELet Id ExpT ExpT + | EApp Type ExpT ExpT + | EAdd Type ExpT ExpT + | ECase Type ExpT [Injection] + deriving (Show, Ord, Eq) + +data Injection = Injection Case ExpT + deriving (Show, Ord, Eq) + +data Case = CLit Lit | CatchAll + deriving (Show, Ord, Eq) + +data Constructor = Constructor Ident [Type] + deriving (Show, Ord, Eq) + +type Id = (Ident, Type) +type ExpT = (Exp, Type) + +data Lit = LInt Integer + | LChar Char + deriving (Show, Ord, Eq) + +newtype Type = Type Ident + deriving (Show, Ord, Eq) From 91816abfe6f1103347329ae454d82f1df5577725 Mon Sep 17 00:00:00 2001 From: Samuel Hammersberg Date: Tue, 21 Mar 2023 10:11:02 +0100 Subject: [PATCH 090/372] Constructors are now seen as global functions. --- src/Codegen/Codegen.hs | 61 +++++++++++------------------------------- 1 file changed, 15 insertions(+), 46 deletions(-) diff --git a/src/Codegen/Codegen.hs b/src/Codegen/Codegen.hs index b67f0c5..e5c6f07 100644 --- a/src/Codegen/Codegen.hs +++ b/src/Codegen/Codegen.hs @@ -8,6 +8,7 @@ import Codegen.LlvmIr (CallingConvention (..), LLVMType (..), LLVMValue (..), Visibility (..), llvmIrToString) import Codegen.LlvmIr as LIR +import Control.Applicative ((<|>)) import Control.Monad.State (StateT, execStateT, foldM_, gets, modify) import qualified Data.Bifunctor as BI @@ -136,6 +137,7 @@ generateCode (Program scs) = do compileScs :: [Bind] -> CompilerState () compileScs [] = do -- as a last step create all the constructors + -- //TODO maybe merge this with the data type match? c <- gets (Map.toList . constructors) mapM_ (\((id, t), ci) -> do let t' = type2LlvmType t @@ -208,7 +210,12 @@ compileScs (DataType id@(GA.Ident outer_id) ts : xs) = do mainContent :: LLVMValue -> [LLVMIr] mainContent var = [ UnsafeRaw $ - "call i32 (ptr, ...) @printf(ptr noundef @.str, i64 noundef " <> show var <> ")\n" + "%2 = alloca %Craig\n" <> + " store %Craig %1, ptr %2\n" <> + " %3 = bitcast %Craig* %2 to i64*\n" <> + " %4 = load i64, ptr %3\n" <> + " call i32 (ptr, ...) @printf(ptr noundef @.str, i64 noundef %4)\n" + -- "call i32 (ptr, ...) @printf(ptr noundef @.str, i64 noundef " <> show var <> ")\n" , -- , SetVariable (GA.Ident "p") (Icmp LLEq I64 (VInteger 2) (VInteger 2)) -- , BrCond (VIdent (GA.Ident "p")) (GA.Ident "b_1") (GA.Ident "b_2") -- , Label (GA.Ident "b_1") @@ -279,10 +286,6 @@ emitECased t e cases = do emit $ Br label -emitAbs :: Type -> Id -> Exp -> CompilerState () -emitAbs _t tid e = do - emit . Comment $ - "Lambda escaped previous stages: \\" <> show tid <> " . " <> show e emitLet :: Bind -> Exp -> CompilerState () emitLet xs e = do emit $ @@ -307,13 +310,16 @@ emitApp t e1 e2 = appEmitter t e1 e2 [] args <- traverse exprToValue newStack vs <- getNewVar funcs <- gets functions - let visibility = maybe Local (const Global) $ Map.lookup id funcs + consts <- gets constructors + let visibility = maybe Local (const Global) $ + const Global <$ Map.lookup id consts + <|> + const Global <$ Map.lookup id funcs + -- this piece of code could probably be improved, i.e remove the double `const Global` args' = map (first valueGetType . dupe) args call = Call FastCC (type2LlvmType t) visibility (GA.Ident name) args' emit $ SetVariable (GA.Ident $ show vs) call - x -> do - emit . Comment $ "The unspeakable happened: " - emit . Comment $ show x + x -> error $ "The unspeakable happened: " <> show x emitIdent :: GA.Ident -> CompilerState () emitIdent id = do @@ -347,43 +353,6 @@ emitSub t e1 e2 = do v <- getNewVar emit $ SetVariable (GA.Ident $ show v) (Sub (type2LlvmType t) v1 v2) - -- emitMul :: Exp -> Exp -> CompilerState () - -- emitMul e1 e2 = do - -- (v1,v2) <- binExprToValues e1 e2 - -- increaseVarCount - -- v <- gets variableCount - -- emit $ SetVariable $ GA.Ident $ show v - -- emit $ Mul I64 v1 v2 - - -- emitMod :: Exp -> Exp -> CompilerState () - -- emitMod e1 e2 = do - -- -- `let m a b = rem (abs $ b + a) b` - -- (v1,v2) <- binExprToValues e1 e2 - -- increaseVarCount - -- vadd <- gets variableCount - -- emit $ SetVariable $ GA.Ident $ show vadd - -- emit $ Add I64 v1 v2 - -- - -- increaseVarCount - -- vabs <- gets variableCount - -- emit $ SetVariable $ GA.Ident $ show vabs - -- emit $ Call I64 (GA.Ident "llvm.abs.i64") - -- [ (I64, VIdent (GA.Ident $ show vadd)) - -- , (I1, VInteger 1) - -- ] - -- increaseVarCount - -- v <- gets variableCount - -- emit $ SetVariable $ GA.Ident $ show v - -- emit $ Srem I64 (VIdent (GA.Ident $ show vabs)) v2 - - -- emitDiv :: Exp -> Exp -> CompilerState () - -- emitDiv e1 e2 = do - -- (v1,v2) <- binExprToValues e1 e2 - -- increaseVarCount - -- v <- gets variableCount - -- emit $ SetVariable $ GA.Ident $ show v - -- emit $ Div I64 v1 v2 - exprToValue :: Exp -> CompilerState LLVMValue exprToValue = \case ELit i -> pure $ case i of From ae34c494f5c333fc4c5f76a09956863122bbcb04 Mon Sep 17 00:00:00 2001 From: Samuel Hammersberg Date: Tue, 21 Mar 2023 10:14:00 +0100 Subject: [PATCH 091/372] Improved the visibility checkup a little bit. --- src/Codegen/Codegen.hs | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/src/Codegen/Codegen.hs b/src/Codegen/Codegen.hs index e5c6f07..750ae5d 100644 --- a/src/Codegen/Codegen.hs +++ b/src/Codegen/Codegen.hs @@ -15,6 +15,7 @@ import qualified Data.Bifunctor as BI import Data.List.Extra (trim) import Data.Map (Map) import qualified Data.Map as Map +import Data.Maybe (fromMaybe) import Data.Tuple.Extra (dupe, first, second) import qualified Grammar.Abs as GA import Grammar.ErrM (Err) @@ -311,10 +312,10 @@ emitApp t e1 e2 = appEmitter t e1 e2 [] vs <- getNewVar funcs <- gets functions consts <- gets constructors - let visibility = maybe Local (const Global) $ - const Global <$ Map.lookup id consts + let visibility = fromMaybe Local $ + Global <$ Map.lookup id consts <|> - const Global <$ Map.lookup id funcs + Global <$ Map.lookup id funcs -- this piece of code could probably be improved, i.e remove the double `const Global` args' = map (first valueGetType . dupe) args call = Call FastCC (type2LlvmType t) visibility (GA.Ident name) args' From 4c015a4aac7e184c0d3342ed9fddf4d2ac32f558 Mon Sep 17 00:00:00 2001 From: sebastian Date: Tue, 21 Mar 2023 14:33:18 +0100 Subject: [PATCH 092/372] initial pattern matching implementation. should be somewhat correct --- src/TypeChecker/TypeChecker.hs | 47 +++++++++++++++----------------- src/TypeChecker/TypeCheckerIr.hs | 3 +- test_program | 10 +++++-- 3 files changed, 32 insertions(+), 28 deletions(-) diff --git a/src/TypeChecker/TypeChecker.hs b/src/TypeChecker/TypeChecker.hs index ec7b005..af62451 100644 --- a/src/TypeChecker/TypeChecker.hs +++ b/src/TypeChecker/TypeChecker.hs @@ -118,11 +118,10 @@ checkPrg (Program bs) = do d' <- freshenData d fmap (T.DData d' :) (checkDef xs) --- TODO: Unify top level types with the types of the expressions beneath --- PERHAPS DONE checkBind :: Bind -> Infer T.Bind checkBind (Bind n t _ args e) = do - (t', e) <- inferExp $ makeLambda e (reverse args) + let lambda = makeLambda e (reverse args) + (t', e) <- inferExp lambda s <- unify t' t let t'' = apply s t unless @@ -296,10 +295,11 @@ algoW = \case -- TODO: give caseExpr a concrete type before proceeding -- probably by returning substitutions in the functions used in this body ECase caseExpr injs -> do - (sub, _, e') <- algoW caseExpr - trace ("SUB: " ++ show sub) return () - t <- checkCase caseExpr injs - return (sub, t, T.ECase t e' (map (\(Inj i _) -> T.Inj (i, t) e') injs)) + (sub, t, e') <- algoW caseExpr + (subst, t) <- checkCase t injs + let composition = subst `compose` sub + let t' = apply composition t + return (composition, t', T.ECase t' e' (map (\(Inj i _) -> T.Inj (i, t') e') injs)) -- | Unify two types producing a new substitution unify :: Type -> Type -> Infer Subst @@ -328,12 +328,18 @@ unify t0 t1 = do , printTree name' , "(" ++ printTree t' ++ ")" ] - (a, b) -> + (a, b) -> do + ctx <- ask + env <- get throwError . unwords $ [ "Type:" , printTree a , "can't be unified with:" , printTree b + , "\nCtx:" + , show ctx + , "\nEnv:" + , show env ] {- | Check if a type is contained in another type. @@ -464,23 +470,12 @@ insertConstr i t = -------- PATTERN MATCHING --------- -unifyAll :: [Type] -> Infer [Subst] -unifyAll [] = return [] -unifyAll [_] = return [] -unifyAll (x : y : xs) = do - uni <- unify x y - all <- unifyAll (y : xs) - return $ uni : all - -checkCase :: Exp -> [Inj] -> Infer Type -checkCase e injs = do - expT <- fst <$> inferExp e - (injTs, returns) <- mapAndUnzipM checkInj injs - unifyAll (expT : injTs) - subst <- foldl1 compose <$> zipWithM unify returns (tail returns) - let substed = map (apply subst) returns - unless (allSame substed || null substed) (throwError "Different return types of case, or no cases") - return $ head substed +checkCase :: Type -> [Inj] -> Infer (Subst, Type) +checkCase expT injs = do + (injs, returns) <- mapAndUnzipM checkInj injs + (sub, _) <- foldM (\(sub, acc) x -> (\a -> (a `compose` sub, (a `apply` acc))) <$> unify x acc) (nullSubst, expT) injs + t <- foldM (\acc x -> (`apply` acc) <$> unify x acc) (head returns) (tail returns) + return (sub, t) {- | fst = type of init | snd = type of expr @@ -510,3 +505,5 @@ flattenType a = [a] litType :: Literal -> Type litType (LInt _) = TMono "Int" + +ctrace a = trace (show a) a diff --git a/src/TypeChecker/TypeCheckerIr.hs b/src/TypeChecker/TypeCheckerIr.hs index 475201e..016dd8a 100644 --- a/src/TypeChecker/TypeCheckerIr.hs +++ b/src/TypeChecker/TypeCheckerIr.hs @@ -23,12 +23,13 @@ data Poly = Forall [Ident] Type deriving (Show) newtype Ctx = Ctx {vars :: Map Ident Poly} + deriving Show data Env = Env { count :: Int , sigs :: Map Ident Type , constructors :: Map Ident Type - } + } deriving Show type Error = String type Subst = Map Ident Type diff --git a/test_program b/test_program index a8accca..2d6fed1 100644 --- a/test_program +++ b/test_program @@ -3,7 +3,13 @@ data Bool () where { False : Bool () }; -main : Bool () -> _Int ; +data Maybe ('a) where { + Nothing : Maybe ('a) + Just : 'a -> Maybe ('a) +}; + +main : Bool () -> Maybe (Bool ()) ; main x = case x of { - 1 => 0 + True => Nothing; + False => Just 0 } From 3026a96eb7e215ccdda1dd1fbc6d0ecf13d583d7 Mon Sep 17 00:00:00 2001 From: sebastian Date: Tue, 21 Mar 2023 14:51:06 +0100 Subject: [PATCH 093/372] added todo for class --- src/TypeChecker/TypeChecker.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/TypeChecker/TypeChecker.hs b/src/TypeChecker/TypeChecker.hs index af62451..d909e49 100644 --- a/src/TypeChecker/TypeChecker.hs +++ b/src/TypeChecker/TypeChecker.hs @@ -377,6 +377,9 @@ inst (Forall xs t) = do compose :: Subst -> Subst -> Subst compose m1 m2 = M.map (apply m1) m2 `M.union` m1 +-- TODO: Split this class into two separate classes, one for free variables +-- and one for applying substitutions + -- | A class representing free variables functions class FreeVars t where -- | Get all free variables from t From 71d07ebf0fbcb97377882eff6f1bdc0ac00a41ad Mon Sep 17 00:00:00 2001 From: Rakarake Date: Tue, 21 Mar 2023 15:59:47 +0100 Subject: [PATCH 094/372] 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 509de4415e967af55f3bbc349080cfe34d45016e Mon Sep 17 00:00:00 2001 From: sebastianselander Date: Tue, 21 Mar 2023 17:09:03 +0100 Subject: [PATCH 095/372] progress on fixing bugs --- src/TypeChecker/TypeChecker.hs | 51 +++++++++++++++++++++------------- test_program | 27 ++++++++++++------ 2 files changed, 49 insertions(+), 29 deletions(-) diff --git a/src/TypeChecker/TypeChecker.hs b/src/TypeChecker/TypeChecker.hs index d909e49..7e59793 100644 --- a/src/TypeChecker/TypeChecker.hs +++ b/src/TypeChecker/TypeChecker.hs @@ -7,17 +7,16 @@ module TypeChecker.TypeChecker where import Control.Monad.Except import Control.Monad.Reader import Control.Monad.State +import Data.Bifunctor (second) import Data.Foldable (traverse_) -import Data.Function (on) import Data.Functor.Identity (runIdentity) import Data.List (foldl') -import Data.List.Extra (allSame) +import Data.List.Extra (unsnoc) import Data.Map (Map) import Data.Map qualified as M import Data.Maybe (fromMaybe) import Data.Set (Set) import Data.Set qualified as S -import Data.Tree (flatten) import Debug.Trace (trace) import Grammar.Abs import Grammar.Print (printTree) @@ -296,10 +295,13 @@ algoW = \case -- probably by returning substitutions in the functions used in this body ECase caseExpr injs -> do (sub, t, e') <- algoW caseExpr - (subst, t) <- checkCase t injs + (subst, inj_t, ret_t) <- checkCase t injs let composition = subst `compose` sub let t' = apply composition t - return (composition, t', T.ECase t' e' (map (\(Inj i _) -> T.Inj (i, t') e') injs)) + trace ("COMPOSITION: " ++ show composition) return () + trace ("T: " ++ show t) return () + trace ("T': " ++ show t') return () + return (composition, t', T.ECase t' e' (map (\(Inj i _) -> T.Inj (i, inj_t) e') injs)) -- | Unify two types producing a new substitution unify :: Type -> Type -> Infer Subst @@ -337,7 +339,7 @@ unify t0 t1 = do , "can't be unified with:" , printTree b , "\nCtx:" - , show ctx + , show ctx , "\nEnv:" , show env ] @@ -462,6 +464,10 @@ fresh = do withBinding :: (Monad m, MonadReader Ctx m) => Ident -> Poly -> m a -> m a withBinding i p = local (\st -> st{vars = M.insert i p (vars st)}) +-- | Run the monadic action with several additional bindings +withBindings :: (Monad m, MonadReader Ctx m) => [(Ident, Poly)] -> m a -> m a +withBindings xs = local (\st -> st{vars = foldl' (flip (uncurry M.insert)) (vars st) xs}) + -- | Insert a function signature into the environment insertSig :: Ident -> Type -> Infer () insertSig i t = modify (\st -> st{sigs = M.insert i t (sigs st)}) @@ -473,34 +479,39 @@ insertConstr i t = -------- PATTERN MATCHING --------- -checkCase :: Type -> [Inj] -> Infer (Subst, Type) +checkCase :: Type -> [Inj] -> Infer (Subst, Type, Type) checkCase expT injs = do (injs, returns) <- mapAndUnzipM checkInj injs - (sub, _) <- foldM (\(sub, acc) x -> (\a -> (a `compose` sub, (a `apply` acc))) <$> unify x acc) (nullSubst, expT) injs - t <- foldM (\acc x -> (`apply` acc) <$> unify x acc) (head returns) (tail returns) - return (sub, t) + (sub, injs_type) <- foldM (\(sub, acc) x -> (\a -> (a `compose` sub, a `apply` acc)) <$> unify x acc) (nullSubst, expT) injs + (_, returns_type) <- foldM (\(sub, acc) x -> (\a -> (a `compose` sub, a `apply` acc)) <$> unify x acc) (nullSubst, head returns) (tail returns) + return (sub, injs_type, returns_type) {- | fst = type of init -| snd = type of expr + | snd = type of expr -} checkInj :: Inj -> Infer (Type, Type) checkInj (Inj it expr) = do - initT <- inferInit it - (exprT, _) <- inferExp expr + (initT, vars) <- inferInit it + let converted = map (second (Forall [])) vars + (exprT, _) <- withBindings converted (inferExp expr) return (initT, exprT) -inferInit :: Init -> Infer Type +inferInit :: Init -> Infer (Type, [T.Id]) inferInit = \case - InitLit lit -> return $ litType lit + InitLit lit -> return (litType lit, mempty) InitConstr fn vars -> do gets (M.lookup fn . constructors) >>= \case Nothing -> throwError $ "Constructor: " ++ printTree fn ++ " does not exist" Just a -> do - let ft = init $ flattenType a - case compare (length vars) (length ft) of - EQ -> return . last $ flattenType a - _ -> throwError "Partial pattern match not allowed" - InitCatch -> fresh + case unsnoc $ flattenType a of + Nothing -> throwError "Partial pattern match not allowed" + Just (vs, ret) -> + case length vars `compare` length vs of + EQ -> do + trace ("IDS AND TYPES: " ++ show (zip vars vs)) return () + return (ret, zip vars vs) + _ -> throwError "Partial pattern match not allowed" + InitCatch -> (,mempty) <$> fresh flattenType :: Type -> [Type] flattenType (TArr a b) = flattenType a ++ flattenType b diff --git a/test_program b/test_program index 2d6fed1..e420e37 100644 --- a/test_program +++ b/test_program @@ -1,15 +1,24 @@ -data Bool () where { - True : Bool () - False : Bool () -}; +-- data Bool () where { +-- True : Bool () +-- False : Bool () +-- }; data Maybe ('a) where { Nothing : Maybe ('a) Just : 'a -> Maybe ('a) }; -main : Bool () -> Maybe (Bool ()) ; -main x = case x of { - True => Nothing; - False => Just 0 -} +-- main : Bool () -> Maybe (Bool ()) ; +-- main x = +-- case x of { +-- True => Nothing; +-- False => Just True +-- }; + +fun : Maybe (_Int) -> _Int ; +fun a = + case a of { + Just b => b; + Nothing => 0 + }; + From 8f151b7531eafdf69f25aa6a8abb110068672054 Mon Sep 17 00:00:00 2001 From: Rakarake Date: Tue, 21 Mar 2023 17:15:15 +0100 Subject: [PATCH 096/372] 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 57fe8cd0a69cd7594506029bc859152d7011f455 Mon Sep 17 00:00:00 2001 From: sebastian Date: Tue, 21 Mar 2023 22:02:28 +0100 Subject: [PATCH 097/372] Fixed larger bug where pattern matching on `Just a` with type `Maybe b` could be used for any type. --- src/TypeChecker/TypeChecker.hs | 33 ++++++++++++--------------------- test_program | 5 ++--- 2 files changed, 14 insertions(+), 24 deletions(-) diff --git a/src/TypeChecker/TypeChecker.hs b/src/TypeChecker/TypeChecker.hs index 7e59793..ee01952 100644 --- a/src/TypeChecker/TypeChecker.hs +++ b/src/TypeChecker/TypeChecker.hs @@ -290,18 +290,12 @@ algoW = \case (s2, t2, e1') <- algoW e1 let composition = s2 `compose` s1 return (composition, t2, apply composition $ T.ELet (T.Bind (name, t2) e0') e1') - - -- TODO: give caseExpr a concrete type before proceeding - -- probably by returning substitutions in the functions used in this body ECase caseExpr injs -> do (sub, t, e') <- algoW caseExpr - (subst, inj_t, ret_t) <- checkCase t injs + (subst, injs, ret_t) <- checkCase t injs let composition = subst `compose` sub - let t' = apply composition t - trace ("COMPOSITION: " ++ show composition) return () - trace ("T: " ++ show t) return () - trace ("T': " ++ show t') return () - return (composition, t', T.ECase t' e' (map (\(Inj i _) -> T.Inj (i, inj_t) e') injs)) + let t' = apply composition ret_t + return (composition, t', T.ECase t' e' injs) -- | Unify two types producing a new substitution unify :: Type -> Type -> Infer Subst @@ -349,7 +343,7 @@ I.E. { a = a -> b } is an unsolvable constraint since there is no substitution where these are equal -} occurs :: Ident -> Type -> Infer Subst -occurs i t@(TPol a) = return (M.singleton i t) +occurs i t@(TPol _) = return (M.singleton i t) occurs i t = if S.member i (free t) then @@ -479,22 +473,22 @@ insertConstr i t = -------- PATTERN MATCHING --------- -checkCase :: Type -> [Inj] -> Infer (Subst, Type, Type) +checkCase :: Type -> [Inj] -> Infer (Subst, [T.Inj], Type) checkCase expT injs = do - (injs, returns) <- mapAndUnzipM checkInj injs - (sub, injs_type) <- foldM (\(sub, acc) x -> (\a -> (a `compose` sub, a `apply` acc)) <$> unify x acc) (nullSubst, expT) injs - (_, returns_type) <- foldM (\(sub, acc) x -> (\a -> (a `compose` sub, a `apply` acc)) <$> unify x acc) (nullSubst, head returns) (tail returns) - return (sub, injs_type, returns_type) + (injTs, injs, returns) <- unzip3 <$> mapM checkInj injs + (sub1, _) <- foldM (\(sub, acc) x -> (\a -> (a `compose` sub, a `apply` acc)) <$> unify x acc) (nullSubst, expT) injTs + (sub2, returns_type) <- foldM (\(sub, acc) x -> (\a -> (a `compose` sub, a `apply` acc)) <$> unify x acc) (nullSubst, head returns) (tail returns) + return (sub2 `compose` sub1, injs, returns_type) {- | fst = type of init | snd = type of expr -} -checkInj :: Inj -> Infer (Type, Type) +checkInj :: Inj -> Infer (Type, T.Inj, Type) checkInj (Inj it expr) = do (initT, vars) <- inferInit it let converted = map (second (Forall [])) vars - (exprT, _) <- withBindings converted (inferExp expr) - return (initT, exprT) + (exprT, e) <- withBindings converted (inferExp expr) + return (initT, T.Inj (it, initT) e, exprT) inferInit :: Init -> Infer (Type, [T.Id]) inferInit = \case @@ -508,7 +502,6 @@ inferInit = \case Just (vs, ret) -> case length vars `compare` length vs of EQ -> do - trace ("IDS AND TYPES: " ++ show (zip vars vs)) return () return (ret, zip vars vs) _ -> throwError "Partial pattern match not allowed" InitCatch -> (,mempty) <$> fresh @@ -519,5 +512,3 @@ flattenType a = [a] litType :: Literal -> Type litType (LInt _) = TMono "Int" - -ctrace a = trace (show a) a diff --git a/test_program b/test_program index e420e37..bc463fe 100644 --- a/test_program +++ b/test_program @@ -15,10 +15,9 @@ data Maybe ('a) where { -- False => Just True -- }; -fun : Maybe (_Int) -> _Int ; +fun : Maybe ('a) -> 'a ; fun a = case a of { - Just b => b; - Nothing => 0 + Just c => c }; From 33b69a1895715e5d0d949c53df487ff65c6cf0de Mon Sep 17 00:00:00 2001 From: sebastian Date: Tue, 21 Mar 2023 22:07:21 +0100 Subject: [PATCH 098/372] Improved formatting --- src/TypeChecker/TypeChecker.hs | 78 +++++++++++++++++++++++----------- 1 file changed, 54 insertions(+), 24 deletions(-) diff --git a/src/TypeChecker/TypeChecker.hs b/src/TypeChecker/TypeChecker.hs index ee01952..1339212 100644 --- a/src/TypeChecker/TypeChecker.hs +++ b/src/TypeChecker/TypeChecker.hs @@ -54,7 +54,15 @@ freshenData (Data (Constr name ts) constrs) = do let xs = (S.toList . free) =<< ts frs <- traverse (const fresh) xs let m = M.fromList $ zip xs frs - return $ Data (Constr name (map (freshenType m) ts)) (map (\(Constructor ident t) -> Constructor ident (freshenType m t)) constrs) + return $ + Data + (Constr name (map (freshenType m) ts)) + ( map + ( \(Constructor ident t) -> + Constructor ident (freshenType m t) + ) + constrs + ) {- | Freshen all polymorphic variables, regardless of name | freshenType "d" (a -> b -> c) becomes (d -> d -> d) @@ -199,8 +207,8 @@ algoW = \case ) applySt s1 $ do s2 <- unify t t' - let composition = s2 `compose` s1 - return (composition, t, apply composition e') + let comp = s2 `compose` s1 + return (comp, t, apply comp e') -- \| ------------------ -- \| Γ ⊢ i : Int, ∅ @@ -253,11 +261,11 @@ algoW = \case -- applySt s2 $ do s3 <- unify (apply s2 t0) (TMono "Int") s4 <- unify (apply s3 t1) (TMono "Int") - let composition = s4 `compose` s3 `compose` s2 `compose` s1 + let comp = s4 `compose` s3 `compose` s2 `compose` s1 return - ( composition + ( comp , TMono "Int" - , apply composition $ T.EAdd (TMono "Int") e0' e1' + , apply comp $ T.EAdd (TMono "Int") e0' e1' ) -- \| Γ ⊢ e₀ : τ₀, S₀ S₀Γ ⊢ e₁ : τ₁, S1 @@ -273,8 +281,8 @@ algoW = \case -- applySt s1 $ do s2 <- unify (apply s1 t0) (TArr t1 fr) let t = apply s2 fr - let composition = s2 `compose` s1 `compose` s0 - return (composition, t, apply composition $ T.EApp t e0' e1') + let comp = s2 `compose` s1 `compose` s0 + return (comp, t, apply comp $ T.EApp t e0' e1') -- \| Γ ⊢ e₀ : τ, S₀ S₀Γ, x : S̅₀Γ̅(τ) ⊢ e₁ : τ', S₁ -- \| ---------------------------------------------- @@ -288,14 +296,14 @@ algoW = \case let t' = generalize (apply s1 env) t1 withBinding name t' $ do (s2, t2, e1') <- algoW e1 - let composition = s2 `compose` s1 - return (composition, t2, apply composition $ T.ELet (T.Bind (name, t2) e0') e1') + let comp = s2 `compose` s1 + return (comp, t2, apply comp $ T.ELet (T.Bind (name, t2) e0') e1') ECase caseExpr injs -> do (sub, t, e') <- algoW caseExpr (subst, injs, ret_t) <- checkCase t injs - let composition = subst `compose` sub - let t' = apply composition ret_t - return (composition, t', T.ECase t' e' injs) + let comp = subst `compose` sub + let t' = apply comp ret_t + return (comp, t', T.ECase t' e' injs) -- | Unify two types producing a new substitution unify :: Type -> Type -> Infer Subst @@ -420,13 +428,20 @@ instance FreeVars T.Exp where free = error "free not implemented for T.Exp" apply :: Subst -> T.Exp -> T.Exp apply s = \case - T.EId (ident, t) -> T.EId (ident, apply s t) - T.ELit t lit -> T.ELit (apply s t) lit - T.ELet (T.Bind (ident, t) e1) e2 -> T.ELet (T.Bind (ident, apply s t) (apply s e1)) (apply s e2) - T.EApp t e1 e2 -> T.EApp (apply s t) (apply s e1) (apply s e2) - T.EAdd t e1 e2 -> T.EAdd (apply s t) (apply s e1) (apply s e2) - T.EAbs t1 (ident, t2) e -> T.EAbs (apply s t1) (ident, apply s t2) (apply s e) - T.ECase t e injs -> T.ECase (apply s t) (apply s e) (apply s injs) + T.EId (ident, t) -> + T.EId (ident, apply s t) + T.ELit t lit -> + T.ELit (apply s t) lit + T.ELet (T.Bind (ident, t) e1) e2 -> + T.ELet (T.Bind (ident, apply s t) (apply s e1)) (apply s e2) + T.EApp t e1 e2 -> + T.EApp (apply s t) (apply s e1) (apply s e2) + T.EAdd t e1 e2 -> + T.EAdd (apply s t) (apply s e1) (apply s e2) + T.EAbs t1 (ident, t2) e -> + T.EAbs (apply s t1) (ident, apply s t2) (apply s e) + T.ECase t e injs -> + T.ECase (apply s t) (apply s e) (apply s injs) instance FreeVars T.Inj where free :: T.Inj -> Set Ident @@ -460,7 +475,8 @@ withBinding i p = local (\st -> st{vars = M.insert i p (vars st)}) -- | Run the monadic action with several additional bindings withBindings :: (Monad m, MonadReader Ctx m) => [(Ident, Poly)] -> m a -> m a -withBindings xs = local (\st -> st{vars = foldl' (flip (uncurry M.insert)) (vars st) xs}) +withBindings xs = + local (\st -> st{vars = foldl' (flip (uncurry M.insert)) (vars st) xs}) -- | Insert a function signature into the environment insertSig :: Ident -> Type -> Infer () @@ -476,8 +492,20 @@ insertConstr i t = checkCase :: Type -> [Inj] -> Infer (Subst, [T.Inj], Type) checkCase expT injs = do (injTs, injs, returns) <- unzip3 <$> mapM checkInj injs - (sub1, _) <- foldM (\(sub, acc) x -> (\a -> (a `compose` sub, a `apply` acc)) <$> unify x acc) (nullSubst, expT) injTs - (sub2, returns_type) <- foldM (\(sub, acc) x -> (\a -> (a `compose` sub, a `apply` acc)) <$> unify x acc) (nullSubst, head returns) (tail returns) + (sub1, _) <- + foldM + ( \(sub, acc) x -> + (\a -> (a `compose` sub, a `apply` acc)) <$> unify x acc + ) + (nullSubst, expT) + injTs + (sub2, returns_type) <- + foldM + ( \(sub, acc) x -> + (\a -> (a `compose` sub, a `apply` acc)) <$> unify x acc + ) + (nullSubst, head returns) + (tail returns) return (sub2 `compose` sub1, injs, returns_type) {- | fst = type of init @@ -495,7 +523,9 @@ inferInit = \case InitLit lit -> return (litType lit, mempty) InitConstr fn vars -> do gets (M.lookup fn . constructors) >>= \case - Nothing -> throwError $ "Constructor: " ++ printTree fn ++ " does not exist" + Nothing -> + throwError $ + "Constructor: " ++ printTree fn ++ " does not exist" Just a -> do case unsnoc $ flattenType a of Nothing -> throwError "Partial pattern match not allowed" From 24007313cb444f4ac5bc15c5e4979c4e4c1d6f81 Mon Sep 17 00:00:00 2001 From: sebastianselander Date: Wed, 22 Mar 2023 10:10:11 +0100 Subject: [PATCH 099/372] added shadowing for ECase in Renamer --- "\\" | 511 ----------------------------------------- src/Renamer/Renamer.hs | 19 +- 2 files changed, 14 insertions(+), 516 deletions(-) delete mode 100644 "\\" diff --git "a/\\" "b/\\" deleted file mode 100644 index 90c24ff..0000000 --- "a/\\" +++ /dev/null @@ -1,511 +0,0 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} - --- | A module for type checking and inference using algorithm W, Hindley-Milner -module TypeChecker.TypeChecker where - -import Control.Monad.Except -import Control.Monad.Reader -import Control.Monad.State -import Data.Foldable (traverse_) -import Data.Functor.Identity (runIdentity) -import Debug.Trace (trace) -import Data.List (foldl') -import Data.Map (Map) -import Data.Map qualified as M -import Data.Set (Set) -import Data.Set qualified as S -import Data.Maybe (fromMaybe) -import Grammar.Abs -import Grammar.Print (printTree) -import TypeChecker.TypeCheckerIr ( - Ctx (..), - Env (..), - Error, - Infer, - Poly (..), - Subst, - ) -import TypeChecker.TypeCheckerIr qualified as T - -initCtx = Ctx mempty - -initEnv = Env 0 mempty mempty - -runPretty :: Exp -> Either Error String -runPretty = fmap (printTree . fst) . run . inferExp - -run :: Infer a -> Either Error a -run = runC initEnv initCtx - -runC :: Env -> Ctx -> Infer a -> Either Error a -runC e c = runIdentity . runExceptT . flip runReaderT c . flip evalStateT e - -typecheck :: Program -> Either Error T.Program -typecheck = run . checkPrg - -{- | Start by freshening the type variable of data types to avoid clash with -other user defined polymorphic types -This might be wrong for type constructors that work over several variables --} --- freshenData :: Data -> Infer Data --- freshenData (Data (Constr name ts) constrs) = do --- new_ts <- traverse freshenType ts --- new_constrs <- traverse freshenConstr constrs --- return $ Data (Constr name new_ts) new_constrs ---TODO: Fix incorrect behavior here - -{- | Freshen all polymorphic variables, regardless of name -| freshenType "d" (a -> b -> c) becomes (d -> d -> d) --} --- freshenType :: Type -> Infer Type --- freshenType t = do --- let freeVars = (S.toList $ free t) --- frs <- sequenceA $ map (const fresh) freeVars --- let remaps = M.fromList $ zip freeVars frs --- return $ go remaps t --- where --- go :: Map Ident Type -> Type -> Type --- go m t = case t of --- TPol a -> fromMaybe (error "bug in \'free\'") (M.lookup a m ) --- TMono a -> TMono a --- TArr t1 t2 -> TArr (go m t1) (go m t2) --- TConstr (Constr ident ts) -> TConstr (Constr ident (map (go m) ts)) - --- freshenConstr :: Constructor -> Infer Constructor --- freshenConstr (Constructor name t) = do --- t' <- freshenType t --- return $ Constructor name t' - -checkData :: Data -> Infer () -checkData d = do - case d of - (Data typ@(Constr name ts) constrs) -> do - unless - (all isPoly ts) - (throwError $ unwords ["Data type incorrectly declared"]) - traverse_ - ( \(Constructor name' t') -> - if TConstr typ == retType t' - then insertConstr name' t' - else - throwError $ - unwords - [ "return type of constructor:" - , printTree name - , "with type:" - , printTree (retType t') - , "does not match data: " - , printTree typ - ] - ) - constrs - -retType :: Type -> Type -retType (TArr _ t2) = retType t2 -retType a = a - -checkPrg :: Program -> Infer T.Program -checkPrg (Program bs) = do - preRun bs - bs' <- checkDef bs - return $ T.Program bs' - where - preRun :: [Def] -> Infer () - preRun [] = return () - preRun (x : xs) = case x of - DBind (Bind n t _ _ _) -> insertSig n t >> preRun xs - DData d@(Data _ _) -> checkData d >> preRun xs - - checkDef :: [Def] -> Infer [T.Def] - checkDef [] = return [] - checkDef (x : xs) = case x of - (DBind b) -> do - b' <- checkBind b - fmap (T.DBind b' :) (checkDef xs) - (DData d) -> fmap (T.DData d :) (checkDef xs) - -checkBind :: Bind -> Infer T.Bind -checkBind (Bind n t _ args e) = do - (t', e') <- inferExp $ makeLambda e (reverse args) - s <- unify t t' - let t'' = apply s t - unless - (t `typeEq` t'') - ( throwError $ - unwords - [ "Top level signature" - , printTree t - , "does not match body with inferred type:" - , printTree t'' - ] - ) - return $ T.Bind (n, t) e' - where - makeLambda :: Exp -> [Ident] -> Exp - makeLambda = foldl (flip EAbs) - -{- | Check if two types are considered equal - For the purpose of the algorithm two polymorphic types are always considered - equal --} -typeEq :: Type -> Type -> Bool -typeEq (TArr l r) (TArr l' r') = typeEq l l' && typeEq r r' -typeEq (TMono a) (TMono b) = a == b -typeEq (TConstr (Constr name a)) (TConstr (Constr name' b)) = - length a == length b - && name == name' - && and (zipWith typeEq a b) -typeEq (TPol _) (TPol _) = True -typeEq _ _ = False - -isMoreSpecificOrEq :: Type -> Type -> Bool -isMoreSpecificOrEq _ (TPol _) = True -isMoreSpecificOrEq (TArr a b) (TArr c d) = - isMoreSpecificOrEq a c && isMoreSpecificOrEq b d -isMoreSpecificOrEq (TConstr (Constr n1 ts1)) (TConstr (Constr n2 ts2)) = - n1 == n2 - && length ts1 == length ts2 - && and (zipWith isMoreSpecificOrEq ts1 ts2) -isMoreSpecificOrEq a b = a == b - -isPoly :: Type -> Bool -isPoly (TPol _) = True -isPoly _ = False - -inferExp :: Exp -> Infer (Type, T.Exp) -inferExp e = do - (s, t, e') <- algoW e - let subbed = apply s t - return (subbed, replace subbed e') - -replace :: Type -> T.Exp -> T.Exp -replace t = \case - T.ELit _ e -> T.ELit t e - T.EId (n, _) -> T.EId (n, t) - T.EAbs _ name e -> T.EAbs t name e - T.EApp _ e1 e2 -> T.EApp t e1 e2 - T.EAdd _ e1 e2 -> T.EAdd t e1 e2 - T.ELet (T.Bind (n, _) e1) e2 -> T.ELet (T.Bind (n, t) e1) e2 - T.ECase _ expr injs -> T.ECase t expr injs - -algoW :: Exp -> Infer (Subst, Type, T.Exp) -algoW = \case - -- \| TODO: More testing need to be done. Unsure of the correctness of this - EAnn e t -> do - (s1, t', e') <- algoW e - unless - (t `isMoreSpecificOrEq` t') - ( throwError $ - unwords - [ "Annotated type:" - , printTree t - , "does not match inferred type:" - , printTree t' - ] - ) - applySt s1 $ do - s2 <- unify t t' - return (s2 `compose` s1, t, e') - - -- \| ------------------ - -- \| Γ ⊢ i : Int, ∅ - - ELit (LInt n) -> - return (nullSubst, TMono "Int", T.ELit (TMono "Int") (LInt n)) - ELit a -> error $ "NOT IMPLEMENTED YET: ELit " ++ show a - -- \| x : σ ∈ Γ   τ = inst(σ) - -- \| ---------------------- - -- \| Γ ⊢ x : τ, ∅ - - EId i -> do - var <- asks vars - case M.lookup i var of - Just t -> inst t >>= \x -> return (nullSubst, x, T.EId (i, x)) - Nothing -> do - sig <- gets sigs - case M.lookup i sig of - Just t -> return (nullSubst, t, T.EId (i, t)) - Nothing -> do - constr <- gets constructors - case M.lookup i constr of - Just t -> return (nullSubst, t, T.EId (i, t)) - Nothing -> - throwError $ - "Unbound variable: " ++ show i - - -- \| τ = newvar Γ, x : τ ⊢ e : τ', S - -- \| --------------------------------- - -- \| Γ ⊢ w λx. e : Sτ → τ', S - - EAbs name e -> do - fr <- fresh - withBinding name (Forall [] fr) $ do - (s1, t', e') <- algoW e - let varType = apply s1 fr - let newArr = TArr varType t' - return (s1, newArr, T.EAbs newArr (name, varType) e') - - -- \| Γ ⊢ e₀ : τ₀, S₀ S₀Γ ⊢ e₁ : τ₁, S₁ - -- \| s₂ = mgu(s₁τ₀, Int) s₃ = mgu(s₂τ₁, Int) - -- \| ------------------------------------------ - -- \| Γ ⊢ e₀ + e₁ : Int, S₃S₂S₁S₀ - -- This might be wrong - - EAdd e0 e1 -> do - (s1, t0, e0') <- algoW e0 - applySt s1 $ do - (s2, t1, e1') <- algoW e1 - -- applySt s2 $ do - s3 <- unify (apply s2 t0) (TMono "Int") - s4 <- unify (apply s3 t1) (TMono "Int") - return - ( s4 `compose` s3 `compose` s2 `compose` s1 - , TMono "Int" - , T.EAdd (TMono "Int") e0' e1' - ) - - -- \| Γ ⊢ e₀ : τ₀, S₀ S₀Γ ⊢ e₁ : τ₁, S1 - -- \| τ' = newvar S₂ = mgu(S₁τ₀, τ₁ → τ') - -- \| -------------------------------------- - -- \| Γ ⊢ e₀ e₁ : S₂τ', S₂S₁S₀ - - EApp e0 e1 -> do - fr <- fresh - (s0, t0, e0') <- algoW e0 - applySt s0 $ do - (s1, t1, e1') <- algoW e1 - -- applySt s1 $ do - s2 <- unify (apply s1 t0) (TArr t1 fr) - let t = apply s2 fr - return (s2 `compose` s1 `compose` s0, t, T.EApp t e0' e1') - - -- \| Γ ⊢ e₀ : τ, S₀ S₀Γ, x : S̅₀Γ̅(τ) ⊢ e₁ : τ', S₁ - -- \| ---------------------------------------------- - -- \| Γ ⊢ let x = e₀ in e₁ : τ', S₁S₀ - - -- The bar over S₀ and Γ means "generalize" - - ELet name e0 e1 -> do - (s1, t1, e0') <- algoW e0 - env <- asks vars - let t' = generalize (apply s1 env) t1 - withBinding name t' $ do - (s2, t2, e1') <- algoW e1 - return (s2 `compose` s1, t2, T.ELet (T.Bind (name, t2) e0') e1') - ECase caseExpr injs -> do - (_, t0, e0') <- algoW caseExpr - (injs', ts) <- mapAndUnzipM (checkInj t0) injs - case ts of - [] -> throwError "Case expression missing any matches" - ts -> do - unified <- zipWithM unify ts (tail ts) - let unified' = foldl' compose mempty unified - let typ = apply unified' (head ts) - return (unified', typ, T.ECase typ e0' injs') - --- | Unify two types producing a new substitution -unify :: Type -> Type -> Infer Subst -unify t0 t1 = do - case (t0, t1) of - (TArr a b, TArr c d) -> do - s1 <- unify a c - s2 <- unify (apply s1 b) (apply s1 d) - return $ s1 `compose` s2 - (TPol a, b) -> occurs a b - (a, TPol b) -> occurs b a - (TMono a, TMono b) -> - if a == b then return M.empty else throwError "Types do not unify" - -- \| TODO: Figure out a cleaner way to express the same thing - (TConstr (Constr name t), TConstr (Constr name' t')) -> - if name == name' && length t == length t' - then do - xs <- zipWithM unify t t' - return $ foldr compose nullSubst xs - else - throwError $ - unwords - [ "Type constructor:" - , printTree name - , "(" ++ printTree t ++ ")" - , "does not match with:" - , printTree name' - , "(" ++ printTree t' ++ ")" - ] - (a, b) -> - throwError . unwords $ - [ "Type:" - , printTree a - , "can't be unified with:" - , printTree b - ] - -{- | Check if a type is contained in another type. -I.E. { a = a -> b } is an unsolvable constraint since there is no substitution -such that these are equal --} -occurs :: Ident -> Type -> Infer Subst -occurs _ (TPol _) = return nullSubst -occurs i t = - if S.member i (free t) - then - throwError $ - unwords - [ "Occurs check failed, can't unify" - , printTree (TPol i) - , "with" - , printTree t - ] - else return $ M.singleton i t - --- | Generalize a type over all free variables in the substitution set -generalize :: Map Ident Poly -> Type -> Poly -generalize env t = Forall (S.toList $ free t S.\\ free env) t - -{- | Instantiate a polymorphic type. The free type variables are substituted -with fresh ones. --} -inst :: Poly -> Infer Type -inst (Forall xs t) = do - xs' <- mapM (const fresh) xs - let s = M.fromList $ zip xs xs' - return $ apply s t - --- | Compose two substitution sets -compose :: Subst -> Subst -> Subst -compose m1 m2 = M.map (apply m1) m2 `M.union` m1 - --- | A class representing free variables functions -class FreeVars t where - -- | Get all free variables from t - free :: t -> Set Ident - - -- | Apply a substitution to t - apply :: Subst -> t -> t - -instance FreeVars Type where - free :: Type -> Set Ident - free (TPol a) = S.singleton a - free (TMono _) = mempty - free (TArr a b) = free a `S.union` free b - -- \| Not guaranteed to be correct - free (TConstr (Constr _ a)) = - foldl' (\acc x -> free x `S.union` acc) S.empty a - - apply :: Subst -> Type -> Type - apply sub t = do - case t of - TMono a -> TMono a - TPol a -> case M.lookup a sub of - Nothing -> TPol a - Just t -> t - TArr a b -> TArr (apply sub a) (apply sub b) - TConstr (Constr name a) -> TConstr (Constr name (map (apply sub) a)) - -instance FreeVars Poly where - free :: Poly -> Set Ident - free (Forall xs t) = free t S.\\ S.fromList xs - apply :: Subst -> Poly -> Poly - apply s (Forall xs t) = Forall xs (apply (foldr M.delete s xs) t) - -instance FreeVars (Map Ident Poly) where - free :: Map Ident Poly -> Set Ident - free m = foldl' S.union S.empty (map free $ M.elems m) - apply :: Subst -> Map Ident Poly -> Map Ident Poly - apply s = M.map (apply s) - --- | Apply substitutions to the environment. -applySt :: Subst -> Infer a -> Infer a -applySt s = local (\st -> st{vars = apply s (vars st)}) - --- | Represents the empty substition set -nullSubst :: Subst -nullSubst = M.empty - --- | Generate a new fresh variable and increment the state counter -fresh :: Infer Type -fresh = do - n <- gets count - modify (\st -> st{count = n + 1}) - return . TPol . Ident $ show n - --- | Run the monadic action with an additional binding -withBinding :: (Monad m, MonadReader Ctx m) => Ident -> Poly -> m a -> m a -withBinding i p = local (\st -> st{vars = M.insert i p (vars st)}) - --- | Insert a function signature into the environment -insertSig :: Ident -> Type -> Infer () -insertSig i t = modify (\st -> st{sigs = M.insert i t (sigs st)}) - --- | Insert a constructor with its data type -insertConstr :: Ident -> Type -> Infer () -insertConstr i t = - modify (\st -> st{constructors = M.insert i t (constructors st)}) - --------- PATTERN MATCHING --------- - --- "case expr of", the type of 'expr' is caseType -checkInj :: Type -> Inj -> Infer (T.Inj, Type) -checkInj caseType (Inj it expr) = do - (args, t') <- initType caseType it - subst <- unify caseType t' - trace ("SUBST: " ++ show subst) return () - applySt subst $ do - (_, t, e') <- local (\st -> st { vars = args `M.union` vars st }) (algoW expr) - return (T.Inj (it, t') e', t) - -initType :: Type -> Init -> Infer (Map Ident Poly, Type) -initType expected = \case - InitLit lit -> do - trace (show "EXPECTED: " ++ show expected ++ "\nreturnType: " ++ show (litType lit)) return () - if litType lit `isMoreSpecificOrEq` expected - then return (mempty, litType lit) - else - throwError $ - unwords - [ "Inferred type" - , printTree $ litType lit - , "does not match expected type:" - , printTree expected - ] - InitConstr c args -> do - st <- gets constructors - case M.lookup c st of - Nothing -> - throwError $ - unwords - [ "Constructor:" - , printTree c - , "does not exist" - ] - Just t -> do - let flat = flattenType t - let returnType = last flat - case ( length (init flat) == length args - , returnType `isMoreSpecificOrEq` expected - ) of - (True, True) -> - return - ( M.fromList $ zip args (map (Forall []) flat) - , expected - ) - (False, _) -> - throwError $ - "Can't partially match on the constructor: " - ++ printTree c - (_, False) -> - throwError $ - unwords - [ "Inferred type" - , printTree returnType - , "does not match expected type:" - , printTree expected - ] - InitCatch -> return (mempty, expected) - -flattenType :: Type -> [Type] -flattenType (TArr a b) = flattenType a ++ flattenType b -flattenType a = [a] - -litType :: Literal -> Type -litType (LInt _) = TMono "Int" diff --git a/src/Renamer/Renamer.hs b/src/Renamer/Renamer.hs index e8e6c38..d056868 100644 --- a/src/Renamer/Renamer.hs +++ b/src/Renamer/Renamer.hs @@ -15,6 +15,7 @@ import Data.Map (Map) import Data.Map qualified as Map import Data.Maybe (fromMaybe) import Data.Tuple.Extra (dupe) +import Debug.Trace (trace) import Grammar.Abs -- | Rename all variables and local binds @@ -70,9 +71,9 @@ renameExp old_names = \case (new_names, e') <- renameExp old_names e pure (new_names, EAnn e' t) ECase e injs -> do - (_, e') <- renameExp old_names e - (new_names, injs') <- renameInjs old_names injs - pure (new_names, ECase e' injs') + (new_names, e') <- renameExp old_names e + (new_names', injs') <- renameInjs new_names injs + pure (new_names', ECase e' injs') renameInjs :: Names -> [Inj] -> Rn (Names, [Inj]) renameInjs ns xs = do @@ -81,8 +82,16 @@ renameInjs ns xs = do renameInj :: Names -> Inj -> Rn (Names, Inj) renameInj ns (Inj init e) = do - (new_names, e') <- renameExp ns e - return (new_names, Inj init e') + (new_names, init') <- renameInit ns init + (new_names', e') <- renameExp new_names e + return (new_names', Inj init' e') + +renameInit :: Names -> Init -> Rn (Names, Init) +renameInit ns i = case i of + InitConstr cs vars -> do + (ns_new, vars') <- newNames ns vars + return (ns_new, InitConstr cs vars') + rest -> return (ns, rest) -- | Create a new name and add it to name environment. newName :: Names -> Ident -> Rn (Names, Ident) From d36370329e64df702f5a26c143b7f6dd83ac8f1f Mon Sep 17 00:00:00 2001 From: Samuel Hammersberg Date: Wed, 22 Mar 2023 10:24:00 +0100 Subject: [PATCH 100/372] Realized that getelementptr might be doing to right thing, and that the uninitialized data comes from padding. --- src/Codegen/Codegen.hs | 23 +++++++++++++---------- src/Codegen/LlvmIr.hs | 7 +++++++ 2 files changed, 20 insertions(+), 10 deletions(-) diff --git a/src/Codegen/Codegen.hs b/src/Codegen/Codegen.hs index 750ae5d..2a0299e 100644 --- a/src/Codegen/Codegen.hs +++ b/src/Codegen/Codegen.hs @@ -151,13 +151,14 @@ compileScs [] = do -- set the first byte to the index of the constructor emit $ SetVariable ptr $ - GetElementPtrInbounds t' (Ref t') - (VIdent top I8) I32 (VInteger 0) I32 (VInteger 0) + GetElementPtr t' (Ref t') (VIdent top I8) + I64 (VInteger 0) + I32 (VInteger 0) emit $ Store I8 (VInteger $ numCI ci ) (Ref I8) ptr -- get a pointer of the correct type ptr' <- GA.Ident . show <$> getNewVar - emit $ SetVariable ptr' (Bitcast (Ref t') ptr (Ref $ CustomType id)) + emit $ SetVariable ptr' (Bitcast (Ref t') top (Ref $ CustomType id)) --emit $ UnsafeRaw "\n" @@ -166,9 +167,10 @@ compileScs [] = do emit $ Comment (show arg_t' <>" "<> arg_n <> " " <> show i ) elemPtr <- GA.Ident . show <$> getNewVar emit $ SetVariable elemPtr ( - GetElementPtrInbounds (CustomType id) (Ref (CustomType id)) - (VIdent ptr' Ptr) I32 - (VInteger 0) I32 (VInteger i)) + GetElementPtr (CustomType id) (Ref (CustomType id)) + (VIdent ptr' Ptr) + I64 (VInteger 0) + I32 (VInteger i)) emit $ Store arg_t' (VIdent (GA.Ident arg_n) arg_t') Ptr elemPtr -- %2 = getelementptr inbounds %Foo_AInteger, %Foo_AInteger* %1, i32 0, i32 1 -- store i32 42, i32* %2 @@ -178,6 +180,7 @@ compileScs [] = do --emit $ UnsafeRaw "\n" -- load and return the constructed value + emit $ Comment "Return the newly constructed value" load <- GA.Ident . show <$> getNewVar emit $ SetVariable load (Load t' Ptr top) emit $ Ret t' (VIdent load t') @@ -213,9 +216,9 @@ mainContent var = [ UnsafeRaw $ "%2 = alloca %Craig\n" <> " store %Craig %1, ptr %2\n" <> - " %3 = bitcast %Craig* %2 to i64*\n" <> - " %4 = load i64, ptr %3\n" <> - " call i32 (ptr, ...) @printf(ptr noundef @.str, i64 noundef %4)\n" + " %3 = bitcast %Craig* %2 to i72*\n" <> + " %4 = load i72, ptr %3\n" <> + " call i32 (ptr, ...) @printf(ptr noundef @.str, i72 noundef %4)\n" -- "call i32 (ptr, ...) @printf(ptr noundef @.str, i64 noundef " <> show var <> ")\n" , -- , SetVariable (GA.Ident "p") (Icmp LLEq I64 (VInteger 2) (VInteger 2)) -- , BrCond (VIdent (GA.Ident "p")) (GA.Ident "b_1") (GA.Ident "b_2") @@ -234,7 +237,7 @@ mainContent var = defaultStart :: [LLVMIr] defaultStart = [ UnsafeRaw "target triple = \"x86_64-pc-linux-gnu\"\n" , UnsafeRaw "target datalayout = \"e-m:o-i64:64-f80:128-n8:16:32:64-S128\"\n" - , UnsafeRaw "@.str = private unnamed_addr constant [3 x i8] c\"%i\n\", align 1\n" + , UnsafeRaw "@.str = private unnamed_addr constant [3 x i8] c\"%x\n\", align 1\n" , UnsafeRaw "declare i32 @printf(ptr noalias nocapture, ...)\n" ] diff --git a/src/Codegen/LlvmIr.hs b/src/Codegen/LlvmIr.hs index ab2ed90..7a0cf82 100644 --- a/src/Codegen/LlvmIr.hs +++ b/src/Codegen/LlvmIr.hs @@ -106,6 +106,7 @@ data LLVMIr | Declare LLVMType Ident Params | SetVariable Ident LLVMIr | Variable Ident + | GetElementPtr LLVMType LLVMType LLVMValue LLVMType LLVMValue LLVMType LLVMValue | GetElementPtrInbounds LLVMType LLVMType LLVMValue LLVMType LLVMValue LLVMType LLVMValue | Add LLVMType LLVMValue LLVMValue | Sub LLVMType LLVMValue LLVMValue @@ -146,6 +147,12 @@ llvmIrToString = go 0 insToString :: Int -> LLVMIr -> String insToString i l = replicate i '\t' <> case l of + (GetElementPtr t1 t2 p t3 v1 t4 v2) -> do + -- getelementptr inbounds %Foo, %Foo* %x, i32 0, i32 0 + concat + [ "getelementptr ", show t1, ", " , show t2 + , " ", show p, ", ", show t3, " ", show v1, + ", ", show t4, " ", show v2, "\n" ] (GetElementPtrInbounds t1 t2 p t3 v1 t4 v2) -> do -- getelementptr inbounds %Foo, %Foo* %x, i32 0, i32 0 concat From 88a4a934b8f448d98947543c6e1fd00b822826d9 Mon Sep 17 00:00:00 2001 From: sebastianselander Date: Wed, 22 Mar 2023 10:32:22 +0100 Subject: [PATCH 101/372] added more manual tests --- Makefile | 3 +++ sample-programs/basic-5 | 8 ++++---- sample-programs/basic-6 | 10 ++++++++++ sample-programs/basic-7 | 10 ++++++++++ sample-programs/basic-8 | 24 ++++++++++++++++++++++++ test_program | 31 ++++++++++++++++--------------- 6 files changed, 67 insertions(+), 19 deletions(-) create mode 100644 sample-programs/basic-6 create mode 100644 sample-programs/basic-7 create mode 100644 sample-programs/basic-8 diff --git a/Makefile b/Makefile index 9c0be2f..d5c908c 100644 --- a/Makefile +++ b/Makefile @@ -28,6 +28,9 @@ test : ./language ./sample-programs/basic-3 ./language ./sample-programs/basic-4 ./language ./sample-programs/basic-5 + ./language ./sample-programs/basic-6 + ./language ./sample-programs/basic-7 + ./language ./sample-programs/basic-8 run : cabal -v0 new-run language -- "test_program" diff --git a/sample-programs/basic-5 b/sample-programs/basic-5 index 9a9a723..319b9b0 100644 --- a/sample-programs/basic-5 +++ b/sample-programs/basic-5 @@ -1,8 +1,8 @@ --- double : _Int -> _Int ; --- double n = n + n; +double : _Int -> _Int ; +double n = n + n; id : 'a -> 'a ; id x = x ; -main : ('a -> 'b -> 'c) ; -main = id ; +main : _Int ; +main = id double 5; diff --git a/sample-programs/basic-6 b/sample-programs/basic-6 new file mode 100644 index 0000000..467d263 --- /dev/null +++ b/sample-programs/basic-6 @@ -0,0 +1,10 @@ +data Bool () where { + True : Bool () + False : Bool () +}; + +main : Bool () -> _Int ; +main b = case b of { + False => 0; + True => 0 +} diff --git a/sample-programs/basic-7 b/sample-programs/basic-7 new file mode 100644 index 0000000..3ddf98b --- /dev/null +++ b/sample-programs/basic-7 @@ -0,0 +1,10 @@ +data Bool () where { + True : Bool () + False : Bool () +}; + +ifThenElse : Bool () -> 'a -> 'a -> 'a; +ifThenElse b if else = case b of { + True => if; + False => else + } diff --git a/sample-programs/basic-8 b/sample-programs/basic-8 new file mode 100644 index 0000000..d916d03 --- /dev/null +++ b/sample-programs/basic-8 @@ -0,0 +1,24 @@ +data Maybe ('a) where { + Nothing : Maybe ('a) + Just : 'a -> Maybe ('a) +}; + +fromJust : Maybe ('a) -> 'a ; +fromJust a = + case a of { + Just a => a + }; + +fromMaybe : 'a -> Maybe ('a) -> 'a ; +fromMaybe a b = + case b of { + Just a => a; + Nothing => a + }; + +maybe : 'b -> ('a -> 'b) -> Maybe ('a) -> 'b; +maybe b f ma = + case ma of { + Just a => f a; + Nothing => b + } diff --git a/test_program b/test_program index bc463fe..d916d03 100644 --- a/test_program +++ b/test_program @@ -1,23 +1,24 @@ --- data Bool () where { --- True : Bool () --- False : Bool () --- }; - data Maybe ('a) where { Nothing : Maybe ('a) Just : 'a -> Maybe ('a) }; --- main : Bool () -> Maybe (Bool ()) ; --- main x = --- case x of { --- True => Nothing; --- False => Just True --- }; - -fun : Maybe ('a) -> 'a ; -fun a = +fromJust : Maybe ('a) -> 'a ; +fromJust a = case a of { - Just c => c + Just a => a }; +fromMaybe : 'a -> Maybe ('a) -> 'a ; +fromMaybe a b = + case b of { + Just a => a; + Nothing => a + }; + +maybe : 'b -> ('a -> 'b) -> Maybe ('a) -> 'b; +maybe b f ma = + case ma of { + Just a => f a; + Nothing => b + } From feeef18cfded47c0f776881799cdb1e664fddd7b Mon Sep 17 00:00:00 2001 From: Samuel Hammersberg Date: Wed, 22 Mar 2023 11:41:02 +0100 Subject: [PATCH 102/372] Started implementing pattern matching on data types. --- src/Codegen/Codegen.hs | 68 ++++++++++++++++++++-------- src/Monomorphizer/MonomorphizerIr.hs | 2 +- 2 files changed, 50 insertions(+), 20 deletions(-) diff --git a/src/Codegen/Codegen.hs b/src/Codegen/Codegen.hs index 2a0299e..225a8d5 100644 --- a/src/Codegen/Codegen.hs +++ b/src/Codegen/Codegen.hs @@ -15,7 +15,7 @@ import qualified Data.Bifunctor as BI import Data.List.Extra (trim) import Data.Map (Map) import qualified Data.Map as Map -import Data.Maybe (fromMaybe) +import Data.Maybe (fromJust, fromMaybe) import Data.Tuple.Extra (dupe, first, second) import qualified Grammar.Abs as GA import Grammar.ErrM (Err) @@ -36,12 +36,12 @@ type CompilerState a = StateT CodeGenerator Err a data FunctionInfo = FunctionInfo { numArgs :: Int , arguments :: [Id] - } + } deriving Show data ConstructorInfo = ConstructorInfo { numArgsCI :: Int , argumentsCI :: [Id] , numCI :: Integer - } + } deriving Show -- | Adds a instruction to the CodeGenerator state @@ -116,15 +116,30 @@ run s = do putStrLn . trim =<< readCreateProcess (shell "lli") s' test :: Integer -> Program -test v = Program [ - DataType (GA.Ident "Craig") [ - Constructor (GA.Ident "Bob") [MIR.Type (GA.Ident "_Int")]--, +test v = Program + [ DataType (GA.Ident "Craig") [ + Constructor (GA.Ident "Bob") [MIR.Type (GA.Ident "_Int")], + Constructor (GA.Ident "Betty") [MIR.Type (GA.Ident "_Int")] + ] + , DataType (GA.Ident "Alice") [ + Constructor (GA.Ident "Eve") [MIR.Type (GA.Ident "_Int")]--, --(GA.Ident "Alice", [TInt, TInt]) - ], - Bind (GA.Ident "fibonacci", MIR.Type (GA.Ident "_Int")) [(GA.Ident "x", MIR.Type (GA.Ident "_Int"))] (EId ("x", MIR.Type (GA.Ident "Craig")), MIR.Type (GA.Ident "Craig")), - Bind (GA.Ident "main", MIR.Type (GA.Ident "_Int")) [] - (EApp (MIR.Type (GA.Ident "Craig")) (EId (GA.Ident "Craig_Bob", MIR.Type (GA.Ident "Craig")), MIR.Type (GA.Ident "Craig")) (ELit (LInt v), MIR.Type (GA.Ident "_Int")), MIR.Type (GA.Ident "Craig"))-- (EInt 92) + ] + , Bind (GA.Ident "fibonacci", MIR.Type (GA.Ident "_Int")) [(GA.Ident "x", MIR.Type (GA.Ident "_Int"))] (EId ("x", MIR.Type (GA.Ident "Craig")), MIR.Type (GA.Ident "Craig")) + , Bind (GA.Ident "main", MIR.Type (GA.Ident "_Int")) [] + --(EApp (MIR.Type (GA.Ident "Craig")) (EId (GA.Ident "Craig_Bob", MIR.Type (GA.Ident "Craig")), MIR.Type (GA.Ident "Craig")) (ELit (LInt v), MIR.Type (GA.Ident "_Int")), MIR.Type (GA.Ident "Craig"))-- (EInt 92) + $ eCaseInt (EApp (MIR.Type (GA.Ident "Craig")) (EId (GA.Ident "Craig_Bob", MIR.Type (GA.Ident "Craig")), MIR.Type (GA.Ident "Craig")) (ELit (LInt v), MIR.Type (GA.Ident "_Int")), MIR.Type (GA.Ident "Craig")) + [ injectionCons "Craig_Betty" "Craig" (int 5) + --, injectionInt 5 (int 6) + , injectionCatchAll (int 10) + ] ] + where + injectionCons x y = Injection (CCons (GA.Ident x, MIR.Type (GA.Ident y))) + injectionInt x = Injection (CLit (LInt x)) + injectionCatchAll = Injection CatchAll + eCaseInt x xs = (ECase (MIR.Type "_Int") x xs, MIR.Type "_Int") + int x = (ELit (LInt x), MIR.Type "_Int") {- | Compiles an AST and produces a LLVM Ir string. An easy way to actually "compile" this output is to @@ -201,8 +216,8 @@ compileScs (Bind (name, _t) args exp : xs) = do modify $ \s -> s { variableCount = 0 } compileScs xs compileScs (DataType id@(GA.Ident outer_id) ts : xs) = do - let biggest_variant = maximum ((\(Constructor _ t) -> sum $ typeByteSize . type2LlvmType <$> t) <$> ts) - emit $ LIR.Type id [I8, Array biggest_variant I8] + let biggestVariant = maximum ((\(Constructor _ t) -> sum $ typeByteSize . type2LlvmType <$> t) <$> ts) + emit $ LIR.Type id [I8, Array biggestVariant I8] mapM_ (\(Constructor (GA.Ident inner_id) fi) -> do emit $ LIR.Type (GA.Ident $ outer_id <> "_" <> inner_id) (I8 : map type2LlvmType fi) ) ts @@ -214,12 +229,12 @@ compileScs (DataType id@(GA.Ident outer_id) ts : xs) = do mainContent :: LLVMValue -> [LLVMIr] mainContent var = [ UnsafeRaw $ - "%2 = alloca %Craig\n" <> - " store %Craig %1, ptr %2\n" <> - " %3 = bitcast %Craig* %2 to i72*\n" <> - " %4 = load i72, ptr %3\n" <> - " call i32 (ptr, ...) @printf(ptr noundef @.str, i72 noundef %4)\n" - -- "call i32 (ptr, ...) @printf(ptr noundef @.str, i64 noundef " <> show var <> ")\n" + -- "%2 = alloca %Craig\n" <> + -- " store %Craig %1, ptr %2\n" <> + -- " %3 = bitcast %Craig* %2 to i72*\n" <> + -- " %4 = load i72, ptr %3\n" <> + -- " call i32 (ptr, ...) @printf(ptr noundef @.str, i72 noundef %4)\n" + "call i32 (ptr, ...) @printf(ptr noundef @.str, i64 noundef " <> show var <> ")\n" , -- , SetVariable (GA.Ident "p") (Icmp LLEq I64 (VInteger 2) (VInteger 2)) -- , BrCond (VIdent (GA.Ident "p")) (GA.Ident "b_1") (GA.Ident "b_2") -- , Label (GA.Ident "b_1") @@ -268,8 +283,23 @@ emitECased t e cases = do emit $ Label label res <- getNewVar emit $ SetVariable (GA.Ident $ show res) (Load ty Ptr (GA.Ident $ show stackPtr)) - where + where emitCases :: LLVMType -> GA.Ident -> Integer -> LLVMValue -> Injection -> CompilerState () + emitCases ty label stackPtr vs (Injection (MIR.CCons id) exp) = do + cons <- gets constructors + let r = fromJust $ Map.lookup id cons + + lbl_failPos <- (\x -> GA.Ident $ "failed_" <> show x) <$> getNewLabel + lbl_succPos <- (\x -> GA.Ident $ "success_" <> show x) <$> getNewLabel + + consCheck <- GA.Ident . show <$> getNewVar + emit $ SetVariable consCheck (Icmp LLEq I8 vs (VInteger $ numCI r)) + emit $ BrCond (VIdent consCheck ty) lbl_succPos lbl_failPos + emit $ Label lbl_succPos + val <- exprToValue (fst exp) + emit $ Store ty val Ptr (GA.Ident . show $ stackPtr) + emit $ Br label + emit $ Label lbl_failPos emitCases ty label stackPtr vs (Injection (MIR.CLit i) exp) = do let i' = case i of LInt i -> VInteger i diff --git a/src/Monomorphizer/MonomorphizerIr.hs b/src/Monomorphizer/MonomorphizerIr.hs index 5bcd5f0..38b230e 100644 --- a/src/Monomorphizer/MonomorphizerIr.hs +++ b/src/Monomorphizer/MonomorphizerIr.hs @@ -19,7 +19,7 @@ data Exp data Injection = Injection Case ExpT deriving (Show, Ord, Eq) -data Case = CLit Lit | CatchAll +data Case = CLit Lit | CCons Id | CatchAll deriving (Show, Ord, Eq) data Constructor = Constructor Ident [Type] From 61c844a255a0615a52fc6beb0449de877fc9a844 Mon Sep 17 00:00:00 2001 From: Samuel Hammersberg Date: Wed, 22 Mar 2023 11:46:07 +0100 Subject: [PATCH 103/372] Revamped getNewVar --- src/Codegen/Codegen.hs | 41 +++++++++++++++++++++-------------------- 1 file changed, 21 insertions(+), 20 deletions(-) diff --git a/src/Codegen/Codegen.hs b/src/Codegen/Codegen.hs index 225a8d5..4183153 100644 --- a/src/Codegen/Codegen.hs +++ b/src/Codegen/Codegen.hs @@ -12,6 +12,7 @@ import Control.Applicative ((<|>)) import Control.Monad.State (StateT, execStateT, foldM_, gets, modify) import qualified Data.Bifunctor as BI +import Data.Functor ((<&>)) import Data.List.Extra (trim) import Data.Map (Map) import qualified Data.Map as Map @@ -57,8 +58,8 @@ getVarCount :: CompilerState Integer getVarCount = gets variableCount -- | Increases the variable count and returns it from the CodeGenerator state -getNewVar :: CompilerState Integer -getNewVar = increaseVarCount >> getVarCount +getNewVar :: CompilerState GA.Ident +getNewVar = (increaseVarCount >> getVarCount) <&> (GA.Ident . show) -- | Increses the label count and returns a label from the CodeGenerator state getNewLabel :: CompilerState Integer @@ -159,8 +160,8 @@ compileScs [] = do let t' = type2LlvmType t let x = BI.second type2LlvmType <$> argumentsCI ci emit $ Define FastCC t' id x - top <- GA.Ident . show <$> getNewVar - ptr <- GA.Ident . show <$> getNewVar + top <- getNewVar + ptr <- getNewVar -- allocated the primary type emit $ SetVariable top (Alloca t') @@ -172,7 +173,7 @@ compileScs [] = do emit $ Store I8 (VInteger $ numCI ci ) (Ref I8) ptr -- get a pointer of the correct type - ptr' <- GA.Ident . show <$> getNewVar + ptr' <- getNewVar emit $ SetVariable ptr' (Bitcast (Ref t') top (Ref $ CustomType id)) --emit $ UnsafeRaw "\n" @@ -180,7 +181,7 @@ compileScs [] = do foldM_ (\i (GA.Ident arg_n, arg_t)-> do let arg_t' = type2LlvmType arg_t emit $ Comment (show arg_t' <>" "<> arg_n <> " " <> show i ) - elemPtr <- GA.Ident . show <$> getNewVar + elemPtr <- getNewVar emit $ SetVariable elemPtr ( GetElementPtr (CustomType id) (Ref (CustomType id)) (VIdent ptr' Ptr) @@ -196,7 +197,7 @@ compileScs [] = do -- load and return the constructed value emit $ Comment "Return the newly constructed value" - load <- GA.Ident . show <$> getNewVar + load <- getNewVar emit $ SetVariable load (Load t' Ptr top) emit $ Ret t' (VIdent load t') emit DefineEnd @@ -278,13 +279,13 @@ emitECased t e cases = do lbl <- getNewLabel let label = GA.Ident $ "escape_" <> show lbl stackPtr <- getNewVar - emit $ SetVariable (GA.Ident $ show stackPtr) (Alloca ty) + emit $ SetVariable stackPtr (Alloca ty) mapM_ (emitCases ty label stackPtr vs) cs emit $ Label label res <- getNewVar - emit $ SetVariable (GA.Ident $ show res) (Load ty Ptr (GA.Ident $ show stackPtr)) + emit $ SetVariable res (Load ty Ptr stackPtr) where - emitCases :: LLVMType -> GA.Ident -> Integer -> LLVMValue -> Injection -> CompilerState () + emitCases :: LLVMType -> GA.Ident -> GA.Ident -> LLVMValue -> Injection -> CompilerState () emitCases ty label stackPtr vs (Injection (MIR.CCons id) exp) = do cons <- gets constructors let r = fromJust $ Map.lookup id cons @@ -292,12 +293,12 @@ emitECased t e cases = do lbl_failPos <- (\x -> GA.Ident $ "failed_" <> show x) <$> getNewLabel lbl_succPos <- (\x -> GA.Ident $ "success_" <> show x) <$> getNewLabel - consCheck <- GA.Ident . show <$> getNewVar + consCheck <- getNewVar emit $ SetVariable consCheck (Icmp LLEq I8 vs (VInteger $ numCI r)) emit $ BrCond (VIdent consCheck ty) lbl_succPos lbl_failPos emit $ Label lbl_succPos val <- exprToValue (fst exp) - emit $ Store ty val Ptr (GA.Ident . show $ stackPtr) + emit $ Store ty val Ptr stackPtr emit $ Br label emit $ Label lbl_failPos emitCases ty label stackPtr vs (Injection (MIR.CLit i) exp) = do @@ -307,16 +308,16 @@ emitECased t e cases = do ns <- getNewVar lbl_failPos <- (\x -> GA.Ident $ "failed_" <> show x) <$> getNewLabel lbl_succPos <- (\x -> GA.Ident $ "success_" <> show x) <$> getNewLabel - emit $ SetVariable (GA.Ident $ show ns) (Icmp LLEq ty vs i') - emit $ BrCond (VIdent (GA.Ident $ show ns) ty) lbl_succPos lbl_failPos + emit $ SetVariable ns (Icmp LLEq ty vs i') + emit $ BrCond (VIdent ns ty) lbl_succPos lbl_failPos emit $ Label lbl_succPos val <- exprToValue (fst exp) - emit $ Store ty val Ptr (GA.Ident . show $ stackPtr) + emit $ Store ty val Ptr stackPtr emit $ Br label emit $ Label lbl_failPos emitCases ty label stackPtr _ (Injection MIR.CatchAll exp) = do val <- exprToValue (fst exp) - emit $ Store ty val Ptr (GA.Ident . show $ stackPtr) + emit $ Store ty val Ptr stackPtr emit $ Br label @@ -352,7 +353,7 @@ emitApp t e1 e2 = appEmitter t e1 e2 [] -- this piece of code could probably be improved, i.e remove the double `const Global` args' = map (first valueGetType . dupe) args call = Call FastCC (type2LlvmType t) visibility (GA.Ident name) args' - emit $ SetVariable (GA.Ident $ show vs) call + emit $ SetVariable vs call x -> error $ "The unspeakable happened: " <> show x emitIdent :: GA.Ident -> CompilerState () @@ -385,7 +386,7 @@ emitSub t e1 e2 = do v1 <- exprToValue e1 v2 <- exprToValue e2 v <- getNewVar - emit $ SetVariable (GA.Ident $ show v) (Sub (type2LlvmType t) v1 v2) + emit $ SetVariable v (Sub (type2LlvmType t) v1 v2) exprToValue :: Exp -> CompilerState LLVMValue exprToValue = \case @@ -399,9 +400,9 @@ exprToValue = \case if numArgs fi == 0 then do vc <- getNewVar - emit $ SetVariable (GA.Ident $ show vc) + emit $ SetVariable vc (Call FastCC (type2LlvmType t) Global name []) - pure $ VIdent (GA.Ident $ show vc) (type2LlvmType t) + pure $ VIdent vc (type2LlvmType t) else pure $ VFunction name Global (type2LlvmType t) Nothing -> pure $ VIdent name (type2LlvmType t) e -> do From cd85297b859a8600f1f91175811d19d7fd590268 Mon Sep 17 00:00:00 2001 From: Samuel Hammersberg Date: Wed, 22 Mar 2023 11:48:40 +0100 Subject: [PATCH 104/372] Removed the ear operator. --- src/Codegen/Codegen.hs | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/src/Codegen/Codegen.hs b/src/Codegen/Codegen.hs index 4183153..bf2f9ba 100644 --- a/src/Codegen/Codegen.hs +++ b/src/Codegen/Codegen.hs @@ -12,7 +12,6 @@ import Control.Applicative ((<|>)) import Control.Monad.State (StateT, execStateT, foldM_, gets, modify) import qualified Data.Bifunctor as BI -import Data.Functor ((<&>)) import Data.List.Extra (trim) import Data.Map (Map) import qualified Data.Map as Map @@ -59,7 +58,7 @@ getVarCount = gets variableCount -- | Increases the variable count and returns it from the CodeGenerator state getNewVar :: CompilerState GA.Ident -getNewVar = (increaseVarCount >> getVarCount) <&> (GA.Ident . show) +getNewVar = (GA.Ident . show) <$> (increaseVarCount >> getVarCount) -- | Increses the label count and returns a label from the CodeGenerator state getNewLabel :: CompilerState Integer From 936cb1301fd5d73e92726ec5bf86d465c0f6a125 Mon Sep 17 00:00:00 2001 From: sebastianselander Date: Wed, 22 Mar 2023 12:45:51 +0100 Subject: [PATCH 105/372] new grammar and adapted renamer --- Grammar.cf | 87 ++- sample-programs/basic-1 | 2 +- sample-programs/basic-2 | 4 +- sample-programs/basic-3 | 2 +- sample-programs/basic-4 | 2 +- sample-programs/basic-5 | 6 +- sample-programs/basic-6 | 2 +- sample-programs/basic-7 | 2 +- sample-programs/basic-8 | 12 +- src/Main.hs | 21 +- src/Renamer/Renamer.hs | 164 ++++-- src/TypeChecker/Bugs.md | 83 --- src/TypeChecker/TypeChecker.hs | 958 ++++++++++++++++--------------- src/TypeChecker/TypeCheckerIr.hs | 306 +++++----- test_program | 28 +- 15 files changed, 858 insertions(+), 821 deletions(-) delete mode 100644 src/TypeChecker/Bugs.md diff --git a/Grammar.cf b/Grammar.cf index 37305e2..356646d 100644 --- a/Grammar.cf +++ b/Grammar.cf @@ -1,50 +1,91 @@ +-------------------------------------------------------------------------------- +-- * PROGRAM +-------------------------------------------------------------------------------- Program. Program ::= [Def] ; +-------------------------------------------------------------------------------- +-- * TOP-LEVEL +-------------------------------------------------------------------------------- + DBind. Def ::= Bind ; +DSig. Def ::= Sig ; DData. Def ::= Data ; -separator Def ";" ; -Bind. Bind ::= Ident ":" Type ";" - Ident [Ident] "=" Exp ; +Sig. Sig ::= LIdent ":" Type ; -Data. Data ::= "data" Constr "where" "{" [Constructor] "}" ; +Bind. Bind ::= LIdent [LIdent] "=" Exp ; -Constructor. Constructor ::= Ident ":" Type ; -separator nonempty Constructor "" ; +-------------------------------------------------------------------------------- +-- * TYPES +-------------------------------------------------------------------------------- -TMono. Type1 ::= "_" Ident ; -TPol. Type1 ::= "'" Ident ; -TConstr. Type1 ::= Constr ; -TArr. Type ::= Type1 "->" Type ; + TLit. Type2 ::= UIdent ; + TVar. Type2 ::= TVar ; + TAll. Type1 ::= "forall" TVar "." Type ; + TIndexed. Type1 ::= Indexed ; +internal TEVar. Type1 ::= TEVar ; + TFun. Type ::= Type1 "->" Type ; -Constr. Constr ::= Ident "(" [Type] ")" ; + MkTVar. TVar ::= LIdent ; +internal MkTEVar. TEVar ::= LIdent ; + +-------------------------------------------------------------------------------- +-- * DATA TYPES +-------------------------------------------------------------------------------- + +Constructor. Constructor ::= UIdent ":" Type ; + +Indexed. Indexed ::= UIdent "(" [Type] ")" ; + +Data. Data ::= "data" Indexed "where" "{" [Constructor] "}" ; + +-------------------------------------------------------------------------------- +-- * EXPRESSIONS +-------------------------------------------------------------------------------- --- TODO: Move literal to its own thing since it's reused in Init as well. EAnn. Exp5 ::= "(" Exp ":" Type ")" ; -EId. Exp4 ::= Ident ; -ELit. Exp4 ::= Literal ; +EId. Exp4 ::= LIdent ; +ELit. Exp4 ::= Lit ; EApp. Exp3 ::= Exp3 Exp4 ; EAdd. Exp1 ::= Exp1 "+" Exp2 ; -ELet. Exp ::= "let" Ident "=" Exp "in" Exp ; -EAbs. Exp ::= "\\" Ident "." Exp ; +ELet. Exp ::= "let" LIdent "=" Exp "in" Exp ; +EAbs. Exp ::= "\\" LIdent "." Exp ; ECase. Exp ::= "case" Exp "of" "{" [Inj] "}"; -LInt. Literal ::= Integer ; +-------------------------------------------------------------------------------- +-- * LITERALS +-------------------------------------------------------------------------------- + +LInt. Lit ::= Integer ; +LChar. Lit ::= Char ; + +-------------------------------------------------------------------------------- +-- * CASE +-------------------------------------------------------------------------------- Inj. Inj ::= Init "=>" Exp ; -separator nonempty Inj ";" ; -InitLit. Init ::= Literal ; -InitConstr. Init ::= Ident [Ident] ; -InitCatch. Init ::= "_" ; +InitLit. Init ::= Lit ; +InitConstructor. Init ::= UIdent [LIdent] ; +InitCatch. Init ::= "_" ; +-------------------------------------------------------------------------------- +-- * AUX +-------------------------------------------------------------------------------- + +separator Def ";" ; +separator nonempty Constructor "" ; separator Type " " ; -coercions Type 2 ; - +separator nonempty Inj ";" ; separator Ident " "; +separator LIdent " "; coercions Exp 5 ; +coercions Type 2 ; + +token UIdent (upper (letter | digit | '_')*) ; +token LIdent (lower (letter | digit | '_')*) ; comment "--" ; comment "{-" "-}" ; diff --git a/sample-programs/basic-1 b/sample-programs/basic-1 index 5cb2b2a..d52aac2 100644 --- a/sample-programs/basic-1 +++ b/sample-programs/basic-1 @@ -1,2 +1,2 @@ -f : _Int -> _Int ; +f : Int -> Int ; f = \x. x+1 ; diff --git a/sample-programs/basic-2 b/sample-programs/basic-2 index 2f0448c..2db6128 100644 --- a/sample-programs/basic-2 +++ b/sample-programs/basic-2 @@ -1,5 +1,5 @@ -add : _Int -> _Int -> _Int ; +add : Int -> Int -> Int ; add x = \y. x+y; -main : _Int ; +main : Int ; main = (\z. z+z) ((add 4) 6) ; diff --git a/sample-programs/basic-3 b/sample-programs/basic-3 index 7ba4971..98c03b9 100644 --- a/sample-programs/basic-3 +++ b/sample-programs/basic-3 @@ -1,2 +1,2 @@ -main : _Int ; +main : Int ; main = (\x. x+x+3) ((\x. x) 2) ; diff --git a/sample-programs/basic-4 b/sample-programs/basic-4 index 365e4cb..55ac9eb 100644 --- a/sample-programs/basic-4 +++ b/sample-programs/basic-4 @@ -1,2 +1,2 @@ -f : _Int -> _Int ; +f : Int -> Int ; f x = let g = (\y. y+1) in g (g x) diff --git a/sample-programs/basic-5 b/sample-programs/basic-5 index 319b9b0..a6414f2 100644 --- a/sample-programs/basic-5 +++ b/sample-programs/basic-5 @@ -1,8 +1,8 @@ -double : _Int -> _Int ; +double : Int -> Int ; double n = n + n; -id : 'a -> 'a ; +id : forall a. a -> a ; id x = x ; -main : _Int ; +main : Int ; main = id double 5; diff --git a/sample-programs/basic-6 b/sample-programs/basic-6 index 467d263..3ed64a0 100644 --- a/sample-programs/basic-6 +++ b/sample-programs/basic-6 @@ -3,7 +3,7 @@ data Bool () where { False : Bool () }; -main : Bool () -> _Int ; +main : Bool () -> Int ; main b = case b of { False => 0; True => 0 diff --git a/sample-programs/basic-7 b/sample-programs/basic-7 index 3ddf98b..9ae2bdf 100644 --- a/sample-programs/basic-7 +++ b/sample-programs/basic-7 @@ -3,7 +3,7 @@ data Bool () where { False : Bool () }; -ifThenElse : Bool () -> 'a -> 'a -> 'a; +ifThenElse : forall a. Bool () -> a -> a -> a; ifThenElse b if else = case b of { True => if; False => else diff --git a/sample-programs/basic-8 b/sample-programs/basic-8 index d916d03..c2c4042 100644 --- a/sample-programs/basic-8 +++ b/sample-programs/basic-8 @@ -1,22 +1,22 @@ -data Maybe ('a) where { - Nothing : Maybe ('a) - Just : 'a -> Maybe ('a) +data Maybe (a) where { + Nothing : Maybe (a) + Just : forall a. a -> Maybe (a) }; -fromJust : Maybe ('a) -> 'a ; +fromJust : Maybe (a) -> a ; fromJust a = case a of { Just a => a }; -fromMaybe : 'a -> Maybe ('a) -> 'a ; +fromMaybe : a -> Maybe (a) -> a ; fromMaybe a b = case b of { Just a => a; Nothing => a }; -maybe : 'b -> ('a -> 'b) -> Maybe ('a) -> 'b; +maybe : b -> (a -> b) -> Maybe (a) -> b; maybe b f ma = case ma of { Just a => f a; diff --git a/src/Main.hs b/src/Main.hs index 7e3922d..0a00cd6 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -11,7 +11,8 @@ import Grammar.Print (printTree) import Renamer.Renamer (rename) import System.Environment (getArgs) import System.Exit (exitFailure, exitSuccess) -import TypeChecker.TypeChecker (typecheck) + +-- import TypeChecker.TypeChecker (typecheck) main :: IO () main = @@ -28,12 +29,12 @@ main' s = do putStrLn $ printTree parsed putStrLn "\n-- Renamer --" - let renamed = rename parsed + renamed <- fromRenamerErr . rename $ parsed putStrLn $ printTree renamed - putStrLn "\n-- TypeChecker --" - typechecked <- fromTypeCheckerErr $ typecheck renamed - putStrLn $ show typechecked + -- putStrLn "\n-- TypeChecker --" + -- typechecked <- fromTypeCheckerErr $ typecheck renamed + -- putStrLn $ show typechecked -- putStrLn "\n-- Lambda Lifter --" -- let lifted = lambdaLift typechecked @@ -55,6 +56,16 @@ fromCompilerErr = ) pure +fromRenamerErr :: Err a -> IO a +fromRenamerErr = + either + ( \err -> do + putStrLn "\nRENAME ERROR" + putStrLn err + exitFailure + ) + pure + fromSyntaxErr :: Err a -> IO a fromSyntaxErr = either diff --git a/src/Renamer/Renamer.hs b/src/Renamer/Renamer.hs index d056868..aac8b16 100644 --- a/src/Renamer/Renamer.hs +++ b/src/Renamer/Renamer.hs @@ -1,56 +1,101 @@ {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} -module Renamer.Renamer where +module Renamer.Renamer (rename) where import Auxiliary (mapAccumM) +import Control.Applicative (Applicative (liftA2)) +import Control.Monad.Except (ExceptT, runExceptT) +import Control.Monad.Identity (Identity, runIdentity) import Control.Monad.State ( MonadState, - State, - evalState, + StateT, + evalStateT, gets, modify, ) -import Data.List (foldl') +import Data.Function (on) import Data.Map (Map) import Data.Map qualified as Map import Data.Maybe (fromMaybe) import Data.Tuple.Extra (dupe) -import Debug.Trace (trace) import Grammar.Abs -- | Rename all variables and local binds -rename :: Program -> Program -rename (Program bs) = Program $ evalState (runRn $ mapM (renameSc initNames) bs) 0 +rename :: Program -> Either String Program +rename (Program defs) = Program <$> renameDefs defs + +renameDefs :: [Def] -> Either String [Def] +renameDefs defs = runIdentity $ runExceptT $ evalStateT (runRn $ mapM renameDef defs) initCxt where - -- initNames = Map.fromList $ map (\(Bind name _ _ _ _) -> dupe name) bs - initNames = Map.fromList $ foldl' saveIfBind [] bs - saveIfBind acc (DBind (Bind name _ _ _ _)) = dupe name : acc - saveIfBind acc _ = acc - renameSc :: Names -> Def -> Rn Def - renameSc old_names (DBind (Bind name t _ parms rhs)) = do - (new_names, parms') <- newNames old_names parms - rhs' <- snd <$> renameExp new_names rhs - pure . DBind $ Bind name t name parms' rhs' - renameSc _ def = pure def + initNames = Map.fromList [dupe name | DBind (Bind name _ _) <- defs] + + renameDef :: Def -> Rn Def + renameDef = \case + DSig (Sig name typ) -> DSig . Sig name <$> renameTVars typ + DBind (Bind name vars rhs) -> do + (new_names, vars') <- newNames initNames vars + rhs' <- snd <$> renameExp new_names rhs + pure . DBind $ Bind name vars' rhs' + DData (Data (Indexed cname types) constrs) -> do + tvars' <- mapM nextNameTVar tvars + let tvars_lt = zip tvars tvars' + typ' = map (substituteTVar tvars_lt) types + constrs' = map (renameConstr tvars_lt) constrs + pure . DData $ Data (Indexed cname typ') constrs' + where + tvars = concatMap (collectTVars []) types + collectTVars tvars = \case + TAll tvar t -> collectTVars (tvar : tvars) t + TIndexed _ -> tvars + -- Should be monad error + TVar v -> [v] + _ -> error ("Bad data type definition: " ++ show types) + + renameConstr :: [(TVar, TVar)] -> Constructor -> Constructor + renameConstr new_types (Constructor name typ) = + Constructor name $ substituteTVar new_types typ + +substituteTVar :: [(TVar, TVar)] -> Type -> Type +substituteTVar new_names typ = case typ of + TLit _ -> typ + TVar tvar + | Just tvar' <- lookup tvar new_names -> + TVar tvar' + | otherwise -> + typ + TFun t1 t2 -> on TFun substitute' t1 t2 + TAll tvar t + | Just tvar' <- lookup tvar new_names -> + TAll tvar' $ substitute' t + | otherwise -> + TAll tvar $ substitute' t + TIndexed (Indexed name typs) -> TIndexed . Indexed name $ map substitute' typs + _ -> error ("Impossible " ++ show typ) + where + substitute' = substituteTVar new_names + +initCxt :: Cxt +initCxt = Cxt 0 0 + +data Cxt = Cxt + { var_counter :: Int + , tvar_counter :: Int + } -- | Rename monad. State holds the number of renamed names. -newtype Rn a = Rn {runRn :: State Int a} - deriving (Functor, Applicative, Monad, MonadState Int) +newtype Rn a = Rn {runRn :: StateT Cxt (ExceptT String Identity) a} + deriving (Functor, Applicative, Monad, MonadState Cxt) -- | Maps old to new name -type Names = Map Ident Ident - -renameLocalBind :: Names -> Bind -> Rn (Names, Bind) -renameLocalBind old_names (Bind name t _ parms rhs) = do - (new_names, name') <- newName old_names name - (new_names', parms') <- newNames new_names parms - (new_names'', rhs') <- renameExp new_names' rhs - pure (new_names'', Bind name' t name' parms' rhs') +type Names = Map LIdent LIdent renameExp :: Names -> Exp -> Rn (Names, Exp) renameExp old_names = \case EId n -> pure (old_names, EId . fromMaybe n $ Map.lookup n old_names) - ELit (LInt i1) -> pure (old_names, ELit (LInt i1)) + ELit lit -> pure (old_names, ELit lit) EApp e1 e2 -> do (env1, e1') <- renameExp old_names e1 (env2, e2') <- renameExp old_names e2 @@ -59,17 +104,21 @@ renameExp old_names = \case (env1, e1') <- renameExp old_names e1 (env2, e2') <- renameExp old_names e2 pure (Map.union env1 env2, EAdd e1' e2') - ELet i e1 e2 -> do - (new_names, e1') <- renameExp old_names e1 - (new_names', e2') <- renameExp new_names e2 - pure (new_names', ELet i e1' e2') + + -- TODO fix shadowing + ELet name rhs e -> do + (new_names, name') <- newName old_names name + (new_names', rhs') <- renameExp new_names rhs + (new_names'', e') <- renameExp new_names' e + pure (new_names'', ELet name' rhs' e') EAbs par e -> do (new_names, par') <- newName old_names par (new_names', e') <- renameExp new_names e pure (new_names', EAbs par' e') EAnn e t -> do (new_names, e') <- renameExp old_names e - pure (new_names, EAnn e' t) + t' <- renameTVars t + pure (new_names, EAnn e' t') ECase e injs -> do (new_names, e') <- renameExp old_names e (new_names', injs') <- renameInjs new_names injs @@ -88,21 +137,58 @@ renameInj ns (Inj init e) = do renameInit :: Names -> Init -> Rn (Names, Init) renameInit ns i = case i of - InitConstr cs vars -> do + InitConstructor cs vars -> do (ns_new, vars') <- newNames ns vars - return (ns_new, InitConstr cs vars') + return (ns_new, InitConstructor cs vars') rest -> return (ns, rest) +renameTVars :: Type -> Rn Type +renameTVars typ = case typ of + TAll tvar t -> do + tvar' <- nextNameTVar tvar + t' <- renameTVars $ substitute tvar tvar' t + pure $ TAll tvar' t' + TFun t1 t2 -> liftA2 TFun (renameTVars t1) (renameTVars t2) + _ -> pure typ + +substitute :: + TVar -> -- α + TVar -> -- α_n + Type -> -- A + Type -- [α_n/α]A +substitute tvar1 tvar2 typ = case typ of + TLit _ -> typ + TVar tvar' + | tvar' == tvar1 -> TVar tvar2 + | otherwise -> typ + TFun t1 t2 -> on TFun substitute' t1 t2 + TAll tvar t -> TAll tvar $ substitute' t + TIndexed (Indexed name typs) -> TIndexed . Indexed name $ map substitute' typs + _ -> error "Impossible" + where + substitute' = substitute tvar1 tvar2 + -- | Create a new name and add it to name environment. -newName :: Names -> Ident -> Rn (Names, Ident) +newName :: Names -> LIdent -> Rn (Names, LIdent) newName env old_name = do new_name <- makeName old_name pure (Map.insert old_name new_name env, new_name) -- | Create multiple names and add them to the name environment -newNames :: Names -> [Ident] -> Rn (Names, [Ident]) +newNames :: Names -> [LIdent] -> Rn (Names, [LIdent]) newNames = mapAccumM newName -- | Annotate name with number and increment the number @prefix ⇒ prefix_number@. -makeName :: Ident -> Rn Ident -makeName (Ident prefix) = gets (\i -> Ident $ prefix ++ "_" ++ show i) <* modify succ +makeName :: LIdent -> Rn LIdent +makeName (LIdent prefix) = do + i <- gets var_counter + let name = LIdent $ prefix ++ "_" ++ show i + modify $ \cxt -> cxt{var_counter = succ cxt.var_counter} + pure name + +nextNameTVar :: TVar -> Rn TVar +nextNameTVar (MkTVar (LIdent s)) = do + i <- gets tvar_counter + let tvar = MkTVar . LIdent $ s ++ "_" ++ show i + modify $ \cxt -> cxt{tvar_counter = succ cxt.tvar_counter} + pure tvar diff --git a/src/TypeChecker/Bugs.md b/src/TypeChecker/Bugs.md deleted file mode 100644 index a265cde..0000000 --- a/src/TypeChecker/Bugs.md +++ /dev/null @@ -1,83 +0,0 @@ -## Bugs - -None known at this moment - -main\_bug should not typecheck - -```hs -apply : ('a -> 'b -> 'c) -> 'a -> 'b -> 'c ; -apply f x = \y. f x y ; - -id : 'a -> 'a ; -id x = x ; - -add : _Int -> _Int -> _Int ; -add x y = x + y ; - -main_bug : _Int -> _Int -> _Int ; -main_bug= (apply id) add ; - -idadd : _Int -> _Int -> _Int ; -idadd = id add ; -``` - -main\_bug should typecheck - -```hs -apply : ('a -> 'b -> 'c) -> 'a -> 'b -> 'c ; -apply f x = \y. f x y ; - -id : 'a -> 'a ; -id x = x ; - -add : _Int -> _Int -> _Int ; -add x y = x + y ; - -main_bug : _Int -> _Int -> _Int ; -main_bug = apply (id add) ; - -idadd : _Int -> _Int -> _Int ; -idadd = id add ; -``` - -## Fixed bugs - -* 1 - -```hs -fmap : ('a -> 'b) -> Maybe ('a) -> Maybe ('b) ; -fmap f x = - case x of { - Just x => Just (f x) ; - Nothing => Nothing - } -``` - -* 2 - -```hs -data Maybe ('a) where { - Nothing : Maybe ('a) - Just : 'a -> Maybe ('a) -}; - -id : 'a -> 'a ; -id x = x ; - -main : Maybe ('a -> 'a) ; -main = Just id; -``` - -But this does -```hs -data Maybe ('a) where { - Nothing : Maybe ('a) - Just : 'a -> Maybe ('a) -}; - -id : 'b -> 'b ; -id x = x ; - -main : Maybe ('a -> 'a) ; -main = Just id; -``` diff --git a/src/TypeChecker/TypeChecker.hs b/src/TypeChecker/TypeChecker.hs index 1339212..4e072d2 100644 --- a/src/TypeChecker/TypeChecker.hs +++ b/src/TypeChecker/TypeChecker.hs @@ -4,541 +4,543 @@ -- | A module for type checking and inference using algorithm W, Hindley-Milner module TypeChecker.TypeChecker where -import Control.Monad.Except -import Control.Monad.Reader -import Control.Monad.State -import Data.Bifunctor (second) -import Data.Foldable (traverse_) -import Data.Functor.Identity (runIdentity) -import Data.List (foldl') -import Data.List.Extra (unsnoc) -import Data.Map (Map) -import Data.Map qualified as M -import Data.Maybe (fromMaybe) -import Data.Set (Set) -import Data.Set qualified as S -import Debug.Trace (trace) -import Grammar.Abs -import Grammar.Print (printTree) -import TypeChecker.TypeCheckerIr ( - Ctx (..), - Env (..), - Error, - Infer, - Poly (..), - Subst, - ) -import TypeChecker.TypeCheckerIr qualified as T +-- import Control.Monad.Except +-- import Control.Monad.Reader +-- import Control.Monad.State +-- import Data.Bifunctor (second) +-- import Data.Foldable (traverse_) +-- import Data.Functor.Identity (runIdentity) +-- import Data.List (foldl') +-- import Data.List.Extra (unsnoc) +-- import Data.Map (Map) +-- import Data.Map qualified as M +-- import Data.Maybe (fromMaybe) +-- import Data.Set (Set) +-- import Data.Set qualified as S +-- import Debug.Trace (trace) +-- import Grammar.Abs +-- import Grammar.Print (printTree) +-- import TypeChecker.TypeCheckerIr ( +-- Ctx (..), +-- Env (..), +-- Error, +-- Infer, +-- Poly (..), +-- Subst, +-- ) +-- import TypeChecker.TypeCheckerIr qualified as T -initCtx = Ctx mempty +-- initCtx = Ctx mempty -initEnv = Env 0 mempty mempty +-- initEnv = Env 0 mempty mempty -runPretty :: Exp -> Either Error String -runPretty = fmap (printTree . fst) . run . inferExp +-- runPretty :: Exp -> Either Error String +-- runPretty = fmap (printTree . fst) . run . inferExp -run :: Infer a -> Either Error a -run = runC initEnv initCtx +-- run :: Infer a -> Either Error a +-- run = runC initEnv initCtx -runC :: Env -> Ctx -> Infer a -> Either Error a -runC e c = runIdentity . runExceptT . flip runReaderT c . flip evalStateT e +-- runC :: Env -> Ctx -> Infer a -> Either Error a +-- runC e c = runIdentity . runExceptT . flip runReaderT c . flip evalStateT e -typecheck :: Program -> Either Error T.Program -typecheck = run . checkPrg +-- typecheck :: Program -> Either Error T.Program +-- typecheck = run . checkPrg -{- | Start by freshening the type variable of data types to avoid clash with -other user defined polymorphic types --} -freshenData :: Data -> Infer Data -freshenData (Data (Constr name ts) constrs) = do - let xs = (S.toList . free) =<< ts - frs <- traverse (const fresh) xs - let m = M.fromList $ zip xs frs - return $ - Data - (Constr name (map (freshenType m) ts)) - ( map - ( \(Constructor ident t) -> - Constructor ident (freshenType m t) - ) - constrs - ) +-- {- | Start by freshening the type variable of data types to avoid clash with +-- other user defined polymorphic types +-- -} +-- freshenData :: Data -> Infer Data +-- freshenData (Data (Constr name ts) constrs) = do +-- let xs = (S.toList . free) =<< ts +-- frs <- traverse (const fresh) xs +-- let m = M.fromList $ zip xs frs +-- return $ +-- Data +-- (Constr name (map (freshenType m) ts)) +-- ( map +-- ( \(Constructor ident t) -> +-- Constructor ident (freshenType m t) +-- ) +-- constrs +-- ) -{- | Freshen all polymorphic variables, regardless of name -| freshenType "d" (a -> b -> c) becomes (d -> d -> d) --} +-- {- | Freshen all polymorphic variables, regardless of name + +{- | freshenType "d" (a -> b -> c) becomes (d -> d -> d) +-\} freshenType :: Map Ident Type -> Type -> Type freshenType m t = case t of TPol poly -> fromMaybe (error "bug in \'free\'") (M.lookup poly m) TMono mono -> TMono mono TArr t1 t2 -> TArr (freshenType m t1) (freshenType m t2) TConstr (Constr ident ts) -> TConstr (Constr ident (map (freshenType m) ts)) - -checkData :: Data -> Infer () -checkData d = do - d' <- freshenData d - case d' of - (Data typ@(Constr name ts) constrs) -> do - unless - (all isPoly ts) - (throwError $ unwords ["Data type incorrectly declared"]) - traverse_ - ( \(Constructor name' t') -> - if TConstr typ == retType t' - then insertConstr name' t' - else - throwError $ - unwords - [ "return type of constructor:" - , printTree name - , "with type:" - , printTree (retType t') - , "does not match data: " - , printTree typ - ] - ) - constrs - -retType :: Type -> Type -retType (TArr _ t2) = retType t2 -retType a = a - -checkPrg :: Program -> Infer T.Program -checkPrg (Program bs) = do - preRun bs - bs' <- checkDef bs - return $ T.Program bs' - where - preRun :: [Def] -> Infer () - preRun [] = return () - preRun (x : xs) = case x of - DBind (Bind n t _ _ _) -> insertSig n t >> preRun xs - DData d@(Data _ _) -> checkData d >> preRun xs - - checkDef :: [Def] -> Infer [T.Def] - checkDef [] = return [] - checkDef (x : xs) = case x of - (DBind b) -> do - b' <- checkBind b - fmap (T.DBind b' :) (checkDef xs) - (DData d) -> do - d' <- freshenData d - fmap (T.DData d' :) (checkDef xs) - -checkBind :: Bind -> Infer T.Bind -checkBind (Bind n t _ args e) = do - let lambda = makeLambda e (reverse args) - (t', e) <- inferExp lambda - s <- unify t' t - let t'' = apply s t - unless - (t `typeEq` t'') - ( throwError $ - unwords - [ "Top level signature" - , printTree t - , "does not match body with inferred type:" - , printTree t'' - ] - ) - return $ T.Bind (n, t) (apply s e) - where - makeLambda :: Exp -> [Ident] -> Exp - makeLambda = foldl (flip EAbs) - -{- | Check if two types are considered equal - For the purpose of the algorithm two polymorphic types are always considered - equal -} -typeEq :: Type -> Type -> Bool -typeEq (TArr l r) (TArr l' r') = typeEq l l' && typeEq r r' -typeEq (TMono a) (TMono b) = a == b -typeEq (TConstr (Constr name a)) (TConstr (Constr name' b)) = - length a == length b - && name == name' - && and (zipWith typeEq a b) -typeEq (TPol _) (TPol _) = True -typeEq _ _ = False -isMoreSpecificOrEq :: Type -> Type -> Bool -isMoreSpecificOrEq _ (TPol _) = True -isMoreSpecificOrEq (TArr a b) (TArr c d) = - isMoreSpecificOrEq a c && isMoreSpecificOrEq b d -isMoreSpecificOrEq (TConstr (Constr n1 ts1)) (TConstr (Constr n2 ts2)) = - n1 == n2 - && length ts1 == length ts2 - && and (zipWith isMoreSpecificOrEq ts1 ts2) -isMoreSpecificOrEq a b = a == b +-- checkData :: Data -> Infer () +-- checkData d = do +-- d' <- freshenData d +-- case d' of +-- (Data typ@(Constr name ts) constrs) -> do +-- unless +-- (all isPoly ts) +-- (throwError $ unwords ["Data type incorrectly declared"]) +-- traverse_ +-- ( \(Constructor name' t') -> +-- if TConstr typ == retType t' +-- then insertConstr name' t' +-- else +-- throwError $ +-- unwords +-- [ "return type of constructor:" +-- , printTree name +-- , "with type:" +-- , printTree (retType t') +-- , "does not match data: " +-- , printTree typ +-- ] +-- ) +-- constrs -isPoly :: Type -> Bool -isPoly (TPol _) = True -isPoly _ = False +-- retType :: Type -> Type +-- retType (TArr _ t2) = retType t2 +-- retType a = a -inferExp :: Exp -> Infer (Type, T.Exp) -inferExp e = do - (s, t, e') <- algoW e - let subbed = apply s t - return (subbed, replace subbed e') +-- checkPrg :: Program -> Infer T.Program +-- checkPrg (Program bs) = do +-- preRun bs +-- bs' <- checkDef bs +-- return $ T.Program bs' +-- where +-- preRun :: [Def] -> Infer () +-- preRun [] = return () +-- preRun (x : xs) = case x of +-- DBind (Bind n t _ _ _) -> insertSig n t >> preRun xs +-- DData d@(Data _ _) -> checkData d >> preRun xs -replace :: Type -> T.Exp -> T.Exp -replace t = \case - T.ELit _ e -> T.ELit t e - T.EId (n, _) -> T.EId (n, t) - T.EAbs _ name e -> T.EAbs t name e - T.EApp _ e1 e2 -> T.EApp t e1 e2 - T.EAdd _ e1 e2 -> T.EAdd t e1 e2 - T.ELet (T.Bind (n, _) e1) e2 -> T.ELet (T.Bind (n, t) e1) e2 - T.ECase _ expr injs -> T.ECase t expr injs +-- checkDef :: [Def] -> Infer [T.Def] +-- checkDef [] = return [] +-- checkDef (x : xs) = case x of +-- (DBind b) -> do +-- b' <- checkBind b +-- fmap (T.DBind b' :) (checkDef xs) +-- (DData d) -> do +-- d' <- freshenData d +-- fmap (T.DData d' :) (checkDef xs) -algoW :: Exp -> Infer (Subst, Type, T.Exp) -algoW = \case - -- \| TODO: More testing need to be done. Unsure of the correctness of this - EAnn e t -> do - (s1, t', e') <- algoW e - unless - (t `isMoreSpecificOrEq` t') - ( throwError $ - unwords - [ "Annotated type:" - , printTree t - , "does not match inferred type:" - , printTree t' - ] - ) - applySt s1 $ do - s2 <- unify t t' - let comp = s2 `compose` s1 - return (comp, t, apply comp e') +-- checkBind :: Bind -> Infer T.Bind +-- checkBind (Bind n t _ args e) = do +-- let lambda = makeLambda e (reverse args) +-- (t', e) <- inferExp lambda +-- s <- unify t' t +-- let t'' = apply s t +-- unless +-- (t `typeEq` t'') +-- ( throwError $ +-- unwords +-- [ "Top level signature" +-- , printTree t +-- , "does not match body with inferred type:" +-- , printTree t'' +-- ] +-- ) +-- return $ T.Bind (n, t) (apply s e) +-- where +-- makeLambda :: Exp -> [Ident] -> Exp +-- makeLambda = foldl (flip EAbs) - -- \| ------------------ - -- \| Γ ⊢ i : Int, ∅ +-- {- | Check if two types are considered equal +-- For the purpose of the algorithm two polymorphic types are always considered +-- equal +-- -} +-- typeEq :: Type -> Type -> Bool +-- typeEq (TArr l r) (TArr l' r') = typeEq l l' && typeEq r r' +-- typeEq (TMono a) (TMono b) = a == b +-- typeEq (TConstr (Constr name a)) (TConstr (Constr name' b)) = +-- length a == length b +-- && name == name' +-- && and (zipWith typeEq a b) +-- typeEq (TPol _) (TPol _) = True +-- typeEq _ _ = False - ELit lit -> - let lt = litType lit - in return (nullSubst, lt, T.ELit lt lit) - -- \| x : σ ∈ Γ   τ = inst(σ) - -- \| ---------------------- - -- \| Γ ⊢ x : τ, ∅ +-- isMoreSpecificOrEq :: Type -> Type -> Bool +-- isMoreSpecificOrEq _ (TPol _) = True +-- isMoreSpecificOrEq (TArr a b) (TArr c d) = +-- isMoreSpecificOrEq a c && isMoreSpecificOrEq b d +-- isMoreSpecificOrEq (TConstr (Constr n1 ts1)) (TConstr (Constr n2 ts2)) = +-- n1 == n2 +-- && length ts1 == length ts2 +-- && and (zipWith isMoreSpecificOrEq ts1 ts2) +-- isMoreSpecificOrEq a b = a == b - EId i -> do - var <- asks vars - case M.lookup i var of - Just t -> inst t >>= \x -> return (nullSubst, x, T.EId (i, x)) - Nothing -> do - sig <- gets sigs - case M.lookup i sig of - Just t -> return (nullSubst, t, T.EId (i, t)) - Nothing -> do - constr <- gets constructors - case M.lookup i constr of - Just t -> return (nullSubst, t, T.EId (i, t)) - Nothing -> - throwError $ - "Unbound variable: " ++ show i +-- isPoly :: Type -> Bool +-- isPoly (TPol _) = True +-- isPoly _ = False - -- \| τ = newvar Γ, x : τ ⊢ e : τ', S - -- \| --------------------------------- - -- \| Γ ⊢ w λx. e : Sτ → τ', S +-- inferExp :: Exp -> Infer (Type, T.Exp) +-- inferExp e = do +-- (s, t, e') <- algoW e +-- let subbed = apply s t +-- return (subbed, replace subbed e') - EAbs name e -> do - fr <- fresh - withBinding name (Forall [] fr) $ do - (s1, t', e') <- algoW e - let varType = apply s1 fr - let newArr = TArr varType t' - return (s1, newArr, apply s1 $ T.EAbs newArr (name, varType) e') +-- replace :: Type -> T.Exp -> T.Exp +-- replace t = \case +-- T.ELit _ e -> T.ELit t e +-- T.EId (n, _) -> T.EId (n, t) +-- T.EAbs _ name e -> T.EAbs t name e +-- T.EApp _ e1 e2 -> T.EApp t e1 e2 +-- T.EAdd _ e1 e2 -> T.EAdd t e1 e2 +-- T.ELet (T.Bind (n, _) e1) e2 -> T.ELet (T.Bind (n, t) e1) e2 +-- T.ECase _ expr injs -> T.ECase t expr injs - -- \| Γ ⊢ e₀ : τ₀, S₀ S₀Γ ⊢ e₁ : τ₁, S₁ - -- \| s₂ = mgu(s₁τ₀, Int) s₃ = mgu(s₂τ₁, Int) - -- \| ------------------------------------------ - -- \| Γ ⊢ e₀ + e₁ : Int, S₃S₂S₁S₀ - -- This might be wrong +-- algoW :: Exp -> Infer (Subst, Type, T.Exp) +-- algoW = \case +-- -- \| TODO: More testing need to be done. Unsure of the correctness of this +-- EAnn e t -> do +-- (s1, t', e') <- algoW e +-- unless +-- (t `isMoreSpecificOrEq` t') +-- ( throwError $ +-- unwords +-- [ "Annotated type:" +-- , printTree t +-- , "does not match inferred type:" +-- , printTree t' +-- ] +-- ) +-- applySt s1 $ do +-- s2 <- unify t t' +-- let comp = s2 `compose` s1 +-- return (comp, t, apply comp e') - EAdd e0 e1 -> do - (s1, t0, e0') <- algoW e0 - applySt s1 $ do - (s2, t1, e1') <- algoW e1 - -- applySt s2 $ do - s3 <- unify (apply s2 t0) (TMono "Int") - s4 <- unify (apply s3 t1) (TMono "Int") - let comp = s4 `compose` s3 `compose` s2 `compose` s1 - return - ( comp - , TMono "Int" - , apply comp $ T.EAdd (TMono "Int") e0' e1' - ) +-- -- \| ------------------ +-- -- \| Γ ⊢ i : Int, ∅ - -- \| Γ ⊢ e₀ : τ₀, S₀ S₀Γ ⊢ e₁ : τ₁, S1 - -- \| τ' = newvar S₂ = mgu(S₁τ₀, τ₁ → τ') - -- \| -------------------------------------- - -- \| Γ ⊢ e₀ e₁ : S₂τ', S₂S₁S₀ +-- ELit lit -> +-- let lt = litType lit +-- in return (nullSubst, lt, T.ELit lt lit) +-- -- \| x : σ ∈ Γ   τ = inst(σ) +-- -- \| ---------------------- +-- -- \| Γ ⊢ x : τ, ∅ - EApp e0 e1 -> do - fr <- fresh - (s0, t0, e0') <- algoW e0 - applySt s0 $ do - (s1, t1, e1') <- algoW e1 - -- applySt s1 $ do - s2 <- unify (apply s1 t0) (TArr t1 fr) - let t = apply s2 fr - let comp = s2 `compose` s1 `compose` s0 - return (comp, t, apply comp $ T.EApp t e0' e1') +-- EId i -> do +-- var <- asks vars +-- case M.lookup i var of +-- Just t -> inst t >>= \x -> return (nullSubst, x, T.EId (i, x)) +-- Nothing -> do +-- sig <- gets sigs +-- case M.lookup i sig of +-- Just t -> return (nullSubst, t, T.EId (i, t)) +-- Nothing -> do +-- constr <- gets constructors +-- case M.lookup i constr of +-- Just t -> return (nullSubst, t, T.EId (i, t)) +-- Nothing -> +-- throwError $ +-- "Unbound variable: " ++ show i - -- \| Γ ⊢ e₀ : τ, S₀ S₀Γ, x : S̅₀Γ̅(τ) ⊢ e₁ : τ', S₁ - -- \| ---------------------------------------------- - -- \| Γ ⊢ let x = e₀ in e₁ : τ', S₁S₀ +-- -- \| τ = newvar Γ, x : τ ⊢ e : τ', S +-- -- \| --------------------------------- +-- -- \| Γ ⊢ w λx. e : Sτ → τ', S - -- The bar over S₀ and Γ means "generalize" +-- EAbs name e -> do +-- fr <- fresh +-- withBinding name (Forall [] fr) $ do +-- (s1, t', e') <- algoW e +-- let varType = apply s1 fr +-- let newArr = TArr varType t' +-- return (s1, newArr, apply s1 $ T.EAbs newArr (name, varType) e') - ELet name e0 e1 -> do - (s1, t1, e0') <- algoW e0 - env <- asks vars - let t' = generalize (apply s1 env) t1 - withBinding name t' $ do - (s2, t2, e1') <- algoW e1 - let comp = s2 `compose` s1 - return (comp, t2, apply comp $ T.ELet (T.Bind (name, t2) e0') e1') - ECase caseExpr injs -> do - (sub, t, e') <- algoW caseExpr - (subst, injs, ret_t) <- checkCase t injs - let comp = subst `compose` sub - let t' = apply comp ret_t - return (comp, t', T.ECase t' e' injs) +-- -- \| Γ ⊢ e₀ : τ₀, S₀ S₀Γ ⊢ e₁ : τ₁, S₁ +-- -- \| s₂ = mgu(s₁τ₀, Int) s₃ = mgu(s₂τ₁, Int) +-- -- \| ------------------------------------------ +-- -- \| Γ ⊢ e₀ + e₁ : Int, S₃S₂S₁S₀ +-- -- This might be wrong --- | Unify two types producing a new substitution -unify :: Type -> Type -> Infer Subst -unify t0 t1 = do - case (t0, t1) of - (TArr a b, TArr c d) -> do - s1 <- unify a c - s2 <- unify (apply s1 b) (apply s1 d) - return $ s1 `compose` s2 - (TPol a, b) -> occurs a b - (a, TPol b) -> occurs b a - (TMono a, TMono b) -> - if a == b then return M.empty else throwError "Types do not unify" - (TConstr (Constr name t), TConstr (Constr name' t')) -> - if name == name' && length t == length t' - then do - xs <- zipWithM unify t t' - return $ foldr compose nullSubst xs - else - throwError $ - unwords - [ "Type constructor:" - , printTree name - , "(" ++ printTree t ++ ")" - , "does not match with:" - , printTree name' - , "(" ++ printTree t' ++ ")" - ] - (a, b) -> do - ctx <- ask - env <- get - throwError . unwords $ - [ "Type:" - , printTree a - , "can't be unified with:" - , printTree b - , "\nCtx:" - , show ctx - , "\nEnv:" - , show env - ] +-- EAdd e0 e1 -> do +-- (s1, t0, e0') <- algoW e0 +-- applySt s1 $ do +-- (s2, t1, e1') <- algoW e1 +-- -- applySt s2 $ do +-- s3 <- unify (apply s2 t0) (TMono "Int") +-- s4 <- unify (apply s3 t1) (TMono "Int") +-- let comp = s4 `compose` s3 `compose` s2 `compose` s1 +-- return +-- ( comp +-- , TMono "Int" +-- , apply comp $ T.EAdd (TMono "Int") e0' e1' +-- ) -{- | Check if a type is contained in another type. -I.E. { a = a -> b } is an unsolvable constraint since there is no substitution -where these are equal --} -occurs :: Ident -> Type -> Infer Subst -occurs i t@(TPol _) = return (M.singleton i t) -occurs i t = - if S.member i (free t) - then - throwError $ - unwords - [ "Occurs check failed, can't unify" - , printTree (TPol i) - , "with" - , printTree t - ] - else return $ M.singleton i t +-- -- \| Γ ⊢ e₀ : τ₀, S₀ S₀Γ ⊢ e₁ : τ₁, S1 +-- -- \| τ' = newvar S₂ = mgu(S₁τ₀, τ₁ → τ') +-- -- \| -------------------------------------- +-- -- \| Γ ⊢ e₀ e₁ : S₂τ', S₂S₁S₀ --- | Generalize a type over all free variables in the substitution set -generalize :: Map Ident Poly -> Type -> Poly -generalize env t = Forall (S.toList $ free t S.\\ free env) t +-- EApp e0 e1 -> do +-- fr <- fresh +-- (s0, t0, e0') <- algoW e0 +-- applySt s0 $ do +-- (s1, t1, e1') <- algoW e1 +-- -- applySt s1 $ do +-- s2 <- unify (apply s1 t0) (TArr t1 fr) +-- let t = apply s2 fr +-- let comp = s2 `compose` s1 `compose` s0 +-- return (comp, t, apply comp $ T.EApp t e0' e1') -{- | Instantiate a polymorphic type. The free type variables are substituted -with fresh ones. --} -inst :: Poly -> Infer Type -inst (Forall xs t) = do - xs' <- mapM (const fresh) xs - let s = M.fromList $ zip xs xs' - return $ apply s t +-- -- \| Γ ⊢ e₀ : τ, S₀ S₀Γ, x : S̅₀Γ̅(τ) ⊢ e₁ : τ', S₁ +-- -- \| ---------------------------------------------- +-- -- \| Γ ⊢ let x = e₀ in e₁ : τ', S₁S₀ --- | Compose two substitution sets -compose :: Subst -> Subst -> Subst -compose m1 m2 = M.map (apply m1) m2 `M.union` m1 +-- -- The bar over S₀ and Γ means "generalize" --- TODO: Split this class into two separate classes, one for free variables --- and one for applying substitutions +-- ELet name e0 e1 -> do +-- (s1, t1, e0') <- algoW e0 +-- env <- asks vars +-- let t' = generalize (apply s1 env) t1 +-- withBinding name t' $ do +-- (s2, t2, e1') <- algoW e1 +-- let comp = s2 `compose` s1 +-- return (comp, t2, apply comp $ T.ELet (T.Bind (name, t2) e0') e1') +-- ECase caseExpr injs -> do +-- (sub, t, e') <- algoW caseExpr +-- (subst, injs, ret_t) <- checkCase t injs +-- let comp = subst `compose` sub +-- let t' = apply comp ret_t +-- return (comp, t', T.ECase t' e' injs) --- | A class representing free variables functions -class FreeVars t where - -- | Get all free variables from t - free :: t -> Set Ident +-- -- | Unify two types producing a new substitution +-- unify :: Type -> Type -> Infer Subst +-- unify t0 t1 = do +-- case (t0, t1) of +-- (TArr a b, TArr c d) -> do +-- s1 <- unify a c +-- s2 <- unify (apply s1 b) (apply s1 d) +-- return $ s1 `compose` s2 +-- (TPol a, b) -> occurs a b +-- (a, TPol b) -> occurs b a +-- (TMono a, TMono b) -> +-- if a == b then return M.empty else throwError "Types do not unify" +-- (TConstr (Constr name t), TConstr (Constr name' t')) -> +-- if name == name' && length t == length t' +-- then do +-- xs <- zipWithM unify t t' +-- return $ foldr compose nullSubst xs +-- else +-- throwError $ +-- unwords +-- [ "Type constructor:" +-- , printTree name +-- , "(" ++ printTree t ++ ")" +-- , "does not match with:" +-- , printTree name' +-- , "(" ++ printTree t' ++ ")" +-- ] +-- (a, b) -> do +-- ctx <- ask +-- env <- get +-- throwError . unwords $ +-- [ "Type:" +-- , printTree a +-- , "can't be unified with:" +-- , printTree b +-- , "\nCtx:" +-- , show ctx +-- , "\nEnv:" +-- , show env +-- ] - -- | Apply a substitution to t - apply :: Subst -> t -> t +-- {- | Check if a type is contained in another type. +-- I.E. { a = a -> b } is an unsolvable constraint since there is no substitution +-- where these are equal +-- -} +-- occurs :: Ident -> Type -> Infer Subst +-- occurs i t@(TPol _) = return (M.singleton i t) +-- occurs i t = +-- if S.member i (free t) +-- then +-- throwError $ +-- unwords +-- [ "Occurs check failed, can't unify" +-- , printTree (TPol i) +-- , "with" +-- , printTree t +-- ] +-- else return $ M.singleton i t -instance FreeVars Type where - free :: Type -> Set Ident - free (TPol a) = S.singleton a - free (TMono _) = mempty - free (TArr a b) = free a `S.union` free b - -- \| Not guaranteed to be correct - free (TConstr (Constr _ a)) = - foldl' (\acc x -> free x `S.union` acc) S.empty a +-- -- | Generalize a type over all free variables in the substitution set +-- generalize :: Map Ident Poly -> Type -> Poly +-- generalize env t = Forall (S.toList $ free t S.\\ free env) t - apply :: Subst -> Type -> Type - apply sub t = do - case t of - TMono a -> TMono a - TPol a -> case M.lookup a sub of - Nothing -> TPol a - Just t -> t - TArr a b -> TArr (apply sub a) (apply sub b) - TConstr (Constr name a) -> TConstr (Constr name (map (apply sub) a)) +-- {- | Instantiate a polymorphic type. The free type variables are substituted +-- with fresh ones. +-- -} +-- inst :: Poly -> Infer Type +-- inst (Forall xs t) = do +-- xs' <- mapM (const fresh) xs +-- let s = M.fromList $ zip xs xs' +-- return $ apply s t -instance FreeVars Poly where - free :: Poly -> Set Ident - free (Forall xs t) = free t S.\\ S.fromList xs - apply :: Subst -> Poly -> Poly - apply s (Forall xs t) = Forall xs (apply (foldr M.delete s xs) t) +-- -- | Compose two substitution sets +-- compose :: Subst -> Subst -> Subst +-- compose m1 m2 = M.map (apply m1) m2 `M.union` m1 -instance FreeVars (Map Ident Poly) where - free :: Map Ident Poly -> Set Ident - free m = foldl' S.union S.empty (map free $ M.elems m) - apply :: Subst -> Map Ident Poly -> Map Ident Poly - apply s = M.map (apply s) +-- -- TODO: Split this class into two separate classes, one for free variables +-- -- and one for applying substitutions -instance FreeVars T.Exp where - free :: T.Exp -> Set Ident - free = error "free not implemented for T.Exp" - apply :: Subst -> T.Exp -> T.Exp - apply s = \case - T.EId (ident, t) -> - T.EId (ident, apply s t) - T.ELit t lit -> - T.ELit (apply s t) lit - T.ELet (T.Bind (ident, t) e1) e2 -> - T.ELet (T.Bind (ident, apply s t) (apply s e1)) (apply s e2) - T.EApp t e1 e2 -> - T.EApp (apply s t) (apply s e1) (apply s e2) - T.EAdd t e1 e2 -> - T.EAdd (apply s t) (apply s e1) (apply s e2) - T.EAbs t1 (ident, t2) e -> - T.EAbs (apply s t1) (ident, apply s t2) (apply s e) - T.ECase t e injs -> - T.ECase (apply s t) (apply s e) (apply s injs) +-- -- | A class representing free variables functions +-- class FreeVars t where +-- -- | Get all free variables from t +-- free :: t -> Set Ident -instance FreeVars T.Inj where - free :: T.Inj -> Set Ident - free = undefined - apply :: Subst -> T.Inj -> T.Inj - apply s (T.Inj (i, t) e) = T.Inj (i, apply s t) (apply s e) +-- -- | Apply a substitution to t +-- apply :: Subst -> t -> t -instance FreeVars [T.Inj] where - free :: [T.Inj] -> Set Ident - free = foldl' (\acc x -> free x `S.union` acc) mempty - apply s = map (apply s) +-- instance FreeVars Type where +-- free :: Type -> Set Ident +-- free (TPol a) = S.singleton a +-- free (TMono _) = mempty +-- free (TArr a b) = free a `S.union` free b +-- -- \| Not guaranteed to be correct +-- free (TConstr (Constr _ a)) = +-- foldl' (\acc x -> free x `S.union` acc) S.empty a --- | Apply substitutions to the environment. -applySt :: Subst -> Infer a -> Infer a -applySt s = local (\st -> st{vars = apply s (vars st)}) +-- apply :: Subst -> Type -> Type +-- apply sub t = do +-- case t of +-- TMono a -> TMono a +-- TPol a -> case M.lookup a sub of +-- Nothing -> TPol a +-- Just t -> t +-- TArr a b -> TArr (apply sub a) (apply sub b) +-- TConstr (Constr name a) -> TConstr (Constr name (map (apply sub) a)) --- | Represents the empty substition set -nullSubst :: Subst -nullSubst = M.empty +-- instance FreeVars Poly where +-- free :: Poly -> Set Ident +-- free (Forall xs t) = free t S.\\ S.fromList xs +-- apply :: Subst -> Poly -> Poly +-- apply s (Forall xs t) = Forall xs (apply (foldr M.delete s xs) t) --- | Generate a new fresh variable and increment the state counter -fresh :: Infer Type -fresh = do - n <- gets count - modify (\st -> st{count = n + 1}) - return . TPol . Ident $ show n +-- instance FreeVars (Map Ident Poly) where +-- free :: Map Ident Poly -> Set Ident +-- free m = foldl' S.union S.empty (map free $ M.elems m) +-- apply :: Subst -> Map Ident Poly -> Map Ident Poly +-- apply s = M.map (apply s) --- | Run the monadic action with an additional binding -withBinding :: (Monad m, MonadReader Ctx m) => Ident -> Poly -> m a -> m a -withBinding i p = local (\st -> st{vars = M.insert i p (vars st)}) +-- instance FreeVars T.Exp where +-- free :: T.Exp -> Set Ident +-- free = error "free not implemented for T.Exp" +-- apply :: Subst -> T.Exp -> T.Exp +-- apply s = \case +-- T.EId (ident, t) -> +-- T.EId (ident, apply s t) +-- T.ELit t lit -> +-- T.ELit (apply s t) lit +-- T.ELet (T.Bind (ident, t) e1) e2 -> +-- T.ELet (T.Bind (ident, apply s t) (apply s e1)) (apply s e2) +-- T.EApp t e1 e2 -> +-- T.EApp (apply s t) (apply s e1) (apply s e2) +-- T.EAdd t e1 e2 -> +-- T.EAdd (apply s t) (apply s e1) (apply s e2) +-- T.EAbs t1 (ident, t2) e -> +-- T.EAbs (apply s t1) (ident, apply s t2) (apply s e) +-- T.ECase t e injs -> +-- T.ECase (apply s t) (apply s e) (apply s injs) --- | Run the monadic action with several additional bindings -withBindings :: (Monad m, MonadReader Ctx m) => [(Ident, Poly)] -> m a -> m a -withBindings xs = - local (\st -> st{vars = foldl' (flip (uncurry M.insert)) (vars st) xs}) +-- instance FreeVars T.Inj where +-- free :: T.Inj -> Set Ident +-- free = undefined +-- apply :: Subst -> T.Inj -> T.Inj +-- apply s (T.Inj (i, t) e) = T.Inj (i, apply s t) (apply s e) --- | Insert a function signature into the environment -insertSig :: Ident -> Type -> Infer () -insertSig i t = modify (\st -> st{sigs = M.insert i t (sigs st)}) +-- instance FreeVars [T.Inj] where +-- free :: [T.Inj] -> Set Ident +-- free = foldl' (\acc x -> free x `S.union` acc) mempty +-- apply s = map (apply s) --- | Insert a constructor with its data type -insertConstr :: Ident -> Type -> Infer () -insertConstr i t = - modify (\st -> st{constructors = M.insert i t (constructors st)}) +-- -- | Apply substitutions to the environment. +-- applySt :: Subst -> Infer a -> Infer a +-- applySt s = local (\st -> st{vars = apply s (vars st)}) --------- PATTERN MATCHING --------- +-- -- | Represents the empty substition set +-- nullSubst :: Subst +-- nullSubst = M.empty -checkCase :: Type -> [Inj] -> Infer (Subst, [T.Inj], Type) -checkCase expT injs = do - (injTs, injs, returns) <- unzip3 <$> mapM checkInj injs - (sub1, _) <- - foldM - ( \(sub, acc) x -> - (\a -> (a `compose` sub, a `apply` acc)) <$> unify x acc - ) - (nullSubst, expT) - injTs - (sub2, returns_type) <- - foldM - ( \(sub, acc) x -> - (\a -> (a `compose` sub, a `apply` acc)) <$> unify x acc - ) - (nullSubst, head returns) - (tail returns) - return (sub2 `compose` sub1, injs, returns_type) +-- -- | Generate a new fresh variable and increment the state counter +-- fresh :: Infer Type +-- fresh = do +-- n <- gets count +-- modify (\st -> st{count = n + 1}) +-- return . TPol . Ident $ show n -{- | fst = type of init - | snd = type of expr --} -checkInj :: Inj -> Infer (Type, T.Inj, Type) -checkInj (Inj it expr) = do - (initT, vars) <- inferInit it - let converted = map (second (Forall [])) vars - (exprT, e) <- withBindings converted (inferExp expr) - return (initT, T.Inj (it, initT) e, exprT) +-- -- | Run the monadic action with an additional binding +-- withBinding :: (Monad m, MonadReader Ctx m) => Ident -> Poly -> m a -> m a +-- withBinding i p = local (\st -> st{vars = M.insert i p (vars st)}) -inferInit :: Init -> Infer (Type, [T.Id]) -inferInit = \case - InitLit lit -> return (litType lit, mempty) - InitConstr fn vars -> do - gets (M.lookup fn . constructors) >>= \case - Nothing -> - throwError $ - "Constructor: " ++ printTree fn ++ " does not exist" - Just a -> do - case unsnoc $ flattenType a of - Nothing -> throwError "Partial pattern match not allowed" - Just (vs, ret) -> - case length vars `compare` length vs of - EQ -> do - return (ret, zip vars vs) - _ -> throwError "Partial pattern match not allowed" - InitCatch -> (,mempty) <$> fresh +-- -- | Run the monadic action with several additional bindings +-- withBindings :: (Monad m, MonadReader Ctx m) => [(Ident, Poly)] -> m a -> m a +-- withBindings xs = +-- local (\st -> st{vars = foldl' (flip (uncurry M.insert)) (vars st) xs}) -flattenType :: Type -> [Type] -flattenType (TArr a b) = flattenType a ++ flattenType b -flattenType a = [a] +-- -- | Insert a function signature into the environment +-- insertSig :: Ident -> Type -> Infer () +-- insertSig i t = modify (\st -> st{sigs = M.insert i t (sigs st)}) -litType :: Literal -> Type -litType (LInt _) = TMono "Int" +-- -- | Insert a constructor with its data type +-- insertConstr :: Ident -> Type -> Infer () +-- insertConstr i t = +-- modify (\st -> st{constructors = M.insert i t (constructors st)}) + +-- -------- PATTERN MATCHING --------- + +-- checkCase :: Type -> [Inj] -> Infer (Subst, [T.Inj], Type) +-- checkCase expT injs = do +-- (injTs, injs, returns) <- unzip3 <$> mapM checkInj injs +-- (sub1, _) <- +-- foldM +-- ( \(sub, acc) x -> +-- (\a -> (a `compose` sub, a `apply` acc)) <$> unify x acc +-- ) +-- (nullSubst, expT) +-- injTs +-- (sub2, returns_type) <- +-- foldM +-- ( \(sub, acc) x -> +-- (\a -> (a `compose` sub, a `apply` acc)) <$> unify x acc +-- ) +-- (nullSubst, head returns) +-- (tail returns) +-- return (sub2 `compose` sub1, injs, returns_type) + +-- {- | fst = type of init +-- | snd = type of expr +-- -} +-- checkInj :: Inj -> Infer (Type, T.Inj, Type) +-- checkInj (Inj it expr) = do +-- (initT, vars) <- inferInit it +-- let converted = map (second (Forall [])) vars +-- (exprT, e) <- withBindings converted (inferExp expr) +-- return (initT, T.Inj (it, initT) e, exprT) + +-- inferInit :: Init -> Infer (Type, [T.Id]) +-- inferInit = \case +-- InitLit lit -> return (litType lit, mempty) +-- InitConstr fn vars -> do +-- gets (M.lookup fn . constructors) >>= \case +-- Nothing -> +-- throwError $ +-- "Constructor: " ++ printTree fn ++ " does not exist" +-- Just a -> do +-- case unsnoc $ flattenType a of +-- Nothing -> throwError "Partial pattern match not allowed" +-- Just (vs, ret) -> +-- case length vars `compare` length vs of +-- EQ -> do +-- return (ret, zip vars vs) +-- _ -> throwError "Partial pattern match not allowed" +-- InitCatch -> (,mempty) <$> fresh + +-- flattenType :: Type -> [Type] +-- flattenType (TArr a b) = flattenType a ++ flattenType b +-- flattenType a = [a] + +-- litType :: Literal -> Type +-- litType (LInt _) = TMono "Int" diff --git a/src/TypeChecker/TypeCheckerIr.hs b/src/TypeChecker/TypeCheckerIr.hs index 016dd8a..2b3c702 100644 --- a/src/TypeChecker/TypeCheckerIr.hs +++ b/src/TypeChecker/TypeCheckerIr.hs @@ -2,178 +2,178 @@ module TypeChecker.TypeCheckerIr where -import Control.Monad.Except -import Control.Monad.Reader -import Control.Monad.State -import Data.Functor.Identity (Identity) -import Data.Map (Map) -import Grammar.Abs ( - Data (..), - Ident (..), - Init (..), - Literal (..), - Type (..), - ) -import Grammar.Print -import Prelude -import Prelude qualified as C (Eq, Ord, Read, Show) +-- import Control.Monad.Except +-- import Control.Monad.Reader +-- import Control.Monad.State +-- import Data.Functor.Identity (Identity) +-- import Data.Map (Map) +-- import Grammar.Abs ( +-- Data (..), +-- Ident (..), +-- Init (..), +-- Literal (..), +-- Type (..), +-- ) +-- import Grammar.Print +-- import Prelude +-- import Prelude qualified as C (Eq, Ord, Read, Show) --- | A data type representing type variables -data Poly = Forall [Ident] Type - deriving (Show) +-- -- | A data type representing type variables +-- data Poly = Forall [Ident] Type +-- deriving (Show) -newtype Ctx = Ctx {vars :: Map Ident Poly} - deriving Show +-- newtype Ctx = Ctx {vars :: Map Ident Poly} +-- deriving Show -data Env = Env - { count :: Int - , sigs :: Map Ident Type - , constructors :: Map Ident Type - } deriving Show +-- data Env = Env +-- { count :: Int +-- , sigs :: Map Ident Type +-- , constructors :: Map Ident Type +-- } deriving Show -type Error = String -type Subst = Map Ident Type +-- type Error = String +-- type Subst = Map Ident Type -type Infer = StateT Env (ReaderT Ctx (ExceptT Error Identity)) +-- type Infer = StateT Env (ReaderT Ctx (ExceptT Error Identity)) -newtype Program = Program [Def] - deriving (C.Eq, C.Ord, C.Show, C.Read) +-- newtype Program = Program [Def] +-- 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 - | ECase Type Exp [Inj] - deriving (C.Eq, C.Ord, C.Read, C.Show) +-- data Exp +-- = EId Id +-- | ELit Type Literal +-- | ELet Bind Exp +-- | EApp Type Exp Exp +-- | EAdd Type Exp Exp +-- | EAbs Type Id Exp +-- | ECase Type Exp [Inj] +-- deriving (C.Eq, C.Ord, C.Read, C.Show) -data Inj = Inj (Init, Type) Exp - deriving (C.Eq, C.Ord, C.Read, C.Show) +-- data Inj = Inj (Init, Type) Exp +-- deriving (C.Eq, C.Ord, C.Read, C.Show) -data Def = DBind Bind | DData Data - deriving (C.Eq, C.Ord, C.Read, C.Show) +-- data Def = DBind Bind | DData Data +-- deriving (C.Eq, C.Ord, C.Read, C.Show) -type Id = (Ident, Type) +-- type Id = (Ident, Type) -data Bind = Bind Id Exp - deriving (C.Eq, C.Ord, C.Show, C.Read) +-- data Bind = Bind Id Exp +-- deriving (C.Eq, C.Ord, C.Show, C.Read) -instance Print [Def] where - prt _ [] = concatD [] - prt _ (x : xs) = concatD [prt 0 x, doc (showString "\n"), prt 0 xs] +-- instance Print [Def] where +-- prt _ [] = concatD [] +-- prt _ (x : xs) = concatD [prt 0 x, doc (showString "\n"), prt 0 xs] -instance Print Def where - prt i (DBind bind) = prt i bind - prt i (DData d) = prt i d +-- instance Print Def where +-- prt i (DBind bind) = prt i bind +-- prt i (DData d) = prt i d -instance Print Program where - prt i (Program sc) = prPrec i 0 $ prt 0 sc +-- instance Print Program where +-- prt i (Program sc) = prPrec i 0 $ prt 0 sc -instance Print Bind where - prt i (Bind (t, name) rhs) = - prPrec i 0 $ - concatD - [ prt 0 name - , doc $ showString ":" - , prt 0 t - , doc $ showString "\n" - , prt 0 name - , doc $ showString "=" - , prt 0 rhs - ] +-- instance Print Bind where +-- prt i (Bind (t, name) rhs) = +-- prPrec i 0 $ +-- concatD +-- [ prt 0 name +-- , doc $ showString ":" +-- , prt 0 t +-- , doc $ showString "\n" +-- , prt 0 name +-- , 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 ";"), doc (showString "\n"), prt 0 xs] +-- instance Print [Bind] where +-- prt _ [] = concatD [] +-- prt _ [x] = concatD [prt 0 x] +-- prt _ (x : xs) = concatD [prt 0 x, doc (showString ";"), doc (showString "\n"), prt 0 xs] -prtIdPs :: Int -> [Id] -> Doc -prtIdPs i = prPrec i 0 . concatD . map (prtIdP i) +-- 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 - ] +-- 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 ")" - ] +-- 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, doc $ showString "\n"] - ELit _ (LInt i1) -> prPrec i 3 $ concatD [prt 0 i1, doc $ showString "\n"] - ELet bs e -> - prPrec i 3 $ - concatD - [ doc $ showString "let" - , prt 0 bs - , doc $ showString "in" - , prt 0 e - , doc $ showString "\n" - ] - EApp _ 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 - , doc $ showString "\n" - ] - EAbs t n e -> - prPrec i 0 $ - concatD - [ doc $ showString "@" - , prt 0 t - , doc $ showString "\\" - , prtId 0 n - , doc $ showString "." - , prt 0 e - , doc $ showString "\n" - ] - ECase t exp injs -> - prPrec - i - 0 - ( concatD - [ doc (showString "case") - , prt 0 exp - , doc (showString "of") - , doc (showString "{") - , prt 0 injs - , doc (showString "}") - , doc (showString ":") - , prt 0 t - , doc $ showString "\n" - ] - ) +-- instance Print Exp where +-- prt i = \case +-- EId n -> prPrec i 3 $ concatD [prtId 0 n, doc $ showString "\n"] +-- ELit _ (LInt i1) -> prPrec i 3 $ concatD [prt 0 i1, doc $ showString "\n"] +-- ELet bs e -> +-- prPrec i 3 $ +-- concatD +-- [ doc $ showString "let" +-- , prt 0 bs +-- , doc $ showString "in" +-- , prt 0 e +-- , doc $ showString "\n" +-- ] +-- EApp _ 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 +-- , doc $ showString "\n" +-- ] +-- EAbs t n e -> +-- prPrec i 0 $ +-- concatD +-- [ doc $ showString "@" +-- , prt 0 t +-- , doc $ showString "\\" +-- , prtId 0 n +-- , doc $ showString "." +-- , prt 0 e +-- , doc $ showString "\n" +-- ] +-- ECase t exp injs -> +-- prPrec +-- i +-- 0 +-- ( concatD +-- [ doc (showString "case") +-- , prt 0 exp +-- , doc (showString "of") +-- , doc (showString "{") +-- , prt 0 injs +-- , doc (showString "}") +-- , doc (showString ":") +-- , prt 0 t +-- , doc $ showString "\n" +-- ] +-- ) -instance Print Inj where - prt i = \case - Inj (init, t) exp -> prPrec i 0 (concatD [prt 0 init, doc (showString ":"), prt 0 t, doc (showString "=>"), prt 0 exp]) +-- instance Print Inj where +-- prt i = \case +-- Inj (init, t) exp -> prPrec i 0 (concatD [prt 0 init, doc (showString ":"), prt 0 t, doc (showString "=>"), prt 0 exp]) -instance Print [Inj] where - prt _ [] = concatD [] - prt _ [x] = concatD [prt 0 x] - prt _ (x : xs) = concatD [prt 0 x, doc (showString ";"), prt 0 xs] +-- instance Print [Inj] where +-- prt _ [] = concatD [] +-- prt _ [x] = concatD [prt 0 x] +-- prt _ (x : xs) = concatD [prt 0 x, doc (showString ";"), prt 0 xs] diff --git a/test_program b/test_program index d916d03..f14962d 100644 --- a/test_program +++ b/test_program @@ -1,24 +1,4 @@ -data Maybe ('a) where { - Nothing : Maybe ('a) - Just : 'a -> Maybe ('a) -}; - -fromJust : Maybe ('a) -> 'a ; -fromJust a = - case a of { - Just a => a - }; - -fromMaybe : 'a -> Maybe ('a) -> 'a ; -fromMaybe a b = - case b of { - Just a => a; - Nothing => a - }; - -maybe : 'b -> ('a -> 'b) -> Maybe ('a) -> 'b; -maybe b f ma = - case ma of { - Just a => f a; - Nothing => b - } +data Maybe (a) where { + Nothing : Maybe (a) + Just : a -> Maybe (a) +} From 914855e20f6389ca52d563f90689963582c73f72 Mon Sep 17 00:00:00 2001 From: sebastianselander Date: Wed, 22 Mar 2023 17:52:39 +0100 Subject: [PATCH 106/372] working on adapting the typechecker --- Grammar.cf | 36 +- src/TypeChecker/TypeChecker.hs | 939 +++++++++++++++---------------- src/TypeChecker/TypeCheckerIr.hs | 335 ++++++----- 3 files changed, 658 insertions(+), 652 deletions(-) diff --git a/Grammar.cf b/Grammar.cf index 356646d..27dfd05 100644 --- a/Grammar.cf +++ b/Grammar.cf @@ -1,12 +1,13 @@ --------------------------------------------------------------------------------- + +------------------------------------------------------------------------------- -- * PROGRAM --------------------------------------------------------------------------------- +------------------------------------------------------------------------------- Program. Program ::= [Def] ; --------------------------------------------------------------------------------- +------------------------------------------------------------------------------- -- * TOP-LEVEL --------------------------------------------------------------------------------- +------------------------------------------------------------------------------- DBind. Def ::= Bind ; DSig. Def ::= Sig ; @@ -16,9 +17,9 @@ Sig. Sig ::= LIdent ":" Type ; Bind. Bind ::= LIdent [LIdent] "=" Exp ; --------------------------------------------------------------------------------- +------------------------------------------------------------------------------- -- * TYPES --------------------------------------------------------------------------------- +------------------------------------------------------------------------------- TLit. Type2 ::= UIdent ; TVar. Type2 ::= TVar ; @@ -30,9 +31,9 @@ internal TEVar. Type1 ::= TEVar ; MkTVar. TVar ::= LIdent ; internal MkTEVar. TEVar ::= LIdent ; --------------------------------------------------------------------------------- +------------------------------------------------------------------------------- -- * DATA TYPES --------------------------------------------------------------------------------- +------------------------------------------------------------------------------- Constructor. Constructor ::= UIdent ":" Type ; @@ -40,12 +41,12 @@ Indexed. Indexed ::= UIdent "(" [Type] ")" ; Data. Data ::= "data" Indexed "where" "{" [Constructor] "}" ; --------------------------------------------------------------------------------- +------------------------------------------------------------------------------- -- * EXPRESSIONS --------------------------------------------------------------------------------- +------------------------------------------------------------------------------- EAnn. Exp5 ::= "(" Exp ":" Type ")" ; -EId. Exp4 ::= LIdent ; +EId. Exp4 ::= Ident ; ELit. Exp4 ::= Lit ; EApp. Exp3 ::= Exp3 Exp4 ; EAdd. Exp1 ::= Exp1 "+" Exp2 ; @@ -53,16 +54,16 @@ ELet. Exp ::= "let" LIdent "=" Exp "in" Exp ; EAbs. Exp ::= "\\" LIdent "." Exp ; ECase. Exp ::= "case" Exp "of" "{" [Inj] "}"; --------------------------------------------------------------------------------- +------------------------------------------------------------------------------- -- * LITERALS --------------------------------------------------------------------------------- +------------------------------------------------------------------------------- LInt. Lit ::= Integer ; LChar. Lit ::= Char ; --------------------------------------------------------------------------------- +------------------------------------------------------------------------------- -- * CASE --------------------------------------------------------------------------------- +------------------------------------------------------------------------------- Inj. Inj ::= Init "=>" Exp ; @@ -70,9 +71,9 @@ InitLit. Init ::= Lit ; InitConstructor. Init ::= UIdent [LIdent] ; InitCatch. Init ::= "_" ; --------------------------------------------------------------------------------- +------------------------------------------------------------------------------- -- * AUX --------------------------------------------------------------------------------- +------------------------------------------------------------------------------- separator Def ";" ; separator nonempty Constructor "" ; @@ -80,6 +81,7 @@ separator Type " " ; separator nonempty Inj ";" ; separator Ident " "; separator LIdent " "; +separator TVar " " ; coercions Exp 5 ; coercions Type 2 ; diff --git a/src/TypeChecker/TypeChecker.hs b/src/TypeChecker/TypeChecker.hs index 4e072d2..4b9269d 100644 --- a/src/TypeChecker/TypeChecker.hs +++ b/src/TypeChecker/TypeChecker.hs @@ -4,543 +4,518 @@ -- | A module for type checking and inference using algorithm W, Hindley-Milner module TypeChecker.TypeChecker where --- import Control.Monad.Except --- import Control.Monad.Reader --- import Control.Monad.State --- import Data.Bifunctor (second) --- import Data.Foldable (traverse_) --- import Data.Functor.Identity (runIdentity) --- import Data.List (foldl') --- import Data.List.Extra (unsnoc) --- import Data.Map (Map) --- import Data.Map qualified as M --- import Data.Maybe (fromMaybe) --- import Data.Set (Set) --- import Data.Set qualified as S --- import Debug.Trace (trace) --- import Grammar.Abs --- import Grammar.Print (printTree) --- import TypeChecker.TypeCheckerIr ( --- Ctx (..), --- Env (..), --- Error, --- Infer, --- Poly (..), --- Subst, --- ) --- import TypeChecker.TypeCheckerIr qualified as T +import Control.Monad.Except +import Control.Monad.Reader +import Control.Monad.State +import Data.Bifunctor (second) +import Data.Coerce (coerce) +import Data.Foldable (traverse_) +import Data.Functor.Identity (runIdentity) +import Data.List (foldl') +import Data.List.Extra (unsnoc) +import Data.Map (Map) +import Data.Map qualified as M +import Data.Maybe (fromMaybe) +import Data.Set (Set) +import Data.Set qualified as S +import Debug.Trace (trace) +import Grammar.Abs +import Grammar.Print (printTree) +import TypeChecker.TypeCheckerIr ( + Ctx (..), + Env (..), + Error, + Infer, + Poly (..), + Subst, + ) +import TypeChecker.TypeCheckerIr qualified as T --- initCtx = Ctx mempty +initCtx = Ctx mempty --- initEnv = Env 0 mempty mempty +initEnv = Env 0 mempty mempty --- runPretty :: Exp -> Either Error String --- runPretty = fmap (printTree . fst) . run . inferExp +runPretty :: Exp -> Either Error String +runPretty = fmap (printTree . fst) . run . inferExp --- run :: Infer a -> Either Error a --- run = runC initEnv initCtx +run :: Infer a -> Either Error a +run = runC initEnv initCtx --- runC :: Env -> Ctx -> Infer a -> Either Error a --- runC e c = runIdentity . runExceptT . flip runReaderT c . flip evalStateT e +runC :: Env -> Ctx -> Infer a -> Either Error a +runC e c = runIdentity . runExceptT . flip runReaderT c . flip evalStateT e --- typecheck :: Program -> Either Error T.Program --- typecheck = run . checkPrg +typecheck :: Program -> Either Error T.Program +typecheck = run . checkPrg --- {- | Start by freshening the type variable of data types to avoid clash with --- other user defined polymorphic types --- -} --- freshenData :: Data -> Infer Data --- freshenData (Data (Constr name ts) constrs) = do --- let xs = (S.toList . free) =<< ts --- frs <- traverse (const fresh) xs --- let m = M.fromList $ zip xs frs --- return $ --- Data --- (Constr name (map (freshenType m) ts)) --- ( map --- ( \(Constructor ident t) -> --- Constructor ident (freshenType m t) --- ) --- constrs --- ) +checkData :: Data -> Infer () +checkData d = do + case d of + (Data typ@(Indexed name ts) constrs) -> do + unless + (all isPoly ts) + (throwError $ unwords ["Data type incorrectly declared"]) + traverse_ + ( \(Constructor name' t') -> + if TIndexed typ == retType t' + then insertConstr name' t' + else + throwError $ + unwords + [ "return type of constructor:" + , printTree name + , "with type:" + , printTree (retType t') + , "does not match data: " + , printTree typ + ] + ) + constrs --- {- | Freshen all polymorphic variables, regardless of name +retType :: Type -> Type +retType (TFun _ t2) = retType t2 +retType a = a -{- | freshenType "d" (a -> b -> c) becomes (d -> d -> d) --\} -freshenType :: Map Ident Type -> Type -> Type -freshenType m t = case t of - TPol poly -> fromMaybe (error "bug in \'free\'") (M.lookup poly m) - TMono mono -> TMono mono - TArr t1 t2 -> TArr (freshenType m t1) (freshenType m t2) - TConstr (Constr ident ts) -> TConstr (Constr ident (map (freshenType m) ts)) +checkPrg :: Program -> Infer T.Program +checkPrg (Program bs) = do + preRun bs + bs' <- checkDef bs + return $ T.Program bs' + where + preRun :: [Def] -> Infer () + preRun [] = return () + preRun (x : xs) = case x of + -- TODO: Check for no overlapping signature definitions + DSig (Sig n t) -> insertSig n t >> preRun xs + DBind (Bind{}) -> preRun xs + DData d@(Data _ _) -> checkData d >> preRun xs + + checkDef :: [Def] -> Infer [T.Def] + checkDef [] = return [] + checkDef (x : xs) = case x of + (DBind b) -> do + b' <- checkBind b + fmap (T.DBind b' :) (checkDef xs) + (DData d) -> fmap (T.DData d :) (checkDef xs) + (DSig _) -> checkDef xs + +checkBind :: Bind -> Infer T.Bind +checkBind (Bind name args e) = do + let lambda = makeLambda e (reverse args) + e@(_, t') <- inferExp lambda + -- TODO: Check for match against existing signatures + return $ T.Bind (coerce name, t') [] e -- (apply s e) + where + makeLambda :: Exp -> [LIdent] -> Exp + makeLambda = foldl (flip EAbs) + +{- | Check if two types are considered equal + For the purpose of the algorithm two polymorphic types are always considered + equal -} +typeEq :: Type -> Type -> Bool +typeEq (TFun l r) (TFun l' r') = typeEq l l' && typeEq r r' +typeEq (TLit a) (TLit b) = a == b +typeEq (TIndexed (Indexed name a)) (TIndexed (Indexed name' b)) = + length a == length b + && name == name' + && and (zipWith typeEq a b) +typeEq (TAll n1 t1) (TAll n2 t2) = t1 `typeEq` t2 +typeEq _ _ = False --- checkData :: Data -> Infer () --- checkData d = do --- d' <- freshenData d --- case d' of --- (Data typ@(Constr name ts) constrs) -> do --- unless --- (all isPoly ts) --- (throwError $ unwords ["Data type incorrectly declared"]) --- traverse_ --- ( \(Constructor name' t') -> --- if TConstr typ == retType t' --- then insertConstr name' t' --- else --- throwError $ --- unwords --- [ "return type of constructor:" --- , printTree name --- , "with type:" --- , printTree (retType t') --- , "does not match data: " --- , printTree typ --- ] --- ) --- constrs +isMoreSpecificOrEq :: T.Type -> T.Type -> Bool +isMoreSpecificOrEq _ (T.TAll _ _) = True +isMoreSpecificOrEq (T.TFun a b) (T.TFun c d) = + isMoreSpecificOrEq a c && isMoreSpecificOrEq b d +isMoreSpecificOrEq (T.TIndexed (T.Indexed n1 ts1)) (T.TIndexed (T.Indexed n2 ts2)) = + n1 == n2 + && length ts1 == length ts2 + && and (zipWith isMoreSpecificOrEq ts1 ts2) +isMoreSpecificOrEq a b = a == b --- retType :: Type -> Type --- retType (TArr _ t2) = retType t2 --- retType a = a +isPoly :: Type -> Bool +isPoly (TAll _ _) = True +isPoly _ = False --- checkPrg :: Program -> Infer T.Program --- checkPrg (Program bs) = do --- preRun bs --- bs' <- checkDef bs --- return $ T.Program bs' --- where --- preRun :: [Def] -> Infer () --- preRun [] = return () --- preRun (x : xs) = case x of --- DBind (Bind n t _ _ _) -> insertSig n t >> preRun xs --- DData d@(Data _ _) -> checkData d >> preRun xs +inferExp :: Exp -> Infer T.ExpT +inferExp e = do + (s, t, e') <- algoW e + let subbed = apply s t + return $ replace subbed (e', t) --- checkDef :: [Def] -> Infer [T.Def] --- checkDef [] = return [] --- checkDef (x : xs) = case x of --- (DBind b) -> do --- b' <- checkBind b --- fmap (T.DBind b' :) (checkDef xs) --- (DData d) -> do --- d' <- freshenData d --- fmap (T.DData d' :) (checkDef xs) +replace :: T.Type -> T.ExpT -> T.ExpT +replace t = second (const t) --- checkBind :: Bind -> Infer T.Bind --- checkBind (Bind n t _ args e) = do --- let lambda = makeLambda e (reverse args) --- (t', e) <- inferExp lambda --- s <- unify t' t --- let t'' = apply s t --- unless --- (t `typeEq` t'') --- ( throwError $ --- unwords --- [ "Top level signature" --- , printTree t --- , "does not match body with inferred type:" --- , printTree t'' --- ] --- ) --- return $ T.Bind (n, t) (apply s e) --- where --- makeLambda :: Exp -> [Ident] -> Exp --- makeLambda = foldl (flip EAbs) +class NewType a b where + toNew :: a -> b --- {- | Check if two types are considered equal --- For the purpose of the algorithm two polymorphic types are always considered --- equal --- -} --- typeEq :: Type -> Type -> Bool --- typeEq (TArr l r) (TArr l' r') = typeEq l l' && typeEq r r' --- typeEq (TMono a) (TMono b) = a == b --- typeEq (TConstr (Constr name a)) (TConstr (Constr name' b)) = --- length a == length b --- && name == name' --- && and (zipWith typeEq a b) --- typeEq (TPol _) (TPol _) = True --- typeEq _ _ = False +instance NewType Type T.Type where + toNew = \case + TLit i -> T.TLit $ coerce i + TVar v -> T.TVar v + TFun t1 t2 -> T.TFun (toNew t1) (toNew t2) + TAll b t -> T.TAll b (toNew t) + TIndexed i -> T.TIndexed (toNew i) + TEVar _ -> error "Should not exist after typechecker" --- isMoreSpecificOrEq :: Type -> Type -> Bool --- isMoreSpecificOrEq _ (TPol _) = True --- isMoreSpecificOrEq (TArr a b) (TArr c d) = --- isMoreSpecificOrEq a c && isMoreSpecificOrEq b d --- isMoreSpecificOrEq (TConstr (Constr n1 ts1)) (TConstr (Constr n2 ts2)) = --- n1 == n2 --- && length ts1 == length ts2 --- && and (zipWith isMoreSpecificOrEq ts1 ts2) --- isMoreSpecificOrEq a b = a == b +instance NewType Indexed T.Indexed where + toNew (Indexed name vars) = T.Indexed (coerce name) (map toNew vars) --- isPoly :: Type -> Bool --- isPoly (TPol _) = True --- isPoly _ = False +algoW :: Exp -> Infer (Subst, T.ExpT) +algoW = \case + -- \| TODO: More testing need to be done. Unsure of the correctness of this + EAnn e t -> do + (s1, (e', t')) <- algoW e + unless + (toNew t `isMoreSpecificOrEq` t') + ( throwError $ + unwords + [ "Annotated type:" + , printTree t + , "does not match inferred type:" + , printTree t' + ] + ) + applySt s1 $ do + s2 <- unify (toNew t) t' + let comp = s2 `compose` s1 + return (comp, (apply comp e', toNew t)) --- inferExp :: Exp -> Infer (Type, T.Exp) --- inferExp e = do --- (s, t, e') <- algoW e --- let subbed = apply s t --- return (subbed, replace subbed e') + -- \| ------------------ + -- \| Γ ⊢ i : Int, ∅ --- replace :: Type -> T.Exp -> T.Exp --- replace t = \case --- T.ELit _ e -> T.ELit t e --- T.EId (n, _) -> T.EId (n, t) --- T.EAbs _ name e -> T.EAbs t name e --- T.EApp _ e1 e2 -> T.EApp t e1 e2 --- T.EAdd _ e1 e2 -> T.EAdd t e1 e2 --- T.ELet (T.Bind (n, _) e1) e2 -> T.ELet (T.Bind (n, t) e1) e2 --- T.ECase _ expr injs -> T.ECase t expr injs + ELit lit -> + let lt = toNew $ litType lit + in return (nullSubst, (T.ELit lt lit, lt)) + -- \| x : σ ∈ Γ   τ = inst(σ) + -- \| ---------------------- + -- \| Γ ⊢ x : τ, ∅ --- algoW :: Exp -> Infer (Subst, Type, T.Exp) --- algoW = \case --- -- \| TODO: More testing need to be done. Unsure of the correctness of this --- EAnn e t -> do --- (s1, t', e') <- algoW e --- unless --- (t `isMoreSpecificOrEq` t') --- ( throwError $ --- unwords --- [ "Annotated type:" --- , printTree t --- , "does not match inferred type:" --- , printTree t' --- ] --- ) --- applySt s1 $ do --- s2 <- unify t t' --- let comp = s2 `compose` s1 --- return (comp, t, apply comp e') + EId i -> do + var <- asks vars + case M.lookup i var of + Just t -> inst (toNew t) >>= \x -> return (nullSubst, x, T.EId (i, x)) + Nothing -> do + sig <- gets sigs + case M.lookup i sig of + Just t -> return (nullSubst, toNew t, T.EId (i, toNew t)) + Nothing -> do + constr <- gets constructors + case M.lookup i constr of + Just t -> return (nullSubst, toNew t, T.EId (i, toNew t)) + Nothing -> + throwError $ + "Unbound variable: " ++ show i --- -- \| ------------------ --- -- \| Γ ⊢ i : Int, ∅ + -- \| τ = newvar Γ, x : τ ⊢ e : τ', S + -- \| --------------------------------- + -- \| Γ ⊢ w λx. e : Sτ → τ', S --- ELit lit -> --- let lt = litType lit --- in return (nullSubst, lt, T.ELit lt lit) --- -- \| x : σ ∈ Γ   τ = inst(σ) --- -- \| ---------------------- --- -- \| Γ ⊢ x : τ, ∅ + EAbs name e -> do + fr <- fresh + withBinding (coerce name) (Forall [] (toNew fr)) $ do + (s1, t', e') <- algoW e + let varType = toNew $ apply s1 fr + let newArr = T.TFun varType (toNew t') + return (s1, newArr, apply s1 $ T.EAbs newArr (coerce name, varType) (e', newArr)) --- EId i -> do --- var <- asks vars --- case M.lookup i var of --- Just t -> inst t >>= \x -> return (nullSubst, x, T.EId (i, x)) --- Nothing -> do --- sig <- gets sigs --- case M.lookup i sig of --- Just t -> return (nullSubst, t, T.EId (i, t)) --- Nothing -> do --- constr <- gets constructors --- case M.lookup i constr of --- Just t -> return (nullSubst, t, T.EId (i, t)) --- Nothing -> --- throwError $ --- "Unbound variable: " ++ show i + -- \| Γ ⊢ e₀ : τ₀, S₀ S₀Γ ⊢ e₁ : τ₁, S₁ + -- \| s₂ = mgu(s₁τ₀, Int) s₃ = mgu(s₂τ₁, Int) + -- \| ------------------------------------------ + -- \| Γ ⊢ e₀ + e₁ : Int, S₃S₂S₁S₀ + -- This might be wrong --- -- \| τ = newvar Γ, x : τ ⊢ e : τ', S --- -- \| --------------------------------- --- -- \| Γ ⊢ w λx. e : Sτ → τ', S + EAdd e0 e1 -> do + (s1, t0, e0') <- algoW e0 + applySt s1 $ do + (s2, t1, e1') <- algoW e1 + -- applySt s2 $ do + s3 <- unify (apply s2 t0) (T.TLit "Int") + s4 <- unify (apply s3 t1) (T.TLit "Int") + let comp = s4 `compose` s3 `compose` s2 `compose` s1 + return + ( comp + , T.TLit "Int" + , apply comp $ T.EAdd (T.TLit "Int") (e0', t0) (e1', t1) + ) --- EAbs name e -> do --- fr <- fresh --- withBinding name (Forall [] fr) $ do --- (s1, t', e') <- algoW e --- let varType = apply s1 fr --- let newArr = TArr varType t' --- return (s1, newArr, apply s1 $ T.EAbs newArr (name, varType) e') + -- \| Γ ⊢ e₀ : τ₀, S₀ S₀Γ ⊢ e₁ : τ₁, S1 + -- \| τ' = newvar S₂ = mgu(S₁τ₀, τ₁ → τ') + -- \| -------------------------------------- + -- \| Γ ⊢ e₀ e₁ : S₂τ', S₂S₁S₀ --- -- \| Γ ⊢ e₀ : τ₀, S₀ S₀Γ ⊢ e₁ : τ₁, S₁ --- -- \| s₂ = mgu(s₁τ₀, Int) s₃ = mgu(s₂τ₁, Int) --- -- \| ------------------------------------------ --- -- \| Γ ⊢ e₀ + e₁ : Int, S₃S₂S₁S₀ --- -- This might be wrong + EApp e0 e1 -> do + fr <- toNew <$> fresh + (s0, t0, e0') <- algoW e0 + applySt s0 $ do + (s1, t1, e1') <- algoW e1 + -- applySt s1 $ do + s2 <- unify (apply s1 t0) (T.TFun (toNew t1) fr) + let t = apply s2 fr + let comp = s2 `compose` s1 `compose` s0 + return (comp, t, apply comp $ T.EApp t (e0', t0) (e1', t1)) --- EAdd e0 e1 -> do --- (s1, t0, e0') <- algoW e0 --- applySt s1 $ do --- (s2, t1, e1') <- algoW e1 --- -- applySt s2 $ do --- s3 <- unify (apply s2 t0) (TMono "Int") --- s4 <- unify (apply s3 t1) (TMono "Int") --- let comp = s4 `compose` s3 `compose` s2 `compose` s1 --- return --- ( comp --- , TMono "Int" --- , apply comp $ T.EAdd (TMono "Int") e0' e1' --- ) + -- \| Γ ⊢ e₀ : τ, S₀ S₀Γ, x : S̅₀Γ̅(τ) ⊢ e₁ : τ', S₁ + -- \| ---------------------------------------------- + -- \| Γ ⊢ let x = e₀ in e₁ : τ', S₁S₀ --- -- \| Γ ⊢ e₀ : τ₀, S₀ S₀Γ ⊢ e₁ : τ₁, S1 --- -- \| τ' = newvar S₂ = mgu(S₁τ₀, τ₁ → τ') --- -- \| -------------------------------------- --- -- \| Γ ⊢ e₀ e₁ : S₂τ', S₂S₁S₀ + -- The bar over S₀ and Γ means "generalize" --- EApp e0 e1 -> do --- fr <- fresh --- (s0, t0, e0') <- algoW e0 --- applySt s0 $ do --- (s1, t1, e1') <- algoW e1 --- -- applySt s1 $ do --- s2 <- unify (apply s1 t0) (TArr t1 fr) --- let t = apply s2 fr --- let comp = s2 `compose` s1 `compose` s0 --- return (comp, t, apply comp $ T.EApp t e0' e1') + ELet name e0 e1 -> do + (s1, t1, e0') <- algoW e0 + env <- asks vars + let t' = generalize (apply s1 env) t1 + withBinding name t' $ do + (s2, t2, e1') <- algoW e1 + let comp = s2 `compose` s1 + return (comp, t2, apply comp $ T.ELet (T.Bind (name, t2) e0') e1') + ECase caseExpr injs -> do + (sub, t, e') <- algoW caseExpr + (subst, injs, ret_t) <- checkCase t injs + let comp = subst `compose` sub + let t' = apply comp ret_t + return (comp, t', T.ECase t' e' injs) --- -- \| Γ ⊢ e₀ : τ, S₀ S₀Γ, x : S̅₀Γ̅(τ) ⊢ e₁ : τ', S₁ --- -- \| ---------------------------------------------- --- -- \| Γ ⊢ let x = e₀ in e₁ : τ', S₁S₀ +-- | Unify two types producing a new substitution +unify :: T.Type -> T.Type -> Infer Subst +unify t0 t1 = do + case (t0, t1) of + (T.TFun a b, T.TFun c d) -> do + s1 <- unify a c + s2 <- unify (apply s1 b) (apply s1 d) + return $ s1 `compose` s2 + (T.TVar t, b) -> occurs b t + (a, T.TVar t) -> occurs a t + (T.TAll _ t, b) -> unify t b + (a, T.TAll _ t) -> unify a t + (T.TLit a, T.TLit b) -> + if a == b then return M.empty else throwError "Types do not unify" + (T.TIndexed (T.Indexed name t), T.TIndexed (T.Indexed name' t')) -> + if name == name' && length t == length t' + then do + xs <- zipWithM unify t t' + return $ foldr compose nullSubst xs + else + throwError $ + unwords + [ "T.Type constructor:" + , printT . Tree name + , "(" ++ printT . Tree t ++ ")" + , "does not match with:" + , printT . Tree name' + , "(" ++ printT . Tree t' ++ ")" + ] + (a, b) -> do + ctx <- ask + env <- get + throwError . unwords $ + [ "T.Type:" + , printT . Tree a + , "can't be unified with:" + , printT . Tree b + , "\nCtx:" + , show ctx + , "\nEnv:" + , show env + ] --- -- The bar over S₀ and Γ means "generalize" +{- | Check if a type is contained in another type. +I.E. { a = a -> b } is an unsolvable constraint since there is no substitution +where these are equal +-} +occurs :: LIdent -> T.Type -> Infer Subst +occurs i t@(T.TVar _) = return (M.singleton i t) +occurs i t = + if S.member i (free t) + then + throwError $ + unwords + [ "Occurs check failed, can't unify" + , printTree (TVar $ MkTVar i) + , "with" + , printTree t + ] + else return $ M.singleton i t --- ELet name e0 e1 -> do --- (s1, t1, e0') <- algoW e0 --- env <- asks vars --- let t' = generalize (apply s1 env) t1 --- withBinding name t' $ do --- (s2, t2, e1') <- algoW e1 --- let comp = s2 `compose` s1 --- return (comp, t2, apply comp $ T.ELet (T.Bind (name, t2) e0') e1') --- ECase caseExpr injs -> do --- (sub, t, e') <- algoW caseExpr --- (subst, injs, ret_t) <- checkCase t injs --- let comp = subst `compose` sub --- let t' = apply comp ret_t --- return (comp, t', T.ECase t' e' injs) +-- | Generalize a type over all free variables in the substitution set +generalize :: Map Ident Poly -> Type -> Poly +generalize env t = Forall (S.toList $ free t S.\\ free env) t --- -- | Unify two types producing a new substitution --- unify :: Type -> Type -> Infer Subst --- unify t0 t1 = do --- case (t0, t1) of --- (TArr a b, TArr c d) -> do --- s1 <- unify a c --- s2 <- unify (apply s1 b) (apply s1 d) --- return $ s1 `compose` s2 --- (TPol a, b) -> occurs a b --- (a, TPol b) -> occurs b a --- (TMono a, TMono b) -> --- if a == b then return M.empty else throwError "Types do not unify" --- (TConstr (Constr name t), TConstr (Constr name' t')) -> --- if name == name' && length t == length t' --- then do --- xs <- zipWithM unify t t' --- return $ foldr compose nullSubst xs --- else --- throwError $ --- unwords --- [ "Type constructor:" --- , printTree name --- , "(" ++ printTree t ++ ")" --- , "does not match with:" --- , printTree name' --- , "(" ++ printTree t' ++ ")" --- ] --- (a, b) -> do --- ctx <- ask --- env <- get --- throwError . unwords $ --- [ "Type:" --- , printTree a --- , "can't be unified with:" --- , printTree b --- , "\nCtx:" --- , show ctx --- , "\nEnv:" --- , show env --- ] +{- | Instantiate a polymorphic type. The free type variables are substituted +with fresh ones. +-} +inst :: T.Type -> Infer T.Type +inst = \case + T.TAll bound t -> do + fr <- fresh + let s = M.singleton fr bound + apply s <$> inst t + _ -> undefined --- {- | Check if a type is contained in another type. --- I.E. { a = a -> b } is an unsolvable constraint since there is no substitution --- where these are equal --- -} --- occurs :: Ident -> Type -> Infer Subst --- occurs i t@(TPol _) = return (M.singleton i t) --- occurs i t = --- if S.member i (free t) --- then --- throwError $ --- unwords --- [ "Occurs check failed, can't unify" --- , printTree (TPol i) --- , "with" --- , printTree t --- ] --- else return $ M.singleton i t +-- | Compose two substitution sets +compose :: Subst -> Subst -> Subst +compose m1 m2 = M.map (apply m1) m2 `M.union` m1 --- -- | Generalize a type over all free variables in the substitution set --- generalize :: Map Ident Poly -> Type -> Poly --- generalize env t = Forall (S.toList $ free t S.\\ free env) t +-- TODO: Split this class into two separate classes, one for free variables +-- and one for applying substitutions --- {- | Instantiate a polymorphic type. The free type variables are substituted --- with fresh ones. --- -} --- inst :: Poly -> Infer Type --- inst (Forall xs t) = do --- xs' <- mapM (const fresh) xs --- let s = M.fromList $ zip xs xs' --- return $ apply s t +-- | A class representing free variables functions +class FreeVars t where + -- | Get all free variables from t + free :: t -> Set LIdent --- -- | Compose two substitution sets --- compose :: Subst -> Subst -> Subst --- compose m1 m2 = M.map (apply m1) m2 `M.union` m1 + -- | Apply a substitution to t + apply :: Subst -> t -> t --- -- TODO: Split this class into two separate classes, one for free variables --- -- and one for applying substitutions +instance FreeVars T.Type where + free :: T.Type -> Set LIdent + free (T.TVar (MkTVar a)) = S.singleton a + free (T.TAll (MkTVar bound) t) = (S.singleton bound) `S.intersection` free t + free (T.TLit _) = mempty + free (T.TFun a b) = free a `S.union` free b + -- \| Not guaranteed to be correct + free (T.TIndexed (T.Indexed _ a)) = + foldl' (\acc x -> free x `S.union` acc) S.empty a --- -- | A class representing free variables functions --- class FreeVars t where --- -- | Get all free variables from t --- free :: t -> Set Ident + apply :: Subst -> T.Type -> T.Type + apply sub t = do + case t of + T.TLit a -> T.TLit a + T.TVar (MkTVar a) -> case M.lookup a sub of + Nothing -> T.TVar (MkTVar a) + Just t -> t + T.TAll bound t -> undefined + T.TFun a b -> T.TFun (apply sub a) (apply sub b) + T.TIndexed (T.Indexed name a) -> T.TIndexed (T.Indexed name (map (apply sub) a)) --- -- | Apply a substitution to t --- apply :: Subst -> t -> t +instance FreeVars Poly where + free :: Poly -> Set LIdent + free (Forall xs t) = free t S.\\ S.fromList xs + apply :: Subst -> Poly -> Poly + apply s (Forall xs t) = Forall xs (apply (foldr M.delete s xs) t) --- instance FreeVars Type where --- free :: Type -> Set Ident --- free (TPol a) = S.singleton a --- free (TMono _) = mempty --- free (TArr a b) = free a `S.union` free b --- -- \| Not guaranteed to be correct --- free (TConstr (Constr _ a)) = --- foldl' (\acc x -> free x `S.union` acc) S.empty a +instance FreeVars (Map LIdent Poly) where + free :: Map LIdent Poly -> Set LIdent + free m = foldl' S.union S.empty (map free $ M.elems m) + apply :: Subst -> Map LIdent Poly -> Map LIdent Poly + apply s = M.map (apply s) --- apply :: Subst -> Type -> Type --- apply sub t = do --- case t of --- TMono a -> TMono a --- TPol a -> case M.lookup a sub of --- Nothing -> TPol a --- Just t -> t --- TArr a b -> TArr (apply sub a) (apply sub b) --- TConstr (Constr name a) -> TConstr (Constr name (map (apply sub) a)) +instance FreeVars T.Exp where + free :: T.Exp -> Set LIdent + free = error "free not implemented for T.Exp" + apply :: Subst -> T.Exp -> T.Exp + apply s = \case + T.EId (ident, t) -> + T.EId (ident, apply s t) + T.ELit t lit -> + T.ELit (apply s t) lit + T.ELet (T.Bind (ident, t) args e1) e2 -> + T.ELet (T.Bind (ident, apply s t) args (apply s e1)) (apply s e2) + T.EApp t e1 e2 -> + T.EApp (apply s t) (apply s e1) (apply s e2) + T.EAdd t e1 e2 -> + T.EAdd (apply s t) (apply s e1) (apply s e2) + T.EAbs t1 (ident, t2) e -> + T.EAbs (apply s t1) (ident, apply s t2) (apply s e) + T.ECase t e injs -> + T.ECase (apply s t) (apply s e) (apply s injs) --- instance FreeVars Poly where --- free :: Poly -> Set Ident --- free (Forall xs t) = free t S.\\ S.fromList xs --- apply :: Subst -> Poly -> Poly --- apply s (Forall xs t) = Forall xs (apply (foldr M.delete s xs) t) +instance FreeVars T.Inj where + free :: T.Inj -> Set LIdent + free = undefined + apply :: Subst -> T.Inj -> T.Inj + apply s (T.Inj (i, t) e) = T.Inj (i, apply s t) (apply s e) --- instance FreeVars (Map Ident Poly) where --- free :: Map Ident Poly -> Set Ident --- free m = foldl' S.union S.empty (map free $ M.elems m) --- apply :: Subst -> Map Ident Poly -> Map Ident Poly --- apply s = M.map (apply s) +instance FreeVars [T.Inj] where + free :: [T.Inj] -> Set LIdent + free = foldl' (\acc x -> free x `S.union` acc) mempty + apply s = map (apply s) --- instance FreeVars T.Exp where --- free :: T.Exp -> Set Ident --- free = error "free not implemented for T.Exp" --- apply :: Subst -> T.Exp -> T.Exp --- apply s = \case --- T.EId (ident, t) -> --- T.EId (ident, apply s t) --- T.ELit t lit -> --- T.ELit (apply s t) lit --- T.ELet (T.Bind (ident, t) e1) e2 -> --- T.ELet (T.Bind (ident, apply s t) (apply s e1)) (apply s e2) --- T.EApp t e1 e2 -> --- T.EApp (apply s t) (apply s e1) (apply s e2) --- T.EAdd t e1 e2 -> --- T.EAdd (apply s t) (apply s e1) (apply s e2) --- T.EAbs t1 (ident, t2) e -> --- T.EAbs (apply s t1) (ident, apply s t2) (apply s e) --- T.ECase t e injs -> --- T.ECase (apply s t) (apply s e) (apply s injs) +-- | Apply substitutions to the environment. +applySt :: Subst -> Infer a -> Infer a +applySt s = local (\st -> st{vars = apply s (vars st)}) --- instance FreeVars T.Inj where --- free :: T.Inj -> Set Ident --- free = undefined --- apply :: Subst -> T.Inj -> T.Inj --- apply s (T.Inj (i, t) e) = T.Inj (i, apply s t) (apply s e) +-- | Represents the empty substition set +nullSubst :: Subst +nullSubst = M.empty --- instance FreeVars [T.Inj] where --- free :: [T.Inj] -> Set Ident --- free = foldl' (\acc x -> free x `S.union` acc) mempty --- apply s = map (apply s) +-- | Generate a new fresh variable and increment the state counter +fresh :: Infer Type +fresh = do + n <- gets count + modify (\st -> st{count = n + 1}) + return . TVar . MkTVar . LIdent $ show n --- -- | Apply substitutions to the environment. --- applySt :: Subst -> Infer a -> Infer a --- applySt s = local (\st -> st{vars = apply s (vars st)}) +-- | Run the monadic action with an additional binding +withBinding :: (Monad m, MonadReader Ctx m) => Ident -> Poly -> m a -> m a +withBinding i p = local (\st -> st{vars = M.insert i p (vars st)}) --- -- | Represents the empty substition set --- nullSubst :: Subst --- nullSubst = M.empty +-- | Run the monadic action with several additional bindings +withBindings :: (Monad m, MonadReader Ctx m) => [(Ident, Poly)] -> m a -> m a +withBindings xs = + local (\st -> st{vars = foldl' (flip (uncurry M.insert)) (vars st) xs}) --- -- | Generate a new fresh variable and increment the state counter --- fresh :: Infer Type --- fresh = do --- n <- gets count --- modify (\st -> st{count = n + 1}) --- return . TPol . Ident $ show n +-- | Insert a function signature into the environment +insertSig :: LIdent -> Type -> Infer () +insertSig i t = modify (\st -> st{sigs = M.insert i t (sigs st)}) --- -- | Run the monadic action with an additional binding --- withBinding :: (Monad m, MonadReader Ctx m) => Ident -> Poly -> m a -> m a --- withBinding i p = local (\st -> st{vars = M.insert i p (vars st)}) +-- | Insert a constructor with its data type +insertConstr :: UIdent -> Type -> Infer () +insertConstr i t = + modify (\st -> st{constructors = M.insert i t (constructors st)}) --- -- | Run the monadic action with several additional bindings --- withBindings :: (Monad m, MonadReader Ctx m) => [(Ident, Poly)] -> m a -> m a --- withBindings xs = --- local (\st -> st{vars = foldl' (flip (uncurry M.insert)) (vars st) xs}) +-------- PATTERN MATCHING --------- --- -- | Insert a function signature into the environment --- insertSig :: Ident -> Type -> Infer () --- insertSig i t = modify (\st -> st{sigs = M.insert i t (sigs st)}) +checkCase :: Type -> [Inj] -> Infer (Subst, [T.Inj], Type) +checkCase expT injs = do + (injTs, injs, returns) <- unzip3 <$> mapM checkInj injs + (sub1, _) <- + foldM + ( \(sub, acc) x -> + (\a -> (a `compose` sub, a `apply` acc)) <$> unify x acc + ) + (nullSubst, expT) + injTs + (sub2, returns_type) <- + foldM + ( \(sub, acc) x -> + (\a -> (a `compose` sub, a `apply` acc)) <$> unify x acc + ) + (nullSubst, head returns) + (tail returns) + return (sub2 `compose` sub1, injs, returns_type) --- -- | Insert a constructor with its data type --- insertConstr :: Ident -> Type -> Infer () --- insertConstr i t = --- modify (\st -> st{constructors = M.insert i t (constructors st)}) +{- | fst = type of init + | snd = type of expr +-} +checkInj :: Inj -> Infer (Type, T.Inj, Type) +checkInj (Inj it expr) = do + (initT, vars) <- inferInit it + let converted = map (second (Forall [])) vars + (exprT, e) <- withBindings converted (inferExp expr) + return (initT, T.Inj (it, initT) e, exprT) --- -------- PATTERN MATCHING --------- +inferInit :: Init -> Infer (Type, [T.Id]) +inferInit = \case + InitLit lit -> return (litType lit, mempty) + InitConstructor fn vars -> do + gets (M.lookup fn . constructors) >>= \case + Nothing -> + throwError $ + "Constructor: " ++ printTree fn ++ " does not exist" + Just a -> do + case unsnoc $ flattenType a of + Nothing -> throwError "Partial pattern match not allowed" + Just (vs, ret) -> + case length vars `compare` length vs of + EQ -> do + return (ret, zip vars vs) + _ -> throwError "Partial pattern match not allowed" + InitCatch -> (,mempty) <$> fresh --- checkCase :: Type -> [Inj] -> Infer (Subst, [T.Inj], Type) --- checkCase expT injs = do --- (injTs, injs, returns) <- unzip3 <$> mapM checkInj injs --- (sub1, _) <- --- foldM --- ( \(sub, acc) x -> --- (\a -> (a `compose` sub, a `apply` acc)) <$> unify x acc --- ) --- (nullSubst, expT) --- injTs --- (sub2, returns_type) <- --- foldM --- ( \(sub, acc) x -> --- (\a -> (a `compose` sub, a `apply` acc)) <$> unify x acc --- ) --- (nullSubst, head returns) --- (tail returns) --- return (sub2 `compose` sub1, injs, returns_type) +flattenType :: Type -> [Type] +flattenType (TFun a b) = flattenType a ++ flattenType b +flattenType a = [a] --- {- | fst = type of init --- | snd = type of expr --- -} --- checkInj :: Inj -> Infer (Type, T.Inj, Type) --- checkInj (Inj it expr) = do --- (initT, vars) <- inferInit it --- let converted = map (second (Forall [])) vars --- (exprT, e) <- withBindings converted (inferExp expr) --- return (initT, T.Inj (it, initT) e, exprT) - --- inferInit :: Init -> Infer (Type, [T.Id]) --- inferInit = \case --- InitLit lit -> return (litType lit, mempty) --- InitConstr fn vars -> do --- gets (M.lookup fn . constructors) >>= \case --- Nothing -> --- throwError $ --- "Constructor: " ++ printTree fn ++ " does not exist" --- Just a -> do --- case unsnoc $ flattenType a of --- Nothing -> throwError "Partial pattern match not allowed" --- Just (vs, ret) -> --- case length vars `compare` length vs of --- EQ -> do --- return (ret, zip vars vs) --- _ -> throwError "Partial pattern match not allowed" --- InitCatch -> (,mempty) <$> fresh - --- flattenType :: Type -> [Type] --- flattenType (TArr a b) = flattenType a ++ flattenType b --- flattenType a = [a] - --- litType :: Literal -> Type --- litType (LInt _) = TMono "Int" +litType :: Lit -> Type +litType (LInt _) = TLit "Int" +litType (LChar _) = TLit "Char" diff --git a/src/TypeChecker/TypeCheckerIr.hs b/src/TypeChecker/TypeCheckerIr.hs index 2b3c702..bfc8a6a 100644 --- a/src/TypeChecker/TypeCheckerIr.hs +++ b/src/TypeChecker/TypeCheckerIr.hs @@ -2,178 +2,207 @@ module TypeChecker.TypeCheckerIr where --- import Control.Monad.Except --- import Control.Monad.Reader --- import Control.Monad.State --- import Data.Functor.Identity (Identity) --- import Data.Map (Map) --- import Grammar.Abs ( --- Data (..), --- Ident (..), --- Init (..), --- Literal (..), --- Type (..), --- ) --- import Grammar.Print --- import Prelude --- import Prelude qualified as C (Eq, Ord, Read, Show) +import Control.Monad.Except +import Control.Monad.Reader +import Control.Monad.State +import Data.Functor.Identity (Identity) +import Data.Map (Map) +import Grammar.Abs ( + Data (..), + Ident (..), + Init (..), + Lit (..), + TVar (..), + ) +import Grammar.Abs qualified as GA (Type (..)) +import Grammar.Print +import Prelude +import Prelude qualified as C (Eq, Ord, Read, Show) --- -- | A data type representing type variables --- data Poly = Forall [Ident] Type --- deriving (Show) +-- | A data type representing type variables +data Poly = Forall [Ident] Type + deriving (Show) --- newtype Ctx = Ctx {vars :: Map Ident Poly} --- deriving Show +newtype Ctx = Ctx {vars :: Map Ident Poly} + deriving (Show) --- data Env = Env --- { count :: Int --- , sigs :: Map Ident Type --- , constructors :: Map Ident Type --- } deriving Show +data Env = Env + { count :: Int + , sigs :: Map Ident GA.Type + , constructors :: Map Ident GA.Type + } + deriving (Show) --- type Error = String --- type Subst = Map Ident Type +type Error = String +type Subst = Map Ident Type --- type Infer = StateT Env (ReaderT Ctx (ExceptT Error Identity)) +type Infer = StateT Env (ReaderT Ctx (ExceptT Error Identity)) --- newtype Program = Program [Def] --- deriving (C.Eq, C.Ord, C.Show, C.Read) +newtype Program = Program [Def] + 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 --- | ECase Type Exp [Inj] --- deriving (C.Eq, C.Ord, C.Read, C.Show) +data Type + = TLit Ident + | TVar TVar + | TFun Type Type + | TAll TVar Type + | TIndexed Indexed + deriving (Show, Eq, Ord, Read) --- data Inj = Inj (Init, Type) Exp --- deriving (C.Eq, C.Ord, C.Read, C.Show) +data Exp + = EId Id + | ELit Lit + | ELet Bind ExpT + | EApp ExpT ExpT + | EAdd ExpT ExpT + | EAbs Id ExpT + | ECase ExpT [Inj] + deriving (C.Eq, C.Ord, C.Read, C.Show) --- data Def = DBind Bind | DData Data --- deriving (C.Eq, C.Ord, C.Read, C.Show) +type ExpT = (Exp, Type) --- type Id = (Ident, Type) +data Indexed = Indexed Ident [Type] + deriving (Show, Read, Ord, Eq) --- data Bind = Bind Id Exp --- deriving (C.Eq, C.Ord, C.Show, C.Read) +data Inj = Inj (Init, Type) ExpT + deriving (C.Eq, C.Ord, C.Read, C.Show) --- instance Print [Def] where --- prt _ [] = concatD [] --- prt _ (x : xs) = concatD [prt 0 x, doc (showString "\n"), prt 0 xs] +data Def = DBind Bind | DData Data + deriving (C.Eq, C.Ord, C.Read, C.Show) --- instance Print Def where --- prt i (DBind bind) = prt i bind --- prt i (DData d) = prt i d +type Id = (Ident, Type) --- instance Print Program where --- prt i (Program sc) = prPrec i 0 $ prt 0 sc +data Bind = Bind Id [Id] ExpT + deriving (C.Eq, C.Ord, C.Show, C.Read) --- instance Print Bind where --- prt i (Bind (t, name) rhs) = --- prPrec i 0 $ --- concatD --- [ prt 0 name --- , doc $ showString ":" --- , prt 0 t --- , doc $ showString "\n" --- , prt 0 name --- , doc $ showString "=" --- , prt 0 rhs --- ] +instance Print [Def] where + prt _ [] = concatD [] + prt _ (x : xs) = concatD [prt 0 x, doc (showString "\n"), prt 0 xs] --- instance Print [Bind] where --- prt _ [] = concatD [] --- prt _ [x] = concatD [prt 0 x] --- prt _ (x : xs) = concatD [prt 0 x, doc (showString ";"), doc (showString "\n"), prt 0 xs] +instance Print Def where + prt i (DBind bind) = prt i bind + prt i (DData d) = prt i d --- prtIdPs :: Int -> [Id] -> Doc --- prtIdPs i = prPrec i 0 . concatD . map (prtIdP i) +instance Print Program where + prt i (Program sc) = prPrec i 0 $ prt 0 sc --- prtId :: Int -> Id -> Doc --- prtId i (name, t) = --- prPrec i 0 $ --- concatD --- [ prt 0 name --- , doc $ showString ":" --- , prt 0 t --- ] +instance Print Bind where + prt i (Bind (t, name) args rhs) = + prPrec i 0 $ + concatD + [ prt 0 name + , doc $ showString ":" + , prt 0 t + , doc $ showString "\n" + , prt 0 name + , doc $ showString "=" + , prt 0 rhs + ] --- 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 [Bind] where + prt _ [] = concatD [] + prt _ [x] = concatD [prt 0 x] + prt _ (x : xs) = concatD [prt 0 x, doc (showString ";"), doc (showString "\n"), prt 0 xs] --- instance Print Exp where --- prt i = \case --- EId n -> prPrec i 3 $ concatD [prtId 0 n, doc $ showString "\n"] --- ELit _ (LInt i1) -> prPrec i 3 $ concatD [prt 0 i1, doc $ showString "\n"] --- ELet bs e -> --- prPrec i 3 $ --- concatD --- [ doc $ showString "let" --- , prt 0 bs --- , doc $ showString "in" --- , prt 0 e --- , doc $ showString "\n" --- ] --- EApp _ 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 --- , doc $ showString "\n" --- ] --- EAbs t n e -> --- prPrec i 0 $ --- concatD --- [ doc $ showString "@" --- , prt 0 t --- , doc $ showString "\\" --- , prtId 0 n --- , doc $ showString "." --- , prt 0 e --- , doc $ showString "\n" --- ] --- ECase t exp injs -> --- prPrec --- i --- 0 --- ( concatD --- [ doc (showString "case") --- , prt 0 exp --- , doc (showString "of") --- , doc (showString "{") --- , prt 0 injs --- , doc (showString "}") --- , doc (showString ":") --- , prt 0 t --- , doc $ showString "\n" --- ] --- ) +prtIdPs :: Int -> [Id] -> Doc +prtIdPs i = prPrec i 0 . concatD . map (prtIdP i) --- instance Print Inj where --- prt i = \case --- Inj (init, t) exp -> prPrec i 0 (concatD [prt 0 init, doc (showString ":"), prt 0 t, doc (showString "=>"), prt 0 exp]) +prtId :: Int -> Id -> Doc +prtId i (name, t) = + prPrec i 0 $ + concatD + [ prt 0 name + , doc $ showString ":" + , prt 0 t + ] --- instance Print [Inj] where --- prt _ [] = concatD [] --- prt _ [x] = concatD [prt 0 x] --- prt _ (x : xs) = concatD [prt 0 x, doc (showString ";"), prt 0 xs] +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, doc $ showString "\n"] + ELit _ lit -> prPrec i 3 $ concatD [prt 0 lit, doc $ showString "\n"] + ELet bs e -> + prPrec i 3 $ + concatD + [ doc $ showString "let" + , prt 0 bs + , doc $ showString "in" + , prt 0 e + , doc $ showString "\n" + ] + EApp _ 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 + , doc $ showString "\n" + ] + EAbs t n e -> + prPrec i 0 $ + concatD + [ doc $ showString "@" + , prt 0 t + , doc $ showString "\\" + , prtId 0 n + , doc $ showString "." + , prt 0 e + , doc $ showString "\n" + ] + ECase t exp injs -> + prPrec + i + 0 + ( concatD + [ doc (showString "case") + , prt 0 exp + , doc (showString "of") + , doc (showString "{") + , prt 0 injs + , doc (showString "}") + , doc (showString ":") + , prt 0 t + , doc $ showString "\n" + ] + ) + +instance Print ExpT where + prt i (e, t) = concatD [prt i e, doc (showString ":"), prt i t] + +instance Print Inj where + prt i = \case + Inj (init, t) exp -> prPrec i 0 (concatD [prt 0 init, doc (showString ":"), prt 0 t, doc (showString "=>"), prt 0 exp]) + +instance Print [Inj] where + prt _ [] = concatD [] + prt _ [x] = concatD [prt 0 x] + prt _ (x : xs) = concatD [prt 0 x, doc (showString ";"), prt 0 xs] + +instance Print Type where + prt i = \case + TLit uident -> prPrec i 2 (concatD [prt 0 uident]) + TVar tvar -> prPrec i 2 (concatD [prt 0 tvar]) + TAll tvar type_ -> prPrec i 1 (concatD [doc (showString "forall"), prt 0 tvar, doc (showString "."), prt 0 type_]) + TIndexed indexed -> prPrec i 1 (concatD [prt 0 indexed]) + TFun type_1 type_2 -> prPrec i 0 (concatD [prt 1 type_1, doc (showString "->"), prt 0 type_2]) + +instance Print Indexed where + prt i (Indexed u ts) = concatD [prt i u, prt i ts] From 3335ab7a57c4420a65bce8f8de1f3692b86f417c Mon Sep 17 00:00:00 2001 From: sebastian Date: Wed, 22 Mar 2023 21:26:14 +0100 Subject: [PATCH 107/372] compatible, EId rule for parsing is not working, testing not done yet --- Grammar.cf | 4 +- src/Main.hs | 8 +- src/Renamer/Renamer.hs | 35 ++--- src/TypeChecker/TypeChecker.hs | 212 ++++++++++++++++--------------- src/TypeChecker/TypeCheckerIr.hs | 28 ++-- 5 files changed, 146 insertions(+), 141 deletions(-) diff --git a/Grammar.cf b/Grammar.cf index 27dfd05..28696c6 100644 --- a/Grammar.cf +++ b/Grammar.cf @@ -51,14 +51,14 @@ ELit. Exp4 ::= Lit ; EApp. Exp3 ::= Exp3 Exp4 ; EAdd. Exp1 ::= Exp1 "+" Exp2 ; ELet. Exp ::= "let" LIdent "=" Exp "in" Exp ; -EAbs. Exp ::= "\\" LIdent "." Exp ; +EAbs. Exp ::= "\\" Ident "." Exp ; ECase. Exp ::= "case" Exp "of" "{" [Inj] "}"; ------------------------------------------------------------------------------- -- * LITERALS ------------------------------------------------------------------------------- -LInt. Lit ::= Integer ; +LInt. Lit ::= Integer ; LChar. Lit ::= Char ; ------------------------------------------------------------------------------- diff --git a/src/Main.hs b/src/Main.hs index 0a00cd6..5a96404 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -12,7 +12,7 @@ import Renamer.Renamer (rename) import System.Environment (getArgs) import System.Exit (exitFailure, exitSuccess) --- import TypeChecker.TypeChecker (typecheck) +import TypeChecker.TypeChecker (typecheck) main :: IO () main = @@ -32,9 +32,9 @@ main' s = do renamed <- fromRenamerErr . rename $ parsed putStrLn $ printTree renamed - -- putStrLn "\n-- TypeChecker --" - -- typechecked <- fromTypeCheckerErr $ typecheck renamed - -- putStrLn $ show typechecked + putStrLn "\n-- TypeChecker --" + typechecked <- fromTypeCheckerErr $ typecheck renamed + putStrLn $ printTree typechecked -- putStrLn "\n-- Lambda Lifter --" -- let lifted = lambdaLift typechecked diff --git a/src/Renamer/Renamer.hs b/src/Renamer/Renamer.hs index aac8b16..9f69185 100644 --- a/src/Renamer/Renamer.hs +++ b/src/Renamer/Renamer.hs @@ -21,6 +21,7 @@ import Data.Map (Map) import Data.Map qualified as Map import Data.Maybe (fromMaybe) import Data.Tuple.Extra (dupe) +import Data.Coerce (coerce) import Grammar.Abs -- | Rename all variables and local binds @@ -30,15 +31,15 @@ rename (Program defs) = Program <$> renameDefs defs renameDefs :: [Def] -> Either String [Def] renameDefs defs = runIdentity $ runExceptT $ evalStateT (runRn $ mapM renameDef defs) initCxt where - initNames = Map.fromList [dupe name | DBind (Bind name _ _) <- defs] + initNames = Map.fromList [dupe (coerce name) | DBind (Bind name _ _) <- defs] renameDef :: Def -> Rn Def renameDef = \case DSig (Sig name typ) -> DSig . Sig name <$> renameTVars typ DBind (Bind name vars rhs) -> do - (new_names, vars') <- newNames initNames vars + (new_names, vars') <- newNames initNames (coerce vars) rhs' <- snd <$> renameExp new_names rhs - pure . DBind $ Bind name vars' rhs' + pure . DBind $ Bind name (coerce vars') rhs' DData (Data (Indexed cname types) constrs) -> do tvars' <- mapM nextNameTVar tvars let tvars_lt = zip tvars tvars' @@ -90,11 +91,11 @@ newtype Rn a = Rn {runRn :: StateT Cxt (ExceptT String Identity) a} deriving (Functor, Applicative, Monad, MonadState Cxt) -- | Maps old to new name -type Names = Map LIdent LIdent +type Names = Map Ident Ident renameExp :: Names -> Exp -> Rn (Names, Exp) renameExp old_names = \case - EId n -> pure (old_names, EId . fromMaybe n $ Map.lookup n old_names) + EId n -> pure (coerce old_names, EId . fromMaybe n $ Map.lookup n (coerce old_names)) ELit lit -> pure (old_names, ELit lit) EApp e1 e2 -> do (env1, e1') <- renameExp old_names e1 @@ -107,14 +108,14 @@ renameExp old_names = \case -- TODO fix shadowing ELet name rhs e -> do - (new_names, name') <- newName old_names name + (new_names, name') <- newName old_names (coerce name) (new_names', rhs') <- renameExp new_names rhs (new_names'', e') <- renameExp new_names' e - pure (new_names'', ELet name' rhs' e') + pure (new_names'', ELet (coerce name') rhs' e') EAbs par e -> do - (new_names, par') <- newName old_names par + (new_names, par') <- newName old_names (coerce par) (new_names', e') <- renameExp new_names e - pure (new_names', EAbs par' e') + pure (new_names', EAbs (coerce par') e') EAnn e t -> do (new_names, e') <- renameExp old_names e t' <- renameTVars t @@ -138,8 +139,8 @@ renameInj ns (Inj init e) = do renameInit :: Names -> Init -> Rn (Names, Init) renameInit ns i = case i of InitConstructor cs vars -> do - (ns_new, vars') <- newNames ns vars - return (ns_new, InitConstructor cs vars') + (ns_new, vars') <- newNames ns (coerce vars) + return (ns_new, InitConstructor cs (coerce vars')) rest -> return (ns, rest) renameTVars :: Type -> Rn Type @@ -169,26 +170,26 @@ substitute tvar1 tvar2 typ = case typ of substitute' = substitute tvar1 tvar2 -- | Create a new name and add it to name environment. -newName :: Names -> LIdent -> Rn (Names, LIdent) +newName :: Names -> Ident -> Rn (Names, Ident) newName env old_name = do new_name <- makeName old_name pure (Map.insert old_name new_name env, new_name) -- | Create multiple names and add them to the name environment -newNames :: Names -> [LIdent] -> Rn (Names, [LIdent]) +newNames :: Names -> [Ident] -> Rn (Names, [Ident]) newNames = mapAccumM newName -- | Annotate name with number and increment the number @prefix ⇒ prefix_number@. -makeName :: LIdent -> Rn LIdent -makeName (LIdent prefix) = do +makeName :: Ident -> Rn Ident +makeName (Ident prefix) = do i <- gets var_counter - let name = LIdent $ prefix ++ "_" ++ show i + let name = Ident $ prefix ++ "_" ++ show i modify $ \cxt -> cxt{var_counter = succ cxt.var_counter} pure name nextNameTVar :: TVar -> Rn TVar nextNameTVar (MkTVar (LIdent s)) = do i <- gets tvar_counter - let tvar = MkTVar . LIdent $ s ++ "_" ++ show i + let tvar = MkTVar $ coerce $ s ++ "_" ++ show i modify $ \cxt -> cxt{tvar_counter = succ cxt.tvar_counter} pure tvar diff --git a/src/TypeChecker/TypeChecker.hs b/src/TypeChecker/TypeChecker.hs index 4b9269d..a3929b5 100644 --- a/src/TypeChecker/TypeChecker.hs +++ b/src/TypeChecker/TypeChecker.hs @@ -57,7 +57,7 @@ checkData d = do traverse_ ( \(Constructor name' t') -> if TIndexed typ == retType t' - then insertConstr name' t' + then insertConstr (coerce name') (toNew t') else throwError $ unwords @@ -85,7 +85,7 @@ checkPrg (Program bs) = do preRun [] = return () preRun (x : xs) = case x of -- TODO: Check for no overlapping signature definitions - DSig (Sig n t) -> insertSig n t >> preRun xs + DSig (Sig n t) -> insertSig (coerce n) (toNew t) >> preRun xs DBind (Bind{}) -> preRun xs DData d@(Data _ _) -> checkData d >> preRun xs @@ -100,13 +100,13 @@ checkPrg (Program bs) = do checkBind :: Bind -> Infer T.Bind checkBind (Bind name args e) = do - let lambda = makeLambda e (reverse args) + let lambda = makeLambda e (reverse $ coerce args) e@(_, t') <- inferExp lambda -- TODO: Check for match against existing signatures return $ T.Bind (coerce name, t') [] e -- (apply s e) where - makeLambda :: Exp -> [LIdent] -> Exp - makeLambda = foldl (flip EAbs) + makeLambda :: Exp -> [Ident] -> Exp + makeLambda = foldl (flip (EAbs . coerce)) {- | Check if two types are considered equal For the purpose of the algorithm two polymorphic types are always considered @@ -138,7 +138,7 @@ isPoly _ = False inferExp :: Exp -> Infer T.ExpT inferExp e = do - (s, t, e') <- algoW e + (s, (e', t)) <- algoW e let subbed = apply s t return $ replace subbed (e', t) @@ -151,15 +151,18 @@ class NewType a b where instance NewType Type T.Type where toNew = \case TLit i -> T.TLit $ coerce i - TVar v -> T.TVar v + TVar v -> T.TVar $ toNew v TFun t1 t2 -> T.TFun (toNew t1) (toNew t2) - TAll b t -> T.TAll b (toNew t) + TAll b t -> T.TAll (toNew b) (toNew t) TIndexed i -> T.TIndexed (toNew i) TEVar _ -> error "Should not exist after typechecker" instance NewType Indexed T.Indexed where toNew (Indexed name vars) = T.Indexed (coerce name) (map toNew vars) +instance NewType TVar T.TVar where + toNew (MkTVar i) = T.MkTVar $ coerce i + algoW :: Exp -> Infer (Subst, T.ExpT) algoW = \case -- \| TODO: More testing need to be done. Unsure of the correctness of this @@ -178,14 +181,14 @@ algoW = \case applySt s1 $ do s2 <- unify (toNew t) t' let comp = s2 `compose` s1 - return (comp, (apply comp e', toNew t)) + return (comp, apply comp (e', toNew t)) -- \| ------------------ -- \| Γ ⊢ i : Int, ∅ ELit lit -> - let lt = toNew $ litType lit - in return (nullSubst, (T.ELit lt lit, lt)) + let lt = litType lit + in return (nullSubst, (T.ELit lit, lt)) -- \| x : σ ∈ Γ   τ = inst(σ) -- \| ---------------------- -- \| Γ ⊢ x : τ, ∅ @@ -193,15 +196,15 @@ algoW = \case EId i -> do var <- asks vars case M.lookup i var of - Just t -> inst (toNew t) >>= \x -> return (nullSubst, x, T.EId (i, x)) + Just t -> inst t >>= \(x) -> return (nullSubst, (T.EId (i, x), x)) Nothing -> do sig <- gets sigs case M.lookup i sig of - Just t -> return (nullSubst, toNew t, T.EId (i, toNew t)) + Just t -> return (nullSubst, (T.EId (i, t), t)) Nothing -> do constr <- gets constructors case M.lookup i constr of - Just t -> return (nullSubst, toNew t, T.EId (i, toNew t)) + Just t -> return (nullSubst, (T.EId (i, t), t)) Nothing -> throwError $ "Unbound variable: " ++ show i @@ -212,11 +215,11 @@ algoW = \case EAbs name e -> do fr <- fresh - withBinding (coerce name) (Forall [] (toNew fr)) $ do - (s1, t', e') <- algoW e - let varType = toNew $ apply s1 fr - let newArr = T.TFun varType (toNew t') - return (s1, newArr, apply s1 $ T.EAbs newArr (coerce name, varType) (e', newArr)) + withBinding (coerce name) fr $ do + (s1, (e', t')) <- algoW e + let varType = apply s1 fr + let newArr = T.TFun varType t' + return (s1, apply s1 $ (T.EAbs (coerce name, varType) (e', newArr), newArr)) -- \| Γ ⊢ e₀ : τ₀, S₀ S₀Γ ⊢ e₁ : τ₁, S₁ -- \| s₂ = mgu(s₁τ₀, Int) s₃ = mgu(s₂τ₁, Int) @@ -225,17 +228,16 @@ algoW = \case -- This might be wrong EAdd e0 e1 -> do - (s1, t0, e0') <- algoW e0 + (s1, (e0', t0)) <- algoW e0 applySt s1 $ do - (s2, t1, e1') <- algoW e1 + (s2, (e1', t1)) <- algoW e1 -- applySt s2 $ do - s3 <- unify (apply s2 t0) (T.TLit "Int") - s4 <- unify (apply s3 t1) (T.TLit "Int") + s3 <- unify (apply s2 t0) int + s4 <- unify (apply s3 t1) int let comp = s4 `compose` s3 `compose` s2 `compose` s1 return ( comp - , T.TLit "Int" - , apply comp $ T.EAdd (T.TLit "Int") (e0', t0) (e1', t1) + , apply comp $ (T.EAdd (e0', t0) (e1', t1), int) ) -- \| Γ ⊢ e₀ : τ₀, S₀ S₀Γ ⊢ e₁ : τ₁, S1 @@ -244,15 +246,15 @@ algoW = \case -- \| Γ ⊢ e₀ e₁ : S₂τ', S₂S₁S₀ EApp e0 e1 -> do - fr <- toNew <$> fresh - (s0, t0, e0') <- algoW e0 + fr <- fresh + (s0, (e0', t0)) <- algoW e0 applySt s0 $ do - (s1, t1, e1') <- algoW e1 + (s1, (e1', t1)) <- algoW e1 -- applySt s1 $ do - s2 <- unify (apply s1 t0) (T.TFun (toNew t1) fr) + s2 <- unify (apply s1 t0) (T.TFun t1 fr) let t = apply s2 fr let comp = s2 `compose` s1 `compose` s0 - return (comp, t, apply comp $ T.EApp t (e0', t0) (e1', t1)) + return (comp, apply comp (T.EApp (e0', t0) (e1', t1), t)) -- \| Γ ⊢ e₀ : τ, S₀ S₀Γ, x : S̅₀Γ̅(τ) ⊢ e₁ : τ', S₁ -- \| ---------------------------------------------- @@ -261,19 +263,21 @@ algoW = \case -- The bar over S₀ and Γ means "generalize" ELet name e0 e1 -> do - (s1, t1, e0') <- algoW e0 + (s1, (e0', t1)) <- algoW e0 env <- asks vars let t' = generalize (apply s1 env) t1 - withBinding name t' $ do - (s2, t2, e1') <- algoW e1 + withBinding (coerce name) t' $ do + (s2, (e1', t2)) <- algoW e1 let comp = s2 `compose` s1 - return (comp, t2, apply comp $ T.ELet (T.Bind (name, t2) e0') e1') + return (comp, apply comp (T.ELet (T.Bind (coerce name, t2) [] (e0', t1)) (e1', t2), t2)) + + -- \| TODO: Add judgement ECase caseExpr injs -> do - (sub, t, e') <- algoW caseExpr + (sub, (e', t)) <- algoW caseExpr (subst, injs, ret_t) <- checkCase t injs let comp = subst `compose` sub let t' = apply comp ret_t - return (comp, t', T.ECase t' e' injs) + return (comp, (T.ECase (e', t) injs, t')) -- | Unify two types producing a new substitution unify :: T.Type -> T.Type -> Infer Subst @@ -283,8 +287,8 @@ unify t0 t1 = do s1 <- unify a c s2 <- unify (apply s1 b) (apply s1 d) return $ s1 `compose` s2 - (T.TVar t, b) -> occurs b t - (a, T.TVar t) -> occurs a t + (T.TVar (T.MkTVar a), t) -> occurs a t + (t, T.TVar (T.MkTVar b)) -> occurs b t (T.TAll _ t, b) -> unify t b (a, T.TAll _ t) -> unify a t (T.TLit a, T.TLit b) -> @@ -298,20 +302,20 @@ unify t0 t1 = do throwError $ unwords [ "T.Type constructor:" - , printT . Tree name - , "(" ++ printT . Tree t ++ ")" + , printTree name + , "(" ++ printTree t ++ ")" , "does not match with:" - , printT . Tree name' - , "(" ++ printT . Tree t' ++ ")" + , printTree name' + , "(" ++ printTree t' ++ ")" ] (a, b) -> do ctx <- ask env <- get throwError . unwords $ [ "T.Type:" - , printT . Tree a + , printTree a , "can't be unified with:" - , printT . Tree b + , printTree b , "\nCtx:" , show ctx , "\nEnv:" @@ -322,7 +326,7 @@ unify t0 t1 = do I.E. { a = a -> b } is an unsolvable constraint since there is no substitution where these are equal -} -occurs :: LIdent -> T.Type -> Infer Subst +occurs :: Ident -> T.Type -> Infer Subst occurs i t@(T.TVar _) = return (M.singleton i t) occurs i t = if S.member i (free t) @@ -330,26 +334,37 @@ occurs i t = throwError $ unwords [ "Occurs check failed, can't unify" - , printTree (TVar $ MkTVar i) + , printTree (T.TVar $ T.MkTVar i) , "with" , printTree t ] else return $ M.singleton i t -- | Generalize a type over all free variables in the substitution set -generalize :: Map Ident Poly -> Type -> Poly -generalize env t = Forall (S.toList $ free t S.\\ free env) t +generalize :: Map Ident T.Type -> T.Type -> T.Type +generalize env t = go freeVars $ removeForalls t + where + freeVars :: [Ident] + freeVars = S.toList $ free t S.\\ free env + go :: [Ident] -> T.Type -> T.Type + go [] t = t + go (x : xs) t = T.TAll (T.MkTVar x) (go xs t) + removeForalls :: T.Type -> T.Type + removeForalls (T.TAll _ t) = removeForalls t + removeForalls (T.TFun t1 t2) = T.TFun (removeForalls t1) (removeForalls t2) + removeForalls t = t {- | Instantiate a polymorphic type. The free type variables are substituted with fresh ones. -} inst :: T.Type -> Infer T.Type inst = \case - T.TAll bound t -> do + T.TAll (T.MkTVar bound) t -> do fr <- fresh - let s = M.singleton fr bound + let s = M.singleton bound fr apply s <$> inst t - _ -> undefined + T.TFun t1 t2 -> T.TFun <$> inst t1 <*> inst t2 + rest -> return rest -- | Compose two substitution sets compose :: Subst -> Subst -> Subst @@ -361,15 +376,15 @@ compose m1 m2 = M.map (apply m1) m2 `M.union` m1 -- | A class representing free variables functions class FreeVars t where -- | Get all free variables from t - free :: t -> Set LIdent + free :: t -> Set Ident -- | Apply a substitution to t apply :: Subst -> t -> t instance FreeVars T.Type where - free :: T.Type -> Set LIdent - free (T.TVar (MkTVar a)) = S.singleton a - free (T.TAll (MkTVar bound) t) = (S.singleton bound) `S.intersection` free t + free :: T.Type -> Set Ident + free (T.TVar (T.MkTVar a)) = S.singleton a + free (T.TAll (T.MkTVar bound) t) = (S.singleton bound) `S.intersection` free t free (T.TLit _) = mempty free (T.TFun a b) = free a `S.union` free b -- \| Not guaranteed to be correct @@ -380,53 +395,40 @@ instance FreeVars T.Type where apply sub t = do case t of T.TLit a -> T.TLit a - T.TVar (MkTVar a) -> case M.lookup a sub of - Nothing -> T.TVar (MkTVar a) + T.TVar (T.MkTVar a) -> case M.lookup a sub of + Nothing -> T.TVar (T.MkTVar $ coerce a) Just t -> t T.TAll bound t -> undefined T.TFun a b -> T.TFun (apply sub a) (apply sub b) T.TIndexed (T.Indexed name a) -> T.TIndexed (T.Indexed name (map (apply sub) a)) -instance FreeVars Poly where - free :: Poly -> Set LIdent - free (Forall xs t) = free t S.\\ S.fromList xs - apply :: Subst -> Poly -> Poly - apply s (Forall xs t) = Forall xs (apply (foldr M.delete s xs) t) - -instance FreeVars (Map LIdent Poly) where - free :: Map LIdent Poly -> Set LIdent +instance FreeVars (Map Ident T.Type) where + free :: Map Ident T.Type -> Set Ident free m = foldl' S.union S.empty (map free $ M.elems m) - apply :: Subst -> Map LIdent Poly -> Map LIdent Poly + apply :: Subst -> Map Ident T.Type -> Map Ident T.Type apply s = M.map (apply s) -instance FreeVars T.Exp where - free :: T.Exp -> Set LIdent +instance FreeVars T.ExpT where + free :: T.ExpT -> Set Ident free = error "free not implemented for T.Exp" - apply :: Subst -> T.Exp -> T.Exp + apply :: Subst -> T.ExpT -> T.ExpT apply s = \case - T.EId (ident, t) -> - T.EId (ident, apply s t) - T.ELit t lit -> - T.ELit (apply s t) lit - T.ELet (T.Bind (ident, t) args e1) e2 -> - T.ELet (T.Bind (ident, apply s t) args (apply s e1)) (apply s e2) - T.EApp t e1 e2 -> - T.EApp (apply s t) (apply s e1) (apply s e2) - T.EAdd t e1 e2 -> - T.EAdd (apply s t) (apply s e1) (apply s e2) - T.EAbs t1 (ident, t2) e -> - T.EAbs (apply s t1) (ident, apply s t2) (apply s e) - T.ECase t e injs -> - T.ECase (apply s t) (apply s e) (apply s injs) + (T.EId (i, innerT), outerT) -> (T.EId (i, apply s innerT), apply s outerT) + (T.ELit lit, t) -> (T.ELit lit, apply s t) + (T.ELet (T.Bind (ident, t1) args e1) e2, t2) -> (T.ELet (T.Bind (ident, apply s t1) args (apply s e1)) (apply s e2), apply s t2) + (T.EApp e1 e2, t) -> (T.EApp (apply s e1) (apply s e2), (apply s t)) + (T.EAdd e1 e2, t) -> (T.EAdd (apply s e1) (apply s e2), (apply s t)) + (T.EAbs (ident, t2) e, t1) -> (T.EAbs (ident, apply s t2) (apply s e), (apply s t1)) + (T.ECase e injs, t) -> (T.ECase (apply s e) (apply s injs), (apply s t)) instance FreeVars T.Inj where - free :: T.Inj -> Set LIdent + free :: T.Inj -> Set Ident free = undefined apply :: Subst -> T.Inj -> T.Inj apply s (T.Inj (i, t) e) = T.Inj (i, apply s t) (apply s e) instance FreeVars [T.Inj] where - free :: [T.Inj] -> Set LIdent + free :: [T.Inj] -> Set Ident free = foldl' (\acc x -> free x `S.union` acc) mempty apply s = map (apply s) @@ -439,33 +441,33 @@ nullSubst :: Subst nullSubst = M.empty -- | Generate a new fresh variable and increment the state counter -fresh :: Infer Type +fresh :: Infer T.Type fresh = do n <- gets count modify (\st -> st{count = n + 1}) - return . TVar . MkTVar . LIdent $ show n + return . T.TVar . T.MkTVar . Ident $ show n -- | Run the monadic action with an additional binding -withBinding :: (Monad m, MonadReader Ctx m) => Ident -> Poly -> m a -> m a +withBinding :: (Monad m, MonadReader Ctx m) => Ident -> T.Type -> m a -> m a withBinding i p = local (\st -> st{vars = M.insert i p (vars st)}) -- | Run the monadic action with several additional bindings -withBindings :: (Monad m, MonadReader Ctx m) => [(Ident, Poly)] -> m a -> m a +withBindings :: (Monad m, MonadReader Ctx m) => [(Ident, T.Type)] -> m a -> m a withBindings xs = local (\st -> st{vars = foldl' (flip (uncurry M.insert)) (vars st) xs}) -- | Insert a function signature into the environment -insertSig :: LIdent -> Type -> Infer () +insertSig :: Ident -> T.Type -> Infer () insertSig i t = modify (\st -> st{sigs = M.insert i t (sigs st)}) -- | Insert a constructor with its data type -insertConstr :: UIdent -> Type -> Infer () +insertConstr :: Ident -> T.Type -> Infer () insertConstr i t = modify (\st -> st{constructors = M.insert i t (constructors st)}) -------- PATTERN MATCHING --------- -checkCase :: Type -> [Inj] -> Infer (Subst, [T.Inj], Type) +checkCase :: T.Type -> [Inj] -> Infer (Subst, [T.Inj], T.Type) checkCase expT injs = do (injTs, injs, returns) <- unzip3 <$> mapM checkInj injs (sub1, _) <- @@ -487,18 +489,17 @@ checkCase expT injs = do {- | fst = type of init | snd = type of expr -} -checkInj :: Inj -> Infer (Type, T.Inj, Type) +checkInj :: Inj -> Infer (T.Type, T.Inj, T.Type) checkInj (Inj it expr) = do (initT, vars) <- inferInit it - let converted = map (second (Forall [])) vars - (exprT, e) <- withBindings converted (inferExp expr) - return (initT, T.Inj (it, initT) e, exprT) + (e, exprT) <- withBindings vars (inferExp expr) + return (initT, T.Inj (it, initT) (e, exprT), exprT) -inferInit :: Init -> Infer (Type, [T.Id]) +inferInit :: Init -> Infer (T.Type, [T.Id]) inferInit = \case InitLit lit -> return (litType lit, mempty) InitConstructor fn vars -> do - gets (M.lookup fn . constructors) >>= \case + gets (M.lookup (coerce fn) . constructors) >>= \case Nothing -> throwError $ "Constructor: " ++ printTree fn ++ " does not exist" @@ -508,14 +509,17 @@ inferInit = \case Just (vs, ret) -> case length vars `compare` length vs of EQ -> do - return (ret, zip vars vs) + return (ret, zip (coerce vars) vs) _ -> throwError "Partial pattern match not allowed" InitCatch -> (,mempty) <$> fresh -flattenType :: Type -> [Type] -flattenType (TFun a b) = flattenType a ++ flattenType b +flattenType :: T.Type -> [T.Type] +flattenType (T.TFun a b) = flattenType a ++ flattenType b flattenType a = [a] -litType :: Lit -> Type -litType (LInt _) = TLit "Int" -litType (LChar _) = TLit "Char" +litType :: Lit -> T.Type +litType (LInt _) = int +litType (LChar _) = char + +int = T.TLit "Int" +char = T.TLit "Char" diff --git a/src/TypeChecker/TypeCheckerIr.hs b/src/TypeChecker/TypeCheckerIr.hs index bfc8a6a..9cf2059 100644 --- a/src/TypeChecker/TypeCheckerIr.hs +++ b/src/TypeChecker/TypeCheckerIr.hs @@ -12,9 +12,7 @@ import Grammar.Abs ( Ident (..), Init (..), Lit (..), - TVar (..), ) -import Grammar.Abs qualified as GA (Type (..)) import Grammar.Print import Prelude import Prelude qualified as C (Eq, Ord, Read, Show) @@ -23,13 +21,13 @@ import Prelude qualified as C (Eq, Ord, Read, Show) data Poly = Forall [Ident] Type deriving (Show) -newtype Ctx = Ctx {vars :: Map Ident Poly} +newtype Ctx = Ctx {vars :: Map Ident Type} deriving (Show) data Env = Env { count :: Int - , sigs :: Map Ident GA.Type - , constructors :: Map Ident GA.Type + , sigs :: Map Ident Type + , constructors :: Map Ident Type } deriving (Show) @@ -41,6 +39,9 @@ type Infer = StateT Env (ReaderT Ctx (ExceptT Error Identity)) newtype Program = Program [Def] deriving (C.Eq, C.Ord, C.Show, C.Read) +data TVar = MkTVar Ident + deriving (Show, Eq, Ord, Read) + data Type = TLit Ident | TVar TVar @@ -130,7 +131,7 @@ prtIdP i (name, t) = instance Print Exp where prt i = \case EId n -> prPrec i 3 $ concatD [prtId 0 n, doc $ showString "\n"] - ELit _ lit -> prPrec i 3 $ concatD [prt 0 lit, doc $ showString "\n"] + ELit lit -> prPrec i 3 $ concatD [prt 0 lit, doc $ showString "\n"] ELet bs e -> prPrec i 3 $ concatD @@ -140,34 +141,31 @@ instance Print Exp where , prt 0 e , doc $ showString "\n" ] - EApp _ e1 e2 -> + EApp e1 e2 -> prPrec i 2 $ concatD [ prt 2 e1 , prt 3 e2 ] - EAdd t e1 e2 -> + EAdd e1 e2 -> prPrec i 1 $ concatD [ doc $ showString "@" - , prt 0 t , prt 1 e1 , doc $ showString "+" , prt 2 e2 , doc $ showString "\n" ] - EAbs t n e -> + EAbs n e -> prPrec i 0 $ concatD [ doc $ showString "@" - , prt 0 t - , doc $ showString "\\" , prtId 0 n , doc $ showString "." , prt 0 e , doc $ showString "\n" ] - ECase t exp injs -> + ECase exp injs -> prPrec i 0 @@ -179,7 +177,6 @@ instance Print Exp where , prt 0 injs , doc (showString "}") , doc (showString ":") - , prt 0 t , doc $ showString "\n" ] ) @@ -196,6 +193,9 @@ instance Print [Inj] where prt _ [x] = concatD [prt 0 x] prt _ (x : xs) = concatD [prt 0 x, doc (showString ";"), prt 0 xs] +instance Print TVar where + prt i (MkTVar id) = prt i id + instance Print Type where prt i = \case TLit uident -> prPrec i 2 (concatD [prt 0 uident]) From 8d1330ad4260b9ca046ea35076be95b8f411f500 Mon Sep 17 00:00:00 2001 From: sebastianselander Date: Thu, 23 Mar 2023 11:13:48 +0100 Subject: [PATCH 108/372] typechecker is compatible with one extra addition to the spec --- Grammar.cf | 5 +-- language.cabal | 2 ++ sample-programs/basic-1 | 2 +- sample-programs/basic-8 | 2 +- src/Renamer/Renamer.hs | 17 +++++----- src/TypeChecker/TypeChecker.hs | 42 ++++++++++++------------ tests/Tests.hs | 59 ++++++++++++++-------------------- 7 files changed, 63 insertions(+), 66 deletions(-) diff --git a/Grammar.cf b/Grammar.cf index 28696c6..3bb15bd 100644 --- a/Grammar.cf +++ b/Grammar.cf @@ -46,12 +46,13 @@ Data. Data ::= "data" Indexed "where" "{" [Constructor] "}" ; ------------------------------------------------------------------------------- EAnn. Exp5 ::= "(" Exp ":" Type ")" ; -EId. Exp4 ::= Ident ; +EVar. Exp4 ::= LIdent ; +ECons. Exp4 ::= UIdent ; ELit. Exp4 ::= Lit ; EApp. Exp3 ::= Exp3 Exp4 ; EAdd. Exp1 ::= Exp1 "+" Exp2 ; ELet. Exp ::= "let" LIdent "=" Exp "in" Exp ; -EAbs. Exp ::= "\\" Ident "." Exp ; +EAbs. Exp ::= "\\" LIdent "." Exp ; ECase. Exp ::= "case" Exp "of" "{" [Inj] "}"; ------------------------------------------------------------------------------- diff --git a/language.cabal b/language.cabal index 637d9f7..7e335ee 100644 --- a/language.cabal +++ b/language.cabal @@ -47,6 +47,8 @@ executable language , either , extra , array + , hspec + , QuickCheck default-language: GHC2021 diff --git a/sample-programs/basic-1 b/sample-programs/basic-1 index d52aac2..ee0ad7a 100644 --- a/sample-programs/basic-1 +++ b/sample-programs/basic-1 @@ -1,2 +1,2 @@ f : Int -> Int ; -f = \x. x+1 ; +f x = x ; diff --git a/sample-programs/basic-8 b/sample-programs/basic-8 index c2c4042..92dd863 100644 --- a/sample-programs/basic-8 +++ b/sample-programs/basic-8 @@ -1,6 +1,6 @@ data Maybe (a) where { Nothing : Maybe (a) - Just : forall a. a -> Maybe (a) + Just : a -> Maybe (a) }; fromJust : Maybe (a) -> a ; diff --git a/src/Renamer/Renamer.hs b/src/Renamer/Renamer.hs index 9f69185..66c8fb2 100644 --- a/src/Renamer/Renamer.hs +++ b/src/Renamer/Renamer.hs @@ -16,12 +16,12 @@ import Control.Monad.State ( gets, modify, ) +import Data.Coerce (coerce) import Data.Function (on) import Data.Map (Map) import Data.Map qualified as Map import Data.Maybe (fromMaybe) import Data.Tuple.Extra (dupe) -import Data.Coerce (coerce) import Grammar.Abs -- | Rename all variables and local binds @@ -91,11 +91,12 @@ newtype Rn a = Rn {runRn :: StateT Cxt (ExceptT String Identity) a} deriving (Functor, Applicative, Monad, MonadState Cxt) -- | Maps old to new name -type Names = Map Ident Ident +type Names = Map LIdent LIdent renameExp :: Names -> Exp -> Rn (Names, Exp) renameExp old_names = \case - EId n -> pure (coerce old_names, EId . fromMaybe n $ Map.lookup n (coerce old_names)) + EVar n -> pure (coerce old_names, EVar . fromMaybe n $ Map.lookup n old_names) + ECons n -> pure (old_names, ECons n) ELit lit -> pure (old_names, ELit lit) EApp e1 e2 -> do (env1, e1') <- renameExp old_names e1 @@ -170,20 +171,20 @@ substitute tvar1 tvar2 typ = case typ of substitute' = substitute tvar1 tvar2 -- | Create a new name and add it to name environment. -newName :: Names -> Ident -> Rn (Names, Ident) +newName :: Names -> LIdent -> Rn (Names, LIdent) newName env old_name = do new_name <- makeName old_name pure (Map.insert old_name new_name env, new_name) -- | Create multiple names and add them to the name environment -newNames :: Names -> [Ident] -> Rn (Names, [Ident]) +newNames :: Names -> [LIdent] -> Rn (Names, [LIdent]) newNames = mapAccumM newName -- | Annotate name with number and increment the number @prefix ⇒ prefix_number@. -makeName :: Ident -> Rn Ident -makeName (Ident prefix) = do +makeName :: LIdent -> Rn LIdent +makeName (LIdent prefix) = do i <- gets var_counter - let name = Ident $ prefix ++ "_" ++ show i + let name = LIdent $ prefix ++ "_" ++ show i modify $ \cxt -> cxt{var_counter = succ cxt.var_counter} pure name diff --git a/src/TypeChecker/TypeChecker.hs b/src/TypeChecker/TypeChecker.hs index a3929b5..112bf7d 100644 --- a/src/TypeChecker/TypeChecker.hs +++ b/src/TypeChecker/TypeChecker.hs @@ -134,6 +134,7 @@ isMoreSpecificOrEq a b = a == b isPoly :: Type -> Bool isPoly (TAll _ _) = True +isPoly (TVar _) = True isPoly _ = False inferExp :: Exp -> Infer T.ExpT @@ -193,21 +194,20 @@ algoW = \case -- \| ---------------------- -- \| Γ ⊢ x : τ, ∅ - EId i -> do + EVar i -> do var <- asks vars - case M.lookup i var of - Just t -> inst t >>= \(x) -> return (nullSubst, (T.EId (i, x), x)) + case M.lookup (coerce i) var of + Just t -> inst t >>= \x -> return (nullSubst, (T.EId (coerce i, x), x)) Nothing -> do sig <- gets sigs - case M.lookup i sig of - Just t -> return (nullSubst, (T.EId (i, t), t)) - Nothing -> do - constr <- gets constructors - case M.lookup i constr of - Just t -> return (nullSubst, (T.EId (i, t), t)) - Nothing -> - throwError $ - "Unbound variable: " ++ show i + case M.lookup (coerce i) sig of + Just t -> return (nullSubst, (T.EId (coerce i, t), t)) + Nothing -> throwError $ "Unbound variable: " ++ show i + ECons i -> do + constr <- gets constructors + case M.lookup (coerce i) constr of + Just t -> return (nullSubst, (T.EId (coerce i, t), t)) + Nothing -> throwError $ "Constructor: '" ++ printTree i ++ "' is not defined" -- \| τ = newvar Γ, x : τ ⊢ e : τ', S -- \| --------------------------------- @@ -219,7 +219,7 @@ algoW = \case (s1, (e', t')) <- algoW e let varType = apply s1 fr let newArr = T.TFun varType t' - return (s1, apply s1 $ (T.EAbs (coerce name, varType) (e', newArr), newArr)) + return (s1, apply s1 (T.EAbs (coerce name, varType) (e', newArr), newArr)) -- \| Γ ⊢ e₀ : τ₀, S₀ S₀Γ ⊢ e₁ : τ₁, S₁ -- \| s₂ = mgu(s₁τ₀, Int) s₃ = mgu(s₂τ₁, Int) @@ -237,7 +237,7 @@ algoW = \case let comp = s4 `compose` s3 `compose` s2 `compose` s1 return ( comp - , apply comp $ (T.EAdd (e0', t0) (e1', t1), int) + , apply comp (T.EAdd (e0', t0) (e1', t1), int) ) -- \| Γ ⊢ e₀ : τ₀, S₀ S₀Γ ⊢ e₁ : τ₁, S1 @@ -384,7 +384,7 @@ class FreeVars t where instance FreeVars T.Type where free :: T.Type -> Set Ident free (T.TVar (T.MkTVar a)) = S.singleton a - free (T.TAll (T.MkTVar bound) t) = (S.singleton bound) `S.intersection` free t + free (T.TAll (T.MkTVar bound) t) = S.singleton bound `S.intersection` free t free (T.TLit _) = mempty free (T.TFun a b) = free a `S.union` free b -- \| Not guaranteed to be correct @@ -398,7 +398,9 @@ instance FreeVars T.Type where T.TVar (T.MkTVar a) -> case M.lookup a sub of Nothing -> T.TVar (T.MkTVar $ coerce a) Just t -> t - T.TAll bound t -> undefined + T.TAll (T.MkTVar i) t -> case M.lookup i sub of + Nothing -> T.TAll (T.MkTVar i) (apply sub t) + Just _ -> apply sub t T.TFun a b -> T.TFun (apply sub a) (apply sub b) T.TIndexed (T.Indexed name a) -> T.TIndexed (T.Indexed name (map (apply sub) a)) @@ -416,10 +418,10 @@ instance FreeVars T.ExpT where (T.EId (i, innerT), outerT) -> (T.EId (i, apply s innerT), apply s outerT) (T.ELit lit, t) -> (T.ELit lit, apply s t) (T.ELet (T.Bind (ident, t1) args e1) e2, t2) -> (T.ELet (T.Bind (ident, apply s t1) args (apply s e1)) (apply s e2), apply s t2) - (T.EApp e1 e2, t) -> (T.EApp (apply s e1) (apply s e2), (apply s t)) - (T.EAdd e1 e2, t) -> (T.EAdd (apply s e1) (apply s e2), (apply s t)) - (T.EAbs (ident, t2) e, t1) -> (T.EAbs (ident, apply s t2) (apply s e), (apply s t1)) - (T.ECase e injs, t) -> (T.ECase (apply s e) (apply s injs), (apply s t)) + (T.EApp e1 e2, t) -> (T.EApp (apply s e1) (apply s e2), apply s t) + (T.EAdd e1 e2, t) -> (T.EAdd (apply s e1) (apply s e2), apply s t) + (T.EAbs (ident, t2) e, t1) -> (T.EAbs (ident, apply s t2) (apply s e), apply s t1) + (T.ECase e injs, t) -> (T.ECase (apply s e) (apply s injs), apply s t) instance FreeVars T.Inj where free :: T.Inj -> Set Ident diff --git a/tests/Tests.hs b/tests/Tests.hs index 655c086..27a4eca 100644 --- a/tests/Tests.hs +++ b/tests/Tests.hs @@ -28,75 +28,66 @@ main = hspec $ do infer_eann infer_eid infer_eabs - infer_eapp test_id_function infer_elit = describe "algoW used on ELit" $ do it "infers the type mono Int" $ do - getType (ELit (LInt 0)) `shouldBe` Right (TMono "Int") + getType (ELit (LInt 0)) `shouldBe` Right (T.TLit "Int") it "infers the type mono Int" $ do - getType (ELit (LInt 9999)) `shouldBe` Right (TMono "Int") + getType (ELit (LInt 9999)) `shouldBe` Right (T.TLit "Int") infer_eann = describe "algoW used on EAnn" $ do it "infers the type and checks if the annotated type matches" $ do - getType (EAnn (ELit $ LInt 0) (TMono "Int")) `shouldBe` Right (TMono "Int") + getType (EAnn (ELit $ LInt 0) (TLit "Int")) `shouldBe` Right (T.TLit "Int") it "fails if the annotated type does not match with the inferred type" $ do - getType (EAnn (ELit $ LInt 0) (TPol "a")) `shouldSatisfy` isLeft + getType (EAnn (ELit $ LInt 0) (TVar $ MkTVar "a")) `shouldSatisfy` isLeft it "should be possible to annotate with a more specific type" $ do - let annotated_lambda = EAnn (EAbs "x" (EId "x")) (TArr (TMono "Int") (TMono "Int")) - in getType annotated_lambda `shouldBe` Right (TArr (TMono "Int") (TMono "Int")) + let annotated_lambda = EAnn (EAbs "x" (EVar "x")) (TFun (TLit "Int") (TLit "Int")) + in getType annotated_lambda `shouldBe` Right (T.TFun (T.TLit "Int") (T.TLit "Int")) it "should fail if the annotated type is more general than the inferred type" $ do - getType (EAnn (ELit (LInt 0)) (TPol "a")) `shouldSatisfy` isLeft + getType (EAnn (ELit (LInt 0)) (TVar $ MkTVar "a")) `shouldSatisfy` isLeft it "should fail if the annotated type is an arrow but the annotated type is not" $ do - getType (EAnn (EAbs "x" (EId "x")) (TPol "a")) `shouldSatisfy` isLeft + getType (EAnn (EAbs "x" (EVar "x")) (TVar $ MkTVar "a")) `shouldSatisfy` isLeft -infer_eid = describe "algoW used on EId" $ do +infer_eid = describe "algoW used on EVar" $ do it "should fail if the variable is not added to the environment" $ do - property $ \x -> getType (EId (Ident (x :: String))) `shouldSatisfy` isLeft + property $ \x -> getType (EVar (LIdent (x :: String))) `shouldSatisfy` isLeft it "should succeed if the type exist in the environment" $ do property $ \x -> do let env = Env 0 mempty mempty - let t = Forall [] (TPol "a") + let t = T.TVar $ T.MkTVar "a" let ctx = Ctx (M.singleton (Ident (x :: String)) t) - getTypeC env ctx (EId (Ident x)) `shouldBe` Right (TPol "a") + getTypeC env ctx (EVar (LIdent x)) `shouldBe` Right (T.TVar $ T.MkTVar "a") infer_eabs = describe "algoW used on EAbs" $ do it "should infer the argument type as int if the variable is used as an int" $ do - let lambda = EAbs "x" (EAdd (EId "x") (ELit (LInt 0))) - getType lambda `shouldBe` Right (TArr (TMono "Int") (TMono "Int")) + let lambda = EAbs "x" (EAdd (EVar "x") (ELit (LInt 0))) + getType lambda `shouldBe` Right (T.TFun (T.TLit "Int") (T.TLit "Int")) it "should infer the argument type as polymorphic if it is not used in the lambda" $ do let lambda = EAbs "x" (ELit (LInt 0)) getType lambda `shouldSatisfy` isArrowPolyToMono it "should infer a variable as function if used as one" $ do - let lambda = EAbs "f" (EAbs "x" (EApp (EId "f") (EId "x"))) - let isOk (Right (TArr (TArr (TPol _) (TPol _)) (TArr (TPol _) (TPol _)))) = True + let lambda = EAbs "f" (EAbs "x" (EApp (EVar "f") (EVar "x"))) + let isOk (Right (T.TFun (T.TFun (T.TVar _) (T.TVar _)) (T.TFun (T.TVar _) (T.TVar _)))) = True isOk _ = False getType lambda `shouldSatisfy` isOk -infer_eapp = describe "algoW used on EApp" $ do - it "should fail if a variable is applied to itself (occurs check)" $ do - property $ \x -> do - let env = Env 0 mempty mempty - let t = Forall [] (TPol "a") - let ctx = Ctx (M.singleton (Ident (x :: String)) t) - getTypeC env ctx (EApp (EId (Ident x)) (EId (Ident x))) `shouldSatisfy` isLeft - churf_id :: Bind -churf_id = Bind "id" (TArr (TPol "a") (TPol "a")) "id" ["x"] (EId "x") +churf_id = Bind "id" ["x"] (EVar "x") churf_add :: Bind -churf_add = Bind "add" (TArr (TMono "Int") (TArr (TMono "Int") (TMono "Int"))) "add" ["x", "y"] (EAdd (EId "x") (EId "y")) +churf_add = Bind "add" ["x", "y"] (EAdd (EVar "x") (EVar "y")) churf_main :: Bind -churf_main = Bind "main" (TArr (TMono "Int") (TMono "Int")) "main" [] (EApp (EApp (EId "id") (EId "add")) (ELit (LInt 0))) +churf_main = Bind "main" [] (EApp (EApp (EVar "id") (EVar "add")) (ELit (LInt 0))) prg = Program [DBind churf_main, DBind churf_add, DBind churf_id] @@ -106,14 +97,14 @@ test_id_function = it "should succeed to find the correct type" $ do typecheck prg `shouldSatisfy` isRight -isArrowPolyToMono :: Either Error Type -> Bool -isArrowPolyToMono (Right (TArr (TPol _) (TMono _))) = True +isArrowPolyToMono :: Either Error T.Type -> Bool +isArrowPolyToMono (Right (T.TFun (T.TVar _) (T.TLit _))) = True isArrowPolyToMono _ = False -- | Empty environment -getType :: Exp -> Either Error Type -getType e = pure fst <*> run (inferExp e) +getType :: Exp -> Either Error T.Type +getType e = pure snd <*> run (inferExp e) -- | Custom environment -getTypeC :: Env -> Ctx -> Exp -> Either Error Type -getTypeC env ctx e = pure fst <*> runC env ctx (inferExp e) +getTypeC :: Env -> Ctx -> Exp -> Either Error T.Type +getTypeC env ctx e = pure snd <*> runC env ctx (inferExp e) From 7fa677e3d3729b2755d35ba380905d6ea1deb43c Mon Sep 17 00:00:00 2001 From: sebastianselander Date: Thu, 23 Mar 2023 14:18:23 +0100 Subject: [PATCH 109/372] typechecker working, still unsure of quality --- src/TypeChecker/TypeChecker.hs | 84 +++++++++++++++++--------------- src/TypeChecker/TypeCheckerIr.hs | 30 +++++------- 2 files changed, 56 insertions(+), 58 deletions(-) diff --git a/src/TypeChecker/TypeChecker.hs b/src/TypeChecker/TypeChecker.hs index 112bf7d..7da23a6 100644 --- a/src/TypeChecker/TypeChecker.hs +++ b/src/TypeChecker/TypeChecker.hs @@ -15,7 +15,6 @@ import Data.List (foldl') import Data.List.Extra (unsnoc) import Data.Map (Map) import Data.Map qualified as M -import Data.Maybe (fromMaybe) import Data.Set (Set) import Data.Set qualified as S import Debug.Trace (trace) @@ -26,7 +25,6 @@ import TypeChecker.TypeCheckerIr ( Env (..), Error, Infer, - Poly (..), Subst, ) import TypeChecker.TypeCheckerIr qualified as T @@ -78,15 +76,21 @@ retType a = a checkPrg :: Program -> Infer T.Program checkPrg (Program bs) = do preRun bs - bs' <- checkDef bs - return $ T.Program bs' + -- Type check the program twice to produce all top-level types in the first pass through + _ <- checkDef bs + bs'' <- checkDef bs + return $ T.Program bs'' where preRun :: [Def] -> Infer () preRun [] = return () preRun (x : xs) = case x of -- TODO: Check for no overlapping signature definitions - DSig (Sig n t) -> insertSig (coerce n) (toNew t) >> preRun xs - DBind (Bind{}) -> preRun xs + DSig (Sig n t) -> insertSig (coerce n) (Just $ toNew t) >> preRun xs + DBind (Bind n _ _) -> do + s <- gets sigs + case M.lookup (coerce n) s of + Nothing -> insertSig (coerce n) Nothing >> preRun xs + Just _ -> preRun xs DData d@(Data _ _) -> checkData d >> preRun xs checkDef :: [Def] -> Infer [T.Def] @@ -102,25 +106,33 @@ checkBind :: Bind -> Infer T.Bind checkBind (Bind name args e) = do let lambda = makeLambda e (reverse $ coerce args) e@(_, t') <- inferExp lambda - -- TODO: Check for match against existing signatures - return $ T.Bind (coerce name, t') [] e -- (apply s e) + s <- gets sigs + -- let fs = map (second Just) $ getFunctionTypes s e + -- mapM_ (uncurry insertSig) fs + case M.lookup (coerce name) s of + Just (Just t) -> do + sub <- unify t t' + let newT = apply sub t + insertSig (coerce name) (Just newT) + return $ T.Bind (coerce name, newT) [] e + _ -> do + insertSig (coerce name) (Just t') + return (T.Bind (coerce name, t') [] e) -- (apply s e) where makeLambda :: Exp -> [Ident] -> Exp makeLambda = foldl (flip (EAbs . coerce)) -{- | Check if two types are considered equal - For the purpose of the algorithm two polymorphic types are always considered - equal --} -typeEq :: Type -> Type -> Bool -typeEq (TFun l r) (TFun l' r') = typeEq l l' && typeEq r r' -typeEq (TLit a) (TLit b) = a == b -typeEq (TIndexed (Indexed name a)) (TIndexed (Indexed name' b)) = - length a == length b - && name == name' - && and (zipWith typeEq a b) -typeEq (TAll n1 t1) (TAll n2 t2) = t1 `typeEq` t2 -typeEq _ _ = False + -- getFunctionTypes :: Map Ident (Maybe T.Type) -> T.ExpT -> [(Ident, T.Type)] + -- getFunctionTypes s = \case + -- (T.EId b, t) -> case M.lookup b s of + -- Just Nothing -> return (b, t) + -- _ -> [] + -- (T.ELit _, _) -> [] + -- (T.ELet (T.Bind _ _ e1) e2, _) -> getFunctionTypes s e1 ++ getFunctionTypes s e2 + -- (T.EApp e1 e2, _) -> getFunctionTypes s e1 ++ getFunctionTypes s e2 + -- (T.EAdd e1 e2, _) -> getFunctionTypes s e1 ++ getFunctionTypes s e2 + -- (T.EAbs _ e, _) -> getFunctionTypes s e + -- (T.ECase e injs, _) -> getFunctionTypes s e ++ concatMap (getFunctionTypes s . \(T.Inj _ e) -> e) injs isMoreSpecificOrEq :: T.Type -> T.Type -> Bool isMoreSpecificOrEq _ (T.TAll _ _) = True @@ -193,20 +205,20 @@ algoW = \case -- \| x : σ ∈ Γ   τ = inst(σ) -- \| ---------------------- -- \| Γ ⊢ x : τ, ∅ - EVar i -> do var <- asks vars case M.lookup (coerce i) var of - Just t -> inst t >>= \x -> return (nullSubst, (T.EId (coerce i, x), x)) + Just t -> inst t >>= \x -> return (nullSubst, (T.EId $ coerce i, x)) Nothing -> do sig <- gets sigs case M.lookup (coerce i) sig of - Just t -> return (nullSubst, (T.EId (coerce i, t), t)) - Nothing -> throwError $ "Unbound variable: " ++ show i + Just (Just t) -> return (nullSubst, (T.EId $ coerce i, t)) + Just Nothing -> (\x -> (nullSubst, (T.EId $ coerce i, x))) <$> fresh + Nothing -> throwError $ "Unbound variable: " ++ printTree i ECons i -> do constr <- gets constructors case M.lookup (coerce i) constr of - Just t -> return (nullSubst, (T.EId (coerce i, t), t)) + Just t -> return (nullSubst, (T.EId $ coerce i, t)) Nothing -> throwError $ "Constructor: '" ++ printTree i ++ "' is not defined" -- \| τ = newvar Γ, x : τ ⊢ e : τ', S @@ -219,7 +231,7 @@ algoW = \case (s1, (e', t')) <- algoW e let varType = apply s1 fr let newArr = T.TFun varType t' - return (s1, apply s1 (T.EAbs (coerce name, varType) (e', newArr), newArr)) + return (s1, apply s1 (T.EAbs (coerce name, varType) (e', t'), newArr)) -- \| Γ ⊢ e₀ : τ₀, S₀ S₀Γ ⊢ e₁ : τ₁, S₁ -- \| s₂ = mgu(s₁τ₀, Int) s₃ = mgu(s₂τ₁, Int) @@ -250,7 +262,6 @@ algoW = \case (s0, (e0', t0)) <- algoW e0 applySt s0 $ do (s1, (e1', t1)) <- algoW e1 - -- applySt s1 $ do s2 <- unify (apply s1 t0) (T.TFun t1 fr) let t = apply s2 fr let comp = s2 `compose` s1 `compose` s0 @@ -309,17 +320,10 @@ unify t0 t1 = do , "(" ++ printTree t' ++ ")" ] (a, b) -> do - ctx <- ask - env <- get throwError . unwords $ - [ "T.Type:" - , printTree a - , "can't be unified with:" - , printTree b - , "\nCtx:" - , show ctx - , "\nEnv:" - , show env + [ "'" ++ printTree a ++ "'" + , "can't be unified with" + , "'" ++ printTree b ++ "'" ] {- | Check if a type is contained in another type. @@ -415,7 +419,7 @@ instance FreeVars T.ExpT where free = error "free not implemented for T.Exp" apply :: Subst -> T.ExpT -> T.ExpT apply s = \case - (T.EId (i, innerT), outerT) -> (T.EId (i, apply s innerT), apply s outerT) + (T.EId i, outerT) -> (T.EId i, apply s outerT) (T.ELit lit, t) -> (T.ELit lit, apply s t) (T.ELet (T.Bind (ident, t1) args e1) e2, t2) -> (T.ELet (T.Bind (ident, apply s t1) args (apply s e1)) (apply s e2), apply s t2) (T.EApp e1 e2, t) -> (T.EApp (apply s e1) (apply s e2), apply s t) @@ -459,7 +463,7 @@ withBindings xs = local (\st -> st{vars = foldl' (flip (uncurry M.insert)) (vars st) xs}) -- | Insert a function signature into the environment -insertSig :: Ident -> T.Type -> Infer () +insertSig :: Ident -> Maybe T.Type -> Infer () insertSig i t = modify (\st -> st{sigs = M.insert i t (sigs st)}) -- | Insert a constructor with its data type diff --git a/src/TypeChecker/TypeCheckerIr.hs b/src/TypeChecker/TypeCheckerIr.hs index 9cf2059..7c24ab3 100644 --- a/src/TypeChecker/TypeCheckerIr.hs +++ b/src/TypeChecker/TypeCheckerIr.hs @@ -17,16 +17,12 @@ import Grammar.Print import Prelude import Prelude qualified as C (Eq, Ord, Read, Show) --- | A data type representing type variables -data Poly = Forall [Ident] Type - deriving (Show) - newtype Ctx = Ctx {vars :: Map Ident Type} deriving (Show) data Env = Env { count :: Int - , sigs :: Map Ident Type + , sigs :: Map Ident (Maybe Type) , constructors :: Map Ident Type } deriving (Show) @@ -39,7 +35,7 @@ type Infer = StateT Env (ReaderT Ctx (ExceptT Error Identity)) newtype Program = Program [Def] deriving (C.Eq, C.Ord, C.Show, C.Read) -data TVar = MkTVar Ident +newtype TVar = MkTVar Ident deriving (Show, Eq, Ord, Read) data Type @@ -51,7 +47,7 @@ data Type deriving (Show, Eq, Ord, Read) data Exp - = EId Id + = EId Ident | ELit Lit | ELet Bind ExpT | EApp ExpT ExpT @@ -78,7 +74,7 @@ data Bind = Bind Id [Id] ExpT instance Print [Def] where prt _ [] = concatD [] - prt _ (x : xs) = concatD [prt 0 x, doc (showString "\n"), prt 0 xs] + prt _ (x : xs) = concatD [prt 0 x, doc (showString "\n\n"), prt 0 xs] instance Print Def where prt i (DBind bind) = prt i bind @@ -88,7 +84,7 @@ instance Print Program where prt i (Program sc) = prPrec i 0 $ prt 0 sc instance Print Bind where - prt i (Bind (t, name) args rhs) = + prt i (Bind (name, t) _ rhs) = prPrec i 0 $ concatD [ prt 0 name @@ -112,9 +108,11 @@ prtId :: Int -> Id -> Doc prtId i (name, t) = prPrec i 0 $ concatD - [ prt 0 name + [ doc $ showString "(" + , prt 0 name , doc $ showString ":" , prt 0 t + , doc $ showString ")" ] prtIdP :: Int -> Id -> Doc @@ -130,8 +128,8 @@ prtIdP i (name, t) = instance Print Exp where prt i = \case - EId n -> prPrec i 3 $ concatD [prtId 0 n, doc $ showString "\n"] - ELit lit -> prPrec i 3 $ concatD [prt 0 lit, doc $ showString "\n"] + EId n -> prPrec i 3 $ concatD [prt 0 n] + ELit lit -> prPrec i 3 $ concatD [prt 0 lit] ELet bs e -> prPrec i 3 $ concatD @@ -139,7 +137,6 @@ instance Print Exp where , prt 0 bs , doc $ showString "in" , prt 0 e - , doc $ showString "\n" ] EApp e1 e2 -> prPrec i 2 $ @@ -154,16 +151,14 @@ instance Print Exp where , prt 1 e1 , doc $ showString "+" , prt 2 e2 - , doc $ showString "\n" ] EAbs n e -> prPrec i 0 $ concatD - [ doc $ showString "@" + [ doc $ showString "λ" , prtId 0 n , doc $ showString "." , prt 0 e - , doc $ showString "\n" ] ECase exp injs -> prPrec @@ -177,12 +172,11 @@ instance Print Exp where , prt 0 injs , doc (showString "}") , doc (showString ":") - , doc $ showString "\n" ] ) instance Print ExpT where - prt i (e, t) = concatD [prt i e, doc (showString ":"), prt i t] + prt i (e, t) = concatD [doc $ showString "(", prt i e, doc (showString ":"), prt i t, doc $ showString ")"] instance Print Inj where prt i = \case From 129a70e051c4a0ef6a810dd26464fcf805fa434d Mon Sep 17 00:00:00 2001 From: Samuel Hammersberg Date: Thu, 23 Mar 2023 15:29:25 +0100 Subject: [PATCH 110/372] WIP Added support for more types of cases. --- src/Codegen/Codegen.hs | 83 +++++++++++++++++++++------- src/Codegen/LlvmIr.hs | 20 +++++-- src/Monomorphizer/MonomorphizerIr.hs | 2 +- 3 files changed, 79 insertions(+), 26 deletions(-) diff --git a/src/Codegen/Codegen.hs b/src/Codegen/Codegen.hs index bf2f9ba..e0c52aa 100644 --- a/src/Codegen/Codegen.hs +++ b/src/Codegen/Codegen.hs @@ -129,13 +129,15 @@ test v = Program , Bind (GA.Ident "main", MIR.Type (GA.Ident "_Int")) [] --(EApp (MIR.Type (GA.Ident "Craig")) (EId (GA.Ident "Craig_Bob", MIR.Type (GA.Ident "Craig")), MIR.Type (GA.Ident "Craig")) (ELit (LInt v), MIR.Type (GA.Ident "_Int")), MIR.Type (GA.Ident "Craig"))-- (EInt 92) $ eCaseInt (EApp (MIR.Type (GA.Ident "Craig")) (EId (GA.Ident "Craig_Bob", MIR.Type (GA.Ident "Craig")), MIR.Type (GA.Ident "Craig")) (ELit (LInt v), MIR.Type (GA.Ident "_Int")), MIR.Type (GA.Ident "Craig")) - [ injectionCons "Craig_Betty" "Craig" (int 5) + [ injectionCons "Craig_Bob" "Craig" [CIdent (GA.Ident "x")] (EId (GA.Ident "x", MIR.Type (GA.Ident "_Int")), MIR.Type (GA.Ident "_Int")) + , injectionCons "Craig_Betty" "Craig" [CLit (LInt 5)] (int 2) + , Injection (CIdent (GA.Ident "z")) (int 3) --, injectionInt 5 (int 6) , injectionCatchAll (int 10) ] ] where - injectionCons x y = Injection (CCons (GA.Ident x, MIR.Type (GA.Ident y))) + injectionCons x y xs = Injection (CCons (GA.Ident x, MIR.Type (GA.Ident y)) xs) injectionInt x = Injection (CLit (LInt x)) injectionCatchAll = Injection CatchAll eCaseInt x xs = (ECase (MIR.Type "_Int") x xs, MIR.Type "_Int") @@ -173,11 +175,11 @@ compileScs [] = do -- get a pointer of the correct type ptr' <- getNewVar - emit $ SetVariable ptr' (Bitcast (Ref t') top (Ref $ CustomType id)) + emit $ SetVariable ptr' (Bitcast (Ref t') (VIdent top Ptr) (Ref $ CustomType id)) --emit $ UnsafeRaw "\n" - foldM_ (\i (GA.Ident arg_n, arg_t)-> do + enumerateOneM_ (\i (GA.Ident arg_n, arg_t) -> do let arg_t' = type2LlvmType arg_t emit $ Comment (show arg_t' <>" "<> arg_n <> " " <> show i ) elemPtr <- getNewVar @@ -187,10 +189,7 @@ compileScs [] = do I64 (VInteger 0) I32 (VInteger i)) emit $ Store arg_t' (VIdent (GA.Ident arg_n) arg_t') Ptr elemPtr - -- %2 = getelementptr inbounds %Foo_AInteger, %Foo_AInteger* %1, i32 0, i32 1 - -- store i32 42, i32* %2 - pure $ i + 1-- + typeByteSize arg_t' - ) 1 (argumentsCI ci) + ) (argumentsCI ci) --emit $ UnsafeRaw "\n" @@ -264,43 +263,74 @@ compileExp (EId (name, _)) = emitIdent name compileExp (EApp t e1 e2) = emitApp t (fst e1) (fst e2) --compileExp (EAbs t ti e) = emitAbs t ti e compileExp (ELet _ binds e) = undefined emitLet binds (fst e) -compileExp (ECase t e cs) = emitECased t (fst e) (map (t,) cs) +compileExp (ECase t e cs) = emitECased t e (map (t,) cs) -- go (EMul e1 e2) = emitMul e1 e2 -- go (EDiv e1 e2) = emitDiv e1 e2 -- go (EMod e1 e2) = emitMod e1 e2 --- aux functions --- -emitECased :: Type -> Exp -> [(Type, Injection)] -> CompilerState () +emitECased :: Type -> ExpT -> [(Type, Injection)] -> CompilerState () emitECased t e cases = do let cs = snd <$> cases let ty = type2LlvmType t - vs <- exprToValue e + let rt = type2LlvmType (snd e) + vs <- exprToValue (fst e) lbl <- getNewLabel let label = GA.Ident $ "escape_" <> show lbl stackPtr <- getNewVar emit $ SetVariable stackPtr (Alloca ty) - mapM_ (emitCases ty label stackPtr vs) cs + mapM_ (emitCases rt ty label stackPtr vs) cs emit $ Label label res <- getNewVar emit $ SetVariable res (Load ty Ptr stackPtr) where - emitCases :: LLVMType -> GA.Ident -> GA.Ident -> LLVMValue -> Injection -> CompilerState () - emitCases ty label stackPtr vs (Injection (MIR.CCons id) exp) = do + emitCases :: LLVMType -> LLVMType -> GA.Ident -> GA.Ident -> LLVMValue -> Injection -> CompilerState () + emitCases rt ty label stackPtr vs (Injection (MIR.CCons consId cs) exp) = do cons <- gets constructors - let r = fromJust $ Map.lookup id cons + let r = fromJust $ Map.lookup consId cons lbl_failPos <- (\x -> GA.Ident $ "failed_" <> show x) <$> getNewLabel lbl_succPos <- (\x -> GA.Ident $ "success_" <> show x) <$> getNewLabel + consVal <- getNewVar + emit $ SetVariable consVal (ExtractValue rt vs 0) + consCheck <- getNewVar - emit $ SetVariable consCheck (Icmp LLEq I8 vs (VInteger $ numCI r)) + emit $ SetVariable consCheck (Icmp LLEq I8 (VIdent consVal I8) (VInteger $ numCI r)) emit $ BrCond (VIdent consCheck ty) lbl_succPos lbl_failPos emit $ Label lbl_succPos + + castPtr <- getNewVar + castedPtr <- getNewVar + casted <- getNewVar + emit $ SetVariable castPtr (Alloca rt) + emit $ Store rt vs Ptr castPtr + emit $ SetVariable castedPtr (Bitcast Ptr (VIdent castPtr Ptr) Ptr) + emit $ SetVariable casted (Load (CustomType (fst consId)) Ptr castedPtr) + val <- exprToValue (fst exp) - emit $ Store ty val Ptr stackPtr + enumerateOneM_ (\i c -> do + case c of + CIdent x -> do + emit . Comment $ "ident " <> show x + emit $ SetVariable x (ExtractValue (CustomType (fst consId)) (VIdent casted Ptr) i) + emit $ Store ty val Ptr stackPtr + CCons x cs -> error "nested constructor" + CLit l -> do + testVar <- getNewVar + emit $ SetVariable testVar (ExtractValue (CustomType (fst consId)) (VIdent casted Ptr) i) + case l of + LInt l -> emit $ Icmp LLEq I64 (VIdent testVar Ptr) (VInteger l) + LChar c -> emit $ Icmp LLEq I8 (VIdent testVar Ptr) (VChar c) + CatchAll -> emit . Comment $ "Catch all" + emit . Comment $ "return this " <> show val + emit . Comment . show $ c + emit . Comment . show $ i + ) cs + -- emit $ Store ty val Ptr stackPtr emit $ Br label emit $ Label lbl_failPos - emitCases ty label stackPtr vs (Injection (MIR.CLit i) exp) = do + emitCases rt ty label stackPtr vs (Injection (MIR.CLit i) exp) = do let i' = case i of LInt i -> VInteger i LChar i -> VChar i @@ -314,7 +344,17 @@ emitECased t e cases = do emit $ Store ty val Ptr stackPtr emit $ Br label emit $ Label lbl_failPos - emitCases ty label stackPtr _ (Injection MIR.CatchAll exp) = do + emitCases rt ty label stackPtr vs (Injection (MIR.CIdent id) exp) = do + -- //TODO this is pretty disgusting and would heavily benefit from a rewrite + valPtr <- getNewVar + emit $ SetVariable valPtr (Alloca rt) + emit $ Store rt vs Ptr valPtr + emit $ SetVariable id (Load rt Ptr valPtr) + increaseVarCount + val <- exprToValue (fst exp) + emit $ Store ty val Ptr stackPtr + emit $ Br label + emitCases _ ty label stackPtr _ (Injection MIR.CatchAll exp) = do val <- exprToValue (fst exp) emit $ Store ty val Ptr stackPtr emit $ Br label @@ -435,6 +475,7 @@ getType (ECase t _ _) = type2LlvmType t valueGetType :: LLVMValue -> LLVMType valueGetType (VInteger _) = I64 +valueGetType (VChar _) = I8 valueGetType (VIdent _ t) = t valueGetType (VConstant s) = Array (fromIntegral $ length s) I8 valueGetType (VFunction _ _ t) = t @@ -449,3 +490,7 @@ typeByteSize (Ref _) = 8 typeByteSize (Function _ _) = 8 typeByteSize (Array n t) = n * typeByteSize t typeByteSize (CustomType _) = 8 + +enumerateOneM_ :: Monad m => (Integer -> a -> m b) -> [a] -> m () +enumerateOneM_ f = foldM_ (\i a -> f i a >> pure (i + 1)) 1 + diff --git a/src/Codegen/LlvmIr.hs b/src/Codegen/LlvmIr.hs index 7a0cf82..ea73b90 100644 --- a/src/Codegen/LlvmIr.hs +++ b/src/Codegen/LlvmIr.hs @@ -106,6 +106,8 @@ data LLVMIr | Declare LLVMType Ident Params | SetVariable Ident LLVMIr | Variable Ident + -- extractvalue , {, }* + | ExtractValue LLVMType LLVMValue Integer | GetElementPtr LLVMType LLVMType LLVMValue LLVMType LLVMValue LLVMType LLVMValue | GetElementPtrInbounds LLVMType LLVMType LLVMValue LLVMType LLVMValue LLVMType LLVMValue | Add LLVMType LLVMValue LLVMValue @@ -121,7 +123,7 @@ data LLVMIr | Alloca LLVMType | Store LLVMType LLVMValue LLVMType Ident | Load LLVMType LLVMType Ident - | Bitcast LLVMType Ident LLVMType + | Bitcast LLVMType LLVMValue LLVMType | Ret LLVMType LLVMValue | Comment String | UnsafeRaw String -- This should generally be avoided, and proper @@ -151,8 +153,14 @@ llvmIrToString = go 0 -- getelementptr inbounds %Foo, %Foo* %x, i32 0, i32 0 concat [ "getelementptr ", show t1, ", " , show t2 - , " ", show p, ", ", show t3, " ", show v1, - ", ", show t4, " ", show v2, "\n" ] + , " ", show p, ", ", show t3, " ", show v1 + , ", ", show t4, " ", show v2, "\n" + ] + (ExtractValue t1 v i) -> do + concat + [ "extractvalue ", show t1, " " + , show v, ", ", show i, "\n" + ] (GetElementPtrInbounds t1 t2 p t3 v1 t4 v2) -> do -- getelementptr inbounds %Foo, %Foo* %x, i32 0, i32 0 concat @@ -216,10 +224,10 @@ llvmIrToString = go 0 [ "load ", show t1, ", " , show t2, " %", addr, "\n" ] - (Bitcast t1 (Ident i) t2) -> + (Bitcast t1 v t2) -> concat - [ "bitcast ", show t1, " %" - , i, " to ", show t2, "\n" + [ "bitcast ", show t1, " " + , show v, " to ", show t2, "\n" ] (Icmp comp t v1 v2) -> concat diff --git a/src/Monomorphizer/MonomorphizerIr.hs b/src/Monomorphizer/MonomorphizerIr.hs index 38b230e..606a719 100644 --- a/src/Monomorphizer/MonomorphizerIr.hs +++ b/src/Monomorphizer/MonomorphizerIr.hs @@ -19,7 +19,7 @@ data Exp data Injection = Injection Case ExpT deriving (Show, Ord, Eq) -data Case = CLit Lit | CCons Id | CatchAll +data Case = CLit Lit | CCons Id [Case] | CIdent Ident | CatchAll deriving (Show, Ord, Eq) data Constructor = Constructor Ident [Type] From 519ed8af6c9d0a32536469100c49d9b9450b2f91 Mon Sep 17 00:00:00 2001 From: sebastianselander Date: Thu, 23 Mar 2023 16:06:09 +0100 Subject: [PATCH 111/372] Added monadic fail to renamer --- src/Renamer/Renamer.hs | 18 ++++++++++-------- src/TypeChecker/TypeChecker.hs | 22 +++++----------------- src/TypeChecker/TypeCheckerIr.hs | 4 ++-- 3 files changed, 17 insertions(+), 27 deletions(-) diff --git a/src/Renamer/Renamer.hs b/src/Renamer/Renamer.hs index 66c8fb2..3fa1afc 100644 --- a/src/Renamer/Renamer.hs +++ b/src/Renamer/Renamer.hs @@ -7,7 +7,7 @@ module Renamer.Renamer (rename) where import Auxiliary (mapAccumM) import Control.Applicative (Applicative (liftA2)) -import Control.Monad.Except (ExceptT, runExceptT) +import Control.Monad.Except (ExceptT, MonadError, runExceptT, throwError) import Control.Monad.Identity (Identity, runIdentity) import Control.Monad.State ( MonadState, @@ -41,19 +41,21 @@ renameDefs defs = runIdentity $ runExceptT $ evalStateT (runRn $ mapM renameDef rhs' <- snd <$> renameExp new_names rhs pure . DBind $ Bind name (coerce vars') rhs' DData (Data (Indexed cname types) constrs) -> do - tvars' <- mapM nextNameTVar tvars - let tvars_lt = zip tvars tvars' + tvars_ <- tvars + tvars' <- mapM nextNameTVar tvars_ + let tvars_lt = zip tvars_ tvars' typ' = map (substituteTVar tvars_lt) types constrs' = map (renameConstr tvars_lt) constrs pure . DData $ Data (Indexed cname typ') constrs' where - tvars = concatMap (collectTVars []) types + tvars = concat <$> mapM (collectTVars []) types + collectTVars :: [TVar] -> Type -> Rn [TVar] collectTVars tvars = \case TAll tvar t -> collectTVars (tvar : tvars) t - TIndexed _ -> tvars + TIndexed _ -> return tvars -- Should be monad error - TVar v -> [v] - _ -> error ("Bad data type definition: " ++ show types) + TVar v -> return [v] + _ -> throwError ("Bad data type definition: " ++ show types) renameConstr :: [(TVar, TVar)] -> Constructor -> Constructor renameConstr new_types (Constructor name typ) = @@ -88,7 +90,7 @@ data Cxt = Cxt -- | Rename monad. State holds the number of renamed names. newtype Rn a = Rn {runRn :: StateT Cxt (ExceptT String Identity) a} - deriving (Functor, Applicative, Monad, MonadState Cxt) + deriving (Functor, Applicative, Monad, MonadState Cxt, MonadError String) -- | Maps old to new name type Names = Map LIdent LIdent diff --git a/src/TypeChecker/TypeChecker.hs b/src/TypeChecker/TypeChecker.hs index 7da23a6..2bab6c8 100644 --- a/src/TypeChecker/TypeChecker.hs +++ b/src/TypeChecker/TypeChecker.hs @@ -77,7 +77,9 @@ checkPrg :: Program -> Infer T.Program checkPrg (Program bs) = do preRun bs -- Type check the program twice to produce all top-level types in the first pass through - _ <- checkDef bs + bs' <- checkDef bs + trace "\nFIRST ITERATION" return () + trace (printTree bs' ++ "\nSECOND ITERATION\n") return () bs'' <- checkDef bs return $ T.Program bs'' where @@ -107,8 +109,6 @@ checkBind (Bind name args e) = do let lambda = makeLambda e (reverse $ coerce args) e@(_, t') <- inferExp lambda s <- gets sigs - -- let fs = map (second Just) $ getFunctionTypes s e - -- mapM_ (uncurry insertSig) fs case M.lookup (coerce name) s of Just (Just t) -> do sub <- unify t t' @@ -122,18 +122,6 @@ checkBind (Bind name args e) = do makeLambda :: Exp -> [Ident] -> Exp makeLambda = foldl (flip (EAbs . coerce)) - -- getFunctionTypes :: Map Ident (Maybe T.Type) -> T.ExpT -> [(Ident, T.Type)] - -- getFunctionTypes s = \case - -- (T.EId b, t) -> case M.lookup b s of - -- Just Nothing -> return (b, t) - -- _ -> [] - -- (T.ELit _, _) -> [] - -- (T.ELet (T.Bind _ _ e1) e2, _) -> getFunctionTypes s e1 ++ getFunctionTypes s e2 - -- (T.EApp e1 e2, _) -> getFunctionTypes s e1 ++ getFunctionTypes s e2 - -- (T.EAdd e1 e2, _) -> getFunctionTypes s e1 ++ getFunctionTypes s e2 - -- (T.EAbs _ e, _) -> getFunctionTypes s e - -- (T.ECase e injs, _) -> getFunctionTypes s e ++ concatMap (getFunctionTypes s . \(T.Inj _ e) -> e) injs - isMoreSpecificOrEq :: T.Type -> T.Type -> Bool isMoreSpecificOrEq _ (T.TAll _ _) = True isMoreSpecificOrEq (T.TFun a b) (T.TFun c d) = @@ -231,7 +219,7 @@ algoW = \case (s1, (e', t')) <- algoW e let varType = apply s1 fr let newArr = T.TFun varType t' - return (s1, apply s1 (T.EAbs (coerce name, varType) (e', t'), newArr)) + return (s1, apply s1 (T.EAbs (coerce name) (e', t'), newArr)) -- \| Γ ⊢ e₀ : τ₀, S₀ S₀Γ ⊢ e₁ : τ₁, S₁ -- \| s₂ = mgu(s₁τ₀, Int) s₃ = mgu(s₂τ₁, Int) @@ -424,7 +412,7 @@ instance FreeVars T.ExpT where (T.ELet (T.Bind (ident, t1) args e1) e2, t2) -> (T.ELet (T.Bind (ident, apply s t1) args (apply s e1)) (apply s e2), apply s t2) (T.EApp e1 e2, t) -> (T.EApp (apply s e1) (apply s e2), apply s t) (T.EAdd e1 e2, t) -> (T.EAdd (apply s e1) (apply s e2), apply s t) - (T.EAbs (ident, t2) e, t1) -> (T.EAbs (ident, apply s t2) (apply s e), apply s t1) + (T.EAbs ident e, t1) -> (T.EAbs ident (apply s e), apply s t1) (T.ECase e injs, t) -> (T.ECase (apply s e) (apply s injs), apply s t) instance FreeVars T.Inj where diff --git a/src/TypeChecker/TypeCheckerIr.hs b/src/TypeChecker/TypeCheckerIr.hs index 7c24ab3..03a2065 100644 --- a/src/TypeChecker/TypeCheckerIr.hs +++ b/src/TypeChecker/TypeCheckerIr.hs @@ -52,7 +52,7 @@ data Exp | ELet Bind ExpT | EApp ExpT ExpT | EAdd ExpT ExpT - | EAbs Id ExpT + | EAbs Ident ExpT | ECase ExpT [Inj] deriving (C.Eq, C.Ord, C.Read, C.Show) @@ -156,7 +156,7 @@ instance Print Exp where prPrec i 0 $ concatD [ doc $ showString "λ" - , prtId 0 n + , prt 0 n , doc $ showString "." , prt 0 e ] From bf0064db865cf1bf66075b69d09671d6b26999d1 Mon Sep 17 00:00:00 2001 From: Samuel Hammersberg Date: Thu, 23 Mar 2023 16:13:59 +0100 Subject: [PATCH 112/372] Added the trait ToIr. --- src/Codegen/Codegen.hs | 6 +- src/Codegen/LlvmIr.hs | 123 +++++++++++++++++++++-------------------- 2 files changed, 66 insertions(+), 63 deletions(-) diff --git a/src/Codegen/Codegen.hs b/src/Codegen/Codegen.hs index e0c52aa..a00ec8e 100644 --- a/src/Codegen/Codegen.hs +++ b/src/Codegen/Codegen.hs @@ -181,7 +181,7 @@ compileScs [] = do enumerateOneM_ (\i (GA.Ident arg_n, arg_t) -> do let arg_t' = type2LlvmType arg_t - emit $ Comment (show arg_t' <>" "<> arg_n <> " " <> show i ) + emit $ Comment (toIr arg_t' <>" "<> arg_n <> " " <> show i ) elemPtr <- getNewVar emit $ SetVariable elemPtr ( GetElementPtr (CustomType id) (Ref (CustomType id)) @@ -233,7 +233,7 @@ mainContent var = -- " %3 = bitcast %Craig* %2 to i72*\n" <> -- " %4 = load i72, ptr %3\n" <> -- " call i32 (ptr, ...) @printf(ptr noundef @.str, i72 noundef %4)\n" - "call i32 (ptr, ...) @printf(ptr noundef @.str, i64 noundef " <> show var <> ")\n" + "call i32 (ptr, ...) @printf(ptr noundef @.str, i64 noundef " <> toIr var <> ")\n" , -- , SetVariable (GA.Ident "p") (Icmp LLEq I64 (VInteger 2) (VInteger 2)) -- , BrCond (VIdent (GA.Ident "p")) (GA.Ident "b_1") (GA.Ident "b_2") -- , Label (GA.Ident "b_1") @@ -323,7 +323,7 @@ emitECased t e cases = do LInt l -> emit $ Icmp LLEq I64 (VIdent testVar Ptr) (VInteger l) LChar c -> emit $ Icmp LLEq I8 (VIdent testVar Ptr) (VChar c) CatchAll -> emit . Comment $ "Catch all" - emit . Comment $ "return this " <> show val + emit . Comment $ "return this " <> toIr val emit . Comment . show $ c emit . Comment . show $ i ) cs diff --git a/src/Codegen/LlvmIr.hs b/src/Codegen/LlvmIr.hs index ea73b90..41ab538 100644 --- a/src/Codegen/LlvmIr.hs +++ b/src/Codegen/LlvmIr.hs @@ -7,19 +7,20 @@ module Codegen.LlvmIr ( LLVMValue (..), LLVMComp (..), Visibility (..), - CallingConvention (..) + CallingConvention (..), + ToIr(..) ) where import Data.List (intercalate) import Grammar.Abs (Ident (..)) data CallingConvention = TailCC | FastCC | CCC | ColdCC -instance Show CallingConvention where - show :: CallingConvention -> String - show TailCC = "tailcc" - show FastCC = "fastcc" - show CCC = "ccc" - show ColdCC = "coldcc" +instance ToIr CallingConvention where + toIr :: CallingConvention -> String + toIr TailCC = "tailcc" + toIr FastCC = "fastcc" + toIr CCC = "ccc" + toIr ColdCC = "coldcc" -- | A datatype which represents some basic LLVM types data LLVMType @@ -33,17 +34,20 @@ data LLVMType | Array Integer LLVMType | CustomType Ident -instance Show LLVMType where - show :: LLVMType -> String - show = \case +class ToIr a where + toIr :: a -> String + +instance ToIr LLVMType where + toIr :: LLVMType -> String + toIr = \case I1 -> "i1" I8 -> "i8" I32 -> "i32" I64 -> "i64" Ptr -> "ptr" - Ref ty -> show ty <> "*" - Function t xs -> show t <> " (" <> intercalate ", " (map show xs) <> ")*" - Array n ty -> concat ["[", show n, " x ", show ty, "]"] + Ref ty -> toIr ty <> "*" + Function t xs -> toIr t <> " (" <> intercalate ", " (map toIr xs) <> ")*" + Array n ty -> concat ["[", show n, " x ", toIr ty, "]"] CustomType (Ident ty) -> "%" <> ty data LLVMComp @@ -57,9 +61,9 @@ data LLVMComp | LLSge | LLSlt | LLSle -instance Show LLVMComp where - show :: LLVMComp -> String - show = \case +instance ToIr LLVMComp where + toIr :: LLVMComp -> String + toIr = \case LLEq -> "eq" LLNe -> "ne" LLUgt -> "ugt" @@ -72,10 +76,10 @@ instance Show LLVMComp where LLSle -> "sle" data Visibility = Local | Global -instance Show Visibility where - show :: Visibility -> String - show Local = "%" - show Global = "@" +instance ToIr Visibility where + toIr :: Visibility -> String + toIr Local = "%" + toIr Global = "@" -- | Represents a LLVM "value", as in an integer, a register variable, -- or a string contstant @@ -86,13 +90,13 @@ data LLVMValue | VConstant String | VFunction Ident Visibility LLVMType -instance Show LLVMValue where - show :: LLVMValue -> String - show v = case v of +instance ToIr LLVMValue where + toIr :: LLVMValue -> String + toIr v = case v of VInteger i -> show i VChar i -> show i VIdent (Ident n) _ -> "%" <> n - VFunction (Ident n) vis _ -> show vis <> n + VFunction (Ident n) vis _ -> toIr vis <> n VConstant s -> "c" <> show s type Params = [(Ident, LLVMType)] @@ -128,7 +132,6 @@ data LLVMIr | Comment String | UnsafeRaw String -- This should generally be avoided, and proper -- instructions should be used in its place - deriving (Show) -- | Converts a list of LLVMIr instructions to a string llvmIrToString :: [LLVMIr] -> String @@ -152,31 +155,31 @@ llvmIrToString = go 0 (GetElementPtr t1 t2 p t3 v1 t4 v2) -> do -- getelementptr inbounds %Foo, %Foo* %x, i32 0, i32 0 concat - [ "getelementptr ", show t1, ", " , show t2 - , " ", show p, ", ", show t3, " ", show v1 - , ", ", show t4, " ", show v2, "\n" + [ "getelementptr ", toIr t1, ", " , toIr t2 + , " ", toIr p, ", ", toIr t3, " ", toIr v1 + , ", ", toIr t4, " ", toIr v2, "\n" ] (ExtractValue t1 v i) -> do concat - [ "extractvalue ", show t1, " " - , show v, ", ", show i, "\n" + [ "extractvalue ", toIr t1, " " + , toIr v, ", ", show i, "\n" ] (GetElementPtrInbounds t1 t2 p t3 v1 t4 v2) -> do -- getelementptr inbounds %Foo, %Foo* %x, i32 0, i32 0 concat - [ "getelementptr inbounds ", show t1, ", " , show t2 - , " ", show p, ", ", show t3, " ", show v1, - ", ", show t4, " ", show v2, "\n" ] + [ "getelementptr inbounds ", toIr t1, ", " , toIr t2 + , " ", toIr p, ", ", toIr t3, " ", toIr v1, + ", ", toIr t4, " ", toIr v2, "\n" ] (Type (Ident n) types) -> concat [ "%", n, " = type { " - , intercalate ", " (map show types) + , intercalate ", " (map toIr types) , " }\n" ] (Define c t (Ident i) params) -> concat - [ "define ", show c, " ", show t, " @", i - , "(", intercalate ", " (map (\(Ident y, x) -> unwords [show x, "%" <> y]) params) + [ "define ", toIr c, " ", toIr t, " @", i + , "(", intercalate ", " (map (\(Ident y, x) -> unwords [toIr x, "%" <> y]) params) , ") {\n" ] DefineEnd -> "}\n" @@ -184,67 +187,67 @@ llvmIrToString = go 0 (SetVariable (Ident i) ir) -> concat ["%", i, " = ", insToString 0 ir] (Add t v1 v2) -> concat - [ "add ", show t, " ", show v1 - , ", ", show v2, "\n" + [ "add ", toIr t, " ", toIr v1 + , ", ", toIr v2, "\n" ] (Sub t v1 v2) -> concat - [ "sub ", show t, " ", show v1, ", " - , show v2, "\n" + [ "sub ", toIr t, " ", toIr v1, ", " + , toIr v2, "\n" ] (Div t v1 v2) -> concat - [ "sdiv ", show t, " ", show v1, ", " - , show v2, "\n" + [ "sdiv ", toIr t, " ", toIr v1, ", " + , toIr v2, "\n" ] (Mul t v1 v2) -> concat - [ "mul ", show t, " ", show v1 - , ", ", show v2, "\n" + [ "mul ", toIr t, " ", toIr v1 + , ", ", toIr v2, "\n" ] (Srem t v1 v2) -> concat - [ "srem ", show t, " ", show v1, ", " - , show v2, "\n" + [ "srem ", toIr t, " ", toIr v1, ", " + , toIr v2, "\n" ] (Call c t vis (Ident i) arg) -> concat - [ "call ", show c, " ", show t, " ", show vis, i, "(" - , intercalate ", " $ Prelude.map (\(x, y) -> show x <> " " <> show y) arg + [ "call ", toIr c, " ", toIr t, " ", toIr vis, i, "(" + , intercalate ", " $ Prelude.map (\(x, y) -> toIr x <> " " <> toIr y) arg , ")\n" ] - (Alloca t) -> unwords ["alloca", show t, "\n"] + (Alloca t) -> unwords ["alloca", toIr t, "\n"] (Store t1 val t2 (Ident id2)) -> concat - [ "store ", show t1, " ", show val - , ", ", show t2 , " %", id2, "\n" + [ "store ", toIr t1, " ", toIr val + , ", ", toIr t2 , " %", id2, "\n" ] (Load t1 t2 (Ident addr)) -> concat - [ "load ", show t1, ", " - , show t2, " %", addr, "\n" + [ "load ", toIr t1, ", " + , toIr t2, " %", addr, "\n" ] (Bitcast t1 v t2) -> concat - [ "bitcast ", show t1, " " - , show v, " to ", show t2, "\n" + [ "bitcast ", toIr t1, " " + , toIr v, " to ", toIr t2, "\n" ] (Icmp comp t v1 v2) -> concat - [ "icmp ", show comp, " ", show t - , " ", show v1, ", ", show v2, "\n" + [ "icmp ", toIr comp, " ", toIr t + , " ", toIr v1, ", ", toIr v2, "\n" ] (Ret t v) -> concat - [ "ret ", show t, " " - , show v, "\n" + [ "ret ", toIr t, " " + , toIr v, "\n" ] (UnsafeRaw s) -> s (Label (Ident s)) -> "\n" <> lblPfx <> s <> ":\n" (Br (Ident s)) -> "br label %" <> lblPfx <> s <> "\n" (BrCond val (Ident s1) (Ident s2)) -> concat - [ "br i1 ", show val, ", ", "label %" + [ "br i1 ", toIr val, ", ", "label %" , lblPfx, s1, ", ", "label %", lblPfx, s2, "\n" ] (Comment s) -> "; " <> s <> "\n" From 42c8ebc7b6f2ce4351285d182a9bde22d16ea384 Mon Sep 17 00:00:00 2001 From: sebastianselander Date: Thu, 23 Mar 2023 16:49:49 +0100 Subject: [PATCH 113/372] Making progress towards finished product --- language.cabal | 7 +- src/LambdaLifter/LambdaLifter.hs | 334 ++++++++++++++++--------------- src/Main.hs | 63 +++--- src/TypeChecker/TypeChecker.hs | 12 ++ tests/Tests.hs | 1 - 5 files changed, 222 insertions(+), 195 deletions(-) diff --git a/language.cabal b/language.cabal index dc436a5..a35b5f0 100644 --- a/language.cabal +++ b/language.cabal @@ -34,9 +34,9 @@ executable language TypeChecker.TypeChecker TypeChecker.TypeCheckerIr Renamer.Renamer - -- LambdaLifter.LambdaLifter - -- Codegen.Codegen - -- Codegen.LlvmIr + LambdaLifter.LambdaLifter + Codegen.Codegen + Codegen.LlvmIr hs-source-dirs: src @@ -49,6 +49,7 @@ executable language , array , hspec , QuickCheck + , directory default-language: GHC2021 diff --git a/src/LambdaLifter/LambdaLifter.hs b/src/LambdaLifter/LambdaLifter.hs index 271cc70..a09f1a7 100644 --- a/src/LambdaLifter/LambdaLifter.hs +++ b/src/LambdaLifter/LambdaLifter.hs @@ -1,192 +1,194 @@ ---{-# LANGUAGE LambdaCase #-} ---{-# LANGUAGE OverloadedStrings #-} - +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} module LambdaLifter.LambdaLifter where ---import Auxiliary (snoc) ---import Control.Applicative (Applicative (liftA2)) ---import Control.Monad.State (MonadState (get, put), State, --- evalState) ---import Data.Set (Set) ---import qualified Data.Set as Set ---import Prelude hiding (exp) ---import Renamer.Renamer ---import TypeChecker.TypeCheckerIr +import Auxiliary (snoc) +import Control.Applicative (Applicative (liftA2)) +import Control.Monad.State (MonadState (get, put), State, evalState) +import Data.Set (Set) +import Data.Set qualified as Set +import Renamer.Renamer +import TypeChecker.TypeChecker (partitionType) +import TypeChecker.TypeCheckerIr +import Prelude hiding (exp) +{- | Lift lambdas and let expression into supercombinators. +Three phases: +@freeVars@ annotates all the free variables. +@abstract@ converts lambdas into let expressions. +@collectScs@ moves every non-constant let expression to a top-level function. +-} +lambdaLift :: Program -> Program +lambdaLift = collectScs . abstract . freeVars ----- | Lift lambdas and let expression into supercombinators. ----- Three phases: ----- @freeVars@ annotatss all the free variables. ----- @abstract@ converts lambdas into let expressions. ----- @collectScs@ moves every non-constant let expression to a top-level function. ---lambdaLift :: Program -> Program ---lambdaLift = collectScs . abstract . freeVars +-- | Annotate free variables +freeVars :: Program -> AnnProgram +freeVars (Program ds) = + [ (n, xs, freeVarsExp (Set.fromList $ map fst xs) e) + | Bind n xs e <- ds + ] +freeVarsExp :: Set Ident -> ExpT -> AnnExpT +freeVarsExp localVars (exp, t) = case exp of + EId n + | Set.member n localVars -> (Set.singleton n, (AId n, t)) + | otherwise -> (mempty, (AId n, t)) + -- EInt i -> (mempty, AInt i) + ELit lit -> (mempty, (ALit lit, t)) + EApp e1 e2 -> (Set.union (freeVarsOf e1') (freeVarsOf e2'), (AApp e1' e2', t)) + where + e1' = freeVarsExp localVars e1 + e2' = freeVarsExp localVars e2 + EAdd e1 e2 -> (Set.union (freeVarsOf e1') (freeVarsOf e2'), (AAdd e1' e2', t)) + where + e1' = freeVarsExp localVars e1 + e2' = freeVarsExp localVars e2 + EAbs par e -> (Set.delete par $ freeVarsOf e', (AAbs par e', t)) + where + e' = freeVarsExp (Set.insert par localVars) e ----- | Annotate free variables ---freeVars :: Program -> AnnProgram ---freeVars (Program ds) = [ (n, xs, freeVarsExp (Set.fromList xs) e) --- | Bind n xs e <- ds --- ] + -- Sum free variables present in bind and the expression + ELet (Bind (name, t_bind) parms rhs) e -> (Set.union binders_frees e_free, (ALet new_bind e', t)) + where + binders_frees = Set.delete name $ freeVarsOf rhs' + e_free = Set.delete name $ freeVarsOf e' ---freeVarsExp :: Set Id -> Exp -> AnnExp ---freeVarsExp localVars = \case --- EId n | Set.member n localVars -> (Set.singleton n, AId n) --- | otherwise -> (mempty, AId n) + rhs' = freeVarsExp e_localVars rhs + new_bind = ABind (name, t_bind) parms rhs' --- ELit _ (LInt i) -> (mempty, AInt i) + e' = freeVarsExp e_localVars e + e_localVars = Set.insert name localVars --- EApp t e1 e2 -> (Set.union (freeVarsOf e1') (freeVarsOf e2'), AApp t e1' e2') --- where --- e1' = freeVarsExp localVars e1 --- e2' = freeVarsExp localVars e2 +freeVarsOf :: AnnExpT -> Set Ident +freeVarsOf = fst --- EAdd t e1 e2 -> (Set.union (freeVarsOf e1') (freeVarsOf e2'), AAdd t e1' e2') --- where --- e1' = freeVarsExp localVars e1 --- e2' = freeVarsExp localVars e2 +-- AST annotated with free variables +type AnnProgram = [(Id, [Id], AnnExpT)] --- EAbs t par e -> (Set.delete par $ freeVarsOf e', AAbs t par e') --- where --- e' = freeVarsExp (Set.insert par localVars) e +type AnnExpT = (Set Ident, AnnExpT') --- -- Sum free variables present in bind and the expression --- ELet (Bind name parms rhs) e -> (Set.union binders_frees e_free, ALet new_bind e') --- where --- binders_frees = Set.delete name $ freeVarsOf rhs' --- e_free = Set.delete name $ freeVarsOf e' +data ABind = ABind Id [Id] AnnExpT deriving (Show) --- rhs' = freeVarsExp e_localVars rhs --- new_bind = ABind name parms rhs' +type AnnExpT' = (AnnExp, Type) --- e' = freeVarsExp e_localVars e --- e_localVars = Set.insert name localVars +data AnnExp + = AId Ident + | ALit Lit + | ALet ABind AnnExpT + | AApp AnnExpT AnnExpT + | AAdd AnnExpT AnnExpT + | AAbs Ident AnnExpT + deriving (Show) +{- | Lift lambdas to let expression of the form @let sc = \v₁ x₁ -> e₁@. +Free variables are @v₁ v₂ .. vₙ@ are bound. +-} +abstract :: AnnProgram -> Program +abstract prog = Program $ evalState (mapM go prog) 0 + where + go :: (Id, [Id], AnnExpT) -> State Int Bind + go (name, parms, rhs) = Bind name (parms ++ parms1) <$> abstractExp rhs' + where + (rhs', parms1) = flattenLambdasAnn rhs ---freeVarsOf :: AnnExp -> Set Id ---freeVarsOf = fst +{- | Flatten nested lambdas and collect the parameters +@\x.\y.\z. ae → (ae, [x,y,z])@ +-} +flattenLambdasAnn :: AnnExpT -> (AnnExpT, [Id]) +flattenLambdasAnn ae = go (ae, []) + where + go :: (AnnExpT, [Id]) -> (AnnExpT, [Id]) + go ((free, (e, t)), acc) + | AAbs par (free1, e1) <- e + , TFun t_par _ <- t = + go ((Set.delete par free1, e1), snoc (par, t_par) acc) + | otherwise = ((free, (e, t)), acc) ----- AST annotated with free variables ---type AnnProgram = [(Id, [Id], AnnExp)] +abstractExp :: AnnExpT -> State Int ExpT +abstractExp (free, (exp, t)) = case exp of + AId n -> pure (EId n, t) + ALit lit -> pure (ELit lit, t) + AApp e1 e2 -> (,t) <$> liftA2 EApp (abstractExp e1) (abstractExp e2) + AAdd e1 e2 -> (,t) <$> liftA2 EAdd (abstractExp e1) (abstractExp e2) + ALet b e -> (,t) <$> liftA2 ELet (go b) (abstractExp e) + where + go (ABind name parms rhs) = do + (rhs', parms1) <- flattenLambdas <$> skipLambdas abstractExp rhs + pure $ Bind name (parms ++ parms1) rhs' ---type AnnExp = (Set Id, AnnExp') + skipLambdas :: (AnnExpT -> State Int ExpT) -> AnnExpT -> State Int ExpT + skipLambdas f (free, (ae, t)) = case ae of + AAbs par ae1 -> do + ae1' <- skipLambdas f ae1 + pure (EAbs par ae1', t) + _ -> f (free, (ae, t)) ---data ABind = ABind Id [Id] AnnExp deriving Show + -- Lift lambda into let and bind free variables + AAbs parm e -> do + i <- nextNumber + rhs <- abstractExp e ---data AnnExp' = AId Id --- | AInt Integer --- | ALet ABind AnnExp --- | AApp Type AnnExp AnnExp --- | AAdd Type AnnExp AnnExp --- | AAbs Type Id AnnExp --- deriving Show ----- | Lift lambdas to let expression of the form @let sc = \v₁ x₁ -> e₁@. ----- Free variables are @v₁ v₂ .. vₙ@ are bound. ---abstract :: AnnProgram -> Program ---abstract prog = Program $ evalState (mapM go prog) 0 --- where --- go :: (Id, [Id], AnnExp) -> State Int Bind --- go (name, parms, rhs) = Bind name (parms ++ parms1) <$> abstractExp rhs' --- where --- (rhs', parms1) = flattenLambdasAnn rhs + let sc_name = Ident ("sc_" ++ show i) + sc = (ELet (Bind (sc_name, t) vars rhs) (EId sc_name, t), t) + pure $ foldl applyVars sc freeList + where + freeList = Set.toList free + vars = zip names . fst $ partitionType (length names) t + names = snoc parm freeList + applyVars (e, t) name = (EApp (e, t) (EId name, t_var), t_return) + where + (t_var : _, t_return) = partitionType 1 t +nextNumber :: State Int Int +nextNumber = do + i <- get + put $ succ i + pure i ----- | Flatten nested lambdas and collect the parameters ----- @\x.\y.\z. ae → (ae, [x,y,z])@ ---flattenLambdasAnn :: AnnExp -> (AnnExp, [Id]) ---flattenLambdasAnn ae = go (ae, []) --- where --- go :: (AnnExp, [Id]) -> (AnnExp, [Id]) --- go ((free, e), acc) = --- case e of --- AAbs _ par (free1, e1) -> --- go ((Set.delete par free1, e1), snoc par acc) --- _ -> ((free, e), acc) +-- | Collects supercombinators by lifting non-constant let expressions +collectScs :: Program -> Program +collectScs (Program scs) = Program $ concatMap collectFromRhs scs + where + collectFromRhs (Bind name parms rhs) = + let (rhs_scs, rhs') = collectScsExp rhs + in Bind name parms rhs' : rhs_scs ---abstractExp :: AnnExp -> State Int Exp ---abstractExp (free, exp) = case exp of --- AId n -> pure $ EId n --- AInt i -> pure $ ELit (TMono "Int") (LInt i) --- AApp t e1 e2 -> liftA2 (EApp t) (abstractExp e1) (abstractExp e2) --- AAdd t e1 e2 -> liftA2 (EAdd t) (abstractExp e1) (abstractExp e2) --- ALet b e -> liftA2 ELet (go b) (abstractExp e) --- where --- go (ABind name parms rhs) = do --- (rhs', parms1) <- flattenLambdas <$> skipLambdas abstractExp rhs --- pure $ Bind name (parms ++ parms1) rhs' +collectScsExp :: ExpT -> ([Bind], ExpT) +collectScsExp expT@(exp, typ) = case exp of + EId _ -> ([], expT) + ELit _ -> ([], expT) + EApp e1 e2 -> (scs1 ++ scs2, (EApp e1' e2', typ)) + where + (scs1, e1') = collectScsExp e1 + (scs2, e2') = collectScsExp e2 + EAdd e1 e2 -> (scs1 ++ scs2, (EAdd e1' e2', typ)) + where + (scs1, e1') = collectScsExp e1 + (scs2, e2') = collectScsExp e2 + EAbs par e -> (scs, (EAbs par e', typ)) + where + (scs, e') = collectScsExp e --- skipLambdas :: (AnnExp -> State Int Exp) -> AnnExp -> State Int Exp --- skipLambdas f (free, ae) = case ae of --- AAbs t par ae1 -> EAbs t par <$> skipLambdas f ae1 --- _ -> f (free, ae) - --- -- Lift lambda into let and bind free variables --- AAbs t parm e -> do --- i <- nextNumber --- rhs <- abstractExp e - --- let sc_name = Ident ("sc_" ++ show i) --- sc = ELet (Bind (sc_name, t) parms rhs) $ EId (sc_name, t) - --- pure $ foldl (EApp $ TMono "Int") sc $ map EId freeList --- where --- freeList = Set.toList free --- parms = snoc parm freeList - - ---nextNumber :: State Int Int ---nextNumber = do --- i <- get --- put $ succ i --- pure i - ----- | Collects supercombinators by lifting non-constant let expressions ---collectScs :: Program -> Program ---collectScs (Program scs) = Program $ concatMap collectFromRhs scs --- where --- collectFromRhs (Bind name parms rhs) = --- let (rhs_scs, rhs') = collectScsExp rhs --- in Bind name parms rhs' : rhs_scs - - ---collectScsExp :: Exp -> ([Bind], Exp) ---collectScsExp = \case --- EId n -> ([], EId n) --- ELit _ (LInt i) -> ([], ELit (TMono "Int") (LInt i)) - --- EApp t e1 e2 -> (scs1 ++ scs2, EApp t e1' e2') --- where --- (scs1, e1') = collectScsExp e1 --- (scs2, e2') = collectScsExp e2 - --- EAdd t e1 e2 -> (scs1 ++ scs2, EAdd t e1' e2') --- where --- (scs1, e1') = collectScsExp e1 --- (scs2, e2') = collectScsExp e2 - --- EAbs t par e -> (scs, EAbs t par e') --- where --- (scs, e') = collectScsExp e - --- -- Collect supercombinators from bind, the rhss, and the expression. --- -- --- -- > f = let sc x y = rhs in e --- -- --- ELet (Bind name parms rhs) e -> if null parms --- then ( rhs_scs ++ e_scs, ELet bind e') --- else (bind : rhs_scs ++ e_scs, e') --- where --- bind = Bind name parms rhs' --- (rhs_scs, rhs') = collectScsExp rhs --- (e_scs, e') = collectScsExp e - - ----- @\x.\y.\z. e → (e, [x,y,z])@ ---flattenLambdas :: Exp -> (Exp, [Id]) ---flattenLambdas = go . (, []) --- where --- go (e, acc) = case e of --- EAbs _ par e1 -> go (e1, snoc par acc) --- _ -> (e, acc) + -- Collect supercombinators from bind, the rhss, and the expression. + -- + -- > f = let sc x y = rhs in e + -- + ELet (Bind name parms rhs) e -> + if null parms + then (rhs_scs ++ et_scs, (ELet bind et', snd et')) + else (bind : rhs_scs ++ et_scs, et') + where + bind = Bind name parms rhs' + (rhs_scs, rhs') = collectScsExp rhs + (et_scs, et') = collectScsExp e +-- @\x.\y.\z. e → (e, [x,y,z])@ +flattenLambdas :: ExpT -> (ExpT, [Id]) +flattenLambdas = go . (,[]) + where + go ((e, t), acc) = case e of + EAbs name e1 -> go (e1, snoc (name, t_var) acc) + where + t_var : _ = fst $ partitionType 1 t + _ -> ((e, t), acc) diff --git a/src/Main.hs b/src/Main.hs index c82f6a5..edb3eea 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -2,32 +2,36 @@ module Main where ---import Codegen.Codegen (generateCode) -import GHC.IO.Handle.Text (hPutStrLn) -import Grammar.ErrM (Err) -import Grammar.Par (myLexer, pProgram) -import Grammar.Print (printTree) +-- import Codegen.Codegen (generateCode) +import GHC.IO.Handle.Text (hPutStrLn) +import Grammar.ErrM (Err) +import Grammar.Par (myLexer, pProgram) +import Grammar.Print (printTree) -- import Interpreter (interpret) -import Control.Monad (when) -import Data.List.Extra (isSuffixOf) ---import LambdaLifter.LambdaLifter (lambdaLift) -import Renamer.Renamer (rename) -import System.Directory (createDirectory, doesPathExist, - getDirectoryContents, - removeDirectoryRecursive, - setCurrentDirectory) -import System.Environment (getArgs) -import System.Exit (exitFailure, exitSuccess) -import System.IO (stderr) -import System.Process.Extra (spawnCommand, waitForProcess) -import TypeChecker.TypeChecker (typecheck) +import Control.Monad (when) +import Data.List.Extra (isSuffixOf) + +-- import LambdaLifter.LambdaLifter (lambdaLift) +import Renamer.Renamer (rename) +import System.Directory ( + createDirectory, + doesPathExist, + getDirectoryContents, + removeDirectoryRecursive, + setCurrentDirectory, + ) +import System.Environment (getArgs) +import System.Exit (exitFailure, exitSuccess) +import System.IO (stderr) +import System.Process.Extra (spawnCommand, waitForProcess) +import TypeChecker.TypeChecker (typecheck) main :: IO () main = getArgs >>= \case [] -> print "Required file path missing" - ("-d": s : _) -> main' True s + ("-d" : s : _) -> main' True s (s : _) -> main' False s main' :: Bool -> String -> IO () @@ -39,7 +43,7 @@ main' debug s = do printToErr $ printTree parsed printToErr "\n-- Renamer --" - let renamed = rename parsed + renamed <- fromRenamerErr . rename $ parsed printToErr $ printTree renamed printToErr "\n-- TypeChecker --" @@ -49,10 +53,10 @@ main' debug s = do -- printToErr "\n-- Lambda Lifter --" -- let lifted = lambdaLift typechecked -- printToErr $ printTree lifted --- + -- -- printToErr "\n -- Printing compiler output to stdout --" -- compiled <- fromCompilerErr $ generateCode lifted - --putStrLn compiled + -- putStrLn compiled -- check <- doesPathExist "output" -- when check (removeDirectoryRecursive "output") @@ -60,7 +64,6 @@ main' debug s = do -- writeFile "output/llvm.ll" compiled -- if debug then debugDotViz else putStrLn compiled - -- interpred <- fromInterpreterErr $ interpret lifted -- putStrLn "\n-- interpret" -- print interpred @@ -76,8 +79,8 @@ debugDotViz = do mapM_ spawnWait commands setCurrentDirectory ".." return () - where - spawnWait s = spawnCommand s >>= waitForProcess + where + spawnWait s = spawnCommand s >>= waitForProcess printToErr :: String -> IO () printToErr = hPutStrLn stderr @@ -111,6 +114,16 @@ fromTypeCheckerErr = ) pure +fromRenamerErr :: Err a -> IO a +fromRenamerErr = + either + ( \err -> do + putStrLn "\nRENAMER ERROR" + putStrLn err + exitFailure + ) + pure + fromInterpreterErr :: Err a -> IO a fromInterpreterErr = either diff --git a/src/TypeChecker/TypeChecker.hs b/src/TypeChecker/TypeChecker.hs index 2bab6c8..b75f4e1 100644 --- a/src/TypeChecker/TypeChecker.hs +++ b/src/TypeChecker/TypeChecker.hs @@ -517,3 +517,15 @@ litType (LChar _) = char int = T.TLit "Int" char = T.TLit "Char" + +partitionType :: + Int -> -- Number of parameters to apply + Type -> + ([Type], Type) +partitionType = go [] + where + go acc 0 t = (acc, t) + go acc i t = case t of + TAll tvar t' -> second (TAll tvar) $ go acc i t' + TFun t1 t2 -> go (acc ++ [t1]) (i - 1) t2 + _ -> error "Number of parameters and type doesn't match" diff --git a/tests/Tests.hs b/tests/Tests.hs index 27a4eca..9c5649f 100644 --- a/tests/Tests.hs +++ b/tests/Tests.hs @@ -18,7 +18,6 @@ import TypeChecker.TypeCheckerIr ( Env (..), Error, Infer, - Poly (..), ) import TypeChecker.TypeCheckerIr qualified as T From e3df4192bbfa19caac41765d9e971eb13aab6d09 Mon Sep 17 00:00:00 2001 From: sebastianselander Date: Thu, 23 Mar 2023 17:20:19 +0100 Subject: [PATCH 114/372] created dummy monomorphizer --- language.cabal | 1 - src/Codegen/Codegen.hs | 420 ++++++++++++++++----------- src/LambdaLifter/LambdaLifter.hs | 194 ------------- src/Main.hs | 11 +- src/Monomorphizer/Monomorphizer.hs | 18 +- src/Monomorphizer/MonomorphizerIr.hs | 28 +- 6 files changed, 279 insertions(+), 393 deletions(-) delete mode 100644 src/LambdaLifter/LambdaLifter.hs diff --git a/language.cabal b/language.cabal index a35b5f0..cbb5260 100644 --- a/language.cabal +++ b/language.cabal @@ -34,7 +34,6 @@ executable language TypeChecker.TypeChecker TypeChecker.TypeCheckerIr Renamer.Renamer - LambdaLifter.LambdaLifter Codegen.Codegen Codegen.LlvmIr diff --git a/src/Codegen/Codegen.hs b/src/Codegen/Codegen.hs index a00ec8e..a8c3cfd 100644 --- a/src/Codegen/Codegen.hs +++ b/src/Codegen/Codegen.hs @@ -1,56 +1,69 @@ -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} module Codegen.Codegen (generateCode) where -import Auxiliary (snoc) -import Codegen.LlvmIr (CallingConvention (..), - LLVMComp (..), LLVMIr (..), - LLVMType (..), LLVMValue (..), - Visibility (..), llvmIrToString) -import Codegen.LlvmIr as LIR -import Control.Applicative ((<|>)) -import Control.Monad.State (StateT, execStateT, foldM_, - gets, modify) -import qualified Data.Bifunctor as BI -import Data.List.Extra (trim) -import Data.Map (Map) -import qualified Data.Map as Map -import Data.Maybe (fromJust, fromMaybe) -import Data.Tuple.Extra (dupe, first, second) -import qualified Grammar.Abs as GA -import Grammar.ErrM (Err) -import Monomorphizer.MonomorphizerIr as MIR -import System.Process.Extra (readCreateProcess, shell) + +import Auxiliary (snoc) +import Codegen.LlvmIr ( + CallingConvention (..), + LLVMComp (..), + LLVMIr (..), + LLVMType (..), + LLVMValue (..), + Visibility (..), + llvmIrToString, + ) +import Codegen.LlvmIr as LIR +import Control.Applicative ((<|>)) +import Control.Monad.State ( + StateT, + execStateT, + foldM_, + gets, + modify, + ) +import Data.Bifunctor qualified as BI +import Data.List.Extra (trim) +import Data.Map (Map) +import Data.Map qualified as Map +import Data.Maybe (fromJust, fromMaybe) +import Data.Tuple.Extra (dupe, first, second) +import Grammar.Abs qualified as GA +import Grammar.ErrM (Err) +import Monomorphizer.MonomorphizerIr as MIR +import System.Process.Extra (readCreateProcess, shell) + -- | The record used as the code generator state data CodeGenerator = CodeGenerator - { instructions :: [LLVMIr] - , functions :: Map Id FunctionInfo - , constructors :: Map Id ConstructorInfo + { instructions :: [LLVMIr] + , functions :: Map Id FunctionInfo + , constructors :: Map Id ConstructorInfo , variableCount :: Integer - , labelCount :: Integer + , labelCount :: Integer } -- | A state type synonym type CompilerState a = StateT CodeGenerator Err a data FunctionInfo = FunctionInfo - { numArgs :: Int + { numArgs :: Int , arguments :: [Id] - } deriving Show + } + deriving (Show) data ConstructorInfo = ConstructorInfo - { numArgsCI :: Int + { numArgsCI :: Int , argumentsCI :: [Id] - , numCI :: Integer - } deriving Show - + , numCI :: Integer + } + deriving (Show) -- | Adds a instruction to the CodeGenerator state emit :: LLVMIr -> CompilerState () -emit l = modify $ \t -> t { instructions = Auxiliary.snoc l $ instructions t } +emit l = modify $ \t -> t{instructions = Auxiliary.snoc l $ instructions t} -- | Increases the variable counter in the CodeGenerator state increaseVarCount :: CompilerState () -increaseVarCount = modify $ \t -> t { variableCount = variableCount t + 1 } +increaseVarCount = modify $ \t -> t{variableCount = variableCount t + 1} -- | Returns the variable count from the CodeGenerator state getVarCount :: CompilerState Integer @@ -66,76 +79,106 @@ getNewLabel = do modify (\t -> t{labelCount = labelCount t + 1}) gets labelCount --- | Produces a map of functions infos from a list of binds, --- which contains useful data for code generation. +{- | Produces a map of functions infos from a list of binds, + which contains useful data for code generation. +-} getFunctions :: [Bind] -> Map Id FunctionInfo getFunctions bs = Map.fromList $ go bs where go [] = [] go (Bind id args _ : xs) = - (id, FunctionInfo { numArgs=length args, arguments=args }) - : go xs - go (DataType n cons : xs) = do - map (\(Constructor id xs) -> ((id, MIR.Type n), FunctionInfo { - numArgs=length xs, arguments=createArgs xs - })) cons - <> go xs + (id, FunctionInfo{numArgs = length args, arguments = args}) + : go xs + go (DataType n cons : xs) = + do + map + ( \(Constructor id xs) -> + ( (id, MIR.Type n) + , FunctionInfo + { numArgs = length xs + , arguments = createArgs xs + } + ) + ) + cons + <> go xs createArgs :: [Type] -> [Id] -createArgs xs = fst $ foldl (\(acc, l) t -> (acc ++ [(GA.Ident ("arg_" <> show l) , t)],l+1)) ([], 0) xs +createArgs xs = fst $ foldl (\(acc, l) t -> (acc ++ [(GA.Ident ("arg_" <> show l), t)], l + 1)) ([], 0) xs --- | Produces a map of functions infos from a list of binds, --- which contains useful data for code generation. +{- | Produces a map of functions infos from a list of binds, + which contains useful data for code generation. +-} getConstructors :: [Bind] -> Map Id ConstructorInfo getConstructors bs = Map.fromList $ go bs where go [] = [] - go (DataType (GA.Ident n) cons : xs) = do - fst (foldl (\(acc,i) (Constructor (GA.Ident id) xs) -> (((GA.Ident (n <> "_" <> id), MIR.Type (GA.Ident n)), ConstructorInfo { - numArgsCI=length xs, - argumentsCI=createArgs xs, - numCI=i - }) : acc, i+1)) ([],0) cons) - <> go xs - go (_: xs) = go xs + go (DataType (GA.Ident n) cons : xs) = + do + fst + ( foldl + ( \(acc, i) (Constructor (GA.Ident id) xs) -> + ( ( (GA.Ident (n <> "_" <> id), MIR.Type (GA.Ident n)) + , ConstructorInfo + { numArgsCI = length xs + , argumentsCI = createArgs xs + , numCI = i + } + ) + : acc + , i + 1 + ) + ) + ([], 0) + cons + ) + <> go xs + go (_ : xs) = go xs initCodeGenerator :: [Bind] -> CodeGenerator -initCodeGenerator scs = CodeGenerator { instructions = defaultStart - , functions = getFunctions scs - , constructors = getConstructors scs - , variableCount = 0 - , labelCount = 0 - } +initCodeGenerator scs = + CodeGenerator + { instructions = defaultStart + , functions = getFunctions scs + , constructors = getConstructors scs + , variableCount = 0 + , labelCount = 0 + } run :: Err String -> IO () run s = do let s' = case s of Right s -> s - Left _ -> error "yo" + Left _ -> error "yo" writeFile "output/llvm.ll" s' putStrLn . trim =<< readCreateProcess (shell "lli") s' test :: Integer -> Program -test v = Program - [ DataType (GA.Ident "Craig") [ - Constructor (GA.Ident "Bob") [MIR.Type (GA.Ident "_Int")], - Constructor (GA.Ident "Betty") [MIR.Type (GA.Ident "_Int")] - ] - , DataType (GA.Ident "Alice") [ - Constructor (GA.Ident "Eve") [MIR.Type (GA.Ident "_Int")]--, - --(GA.Ident "Alice", [TInt, TInt]) - ] - , Bind (GA.Ident "fibonacci", MIR.Type (GA.Ident "_Int")) [(GA.Ident "x", MIR.Type (GA.Ident "_Int"))] (EId ("x", MIR.Type (GA.Ident "Craig")), MIR.Type (GA.Ident "Craig")) - , Bind (GA.Ident "main", MIR.Type (GA.Ident "_Int")) [] - --(EApp (MIR.Type (GA.Ident "Craig")) (EId (GA.Ident "Craig_Bob", MIR.Type (GA.Ident "Craig")), MIR.Type (GA.Ident "Craig")) (ELit (LInt v), MIR.Type (GA.Ident "_Int")), MIR.Type (GA.Ident "Craig"))-- (EInt 92) - $ eCaseInt (EApp (MIR.Type (GA.Ident "Craig")) (EId (GA.Ident "Craig_Bob", MIR.Type (GA.Ident "Craig")), MIR.Type (GA.Ident "Craig")) (ELit (LInt v), MIR.Type (GA.Ident "_Int")), MIR.Type (GA.Ident "Craig")) - [ injectionCons "Craig_Bob" "Craig" [CIdent (GA.Ident "x")] (EId (GA.Ident "x", MIR.Type (GA.Ident "_Int")), MIR.Type (GA.Ident "_Int")) - , injectionCons "Craig_Betty" "Craig" [CLit (LInt 5)] (int 2) - , Injection (CIdent (GA.Ident "z")) (int 3) - --, injectionInt 5 (int 6) - , injectionCatchAll (int 10) +test v = + Program + [ DataType + (GA.Ident "Craig") + [ Constructor (GA.Ident "Bob") [MIR.Type (GA.Ident "_Int")] + , Constructor (GA.Ident "Betty") [MIR.Type (GA.Ident "_Int")] ] - ] + , DataType + (GA.Ident "Alice") + [ Constructor (GA.Ident "Eve") [MIR.Type (GA.Ident "_Int")] -- , + -- (GA.Ident "Alice", [TInt, TInt]) + ] + , Bind (GA.Ident "fibonacci", MIR.Type (GA.Ident "_Int")) [(GA.Ident "x", MIR.Type (GA.Ident "_Int"))] (EId ("x", MIR.Type (GA.Ident "Craig")), MIR.Type (GA.Ident "Craig")) + , Bind (GA.Ident "main", MIR.Type (GA.Ident "_Int")) [] + -- (EApp (MIR.Type (GA.Ident "Craig")) (EId (GA.Ident "Craig_Bob", MIR.Type (GA.Ident "Craig")), MIR.Type (GA.Ident "Craig")) (ELit (LInt v), MIR.Type (GA.Ident "_Int")), MIR.Type (GA.Ident "Craig"))-- (EInt 92) + $ + eCaseInt + (EApp (MIR.Type (GA.Ident "Craig")) (EId (GA.Ident "Craig_Bob", MIR.Type (GA.Ident "Craig")), MIR.Type (GA.Ident "Craig")) (ELit (LInt v), MIR.Type (GA.Ident "_Int")), MIR.Type (GA.Ident "Craig")) + [ injectionCons "Craig_Bob" "Craig" [CIdent (GA.Ident "x")] (EId (GA.Ident "x", MIR.Type (GA.Ident "_Int")), MIR.Type (GA.Ident "_Int")) + , injectionCons "Craig_Betty" "Craig" [CLit (LInt 5)] (int 2) + , Injection (CIdent (GA.Ident "z")) (int 3) + , -- , injectionInt 5 (int 6) + injectionCatchAll (int 10) + ] + ] where injectionCons x y xs = Injection (CCons (GA.Ident x, MIR.Type (GA.Ident y)) xs) injectionInt x = Injection (CLit (LInt x)) @@ -153,11 +196,12 @@ generateCode (Program scs) = do llvmIrToString . instructions <$> execStateT (compileScs scs) codegen compileScs :: [Bind] -> CompilerState () -compileScs [] = do +compileScs [] = do -- as a last step create all the constructors -- //TODO maybe merge this with the data type match? c <- gets (Map.toList . constructors) - mapM_ (\((id, t), ci) -> do + mapM_ + ( \((id, t), ci) -> do let t' = type2LlvmType t let x = BI.second type2LlvmType <$> argumentsCI ci emit $ Define FastCC t' id x @@ -166,32 +210,47 @@ compileScs [] = do -- allocated the primary type emit $ SetVariable top (Alloca t') - -- set the first byte to the index of the constructor - emit $ SetVariable ptr $ - GetElementPtr t' (Ref t') (VIdent top I8) - I64 (VInteger 0) - I32 (VInteger 0) - emit $ Store I8 (VInteger $ numCI ci ) (Ref I8) ptr + -- set the first byte to the index of the constructor + emit $ + SetVariable ptr $ + GetElementPtr + t' + (Ref t') + (VIdent top I8) + I64 + (VInteger 0) + I32 + (VInteger 0) + emit $ Store I8 (VInteger $ numCI ci) (Ref I8) ptr - -- get a pointer of the correct type + -- get a pointer of the correct type ptr' <- getNewVar emit $ SetVariable ptr' (Bitcast (Ref t') (VIdent top Ptr) (Ref $ CustomType id)) - --emit $ UnsafeRaw "\n" + -- emit $ UnsafeRaw "\n" - enumerateOneM_ (\i (GA.Ident arg_n, arg_t) -> do - let arg_t' = type2LlvmType arg_t - emit $ Comment (toIr arg_t' <>" "<> arg_n <> " " <> show i ) - elemPtr <- getNewVar - emit $ SetVariable elemPtr ( - GetElementPtr (CustomType id) (Ref (CustomType id)) - (VIdent ptr' Ptr) - I64 (VInteger 0) - I32 (VInteger i)) - emit $ Store arg_t' (VIdent (GA.Ident arg_n) arg_t') Ptr elemPtr - ) (argumentsCI ci) + enumerateOneM_ + ( \i (GA.Ident arg_n, arg_t) -> do + let arg_t' = type2LlvmType arg_t + emit $ Comment (toIr arg_t' <> " " <> arg_n <> " " <> show i) + elemPtr <- getNewVar + emit $ + SetVariable + elemPtr + ( GetElementPtr + (CustomType id) + (Ref (CustomType id)) + (VIdent ptr' Ptr) + I64 + (VInteger 0) + I32 + (VInteger i) + ) + emit $ Store arg_t' (VIdent (GA.Ident arg_n) arg_t') Ptr elemPtr + ) + (argumentsCI ci) - --emit $ UnsafeRaw "\n" + -- emit $ UnsafeRaw "\n" -- load and return the constructed value emit $ Comment "Return the newly constructed value" @@ -200,8 +259,9 @@ compileScs [] = do emit $ Ret t' (VIdent load t') emit DefineEnd - modify $ \s -> s { variableCount = 0 } - ) c + modify $ \s -> s{variableCount = 0} + ) + c compileScs (Bind (name, _t) args exp : xs) = do emit $ UnsafeRaw "\n" emit . Comment $ show name <> ": " <> show exp @@ -212,18 +272,20 @@ compileScs (Bind (name, _t) args exp : xs) = do then mapM_ emit $ mainContent functionBody else emit $ Ret I64 functionBody emit DefineEnd - modify $ \s -> s { variableCount = 0 } + modify $ \s -> s{variableCount = 0} compileScs xs compileScs (DataType id@(GA.Ident outer_id) ts : xs) = do let biggestVariant = maximum ((\(Constructor _ t) -> sum $ typeByteSize . type2LlvmType <$> t) <$> ts) emit $ LIR.Type id [I8, Array biggestVariant I8] - mapM_ (\(Constructor (GA.Ident inner_id) fi) -> do + mapM_ + ( \(Constructor (GA.Ident inner_id) fi) -> do emit $ LIR.Type (GA.Ident $ outer_id <> "_" <> inner_id) (I8 : map type2LlvmType fi) - ) ts + ) + ts compileScs xs - -- where - -- _t_return = snd $ partitionType (length args) t +-- where +-- _t_return = snd $ partitionType (length args) t mainContent :: LLVMValue -> [LLVMIr] mainContent var = @@ -233,7 +295,7 @@ mainContent var = -- " %3 = bitcast %Craig* %2 to i72*\n" <> -- " %4 = load i72, ptr %3\n" <> -- " call i32 (ptr, ...) @printf(ptr noundef @.str, i72 noundef %4)\n" - "call i32 (ptr, ...) @printf(ptr noundef @.str, i64 noundef " <> toIr var <> ")\n" + "call i32 (ptr, ...) @printf(ptr noundef @.str, i64 noundef " <> toIr var <> ")\n" , -- , SetVariable (GA.Ident "p") (Icmp LLEq I64 (VInteger 2) (VInteger 2)) -- , BrCond (VIdent (GA.Ident "p")) (GA.Ident "b_1") (GA.Ident "b_2") -- , Label (GA.Ident "b_1") @@ -249,24 +311,26 @@ mainContent var = ] defaultStart :: [LLVMIr] -defaultStart = [ UnsafeRaw "target triple = \"x86_64-pc-linux-gnu\"\n" - , UnsafeRaw "target datalayout = \"e-m:o-i64:64-f80:128-n8:16:32:64-S128\"\n" - , UnsafeRaw "@.str = private unnamed_addr constant [3 x i8] c\"%x\n\", align 1\n" - , UnsafeRaw "declare i32 @printf(ptr noalias nocapture, ...)\n" - ] +defaultStart = + [ UnsafeRaw "target triple = \"x86_64-pc-linux-gnu\"\n" + , UnsafeRaw "target datalayout = \"e-m:o-i64:64-f80:128-n8:16:32:64-S128\"\n" + , UnsafeRaw "@.str = private unnamed_addr constant [3 x i8] c\"%x\n\", align 1\n" + , UnsafeRaw "declare i32 @printf(ptr noalias nocapture, ...)\n" + ] compileExp :: Exp -> CompilerState () -compileExp (ELit lit) = emitLit lit -compileExp (EAdd t e1 e2) = emitAdd t (fst e1) (fst e2) ---compileExp (ESub t e1 e2) = emitSub t e1 e2 -compileExp (EId (name, _)) = emitIdent name -compileExp (EApp t e1 e2) = emitApp t (fst e1) (fst e2) ---compileExp (EAbs t ti e) = emitAbs t ti e +compileExp (ELit lit) = emitLit lit +compileExp (EAdd t e1 e2) = emitAdd t (fst e1) (fst e2) +-- compileExp (ESub t e1 e2) = emitSub t e1 e2 +compileExp (EId (name, _)) = emitIdent name +compileExp (EApp t e1 e2) = emitApp t (fst e1) (fst e2) +-- compileExp (EAbs t ti e) = emitAbs t ti e compileExp (ELet _ binds e) = undefined emitLet binds (fst e) -compileExp (ECase t e cs) = emitECased t e (map (t,) cs) - -- go (EMul e1 e2) = emitMul e1 e2 - -- go (EDiv e1 e2) = emitDiv e1 e2 - -- go (EMod e1 e2) = emitMod e1 e2 +compileExp (ECase t e cs) = emitECased t e (map (t,) cs) + +-- go (EMul e1 e2) = emitMul e1 e2 +-- go (EDiv e1 e2) = emitDiv e1 e2 +-- go (EMod e1 e2) = emitMod e1 e2 --- aux functions --- emitECased :: Type -> ExpT -> [(Type, Injection)] -> CompilerState () @@ -309,31 +373,33 @@ emitECased t e cases = do emit $ SetVariable casted (Load (CustomType (fst consId)) Ptr castedPtr) val <- exprToValue (fst exp) - enumerateOneM_ (\i c -> do + enumerateOneM_ + ( \i c -> do case c of - CIdent x -> do + CIdent x -> do emit . Comment $ "ident " <> show x emit $ SetVariable x (ExtractValue (CustomType (fst consId)) (VIdent casted Ptr) i) emit $ Store ty val Ptr stackPtr CCons x cs -> error "nested constructor" - CLit l -> do + CLit l -> do testVar <- getNewVar emit $ SetVariable testVar (ExtractValue (CustomType (fst consId)) (VIdent casted Ptr) i) case l of - LInt l -> emit $ Icmp LLEq I64 (VIdent testVar Ptr) (VInteger l) + LInt l -> emit $ Icmp LLEq I64 (VIdent testVar Ptr) (VInteger l) LChar c -> emit $ Icmp LLEq I8 (VIdent testVar Ptr) (VChar c) - CatchAll -> emit . Comment $ "Catch all" + CatchAll -> emit . Comment $ "Catch all" emit . Comment $ "return this " <> toIr val emit . Comment . show $ c emit . Comment . show $ i - ) cs + ) + cs -- emit $ Store ty val Ptr stackPtr emit $ Br label emit $ Label lbl_failPos emitCases rt ty label stackPtr vs (Injection (MIR.CLit i) exp) = do let i' = case i of - LInt i -> VInteger i - LChar i -> VChar i + LInt i -> VInteger i + LChar i -> VChar i ns <- getNewVar lbl_failPos <- (\x -> GA.Ident $ "failed_" <> show x) <$> getNewLabel lbl_succPos <- (\x -> GA.Ident $ "success_" <> show x) <$> getNewLabel @@ -359,7 +425,6 @@ emitECased t e cases = do emit $ Store ty val Ptr stackPtr emit $ Br label - emitLet :: Bind -> Exp -> CompilerState () emitLet xs e = do emit $ @@ -380,18 +445,18 @@ emitApp t e1 e2 = appEmitter t e1 e2 [] let newStack = e2 : stack case e1 of EApp _ (e1', _) (e2', _) -> appEmitter t e1' e2' newStack - EId id@(GA.Ident name,_ ) -> do + EId id@(GA.Ident name, _) -> do args <- traverse exprToValue newStack vs <- getNewVar funcs <- gets functions consts <- gets constructors - let visibility = fromMaybe Local $ - Global <$ Map.lookup id consts - <|> - Global <$ Map.lookup id funcs - -- this piece of code could probably be improved, i.e remove the double `const Global` - args' = map (first valueGetType . dupe) args - call = Call FastCC (type2LlvmType t) visibility (GA.Ident name) args' + let visibility = + fromMaybe Local $ + Global <$ Map.lookup id consts + <|> Global <$ Map.lookup id funcs + -- this piece of code could probably be improved, i.e remove the double `const Global` + args' = map (first valueGetType . dupe) args + call = Call FastCC (type2LlvmType t) visibility (GA.Ident name) args' emit $ SetVariable vs call x -> error $ "The unspeakable happened: " <> show x @@ -405,14 +470,13 @@ emitIdent id = do emitLit :: Lit -> CompilerState () emitLit i = do -- !!this should never happen!! - let (i',t) = case i of - (LInt i'') -> (VInteger i'',I64) - (LChar i'') -> (VChar i'', I8) + let (i', t) = case i of + (LInt i'') -> (VInteger i'', I64) + (LChar i'') -> (VChar i'', I8) varCount <- getNewVar emit $ Comment "This should not have happened!" emit $ SetVariable (GA.Ident (show varCount)) (Add t i' (VInteger 0)) - emitAdd :: Type -> Exp -> Exp -> CompilerState () emitAdd t e1 e2 = do v1 <- exprToValue e1 @@ -430,8 +494,8 @@ emitSub t e1 e2 = do exprToValue :: Exp -> CompilerState LLVMValue exprToValue = \case ELit i -> pure $ case i of - (LInt i) -> VInteger i - (LChar i) -> VChar i + (LInt i) -> VInteger i + (LChar i) -> VChar i EId id@(name, t) -> do funcs <- gets functions case Map.lookup id funcs of @@ -439,8 +503,10 @@ exprToValue = \case if numArgs fi == 0 then do vc <- getNewVar - emit $ SetVariable vc - (Call FastCC (type2LlvmType t) Global name []) + emit $ + SetVariable + vc + (Call FastCC (type2LlvmType t) Global name []) pure $ VIdent vc (type2LlvmType t) else pure $ VFunction name Global (type2LlvmType t) Nothing -> pure $ VIdent name (type2LlvmType t) @@ -452,45 +518,45 @@ exprToValue = \case type2LlvmType :: Type -> LLVMType type2LlvmType (MIR.Type (GA.Ident t)) = case t of "_Int" -> I64 - t -> CustomType (GA.Ident t) - -- TInt -> I64 - -- TFun t xs -> do - -- let (t', xs') = function2LLVMType xs [type2LlvmType t] - -- Function t' xs' - -- TPol t -> CustomType t - --where - -- function2LLVMType :: Type -> [LLVMType] -> (LLVMType, [LLVMType]) - -- function2LLVMType (TFun t xs) s = function2LLVMType xs (type2LlvmType t : s) - -- function2LLVMType x s = (type2LlvmType x, s) + t -> CustomType (GA.Ident t) + +-- TInt -> I64 +-- TFun t xs -> do +-- let (t', xs') = function2LLVMType xs [type2LlvmType t] +-- Function t' xs' +-- TPol t -> CustomType t +-- where +-- function2LLVMType :: Type -> [LLVMType] -> (LLVMType, [LLVMType]) +-- function2LLVMType (TFun t xs) s = function2LLVMType xs (type2LlvmType t : s) +-- function2LLVMType x s = (type2LlvmType x, s) getType :: Exp -> LLVMType -getType (ELit l) = I64 -getType (EAdd t _ _) = type2LlvmType t ---getType (ESub t _ _) = type2LlvmType t -getType (EId (_, t)) = type2LlvmType t -getType (EApp t _ _) = type2LlvmType t ---getType (EAbs t _ _) = type2LlvmType t +getType (ELit l) = I64 +getType (EAdd t _ _) = type2LlvmType t +-- getType (ESub t _ _) = type2LlvmType t +getType (EId (_, t)) = type2LlvmType t +getType (EApp t _ _) = type2LlvmType t +-- getType (EAbs t _ _) = type2LlvmType t getType (ELet (_, t) _ e) = type2LlvmType t -getType (ECase t _ _) = type2LlvmType t +getType (ECase t _ _) = type2LlvmType t valueGetType :: LLVMValue -> LLVMType -valueGetType (VInteger _) = I64 -valueGetType (VChar _) = I8 -valueGetType (VIdent _ t) = t -valueGetType (VConstant s) = Array (fromIntegral $ length s) I8 +valueGetType (VInteger _) = I64 +valueGetType (VChar _) = I8 +valueGetType (VIdent _ t) = t +valueGetType (VConstant s) = Array (fromIntegral $ length s) I8 valueGetType (VFunction _ _ t) = t typeByteSize :: LLVMType -> Integer -typeByteSize I1 = 1 -typeByteSize I8 = 1 -typeByteSize I32 = 4 -typeByteSize I64 = 8 -typeByteSize Ptr = 8 -typeByteSize (Ref _) = 8 +typeByteSize I1 = 1 +typeByteSize I8 = 1 +typeByteSize I32 = 4 +typeByteSize I64 = 8 +typeByteSize Ptr = 8 +typeByteSize (Ref _) = 8 typeByteSize (Function _ _) = 8 -typeByteSize (Array n t) = n * typeByteSize t +typeByteSize (Array n t) = n * typeByteSize t typeByteSize (CustomType _) = 8 enumerateOneM_ :: Monad m => (Integer -> a -> m b) -> [a] -> m () enumerateOneM_ f = foldM_ (\i a -> f i a >> pure (i + 1)) 1 - diff --git a/src/LambdaLifter/LambdaLifter.hs b/src/LambdaLifter/LambdaLifter.hs deleted file mode 100644 index a09f1a7..0000000 --- a/src/LambdaLifter/LambdaLifter.hs +++ /dev/null @@ -1,194 +0,0 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} - -module LambdaLifter.LambdaLifter where - -import Auxiliary (snoc) -import Control.Applicative (Applicative (liftA2)) -import Control.Monad.State (MonadState (get, put), State, evalState) -import Data.Set (Set) -import Data.Set qualified as Set -import Renamer.Renamer -import TypeChecker.TypeChecker (partitionType) -import TypeChecker.TypeCheckerIr -import Prelude hiding (exp) - -{- | Lift lambdas and let expression into supercombinators. -Three phases: -@freeVars@ annotates all the free variables. -@abstract@ converts lambdas into let expressions. -@collectScs@ moves every non-constant let expression to a top-level function. --} -lambdaLift :: Program -> Program -lambdaLift = collectScs . abstract . freeVars - --- | Annotate free variables -freeVars :: Program -> AnnProgram -freeVars (Program ds) = - [ (n, xs, freeVarsExp (Set.fromList $ map fst xs) e) - | Bind n xs e <- ds - ] - -freeVarsExp :: Set Ident -> ExpT -> AnnExpT -freeVarsExp localVars (exp, t) = case exp of - EId n - | Set.member n localVars -> (Set.singleton n, (AId n, t)) - | otherwise -> (mempty, (AId n, t)) - -- EInt i -> (mempty, AInt i) - ELit lit -> (mempty, (ALit lit, t)) - EApp e1 e2 -> (Set.union (freeVarsOf e1') (freeVarsOf e2'), (AApp e1' e2', t)) - where - e1' = freeVarsExp localVars e1 - e2' = freeVarsExp localVars e2 - EAdd e1 e2 -> (Set.union (freeVarsOf e1') (freeVarsOf e2'), (AAdd e1' e2', t)) - where - e1' = freeVarsExp localVars e1 - e2' = freeVarsExp localVars e2 - EAbs par e -> (Set.delete par $ freeVarsOf e', (AAbs par e', t)) - where - e' = freeVarsExp (Set.insert par localVars) e - - -- Sum free variables present in bind and the expression - ELet (Bind (name, t_bind) parms rhs) e -> (Set.union binders_frees e_free, (ALet new_bind e', t)) - where - binders_frees = Set.delete name $ freeVarsOf rhs' - e_free = Set.delete name $ freeVarsOf e' - - rhs' = freeVarsExp e_localVars rhs - new_bind = ABind (name, t_bind) parms rhs' - - e' = freeVarsExp e_localVars e - e_localVars = Set.insert name localVars - -freeVarsOf :: AnnExpT -> Set Ident -freeVarsOf = fst - --- AST annotated with free variables -type AnnProgram = [(Id, [Id], AnnExpT)] - -type AnnExpT = (Set Ident, AnnExpT') - -data ABind = ABind Id [Id] AnnExpT deriving (Show) - -type AnnExpT' = (AnnExp, Type) - -data AnnExp - = AId Ident - | ALit Lit - | ALet ABind AnnExpT - | AApp AnnExpT AnnExpT - | AAdd AnnExpT AnnExpT - | AAbs Ident AnnExpT - deriving (Show) - -{- | Lift lambdas to let expression of the form @let sc = \v₁ x₁ -> e₁@. -Free variables are @v₁ v₂ .. vₙ@ are bound. --} -abstract :: AnnProgram -> Program -abstract prog = Program $ evalState (mapM go prog) 0 - where - go :: (Id, [Id], AnnExpT) -> State Int Bind - go (name, parms, rhs) = Bind name (parms ++ parms1) <$> abstractExp rhs' - where - (rhs', parms1) = flattenLambdasAnn rhs - -{- | Flatten nested lambdas and collect the parameters -@\x.\y.\z. ae → (ae, [x,y,z])@ --} -flattenLambdasAnn :: AnnExpT -> (AnnExpT, [Id]) -flattenLambdasAnn ae = go (ae, []) - where - go :: (AnnExpT, [Id]) -> (AnnExpT, [Id]) - go ((free, (e, t)), acc) - | AAbs par (free1, e1) <- e - , TFun t_par _ <- t = - go ((Set.delete par free1, e1), snoc (par, t_par) acc) - | otherwise = ((free, (e, t)), acc) - -abstractExp :: AnnExpT -> State Int ExpT -abstractExp (free, (exp, t)) = case exp of - AId n -> pure (EId n, t) - ALit lit -> pure (ELit lit, t) - AApp e1 e2 -> (,t) <$> liftA2 EApp (abstractExp e1) (abstractExp e2) - AAdd e1 e2 -> (,t) <$> liftA2 EAdd (abstractExp e1) (abstractExp e2) - ALet b e -> (,t) <$> liftA2 ELet (go b) (abstractExp e) - where - go (ABind name parms rhs) = do - (rhs', parms1) <- flattenLambdas <$> skipLambdas abstractExp rhs - pure $ Bind name (parms ++ parms1) rhs' - - skipLambdas :: (AnnExpT -> State Int ExpT) -> AnnExpT -> State Int ExpT - skipLambdas f (free, (ae, t)) = case ae of - AAbs par ae1 -> do - ae1' <- skipLambdas f ae1 - pure (EAbs par ae1', t) - _ -> f (free, (ae, t)) - - -- Lift lambda into let and bind free variables - AAbs parm e -> do - i <- nextNumber - rhs <- abstractExp e - - let sc_name = Ident ("sc_" ++ show i) - sc = (ELet (Bind (sc_name, t) vars rhs) (EId sc_name, t), t) - pure $ foldl applyVars sc freeList - where - freeList = Set.toList free - vars = zip names . fst $ partitionType (length names) t - names = snoc parm freeList - applyVars (e, t) name = (EApp (e, t) (EId name, t_var), t_return) - where - (t_var : _, t_return) = partitionType 1 t - -nextNumber :: State Int Int -nextNumber = do - i <- get - put $ succ i - pure i - --- | Collects supercombinators by lifting non-constant let expressions -collectScs :: Program -> Program -collectScs (Program scs) = Program $ concatMap collectFromRhs scs - where - collectFromRhs (Bind name parms rhs) = - let (rhs_scs, rhs') = collectScsExp rhs - in Bind name parms rhs' : rhs_scs - -collectScsExp :: ExpT -> ([Bind], ExpT) -collectScsExp expT@(exp, typ) = case exp of - EId _ -> ([], expT) - ELit _ -> ([], expT) - EApp e1 e2 -> (scs1 ++ scs2, (EApp e1' e2', typ)) - where - (scs1, e1') = collectScsExp e1 - (scs2, e2') = collectScsExp e2 - EAdd e1 e2 -> (scs1 ++ scs2, (EAdd e1' e2', typ)) - where - (scs1, e1') = collectScsExp e1 - (scs2, e2') = collectScsExp e2 - EAbs par e -> (scs, (EAbs par e', typ)) - where - (scs, e') = collectScsExp e - - -- Collect supercombinators from bind, the rhss, and the expression. - -- - -- > f = let sc x y = rhs in e - -- - ELet (Bind name parms rhs) e -> - if null parms - then (rhs_scs ++ et_scs, (ELet bind et', snd et')) - else (bind : rhs_scs ++ et_scs, et') - where - bind = Bind name parms rhs' - (rhs_scs, rhs') = collectScsExp rhs - (et_scs, et') = collectScsExp e - --- @\x.\y.\z. e → (e, [x,y,z])@ -flattenLambdas :: ExpT -> (ExpT, [Id]) -flattenLambdas = go . (,[]) - where - go ((e, t), acc) = case e of - EAbs name e1 -> go (e1, snoc (name, t_var) acc) - where - t_var : _ = fst $ partitionType 1 t - _ -> ((e, t), acc) diff --git a/src/Main.hs b/src/Main.hs index edb3eea..ba7578c 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -2,17 +2,16 @@ module Main where --- import Codegen.Codegen (generateCode) +import Codegen.Codegen (generateCode) import GHC.IO.Handle.Text (hPutStrLn) import Grammar.ErrM (Err) import Grammar.Par (myLexer, pProgram) import Grammar.Print (printTree) +import Monomorphizer.Monomorphizer (monomorphize) --- import Interpreter (interpret) import Control.Monad (when) import Data.List.Extra (isSuffixOf) --- import LambdaLifter.LambdaLifter (lambdaLift) import Renamer.Renamer (rename) import System.Directory ( createDirectory, @@ -54,9 +53,9 @@ main' debug s = do -- let lifted = lambdaLift typechecked -- printToErr $ printTree lifted -- - -- printToErr "\n -- Printing compiler output to stdout --" - -- compiled <- fromCompilerErr $ generateCode lifted - -- putStrLn compiled + printToErr "\n -- Printing compiler output to stdout --" + compiled <- fromCompilerErr $ generateCode (monomorphize typechecked) + putStrLn compiled -- check <- doesPathExist "output" -- when check (removeDirectoryRecursive "output") diff --git a/src/Monomorphizer/Monomorphizer.hs b/src/Monomorphizer/Monomorphizer.hs index 58a0abc..69cfa35 100644 --- a/src/Monomorphizer/Monomorphizer.hs +++ b/src/Monomorphizer/Monomorphizer.hs @@ -1 +1,17 @@ -module Monomorphizer.Monomorphizer where +module Monomorphizer.Monomorphizer (monomorphize) where + +import Monomorphizer.MonomorphizerIr +import TypeChecker.TypeCheckerIr qualified as T + +monomorphize :: T.Program -> Program +monomorphize (T.Program ds) = Program $ monoDefs ds + +monoDefs :: [T.Def] -> [Def] +monoDefs = map monoDef + +monoDef :: T.Def -> Def +monoDef (T.DBind bind) = DBind $ monoBind bind +monoDef (T.DData d) = DData d + +monoBind :: T.Bind -> Bind +monoBind (T.Bind name args e) = Bind name args e diff --git a/src/Monomorphizer/MonomorphizerIr.hs b/src/Monomorphizer/MonomorphizerIr.hs index 606a719..8f75f71 100644 --- a/src/Monomorphizer/MonomorphizerIr.hs +++ b/src/Monomorphizer/MonomorphizerIr.hs @@ -1,14 +1,19 @@ module Monomorphizer.MonomorphizerIr where -import Grammar.Abs (Ident) -newtype Program = Program [Bind] +import Grammar.Abs (Data, Ident, Init) +import TypeChecker.TypeCheckerIr (ExpT, Id, Indexed) + +newtype Program = Program [Def] deriving (Show, Ord, Eq) -data Bind = Bind Id [Id] ExpT | DataType Ident [Constructor] +data Def = DBind Bind | DData Data + deriving (Show, Ord, Eq) + +data Bind = Bind Id [Id] ExpT deriving (Show, Ord, Eq) data Exp - = EId Id + = EId Id | ELit Lit | ELet Id ExpT ExpT | EApp Type ExpT ExpT @@ -16,20 +21,15 @@ data Exp | ECase Type ExpT [Injection] deriving (Show, Ord, Eq) -data Injection = Injection Case ExpT - deriving (Show, Ord, Eq) - -data Case = CLit Lit | CCons Id [Case] | CIdent Ident | CatchAll - deriving (Show, Ord, Eq) +data Injection = Injection (Init, Type) ExpT + deriving (Eq, Ord, Show) data Constructor = Constructor Ident [Type] deriving (Show, Ord, Eq) -type Id = (Ident, Type) -type ExpT = (Exp, Type) - -data Lit = LInt Integer - | LChar Char +data Lit + = LInt Integer + | LChar Char deriving (Show, Ord, Eq) newtype Type = Type Ident From e283e83486d264031ec6e365d0fa2b6e30250161 Mon Sep 17 00:00:00 2001 From: Samuel Hammersberg Date: Thu, 23 Mar 2023 17:49:37 +0100 Subject: [PATCH 115/372] Fixed some reexports. --- src/Monomorphizer/MonomorphizerIr.hs | 11 ++++++++--- 1 file changed, 8 insertions(+), 3 deletions(-) diff --git a/src/Monomorphizer/MonomorphizerIr.hs b/src/Monomorphizer/MonomorphizerIr.hs index 8f75f71..2025881 100644 --- a/src/Monomorphizer/MonomorphizerIr.hs +++ b/src/Monomorphizer/MonomorphizerIr.hs @@ -1,7 +1,12 @@ -module Monomorphizer.MonomorphizerIr where +module Monomorphizer.MonomorphizerIr (module Monomorphizer.MonomorphizerIr, module RE1, module RE2) where + +import qualified Grammar.Abs as RE1 (Data (..), Ident (..), + Init (..)) +import qualified TypeChecker.TypeCheckerIr as RE2 (ExpT, Id, Indexed) + +import Grammar.Abs (Data (..), Ident (..), Init (..)) +import TypeChecker.TypeCheckerIr (ExpT, Id, Indexed) -import Grammar.Abs (Data, Ident, Init) -import TypeChecker.TypeCheckerIr (ExpT, Id, Indexed) newtype Program = Program [Def] deriving (Show, Ord, Eq) From c19f82189228016eac76e6daaf59fb52cd225b16 Mon Sep 17 00:00:00 2001 From: Samuel Hammersberg Date: Thu, 23 Mar 2023 17:54:41 +0100 Subject: [PATCH 116/372] Switched around EId. --- src/Monomorphizer/MonomorphizerIr.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Monomorphizer/MonomorphizerIr.hs b/src/Monomorphizer/MonomorphizerIr.hs index 2025881..29131ca 100644 --- a/src/Monomorphizer/MonomorphizerIr.hs +++ b/src/Monomorphizer/MonomorphizerIr.hs @@ -18,7 +18,7 @@ data Bind = Bind Id [Id] ExpT deriving (Show, Ord, Eq) data Exp - = EId Id + = EId Ident | ELit Lit | ELet Id ExpT ExpT | EApp Type ExpT ExpT From c6e8305215c6657aeb9ed0ad2c5a1195f12e7b3b Mon Sep 17 00:00:00 2001 From: sebastianselander Date: Thu, 23 Mar 2023 18:15:25 +0100 Subject: [PATCH 117/372] created dummy monomorphizer --- src/Monomorphizer/Monomorphizer.hs | 38 +++++++++++++++++++++++++++- src/Monomorphizer/MonomorphizerIr.hs | 23 ++++++++--------- src/TypeChecker/TypeCheckerIr.hs | 11 +++++++- 3 files changed, 57 insertions(+), 15 deletions(-) diff --git a/src/Monomorphizer/Monomorphizer.hs b/src/Monomorphizer/Monomorphizer.hs index 69cfa35..a2c7317 100644 --- a/src/Monomorphizer/Monomorphizer.hs +++ b/src/Monomorphizer/Monomorphizer.hs @@ -1,5 +1,8 @@ +{-# LANGUAGE LambdaCase #-} + module Monomorphizer.Monomorphizer (monomorphize) where +import Grammar.Abs (Ident (..)) import Monomorphizer.MonomorphizerIr import TypeChecker.TypeCheckerIr qualified as T @@ -14,4 +17,37 @@ monoDef (T.DBind bind) = DBind $ monoBind bind monoDef (T.DData d) = DData d monoBind :: T.Bind -> Bind -monoBind (T.Bind name args e) = Bind name args e +monoBind (T.Bind name args (e, t)) = Bind name args (e, t) + +monoExpr :: T.Exp -> Exp +monoExpr = \case + T.EId (Ident i) -> EId (Ident i) + T.ELit lit -> ELit $ monoLit lit + T.ELet bind expt -> ELet (monoBind bind) (monoexpt expt) + T.EApp expt1 expt2 -> EApp (monoexpt expt1) (monoexpt expt2) + T.EAdd expt1 expt2 -> EAdd (monoexpt expt1) (monoexpt expt2) + T.EAbs i expt -> error "BUG" + T.ECase expt injs -> ECase (monoexpt expt) (monoInjs injs) + +monoType :: T.Type -> Type +monoType (T.TAll _ t) = monoType t +monoType (T.TVar (T.MkTVar i)) = error "NOT POLYMORPHIC TYPES" +monoType (T.TLit i) = TLit i +monoType (T.TFun t1 t2) = TFun (monoType t1) (monoType t2) + +monoexpt :: T.ExpT -> ExpT +monoexpt (e, t) = (e, t) + +monoId :: T.Id -> Id +monoId = id + +monoLit :: T.Lit -> Lit +monoLit (T.LInt i) = LInt i +monoLit (T.LChar c) = LChar c + +monoInjs = map monoInj + +monoInj (T.Inj (init, t) expt) = Injection (monoInit init, monoType t) (monoexpt expt) + +monoInit :: T.Init -> Init +monoInit = id diff --git a/src/Monomorphizer/MonomorphizerIr.hs b/src/Monomorphizer/MonomorphizerIr.hs index 29131ca..aa25f42 100644 --- a/src/Monomorphizer/MonomorphizerIr.hs +++ b/src/Monomorphizer/MonomorphizerIr.hs @@ -1,12 +1,9 @@ -module Monomorphizer.MonomorphizerIr (module Monomorphizer.MonomorphizerIr, module RE1, module RE2) where - -import qualified Grammar.Abs as RE1 (Data (..), Ident (..), - Init (..)) -import qualified TypeChecker.TypeCheckerIr as RE2 (ExpT, Id, Indexed) - -import Grammar.Abs (Data (..), Ident (..), Init (..)) -import TypeChecker.TypeCheckerIr (ExpT, Id, Indexed) +module Monomorphizer.MonomorphizerIr (module Monomorphizer.MonomorphizerIr, module RE, module GA) where +import Grammar.Abs (Data, Ident, Init) +import Grammar.Abs qualified as GA (Data, Ident, Init) +import TypeChecker.TypeCheckerIr (ExpT, Id, Indexed) +import TypeChecker.TypeCheckerIr qualified as RE (ExpT, Id, Indexed) newtype Program = Program [Def] deriving (Show, Ord, Eq) @@ -20,10 +17,10 @@ data Bind = Bind Id [Id] ExpT data Exp = EId Ident | ELit Lit - | ELet Id ExpT ExpT - | EApp Type ExpT ExpT - | EAdd Type ExpT ExpT - | ECase Type ExpT [Injection] + | ELet Bind ExpT + | EApp ExpT ExpT + | EAdd ExpT ExpT + | ECase ExpT [Injection] deriving (Show, Ord, Eq) data Injection = Injection (Init, Type) ExpT @@ -37,5 +34,5 @@ data Lit | LChar Char deriving (Show, Ord, Eq) -newtype Type = Type Ident +data Type = TLit Ident | TFun Type Type deriving (Show, Ord, Eq) diff --git a/src/TypeChecker/TypeCheckerIr.hs b/src/TypeChecker/TypeCheckerIr.hs index 03a2065..45ea516 100644 --- a/src/TypeChecker/TypeCheckerIr.hs +++ b/src/TypeChecker/TypeCheckerIr.hs @@ -1,6 +1,9 @@ {-# LANGUAGE LambdaCase #-} -module TypeChecker.TypeCheckerIr where +module TypeChecker.TypeCheckerIr ( + module TypeChecker.TypeCheckerIr, + module GA, +) where import Control.Monad.Except import Control.Monad.Reader @@ -13,6 +16,12 @@ import Grammar.Abs ( Init (..), Lit (..), ) +import Grammar.Abs qualified as GA ( + Data (..), + Ident (..), + Init (..), + Lit (..), + ) import Grammar.Print import Prelude import Prelude qualified as C (Eq, Ord, Read, Show) From c85010a8a1cba12e59aa8dfe29c92d9f689fce2f Mon Sep 17 00:00:00 2001 From: Samuel Hammersberg Date: Thu, 23 Mar 2023 20:20:17 +0100 Subject: [PATCH 118/372] Fixed ExpT --- src/Monomorphizer/Monomorphizer.hs | 23 ++++++++++++----------- src/Monomorphizer/MonomorphizerIr.hs | 11 +++++++---- 2 files changed, 19 insertions(+), 15 deletions(-) diff --git a/src/Monomorphizer/Monomorphizer.hs b/src/Monomorphizer/Monomorphizer.hs index a2c7317..6bb16fb 100644 --- a/src/Monomorphizer/Monomorphizer.hs +++ b/src/Monomorphizer/Monomorphizer.hs @@ -2,9 +2,10 @@ module Monomorphizer.Monomorphizer (monomorphize) where -import Grammar.Abs (Ident (..)) -import Monomorphizer.MonomorphizerIr -import TypeChecker.TypeCheckerIr qualified as T +import Grammar.Abs (Ident (..)) +import Monomorphizer.MonomorphizerIr +import qualified Monomorphizer.MonomorphizerIr as M +import qualified TypeChecker.TypeCheckerIr as T monomorphize :: T.Program -> Program monomorphize (T.Program ds) = Program $ monoDefs ds @@ -14,12 +15,12 @@ monoDefs = map monoDef monoDef :: T.Def -> Def monoDef (T.DBind bind) = DBind $ monoBind bind -monoDef (T.DData d) = DData d +monoDef (T.DData d) = DData d monoBind :: T.Bind -> Bind monoBind (T.Bind name args (e, t)) = Bind name args (e, t) -monoExpr :: T.Exp -> Exp +monoExpr :: T.Exp -> M.Exp monoExpr = \case T.EId (Ident i) -> EId (Ident i) T.ELit lit -> ELit $ monoLit lit @@ -30,19 +31,19 @@ monoExpr = \case T.ECase expt injs -> ECase (monoexpt expt) (monoInjs injs) monoType :: T.Type -> Type -monoType (T.TAll _ t) = monoType t +monoType (T.TAll _ t) = monoType t monoType (T.TVar (T.MkTVar i)) = error "NOT POLYMORPHIC TYPES" -monoType (T.TLit i) = TLit i -monoType (T.TFun t1 t2) = TFun (monoType t1) (monoType t2) +monoType (T.TLit i) = TLit i +monoType (T.TFun t1 t2) = TFun (monoType t1) (monoType t2) -monoexpt :: T.ExpT -> ExpT -monoexpt (e, t) = (e, t) +monoexpt :: T.ExpT -> M.ExpT +monoexpt (e, t) = (monoExpr e, monoType t) monoId :: T.Id -> Id monoId = id monoLit :: T.Lit -> Lit -monoLit (T.LInt i) = LInt i +monoLit (T.LInt i) = LInt i monoLit (T.LChar c) = LChar c monoInjs = map monoInj diff --git a/src/Monomorphizer/MonomorphizerIr.hs b/src/Monomorphizer/MonomorphizerIr.hs index aa25f42..ce8e1e3 100644 --- a/src/Monomorphizer/MonomorphizerIr.hs +++ b/src/Monomorphizer/MonomorphizerIr.hs @@ -1,9 +1,10 @@ module Monomorphizer.MonomorphizerIr (module Monomorphizer.MonomorphizerIr, module RE, module GA) where -import Grammar.Abs (Data, Ident, Init) -import Grammar.Abs qualified as GA (Data, Ident, Init) -import TypeChecker.TypeCheckerIr (ExpT, Id, Indexed) -import TypeChecker.TypeCheckerIr qualified as RE (ExpT, Id, Indexed) +import Grammar.Abs (Data (..), Ident (..), Init (..)) +import qualified Grammar.Abs as GA (Data (..), Ident (..), + Init (..)) +import qualified TypeChecker.TypeCheckerIr as RE (Id, Indexed) +import TypeChecker.TypeCheckerIr (Id, Indexed) newtype Program = Program [Def] deriving (Show, Ord, Eq) @@ -26,6 +27,8 @@ data Exp data Injection = Injection (Init, Type) ExpT deriving (Eq, Ord, Show) +type ExpT = (Exp, Type) + data Constructor = Constructor Ident [Type] deriving (Show, Ord, Eq) From 6cbc83c5d9099ded84ffc2bacb5aa1fbe0cedd07 Mon Sep 17 00:00:00 2001 From: Samuel Hammersberg Date: Thu, 23 Mar 2023 20:22:36 +0100 Subject: [PATCH 119/372] Fixed a miss. --- src/Monomorphizer/Monomorphizer.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Monomorphizer/Monomorphizer.hs b/src/Monomorphizer/Monomorphizer.hs index 6bb16fb..659e813 100644 --- a/src/Monomorphizer/Monomorphizer.hs +++ b/src/Monomorphizer/Monomorphizer.hs @@ -18,7 +18,7 @@ monoDef (T.DBind bind) = DBind $ monoBind bind monoDef (T.DData d) = DData d monoBind :: T.Bind -> Bind -monoBind (T.Bind name args (e, t)) = Bind name args (e, t) +monoBind (T.Bind name args (e, t)) = Bind name args (monoExpr e, monoType t) monoExpr :: T.Exp -> M.Exp monoExpr = \case From 75fa232e214af552146968182533a14d6cf269c0 Mon Sep 17 00:00:00 2001 From: Samuel Hammersberg Date: Thu, 23 Mar 2023 21:35:52 +0100 Subject: [PATCH 120/372] No more warnings, but everything to do with datatypes is outcommented. --- src/Codegen/Codegen.hs | 316 +++++++++++++-------------- src/Main.hs | 39 ++-- src/Monomorphizer/Monomorphizer.hs | 4 +- src/Monomorphizer/MonomorphizerIr.hs | 6 +- 4 files changed, 172 insertions(+), 193 deletions(-) diff --git a/src/Codegen/Codegen.hs b/src/Codegen/Codegen.hs index a8c3cfd..a9f521f 100644 --- a/src/Codegen/Codegen.hs +++ b/src/Codegen/Codegen.hs @@ -1,59 +1,44 @@ -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} module Codegen.Codegen (generateCode) where -import Auxiliary (snoc) -import Codegen.LlvmIr ( - CallingConvention (..), - LLVMComp (..), - LLVMIr (..), - LLVMType (..), - LLVMValue (..), - Visibility (..), - llvmIrToString, - ) -import Codegen.LlvmIr as LIR -import Control.Applicative ((<|>)) -import Control.Monad.State ( - StateT, - execStateT, - foldM_, - gets, - modify, - ) -import Data.Bifunctor qualified as BI -import Data.List.Extra (trim) -import Data.Map (Map) -import Data.Map qualified as Map -import Data.Maybe (fromJust, fromMaybe) -import Data.Tuple.Extra (dupe, first, second) -import Grammar.Abs qualified as GA -import Grammar.ErrM (Err) -import Monomorphizer.MonomorphizerIr as MIR -import System.Process.Extra (readCreateProcess, shell) +import Auxiliary (snoc) +import Codegen.LlvmIr as LIR +import Control.Applicative ((<|>)) +import Control.Monad.State (StateT, execStateT, foldM_, + gets, modify) +import qualified Data.Bifunctor as BI +import Data.Coerce (coerce) +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Maybe (fromJust, fromMaybe) +import Data.Tuple.Extra (dupe, first, second) +import qualified Grammar.Abs as GA +import Grammar.ErrM (Err) +import Monomorphizer.MonomorphizerIr as MIR -- | The record used as the code generator state data CodeGenerator = CodeGenerator - { instructions :: [LLVMIr] - , functions :: Map Id FunctionInfo - , constructors :: Map Id ConstructorInfo + { instructions :: [LLVMIr] + , functions :: Map MIR.Id FunctionInfo + , constructors :: Map Ident ConstructorInfo , variableCount :: Integer - , labelCount :: Integer + , labelCount :: Integer } -- | A state type synonym type CompilerState a = StateT CodeGenerator Err a data FunctionInfo = FunctionInfo - { numArgs :: Int + { numArgs :: Int , arguments :: [Id] } deriving (Show) data ConstructorInfo = ConstructorInfo - { numArgsCI :: Int + { numArgsCI :: Int , argumentsCI :: [Id] - , numCI :: Integer + , numCI :: Integer } deriving (Show) @@ -82,18 +67,17 @@ getNewLabel = do {- | Produces a map of functions infos from a list of binds, which contains useful data for code generation. -} -getFunctions :: [Bind] -> Map Id FunctionInfo +getFunctions :: [MIR.Def] -> Map Id FunctionInfo getFunctions bs = Map.fromList $ go bs where go [] = [] - go (Bind id args _ : xs) = + go (MIR.DBind (MIR.Bind id args _) : xs) = (id, FunctionInfo{numArgs = length args, arguments = args}) : go xs - go (DataType n cons : xs) = - do - map + go (MIR.DData (MIR.Data n cons) : xs) = undefined + {-do map ( \(Constructor id xs) -> - ( (id, MIR.Type n) + ( (id, MIR.TLit n) , FunctionInfo { numArgs = length xs , arguments = createArgs xs @@ -101,24 +85,24 @@ getFunctions bs = Map.fromList $ go bs ) ) cons - <> go xs + <> go xs-} -createArgs :: [Type] -> [Id] +createArgs :: [MIR.Type] -> [Id] createArgs xs = fst $ foldl (\(acc, l) t -> (acc ++ [(GA.Ident ("arg_" <> show l), t)], l + 1)) ([], 0) xs {- | Produces a map of functions infos from a list of binds, which contains useful data for code generation. -} -getConstructors :: [Bind] -> Map Id ConstructorInfo +getConstructors :: [MIR.Def] -> Map Ident ConstructorInfo getConstructors bs = Map.fromList $ go bs where - go [] = [] - go (DataType (GA.Ident n) cons : xs) = - do + go [] = [] + go (MIR.DData (MIR.Data n cons) : xs) = undefined + {-do fst ( foldl - ( \(acc, i) (Constructor (GA.Ident id) xs) -> - ( ( (GA.Ident (n <> "_" <> id), MIR.Type (GA.Ident n)) + ( \(acc, i) (GA.Constructor (GA.Ident id) xs) -> + ( ( (GA.Ident (n <> "_" <> id), MIR.TLit (GA.Ident n)) , ConstructorInfo { numArgsCI = length xs , argumentsCI = createArgs xs @@ -132,10 +116,10 @@ getConstructors bs = Map.fromList $ go bs ([], 0) cons ) - <> go xs - go (_ : xs) = go xs + <> go xs-} + go (_ : xs) = go xs -initCodeGenerator :: [Bind] -> CodeGenerator +initCodeGenerator :: [MIR.Def] -> CodeGenerator initCodeGenerator scs = CodeGenerator { instructions = defaultStart @@ -145,11 +129,12 @@ initCodeGenerator scs = , labelCount = 0 } +{- run :: Err String -> IO () run s = do let s' = case s of Right s -> s - Left _ -> error "yo" + Left _ -> error "yo" writeFile "output/llvm.ll" s' putStrLn . trim =<< readCreateProcess (shell "lli") s' @@ -171,7 +156,7 @@ test v = -- (EApp (MIR.Type (GA.Ident "Craig")) (EId (GA.Ident "Craig_Bob", MIR.Type (GA.Ident "Craig")), MIR.Type (GA.Ident "Craig")) (ELit (LInt v), MIR.Type (GA.Ident "_Int")), MIR.Type (GA.Ident "Craig"))-- (EInt 92) $ eCaseInt - (EApp (MIR.Type (GA.Ident "Craig")) (EId (GA.Ident "Craig_Bob", MIR.Type (GA.Ident "Craig")), MIR.Type (GA.Ident "Craig")) (ELit (LInt v), MIR.Type (GA.Ident "_Int")), MIR.Type (GA.Ident "Craig")) + (EApp (MIR.TLit (GA.Ident "Craig")) (EId (GA.Ident "Craig_Bob", MIR.TLit (GA.Ident "Craig")), MIR.TLit (GA.Ident "Craig")) (ELit (LInt v), MIR.Type (GA.Ident "_Int")), MIR.Type (GA.Ident "Craig")) [ injectionCons "Craig_Bob" "Craig" [CIdent (GA.Ident "x")] (EId (GA.Ident "x", MIR.Type (GA.Ident "_Int")), MIR.Type (GA.Ident "_Int")) , injectionCons "Craig_Betty" "Craig" [CLit (LInt 5)] (int 2) , Injection (CIdent (GA.Ident "z")) (int 3) @@ -183,23 +168,24 @@ test v = injectionCons x y xs = Injection (CCons (GA.Ident x, MIR.Type (GA.Ident y)) xs) injectionInt x = Injection (CLit (LInt x)) injectionCatchAll = Injection CatchAll - eCaseInt x xs = (ECase (MIR.Type "_Int") x xs, MIR.Type "_Int") - int x = (ELit (LInt x), MIR.Type "_Int") - + eCaseInt x xs = (ECase (MIR.TLit (MIR.Ident "_Int")) x xs, MIR.TLit (MIR.Ident "_Int")) + int x = (ELit (LInt x), MIR.TLit (MIR.Ident "_Int")) +-} {- | Compiles an AST and produces a LLVM Ir string. An easy way to actually "compile" this output is to Simply pipe it to LLI -} -generateCode :: Program -> Err String -generateCode (Program scs) = do +generateCode :: MIR.Program -> Err String +generateCode (MIR.Program scs) = do let codegen = initCodeGenerator scs llvmIrToString . instructions <$> execStateT (compileScs scs) codegen -compileScs :: [Bind] -> CompilerState () +compileScs :: [MIR.Def] -> CompilerState () compileScs [] = do + undefined -- as a last step create all the constructors -- //TODO maybe merge this with the data type match? - c <- gets (Map.toList . constructors) + {-c <- gets (Map.toList . constructors) mapM_ ( \((id, t), ci) -> do let t' = type2LlvmType t @@ -261,28 +247,29 @@ compileScs [] = do modify $ \s -> s{variableCount = 0} ) - c -compileScs (Bind (name, _t) args exp : xs) = do + c-} +compileScs (MIR.DBind (MIR.Bind (name, _t) args exp) : xs) = do emit $ UnsafeRaw "\n" emit . Comment $ show name <> ": " <> show exp let args' = map (second type2LlvmType) args emit $ Define FastCC I64 {-(type2LlvmType t_return)-} name args' - functionBody <- exprToValue (fst exp) + functionBody <- exprToValue exp if name == "main" then mapM_ emit $ mainContent functionBody else emit $ Ret I64 functionBody emit DefineEnd modify $ \s -> s{variableCount = 0} compileScs xs -compileScs (DataType id@(GA.Ident outer_id) ts : xs) = do - let biggestVariant = maximum ((\(Constructor _ t) -> sum $ typeByteSize . type2LlvmType <$> t) <$> ts) - emit $ LIR.Type id [I8, Array biggestVariant I8] - mapM_ - ( \(Constructor (GA.Ident inner_id) fi) -> do - emit $ LIR.Type (GA.Ident $ outer_id <> "_" <> inner_id) (I8 : map type2LlvmType fi) - ) - ts - compileScs xs +compileScs (MIR.DData (MIR.Data outer_id ts) : xs) = do + undefined +-- let biggestVariant = maximum ((\(Constructor _ t) -> sum $ typeByteSize . type2LlvmType <$> t) <$> ts) +-- emit $ LIR.Type outer_id [I8, Array biggestVariant I8] +-- mapM_ +-- ( \(GA.Constructor (GA.UIdent inner_id) fi) -> do +-- emit $ LIR.Type (GA.Ident $ outer_id <> "_" <> inner_id) (I8 : map type2LlvmType fi) +-- ) +-- ts +-- compileScs xs -- where -- _t_return = snd $ partitionType (length args) t @@ -318,27 +305,27 @@ defaultStart = , UnsafeRaw "declare i32 @printf(ptr noalias nocapture, ...)\n" ] -compileExp :: Exp -> CompilerState () -compileExp (ELit lit) = emitLit lit -compileExp (EAdd t e1 e2) = emitAdd t (fst e1) (fst e2) +compileExp :: ExpT -> CompilerState () +compileExp (MIR.ELit lit,t) = emitLit lit +compileExp (MIR.EAdd e1 e2,t) = emitAdd t e1 e2 -- compileExp (ESub t e1 e2) = emitSub t e1 e2 -compileExp (EId (name, _)) = emitIdent name -compileExp (EApp t e1 e2) = emitApp t (fst e1) (fst e2) +compileExp (MIR.EId name,t) = emitIdent name +compileExp (MIR.EApp e1 e2,t) = emitApp t e1 e2 -- compileExp (EAbs t ti e) = emitAbs t ti e -compileExp (ELet _ binds e) = undefined emitLet binds (fst e) -compileExp (ECase t e cs) = emitECased t e (map (t,) cs) +compileExp (MIR.ELet binds e,t) = undefined -- emitLet binds (fst e) +compileExp (MIR.ECase e cs,t) = emitECased t e (map (t,) cs) -- go (EMul e1 e2) = emitMul e1 e2 -- go (EDiv e1 e2) = emitDiv e1 e2 -- go (EMod e1 e2) = emitMod e1 e2 --- aux functions --- -emitECased :: Type -> ExpT -> [(Type, Injection)] -> CompilerState () +emitECased :: MIR.Type -> ExpT -> [(MIR.Type, Injection)] -> CompilerState () emitECased t e cases = do let cs = snd <$> cases let ty = type2LlvmType t let rt = type2LlvmType (snd e) - vs <- exprToValue (fst e) + vs <- exprToValue e lbl <- getNewLabel let label = GA.Ident $ "escape_" <> show lbl stackPtr <- getNewVar @@ -349,9 +336,9 @@ emitECased t e cases = do emit $ SetVariable res (Load ty Ptr stackPtr) where emitCases :: LLVMType -> LLVMType -> GA.Ident -> GA.Ident -> LLVMValue -> Injection -> CompilerState () - emitCases rt ty label stackPtr vs (Injection (MIR.CCons consId cs) exp) = do + emitCases rt ty label stackPtr vs (Injection (MIR.InitConstructor consId cs, _t) exp) = do cons <- gets constructors - let r = fromJust $ Map.lookup consId cons + let r = fromJust $ Map.lookup (coerce consId) cons lbl_failPos <- (\x -> GA.Ident $ "failed_" <> show x) <$> getNewLabel lbl_succPos <- (\x -> GA.Ident $ "success_" <> show x) <$> getNewLabel @@ -370,62 +357,62 @@ emitECased t e cases = do emit $ SetVariable castPtr (Alloca rt) emit $ Store rt vs Ptr castPtr emit $ SetVariable castedPtr (Bitcast Ptr (VIdent castPtr Ptr) Ptr) - emit $ SetVariable casted (Load (CustomType (fst consId)) Ptr castedPtr) + emit $ SetVariable casted (Load (CustomType (coerce consId)) Ptr castedPtr) - val <- exprToValue (fst exp) - enumerateOneM_ - ( \i c -> do - case c of - CIdent x -> do - emit . Comment $ "ident " <> show x - emit $ SetVariable x (ExtractValue (CustomType (fst consId)) (VIdent casted Ptr) i) - emit $ Store ty val Ptr stackPtr - CCons x cs -> error "nested constructor" - CLit l -> do - testVar <- getNewVar - emit $ SetVariable testVar (ExtractValue (CustomType (fst consId)) (VIdent casted Ptr) i) - case l of - LInt l -> emit $ Icmp LLEq I64 (VIdent testVar Ptr) (VInteger l) - LChar c -> emit $ Icmp LLEq I8 (VIdent testVar Ptr) (VChar c) - CatchAll -> emit . Comment $ "Catch all" - emit . Comment $ "return this " <> toIr val - emit . Comment . show $ c - emit . Comment . show $ i - ) - cs + val <- exprToValue exp + -- enumerateOneM_ + -- (\i c -> do + -- case c of + -- CIdent x -> do + -- emit . Comment $ "ident " <> show x + -- emit $ SetVariable x (ExtractValue (CustomType (fst consId)) (VIdent casted Ptr) i) + -- emit $ Store ty val Ptr stackPtr + -- CCons x cs -> error "nested constructor" + -- CLit l -> do + -- testVar <- getNewVar + -- emit $ SetVariable testVar (ExtractValue (CustomType (fst consId)) (VIdent casted Ptr) i) + -- case l of + -- LInt l -> emit $ Icmp LLEq I64 (VIdent testVar Ptr) (VInteger l) + -- LChar c -> emit $ Icmp LLEq I8 (VIdent testVar Ptr) (VChar c) + -- CCatch -> emit . Comment $ "Catch all" + -- emit . Comment $ "return this " <> toIr val + -- emit . Comment . show $ c + -- emit . Comment . show $ i + -- ) + -- cs -- emit $ Store ty val Ptr stackPtr emit $ Br label emit $ Label lbl_failPos - emitCases rt ty label stackPtr vs (Injection (MIR.CLit i) exp) = do + emitCases rt ty label stackPtr vs (Injection (MIR.InitLit i, _) exp) = do let i' = case i of - LInt i -> VInteger i - LChar i -> VChar i + GA.LInt i -> VInteger i + GA.LChar i -> VChar i ns <- getNewVar lbl_failPos <- (\x -> GA.Ident $ "failed_" <> show x) <$> getNewLabel lbl_succPos <- (\x -> GA.Ident $ "success_" <> show x) <$> getNewLabel emit $ SetVariable ns (Icmp LLEq ty vs i') emit $ BrCond (VIdent ns ty) lbl_succPos lbl_failPos emit $ Label lbl_succPos - val <- exprToValue (fst exp) + val <- exprToValue exp emit $ Store ty val Ptr stackPtr emit $ Br label emit $ Label lbl_failPos - emitCases rt ty label stackPtr vs (Injection (MIR.CIdent id) exp) = do - -- //TODO this is pretty disgusting and would heavily benefit from a rewrite - valPtr <- getNewVar - emit $ SetVariable valPtr (Alloca rt) - emit $ Store rt vs Ptr valPtr - emit $ SetVariable id (Load rt Ptr valPtr) - increaseVarCount - val <- exprToValue (fst exp) - emit $ Store ty val Ptr stackPtr - emit $ Br label - emitCases _ ty label stackPtr _ (Injection MIR.CatchAll exp) = do - val <- exprToValue (fst exp) +-- emitCases rt ty label stackPtr vs (Injection (MIR.CIdent id) exp) = do +-- -- //TODO this is pretty disgusting and would heavily benefit from a rewrite +-- valPtr <- getNewVar +-- emit $ SetVariable valPtr (Alloca rt) +-- emit $ Store rt vs Ptr valPtr +-- emit $ SetVariable id (Load rt Ptr valPtr) +-- increaseVarCount +-- val <- exprToValue (fst exp) +-- emit $ Store ty val Ptr stackPtr +-- emit $ Br label + emitCases _ ty label stackPtr _ (Injection (MIR.InitCatch, _) exp) = do + val <- exprToValue exp emit $ Store ty val Ptr stackPtr emit $ Br label -emitLet :: Bind -> Exp -> CompilerState () +--emitLet :: Bind -> Exp -> CompilerState () emitLet xs e = do emit $ Comment $ @@ -437,26 +424,26 @@ emitLet xs e = do , ") is not implemented!" ] -emitApp :: Type -> Exp -> Exp -> CompilerState () -emitApp t e1 e2 = appEmitter t e1 e2 [] +emitApp :: MIR.Type -> ExpT -> ExpT -> CompilerState () +emitApp t e1 e2 = appEmitter e1 e2 [] where - appEmitter :: Type -> Exp -> Exp -> [Exp] -> CompilerState () - appEmitter t e1 e2 stack = do + appEmitter :: ExpT -> ExpT -> [ExpT] -> CompilerState () + appEmitter e1 e2 stack = do let newStack = e2 : stack case e1 of - EApp _ (e1', _) (e2', _) -> appEmitter t e1' e2' newStack - EId id@(GA.Ident name, _) -> do + (MIR.EApp e1' e2', t) -> appEmitter e1' e2' newStack + (MIR.EId name, t) -> do args <- traverse exprToValue newStack vs <- getNewVar funcs <- gets functions consts <- gets constructors let visibility = fromMaybe Local $ - Global <$ Map.lookup id consts - <|> Global <$ Map.lookup id funcs + Global <$ Map.lookup name consts + <|> Global <$ Map.lookup (name,t) funcs -- this piece of code could probably be improved, i.e remove the double `const Global` args' = map (first valueGetType . dupe) args - call = Call FastCC (type2LlvmType t) visibility (GA.Ident name) args' + call = Call FastCC (type2LlvmType t) visibility name args' emit $ SetVariable vs call x -> error $ "The unspeakable happened: " <> show x @@ -467,38 +454,38 @@ emitIdent id = do emit $ Variable id emit $ UnsafeRaw "\n" -emitLit :: Lit -> CompilerState () +emitLit :: MIR.Lit -> CompilerState () emitLit i = do -- !!this should never happen!! let (i', t) = case i of - (LInt i'') -> (VInteger i'', I64) - (LChar i'') -> (VChar i'', I8) + (MIR.LInt i'') -> (VInteger i'', I64) + (MIR.LChar i'') -> (VChar i'', I8) varCount <- getNewVar emit $ Comment "This should not have happened!" emit $ SetVariable (GA.Ident (show varCount)) (Add t i' (VInteger 0)) -emitAdd :: Type -> Exp -> Exp -> CompilerState () +emitAdd :: MIR.Type -> ExpT -> ExpT -> CompilerState () emitAdd t e1 e2 = do v1 <- exprToValue e1 v2 <- exprToValue e2 v <- getNewVar emit $ SetVariable (GA.Ident $ show v) (Add (type2LlvmType t) v1 v2) -emitSub :: Type -> Exp -> Exp -> CompilerState () +emitSub :: MIR.Type -> ExpT -> ExpT -> CompilerState () emitSub t e1 e2 = do v1 <- exprToValue e1 v2 <- exprToValue e2 v <- getNewVar emit $ SetVariable v (Sub (type2LlvmType t) v1 v2) -exprToValue :: Exp -> CompilerState LLVMValue +exprToValue :: ExpT -> CompilerState LLVMValue exprToValue = \case - ELit i -> pure $ case i of - (LInt i) -> VInteger i - (LChar i) -> VChar i - EId id@(name, t) -> do + (MIR.ELit i, t) -> pure $ case i of + (MIR.LInt i) -> VInteger i + (MIR.LChar i) -> VChar i + (MIR.EId name, t) -> do funcs <- gets functions - case Map.lookup id funcs of + case Map.lookup (name, t) funcs of Just fi -> do if numArgs fi == 0 then do @@ -515,10 +502,10 @@ exprToValue = \case v <- getVarCount pure $ VIdent (GA.Ident $ show v) (getType e) -type2LlvmType :: Type -> LLVMType -type2LlvmType (MIR.Type (GA.Ident t)) = case t of +type2LlvmType :: MIR.Type -> LLVMType +type2LlvmType = undefined {-(MIR.Type (GA.Ident t)) = case t of "_Int" -> I64 - t -> CustomType (GA.Ident t) + t -> CustomType (GA.Ident t)-} -- TInt -> I64 -- TFun t xs -> do @@ -530,32 +517,25 @@ type2LlvmType (MIR.Type (GA.Ident t)) = case t of -- function2LLVMType (TFun t xs) s = function2LLVMType xs (type2LlvmType t : s) -- function2LLVMType x s = (type2LlvmType x, s) -getType :: Exp -> LLVMType -getType (ELit l) = I64 -getType (EAdd t _ _) = type2LlvmType t --- getType (ESub t _ _) = type2LlvmType t -getType (EId (_, t)) = type2LlvmType t -getType (EApp t _ _) = type2LlvmType t --- getType (EAbs t _ _) = type2LlvmType t -getType (ELet (_, t) _ e) = type2LlvmType t -getType (ECase t _ _) = type2LlvmType t +getType :: ExpT -> LLVMType +getType (_, t) = type2LlvmType t valueGetType :: LLVMValue -> LLVMType -valueGetType (VInteger _) = I64 -valueGetType (VChar _) = I8 -valueGetType (VIdent _ t) = t -valueGetType (VConstant s) = Array (fromIntegral $ length s) I8 +valueGetType (VInteger _) = I64 +valueGetType (VChar _) = I8 +valueGetType (VIdent _ t) = t +valueGetType (VConstant s) = Array (fromIntegral $ length s) I8 valueGetType (VFunction _ _ t) = t typeByteSize :: LLVMType -> Integer -typeByteSize I1 = 1 -typeByteSize I8 = 1 -typeByteSize I32 = 4 -typeByteSize I64 = 8 -typeByteSize Ptr = 8 -typeByteSize (Ref _) = 8 +typeByteSize I1 = 1 +typeByteSize I8 = 1 +typeByteSize I32 = 4 +typeByteSize I64 = 8 +typeByteSize Ptr = 8 +typeByteSize (Ref _) = 8 typeByteSize (Function _ _) = 8 -typeByteSize (Array n t) = n * typeByteSize t +typeByteSize (Array n t) = n * typeByteSize t typeByteSize (CustomType _) = 8 enumerateOneM_ :: Monad m => (Integer -> a -> m b) -> [a] -> m () diff --git a/src/Main.hs b/src/Main.hs index ba7578c..fe64a96 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -2,29 +2,26 @@ module Main where -import Codegen.Codegen (generateCode) -import GHC.IO.Handle.Text (hPutStrLn) -import Grammar.ErrM (Err) -import Grammar.Par (myLexer, pProgram) -import Grammar.Print (printTree) -import Monomorphizer.Monomorphizer (monomorphize) +import Codegen.Codegen (generateCode) +import GHC.IO.Handle.Text (hPutStrLn) +import Grammar.ErrM (Err) +import Grammar.Par (myLexer, pProgram) +import Grammar.Print (printTree) +import Monomorphizer.Monomorphizer (monomorphize) -import Control.Monad (when) -import Data.List.Extra (isSuffixOf) +import Control.Monad (when) +import Data.List.Extra (isSuffixOf) -import Renamer.Renamer (rename) -import System.Directory ( - createDirectory, - doesPathExist, - getDirectoryContents, - removeDirectoryRecursive, - setCurrentDirectory, - ) -import System.Environment (getArgs) -import System.Exit (exitFailure, exitSuccess) -import System.IO (stderr) -import System.Process.Extra (spawnCommand, waitForProcess) -import TypeChecker.TypeChecker (typecheck) +import Renamer.Renamer (rename) +import System.Directory (createDirectory, doesPathExist, + getDirectoryContents, + removeDirectoryRecursive, + setCurrentDirectory) +import System.Environment (getArgs) +import System.Exit (exitFailure, exitSuccess) +import System.IO (stderr) +import System.Process.Extra (spawnCommand, waitForProcess) +import TypeChecker.TypeChecker (typecheck) main :: IO () main = diff --git a/src/Monomorphizer/Monomorphizer.hs b/src/Monomorphizer/Monomorphizer.hs index 659e813..b0d8c67 100644 --- a/src/Monomorphizer/Monomorphizer.hs +++ b/src/Monomorphizer/Monomorphizer.hs @@ -18,7 +18,7 @@ monoDef (T.DBind bind) = DBind $ monoBind bind monoDef (T.DData d) = DData d monoBind :: T.Bind -> Bind -monoBind (T.Bind name args (e, t)) = Bind name args (monoExpr e, monoType t) +monoBind (T.Bind name args (e, t)) = Bind (monoId name) (map monoId args) (monoExpr e, monoType t) monoExpr :: T.Exp -> M.Exp monoExpr = \case @@ -40,7 +40,7 @@ monoexpt :: T.ExpT -> M.ExpT monoexpt (e, t) = (monoExpr e, monoType t) monoId :: T.Id -> Id -monoId = id +monoId (n,t) = (n, monoType t) monoLit :: T.Lit -> Lit monoLit (T.LInt i) = LInt i diff --git a/src/Monomorphizer/MonomorphizerIr.hs b/src/Monomorphizer/MonomorphizerIr.hs index ce8e1e3..65d0c4b 100644 --- a/src/Monomorphizer/MonomorphizerIr.hs +++ b/src/Monomorphizer/MonomorphizerIr.hs @@ -3,8 +3,10 @@ module Monomorphizer.MonomorphizerIr (module Monomorphizer.MonomorphizerIr, modu import Grammar.Abs (Data (..), Ident (..), Init (..)) import qualified Grammar.Abs as GA (Data (..), Ident (..), Init (..)) -import qualified TypeChecker.TypeCheckerIr as RE (Id, Indexed) -import TypeChecker.TypeCheckerIr (Id, Indexed) +import qualified TypeChecker.TypeCheckerIr as RE (Indexed) +import TypeChecker.TypeCheckerIr (Indexed) + +type Id = (Ident, Type) newtype Program = Program [Def] deriving (Show, Ord, Eq) From 0012efabb7dbe93a875595f1fd3f86d43f758af8 Mon Sep 17 00:00:00 2001 From: Samuel Hammersberg Date: Thu, 23 Mar 2023 22:01:40 +0100 Subject: [PATCH 121/372] Fixed some more stuff. --- src/Codegen/Codegen.hs | 10 ++--- src/Monomorphizer/Monomorphizer.hs | 56 +++++++++++++++------------- src/Monomorphizer/MonomorphizerIr.hs | 9 ++--- 3 files changed, 40 insertions(+), 35 deletions(-) diff --git a/src/Codegen/Codegen.hs b/src/Codegen/Codegen.hs index a9f521f..16ed84f 100644 --- a/src/Codegen/Codegen.hs +++ b/src/Codegen/Codegen.hs @@ -74,7 +74,7 @@ getFunctions bs = Map.fromList $ go bs go (MIR.DBind (MIR.Bind id args _) : xs) = (id, FunctionInfo{numArgs = length args, arguments = args}) : go xs - go (MIR.DData (MIR.Data n cons) : xs) = undefined + go (MIR.DData (MIR.Constructor n cons) : xs) = undefined {-do map ( \(Constructor id xs) -> ( (id, MIR.TLit n) @@ -96,8 +96,8 @@ createArgs xs = fst $ foldl (\(acc, l) t -> (acc ++ [(GA.Ident ("arg_" <> show l getConstructors :: [MIR.Def] -> Map Ident ConstructorInfo getConstructors bs = Map.fromList $ go bs where - go [] = [] - go (MIR.DData (MIR.Data n cons) : xs) = undefined + go [] = [] + go (MIR.DData (MIR.Constructor n cons) : xs) = undefined {-do fst ( foldl @@ -117,7 +117,7 @@ getConstructors bs = Map.fromList $ go bs cons ) <> go xs-} - go (_ : xs) = go xs + go (_ : xs) = go xs initCodeGenerator :: [MIR.Def] -> CodeGenerator initCodeGenerator scs = @@ -260,7 +260,7 @@ compileScs (MIR.DBind (MIR.Bind (name, _t) args exp) : xs) = do emit DefineEnd modify $ \s -> s{variableCount = 0} compileScs xs -compileScs (MIR.DData (MIR.Data outer_id ts) : xs) = do +compileScs (MIR.DData (MIR.Constructor outer_id ts) : xs) = do undefined -- let biggestVariant = maximum ((\(Constructor _ t) -> sum $ typeByteSize . type2LlvmType <$> t) <$> ts) -- emit $ LIR.Type outer_id [I8, Array biggestVariant I8] diff --git a/src/Monomorphizer/Monomorphizer.hs b/src/Monomorphizer/Monomorphizer.hs index b0d8c67..c7506cb 100644 --- a/src/Monomorphizer/Monomorphizer.hs +++ b/src/Monomorphizer/Monomorphizer.hs @@ -2,53 +2,59 @@ module Monomorphizer.Monomorphizer (monomorphize) where -import Grammar.Abs (Ident (..)) -import Monomorphizer.MonomorphizerIr +import Data.Coerce (coerce) +import Grammar.Abs (Constructor (..), Ident (..), + Indexed (..)) import qualified Monomorphizer.MonomorphizerIr as M import qualified TypeChecker.TypeCheckerIr as T -monomorphize :: T.Program -> Program -monomorphize (T.Program ds) = Program $ monoDefs ds +monomorphize :: T.Program -> M.Program +monomorphize (T.Program ds) = M.Program $ monoDefs ds -monoDefs :: [T.Def] -> [Def] +monoDefs :: [T.Def] -> [M.Def] monoDefs = map monoDef -monoDef :: T.Def -> Def -monoDef (T.DBind bind) = DBind $ monoBind bind -monoDef (T.DData d) = DData d +monoDef :: T.Def -> M.Def +monoDef (T.DBind bind) = M.DBind $ monoBind bind +monoDef (T.DData d) = M.DData $ monoData d -monoBind :: T.Bind -> Bind -monoBind (T.Bind name args (e, t)) = Bind (monoId name) (map monoId args) (monoExpr e, monoType t) +monoBind :: T.Bind -> M.Bind +monoBind (T.Bind name args (e, t)) = M.Bind (monoId name) (map monoId args) (monoExpr e, monoType t) + +monoData :: T.Data -> M.Constructor +monoData (T.Data (Indexed n _) cons) = undefined-- M.Constructor n (map (\(Constructor n t) -> (n, monoType t)) cons) monoExpr :: T.Exp -> M.Exp monoExpr = \case - T.EId (Ident i) -> EId (Ident i) - T.ELit lit -> ELit $ monoLit lit - T.ELet bind expt -> ELet (monoBind bind) (monoexpt expt) - T.EApp expt1 expt2 -> EApp (monoexpt expt1) (monoexpt expt2) - T.EAdd expt1 expt2 -> EAdd (monoexpt expt1) (monoexpt expt2) + T.EId (Ident i) -> M.EId (Ident i) + T.ELit lit -> M.ELit $ monoLit lit + T.ELet bind expt -> M.ELet (monoBind bind) (monoexpt expt) + T.EApp expt1 expt2 -> M.EApp (monoexpt expt1) (monoexpt expt2) + T.EAdd expt1 expt2 -> M.EAdd (monoexpt expt1) (monoexpt expt2) T.EAbs i expt -> error "BUG" - T.ECase expt injs -> ECase (monoexpt expt) (monoInjs injs) + T.ECase expt injs -> M.ECase (monoexpt expt) (monoInjs injs) -monoType :: T.Type -> Type +monoType :: T.Type -> M.Type monoType (T.TAll _ t) = monoType t monoType (T.TVar (T.MkTVar i)) = error "NOT POLYMORPHIC TYPES" -monoType (T.TLit i) = TLit i -monoType (T.TFun t1 t2) = TFun (monoType t1) (monoType t2) +monoType (T.TLit i) = M.TLit i +monoType (T.TFun t1 t2) = M.TFun (monoType t1) (monoType t2) monoexpt :: T.ExpT -> M.ExpT monoexpt (e, t) = (monoExpr e, monoType t) -monoId :: T.Id -> Id +monoId :: T.Id -> M.Id monoId (n,t) = (n, monoType t) -monoLit :: T.Lit -> Lit -monoLit (T.LInt i) = LInt i -monoLit (T.LChar c) = LChar c +monoLit :: T.Lit -> M.Lit +monoLit (T.LInt i) = M.LInt i +monoLit (T.LChar c) = M.LChar c +monoInjs :: [T.Inj] -> [M.Injection] monoInjs = map monoInj -monoInj (T.Inj (init, t) expt) = Injection (monoInit init, monoType t) (monoexpt expt) +monoInj :: T.Inj -> M.Injection +monoInj (T.Inj (init, t) expt) = M.Injection (monoInit init, monoType t) (monoexpt expt) -monoInit :: T.Init -> Init +monoInit :: T.Init -> M.Init monoInit = id diff --git a/src/Monomorphizer/MonomorphizerIr.hs b/src/Monomorphizer/MonomorphizerIr.hs index 65d0c4b..18f29ed 100644 --- a/src/Monomorphizer/MonomorphizerIr.hs +++ b/src/Monomorphizer/MonomorphizerIr.hs @@ -1,8 +1,7 @@ module Monomorphizer.MonomorphizerIr (module Monomorphizer.MonomorphizerIr, module RE, module GA) where -import Grammar.Abs (Data (..), Ident (..), Init (..)) -import qualified Grammar.Abs as GA (Data (..), Ident (..), - Init (..)) +import Grammar.Abs (Ident (..), Init (..), UIdent) +import qualified Grammar.Abs as GA (Ident (..), Init (..)) import qualified TypeChecker.TypeCheckerIr as RE (Indexed) import TypeChecker.TypeCheckerIr (Indexed) @@ -11,7 +10,7 @@ type Id = (Ident, Type) newtype Program = Program [Def] deriving (Show, Ord, Eq) -data Def = DBind Bind | DData Data +data Def = DBind Bind | DData Constructor deriving (Show, Ord, Eq) data Bind = Bind Id [Id] ExpT @@ -31,7 +30,7 @@ data Injection = Injection (Init, Type) ExpT type ExpT = (Exp, Type) -data Constructor = Constructor Ident [Type] +data Constructor = Constructor UIdent [(UIdent, Type)] deriving (Show, Ord, Eq) data Lit From fc60112877f344cb2ab14ab82c8aad23b2367b05 Mon Sep 17 00:00:00 2001 From: sebastian Date: Thu, 23 Mar 2023 22:07:55 +0100 Subject: [PATCH 122/372] Made binds keep args instead of lambda converting --- language.cabal | 2 ++ src/TypeChecker/TypeChecker.hs | 26 ++++++++++++++------------ src/TypeChecker/TypeCheckerIr.hs | 3 ++- 3 files changed, 18 insertions(+), 13 deletions(-) diff --git a/language.cabal b/language.cabal index cbb5260..a098bd7 100644 --- a/language.cabal +++ b/language.cabal @@ -33,6 +33,8 @@ executable language Auxiliary TypeChecker.TypeChecker TypeChecker.TypeCheckerIr + Monomorphizer.Monomorphizer + Monomorphizer.MonomorphizerIr Renamer.Renamer Codegen.Codegen Codegen.LlvmIr diff --git a/src/TypeChecker/TypeChecker.hs b/src/TypeChecker/TypeChecker.hs index b75f4e1..a2b4308 100644 --- a/src/TypeChecker/TypeChecker.hs +++ b/src/TypeChecker/TypeChecker.hs @@ -106,18 +106,20 @@ checkPrg (Program bs) = do checkBind :: Bind -> Infer T.Bind checkBind (Bind name args e) = do - let lambda = makeLambda e (reverse $ coerce args) - e@(_, t') <- inferExp lambda - s <- gets sigs - case M.lookup (coerce name) s of - Just (Just t) -> do - sub <- unify t t' - let newT = apply sub t - insertSig (coerce name) (Just newT) - return $ T.Bind (coerce name, newT) [] e - _ -> do - insertSig (coerce name) (Just t') - return (T.Bind (coerce name, t') [] e) -- (apply s e) + -- let lambda = makeLambda e (reverse $ coerce args) + args <- zip args <$> mapM (const fresh) args + withBindings (map coerce args) $ do + e@(_, t') <- inferExp e + s <- gets sigs + case M.lookup (coerce name) s of + Just (Just t) -> do + sub <- unify t t' + let newT = apply sub t + insertSig (coerce name) (Just newT) + return $ T.Bind (coerce name, newT) (map coerce args) e + _ -> do + insertSig (coerce name) (Just t') + return (T.Bind (coerce name, t') (map coerce args) e) -- (apply s e) where makeLambda :: Exp -> [Ident] -> Exp makeLambda = foldl (flip (EAbs . coerce)) diff --git a/src/TypeChecker/TypeCheckerIr.hs b/src/TypeChecker/TypeCheckerIr.hs index 45ea516..1113dbc 100644 --- a/src/TypeChecker/TypeCheckerIr.hs +++ b/src/TypeChecker/TypeCheckerIr.hs @@ -93,7 +93,7 @@ instance Print Program where prt i (Program sc) = prPrec i 0 $ prt 0 sc instance Print Bind where - prt i (Bind (name, t) _ rhs) = + prt i (Bind (name, t) args rhs) = prPrec i 0 $ concatD [ prt 0 name @@ -101,6 +101,7 @@ instance Print Bind where , prt 0 t , doc $ showString "\n" , prt 0 name + , prtIdPs 0 args , doc $ showString "=" , prt 0 rhs ] From bef78217565ccc6583b63ee5e16dafd88c6421cc Mon Sep 17 00:00:00 2001 From: Rakarake Date: Fri, 24 Mar 2023 00:55:05 +0100 Subject: [PATCH 123/372] 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 From 30a79f34afc46fb31927354059496e8d0ca2c52d Mon Sep 17 00:00:00 2001 From: Samuel Hammersberg Date: Fri, 24 Mar 2023 10:57:21 +0100 Subject: [PATCH 124/372] Added some missing functionality to the dummy monomorphizer. --- src/Monomorphizer/Monomorphizer.hs | 16 ++++++++++++++-- src/Monomorphizer/MonomorphizerIr.hs | 4 ++++ 2 files changed, 18 insertions(+), 2 deletions(-) diff --git a/src/Monomorphizer/Monomorphizer.hs b/src/Monomorphizer/Monomorphizer.hs index c7506cb..6af43b4 100644 --- a/src/Monomorphizer/Monomorphizer.hs +++ b/src/Monomorphizer/Monomorphizer.hs @@ -5,6 +5,7 @@ module Monomorphizer.Monomorphizer (monomorphize) where import Data.Coerce (coerce) import Grammar.Abs (Constructor (..), Ident (..), Indexed (..)) +import qualified Grammar.Abs as GA import qualified Monomorphizer.MonomorphizerIr as M import qualified TypeChecker.TypeCheckerIr as T @@ -22,7 +23,7 @@ monoBind :: T.Bind -> M.Bind monoBind (T.Bind name args (e, t)) = M.Bind (monoId name) (map monoId args) (monoExpr e, monoType t) monoData :: T.Data -> M.Constructor -monoData (T.Data (Indexed n _) cons) = undefined-- M.Constructor n (map (\(Constructor n t) -> (n, monoType t)) cons) +monoData (T.Data (Indexed n _) cons) = M.Constructor n (map (\(Constructor n t) -> (n, monoAbsType t)) cons) monoExpr :: T.Exp -> M.Exp monoExpr = \case @@ -31,14 +32,24 @@ monoExpr = \case T.ELet bind expt -> M.ELet (monoBind bind) (monoexpt expt) T.EApp expt1 expt2 -> M.EApp (monoexpt expt1) (monoexpt expt2) T.EAdd expt1 expt2 -> M.EAdd (monoexpt expt1) (monoexpt expt2) - T.EAbs i expt -> error "BUG" + T.EAbs _i _expt -> error "BUG" T.ECase expt injs -> M.ECase (monoexpt expt) (monoInjs injs) +monoAbsType :: GA.Type -> M.Type +monoAbsType (GA.TLit u) = M.TLit (coerce u) +monoAbsType (GA.TVar _v) = error "NOT POLYMORHPIC TYPES" +monoAbsType (GA.TAll _v _t) = error "NOT ALL TYPES" +monoAbsType (GA.TIndexed _i) = error "NOT INDEXED TYPES" +monoAbsType (GA.TEVar _v) = error "I DONT KNOW WHAT THIS IS" +monoAbsType (GA.TFun t1 t2) = M.TFun (monoAbsType t1) (monoAbsType t2) + + monoType :: T.Type -> M.Type monoType (T.TAll _ t) = monoType t monoType (T.TVar (T.MkTVar i)) = error "NOT POLYMORPHIC TYPES" monoType (T.TLit i) = M.TLit i monoType (T.TFun t1 t2) = M.TFun (monoType t1) (monoType t2) +monoType (T.TIndexed _) = error "Not sure what this is" monoexpt :: T.ExpT -> M.ExpT monoexpt (e, t) = (monoExpr e, monoType t) @@ -58,3 +69,4 @@ monoInj (T.Inj (init, t) expt) = M.Injection (monoInit init, monoType t) (monoex monoInit :: T.Init -> M.Init monoInit = id + diff --git a/src/Monomorphizer/MonomorphizerIr.hs b/src/Monomorphizer/MonomorphizerIr.hs index 18f29ed..f24bab5 100644 --- a/src/Monomorphizer/MonomorphizerIr.hs +++ b/src/Monomorphizer/MonomorphizerIr.hs @@ -40,3 +40,7 @@ data Lit data Type = TLit Ident | TFun Type Type deriving (Show, Ord, Eq) + +flattenType :: Type -> [Type] +flattenType (TFun t1 t2) = t1 : flattenType t2 +flattenType x = [x] From 3371c3a146b2626ffd803d757f9a39ba2af5a018 Mon Sep 17 00:00:00 2001 From: sebastianselander Date: Fri, 24 Mar 2023 11:21:25 +0100 Subject: [PATCH 125/372] Remade lets with bind & improvements --- Grammar.cf | 2 +- src/Renamer/Renamer.hs | 20 ++++++++------- src/TypeChecker/TypeChecker.hs | 46 +++++++++++++++++++++++----------- 3 files changed, 43 insertions(+), 25 deletions(-) diff --git a/Grammar.cf b/Grammar.cf index 3bb15bd..65d5782 100644 --- a/Grammar.cf +++ b/Grammar.cf @@ -51,7 +51,7 @@ ECons. Exp4 ::= UIdent ; ELit. Exp4 ::= Lit ; EApp. Exp3 ::= Exp3 Exp4 ; EAdd. Exp1 ::= Exp1 "+" Exp2 ; -ELet. Exp ::= "let" LIdent "=" Exp "in" Exp ; +ELet. Exp ::= "let" Bind "in" Exp ; EAbs. Exp ::= "\\" LIdent "." Exp ; ECase. Exp ::= "case" Exp "of" "{" [Inj] "}"; diff --git a/src/Renamer/Renamer.hs b/src/Renamer/Renamer.hs index 3fa1afc..e60310e 100644 --- a/src/Renamer/Renamer.hs +++ b/src/Renamer/Renamer.hs @@ -36,10 +36,7 @@ renameDefs defs = runIdentity $ runExceptT $ evalStateT (runRn $ mapM renameDef renameDef :: Def -> Rn Def renameDef = \case DSig (Sig name typ) -> DSig . Sig name <$> renameTVars typ - DBind (Bind name vars rhs) -> do - (new_names, vars') <- newNames initNames (coerce vars) - rhs' <- snd <$> renameExp new_names rhs - pure . DBind $ Bind name (coerce vars') rhs' + DBind bind -> DBind . snd <$> renameBind initNames bind DData (Data (Indexed cname types) constrs) -> do tvars_ <- tvars tvars' <- mapM nextNameTVar tvars_ @@ -61,6 +58,12 @@ renameDefs defs = runIdentity $ runExceptT $ evalStateT (runRn $ mapM renameDef renameConstr new_types (Constructor name typ) = Constructor name $ substituteTVar new_types typ +renameBind :: Names -> Bind -> Rn (Names, Bind) +renameBind old_names (Bind name vars rhs) = do + (new_names, vars') <- newNames old_names (coerce vars) + (newer_names, rhs') <- renameExp new_names rhs + pure (newer_names, Bind name (coerce vars') rhs') + substituteTVar :: [(TVar, TVar)] -> Type -> Type substituteTVar new_names typ = case typ of TLit _ -> typ @@ -110,11 +113,10 @@ renameExp old_names = \case pure (Map.union env1 env2, EAdd e1' e2') -- TODO fix shadowing - ELet name rhs e -> do - (new_names, name') <- newName old_names (coerce name) - (new_names', rhs') <- renameExp new_names rhs - (new_names'', e') <- renameExp new_names' e - pure (new_names'', ELet (coerce name') rhs' e') + ELet bind e -> do + (new_names, bind') <- renameBind old_names bind + (new_names', e') <- renameExp new_names e + pure (new_names', ELet bind' e') EAbs par e -> do (new_names, par') <- newName old_names (coerce par) (new_names', e') <- renameExp new_names e diff --git a/src/TypeChecker/TypeChecker.hs b/src/TypeChecker/TypeChecker.hs index a2b4308..712c1cd 100644 --- a/src/TypeChecker/TypeChecker.hs +++ b/src/TypeChecker/TypeChecker.hs @@ -78,8 +78,7 @@ checkPrg (Program bs) = do preRun bs -- Type check the program twice to produce all top-level types in the first pass through bs' <- checkDef bs - trace "\nFIRST ITERATION" return () - trace (printTree bs' ++ "\nSECOND ITERATION\n") return () + trace ("FIRST ITERATION: " ++ printTree bs') pure () bs'' <- checkDef bs return $ T.Program bs'' where @@ -106,23 +105,35 @@ checkPrg (Program bs) = do checkBind :: Bind -> Infer T.Bind checkBind (Bind name args e) = do - -- let lambda = makeLambda e (reverse $ coerce args) + let lambda = makeLambda e (reverse (coerce args)) + (_, lambdaT) <- inferExp lambda args <- zip args <$> mapM (const fresh) args withBindings (map coerce args) $ do - e@(_, t') <- inferExp e + e@(_, _) <- inferExp e s <- gets sigs + -- let fs = map (second Just) (getFunctionTypes s e) + -- mapM_ (uncurry insertSig) fs case M.lookup (coerce name) s of Just (Just t) -> do - sub <- unify t t' + sub <- unify t lambdaT let newT = apply sub t insertSig (coerce name) (Just newT) return $ T.Bind (coerce name, newT) (map coerce args) e _ -> do - insertSig (coerce name) (Just t') - return (T.Bind (coerce name, t') (map coerce args) e) -- (apply s e) - where - makeLambda :: Exp -> [Ident] -> Exp - makeLambda = foldl (flip (EAbs . coerce)) + insertSig (coerce name) (Just lambdaT) + return (T.Bind (coerce name, lambdaT) (map coerce args) e) -- (apply s e) + -- where + -- getFunctionTypes :: Map Ident (Maybe T.Type) -> T.ExpT -> [(Ident, T.Type)] + -- getFunctionTypes s = \case + -- (T.EId b, t) -> case M.lookup b s of + -- Just Nothing -> return (b, t) + -- _ -> [] + -- (T.ELit _, _) -> [] + -- (T.ELet (T.Bind _ _ e1) e2, _) -> getFunctionTypes s e1 ++ getFunctionTypes s e2 + -- (T.EApp e1 e2, _) -> getFunctionTypes s e1 ++ getFunctionTypes s e2 + -- (T.EAdd e1 e2, _) -> getFunctionTypes s e1 ++ getFunctionTypes s e2 + -- (T.EAbs _ e, _) -> getFunctionTypes s e + -- (T.ECase e injs, _) -> getFunctionTypes s e ++ concatMap (getFunctionTypes s . \(T.Inj _ e) -> e) injs isMoreSpecificOrEq :: T.Type -> T.Type -> Bool isMoreSpecificOrEq _ (T.TAll _ _) = True @@ -263,14 +274,15 @@ algoW = \case -- The bar over S₀ and Γ means "generalize" - ELet name e0 e1 -> do - (s1, (e0', t1)) <- algoW e0 + ELet b@(Bind name args e) e1 -> do + (s1, (_, t0)) <- algoW (makeLambda e (coerce args)) + bind' <- checkBind b env <- asks vars - let t' = generalize (apply s1 env) t1 + let t' = generalize (apply s1 env) t0 withBinding (coerce name) t' $ do (s2, (e1', t2)) <- algoW e1 let comp = s2 `compose` s1 - return (comp, apply comp (T.ELet (T.Bind (coerce name, t2) [] (e0', t1)) (e1', t2), t2)) + return (comp, apply comp (T.ELet bind' (e1', t2), t2)) -- \| TODO: Add judgement ECase caseExpr injs -> do @@ -280,8 +292,12 @@ algoW = \case let t' = apply comp ret_t return (comp, (T.ECase (e', t) injs, t')) +makeLambda :: Exp -> [Ident] -> Exp +makeLambda = foldl (flip (EAbs . coerce)) + -- | Unify two types producing a new substitution unify :: T.Type -> T.Type -> Infer Subst +unify t0 t1 | trace ("T0: " ++ show t0 ++ "\nT1: " ++ show t1) False = undefined unify t0 t1 = do case (t0, t1) of (T.TFun a b, T.TFun c d) -> do @@ -293,7 +309,7 @@ unify t0 t1 = do (T.TAll _ t, b) -> unify t b (a, T.TAll _ t) -> unify a t (T.TLit a, T.TLit b) -> - if a == b then return M.empty else throwError "Types do not unify" + if a == b then return M.empty else throwError . unwords $ ["Can not unify", "'" ++ printTree (T.TLit a) ++ "'", "with", "'" ++ printTree (T.TLit b) ++ "'"] (T.TIndexed (T.Indexed name t), T.TIndexed (T.Indexed name' t')) -> if name == name' && length t == length t' then do From aa73f147f02449131da73fa8d93cfd489de00fc9 Mon Sep 17 00:00:00 2001 From: sebastianselander Date: Fri, 24 Mar 2023 11:21:46 +0100 Subject: [PATCH 126/372] Remade lets with bind & improvements --- test_program | 45 +++++++++++++++++++++++++++++++++++++++++---- 1 file changed, 41 insertions(+), 4 deletions(-) diff --git a/test_program b/test_program index f14962d..ded8250 100644 --- a/test_program +++ b/test_program @@ -1,4 +1,41 @@ -data Maybe (a) where { - Nothing : Maybe (a) - Just : a -> Maybe (a) -} +data List (a) where { + Nil : List (a) + Cons : a -> List (a) -> List (a) +}; + +data Bool () where { + True : Bool () + False : Bool () + }; + +-- hello_world = Cons 'h' (Cons 'e' (Cons 'l' (Cons 'l' (Cons 'o' (Cons ' ' (Cons 'w' (Cons 'o' (Cons 'r' (Cons 'l' (Cons 'd' Nil)))))))))) ; + +-- length : List (a) -> Int ; +-- length xs = case xs of { +-- Nil => 0 ; +-- Cons x xs => length xs +-- }; + +-- head : List (a) -> a ; +-- head xs = case xs of { +-- Cons x xs => x +-- }; + +firstIsOne : List (Int) -> Bool () ; +firstIsOne xs = case xs of { + Cons x xs => case x of { + 1 => True ; + _ => case xs of { + Cons x xs => False ; + _ => False + } + }; + _ => False + }; + +-- firstIsOne :: [Int] -> Bool +-- firstIsOne xs = case xs of +-- (1 : xs) -> True +-- _ -> False + +main = firstIsOne (Cons 'a' Nil) From 32f8a3e8a98bf898810ad4bad6e753d7ceaa99d8 Mon Sep 17 00:00:00 2001 From: sebastianselander Date: Fri, 24 Mar 2023 11:27:19 +0100 Subject: [PATCH 127/372] duplicate signatures disallowed --- src/TypeChecker/TypeChecker.hs | 5 +++-- test_program | 1 + 2 files changed, 4 insertions(+), 2 deletions(-) diff --git a/src/TypeChecker/TypeChecker.hs b/src/TypeChecker/TypeChecker.hs index 712c1cd..9f1879b 100644 --- a/src/TypeChecker/TypeChecker.hs +++ b/src/TypeChecker/TypeChecker.hs @@ -85,8 +85,9 @@ checkPrg (Program bs) = do preRun :: [Def] -> Infer () preRun [] = return () preRun (x : xs) = case x of - -- TODO: Check for no overlapping signature definitions - DSig (Sig n t) -> insertSig (coerce n) (Just $ toNew t) >> preRun xs + DSig (Sig n t) -> do + gets (M.member (coerce n) . sigs) >>= flip when (throwError $ "Duplicate signatures for function '" ++ printTree n ++ "'") + insertSig (coerce n) (Just $ toNew t) >> preRun xs DBind (Bind n _ _) -> do s <- gets sigs case M.lookup (coerce n) s of diff --git a/test_program b/test_program index ded8250..eb31907 100644 --- a/test_program +++ b/test_program @@ -21,6 +21,7 @@ data Bool () where { -- Cons x xs => x -- }; +firstIsOne : List (Int) -> Bool () ; firstIsOne : List (Int) -> Bool () ; firstIsOne xs = case xs of { Cons x xs => case x of { From 3f618e77f91a132f4677672d107c5bc645a52dfb Mon Sep 17 00:00:00 2001 From: Samuel Hammersberg Date: Fri, 24 Mar 2023 11:55:05 +0100 Subject: [PATCH 128/372] Got most of the codegenerator working. --- src/Codegen/Codegen.hs | 89 +++++++++++++++++++----------------------- 1 file changed, 41 insertions(+), 48 deletions(-) diff --git a/src/Codegen/Codegen.hs b/src/Codegen/Codegen.hs index 16ed84f..333c7bb 100644 --- a/src/Codegen/Codegen.hs +++ b/src/Codegen/Codegen.hs @@ -22,7 +22,7 @@ import Monomorphizer.MonomorphizerIr as MIR data CodeGenerator = CodeGenerator { instructions :: [LLVMIr] , functions :: Map MIR.Id FunctionInfo - , constructors :: Map Ident ConstructorInfo + , constructors :: Map MIR.Id ConstructorInfo , variableCount :: Integer , labelCount :: Integer } @@ -74,18 +74,18 @@ getFunctions bs = Map.fromList $ go bs go (MIR.DBind (MIR.Bind id args _) : xs) = (id, FunctionInfo{numArgs = length args, arguments = args}) : go xs - go (MIR.DData (MIR.Constructor n cons) : xs) = undefined - {-do map - ( \(Constructor id xs) -> - ( (id, MIR.TLit n) + go (MIR.DData (MIR.Constructor n cons) : xs) = + do map + ( \(id, xs) -> + ( (coerce id, MIR.TLit (coerce n)) , FunctionInfo - { numArgs = length xs - , arguments = createArgs xs + { numArgs = length (flattenType xs) + , arguments = createArgs (flattenType xs) } ) ) cons - <> go xs-} + <> go xs createArgs :: [MIR.Type] -> [Id] createArgs xs = fst $ foldl (\(acc, l) t -> (acc ++ [(GA.Ident ("arg_" <> show l), t)], l + 1)) ([], 0) xs @@ -93,19 +93,19 @@ createArgs xs = fst $ foldl (\(acc, l) t -> (acc ++ [(GA.Ident ("arg_" <> show l {- | Produces a map of functions infos from a list of binds, which contains useful data for code generation. -} -getConstructors :: [MIR.Def] -> Map Ident ConstructorInfo +getConstructors :: [MIR.Def] -> Map MIR.Id ConstructorInfo getConstructors bs = Map.fromList $ go bs where go [] = [] - go (MIR.DData (MIR.Constructor n cons) : xs) = undefined - {-do + go (MIR.DData (MIR.Constructor (GA.UIdent n) cons) : xs) = + do fst ( foldl - ( \(acc, i) (GA.Constructor (GA.Ident id) xs) -> - ( ( (GA.Ident (n <> "_" <> id), MIR.TLit (GA.Ident n)) + ( \(acc, i) (GA.UIdent id, xs) -> + ( ( (GA.Ident (n <> "_" <> id), MIR.TLit (coerce n)) , ConstructorInfo - { numArgsCI = length xs - , argumentsCI = createArgs xs + { numArgsCI = length (flattenType xs) + , argumentsCI = createArgs (flattenType xs) , numCI = i } ) @@ -116,7 +116,7 @@ getConstructors bs = Map.fromList $ go bs ([], 0) cons ) - <> go xs-} + <> go xs go (_ : xs) = go xs initCodeGenerator :: [MIR.Def] -> CodeGenerator @@ -182,10 +182,9 @@ generateCode (MIR.Program scs) = do compileScs :: [MIR.Def] -> CompilerState () compileScs [] = do - undefined -- as a last step create all the constructors -- //TODO maybe merge this with the data type match? - {-c <- gets (Map.toList . constructors) + c <- gets (Map.toList . constructors) mapM_ ( \((id, t), ci) -> do let t' = type2LlvmType t @@ -247,7 +246,7 @@ compileScs [] = do modify $ \s -> s{variableCount = 0} ) - c-} + c compileScs (MIR.DBind (MIR.Bind (name, _t) args exp) : xs) = do emit $ UnsafeRaw "\n" emit . Comment $ show name <> ": " <> show exp @@ -260,19 +259,16 @@ compileScs (MIR.DBind (MIR.Bind (name, _t) args exp) : xs) = do emit DefineEnd modify $ \s -> s{variableCount = 0} compileScs xs -compileScs (MIR.DData (MIR.Constructor outer_id ts) : xs) = do - undefined --- let biggestVariant = maximum ((\(Constructor _ t) -> sum $ typeByteSize . type2LlvmType <$> t) <$> ts) --- emit $ LIR.Type outer_id [I8, Array biggestVariant I8] --- mapM_ --- ( \(GA.Constructor (GA.UIdent inner_id) fi) -> do --- emit $ LIR.Type (GA.Ident $ outer_id <> "_" <> inner_id) (I8 : map type2LlvmType fi) --- ) --- ts --- compileScs xs - --- where --- _t_return = snd $ partitionType (length args) t +compileScs (MIR.DData (MIR.Constructor (GA.UIdent outer_id) ts) : xs) = do + let types = BI.second flattenType <$> ts + let biggestVariant = maximum $ sum . map (typeByteSize . type2LlvmType) <$> (snd <$> types) + emit $ LIR.Type (coerce outer_id) [I8, Array biggestVariant I8] + mapM_ + ( \(GA.UIdent inner_id, fi) -> do + emit $ LIR.Type (GA.Ident $ outer_id <> "_" <> inner_id) (I8 : map type2LlvmType fi) + ) + types + compileScs xs mainContent :: LLVMValue -> [LLVMIr] mainContent var = @@ -336,9 +332,9 @@ emitECased t e cases = do emit $ SetVariable res (Load ty Ptr stackPtr) where emitCases :: LLVMType -> LLVMType -> GA.Ident -> GA.Ident -> LLVMValue -> Injection -> CompilerState () - emitCases rt ty label stackPtr vs (Injection (MIR.InitConstructor consId cs, _t) exp) = do + emitCases rt ty label stackPtr vs (Injection (MIR.InitConstructor consId cs, t) exp) = do cons <- gets constructors - let r = fromJust $ Map.lookup (coerce consId) cons + let r = fromJust $ Map.lookup (coerce consId, t) cons lbl_failPos <- (\x -> GA.Ident $ "failed_" <> show x) <$> getNewLabel lbl_succPos <- (\x -> GA.Ident $ "success_" <> show x) <$> getNewLabel @@ -439,7 +435,7 @@ emitApp t e1 e2 = appEmitter e1 e2 [] consts <- gets constructors let visibility = fromMaybe Local $ - Global <$ Map.lookup name consts + Global <$ Map.lookup (name, t) consts <|> Global <$ Map.lookup (name,t) funcs -- this piece of code could probably be improved, i.e remove the double `const Global` args' = map (first valueGetType . dupe) args @@ -503,19 +499,16 @@ exprToValue = \case pure $ VIdent (GA.Ident $ show v) (getType e) type2LlvmType :: MIR.Type -> LLVMType -type2LlvmType = undefined {-(MIR.Type (GA.Ident t)) = case t of - "_Int" -> I64 - t -> CustomType (GA.Ident t)-} - --- TInt -> I64 --- TFun t xs -> do --- let (t', xs') = function2LLVMType xs [type2LlvmType t] --- Function t' xs' --- TPol t -> CustomType t --- where --- function2LLVMType :: Type -> [LLVMType] -> (LLVMType, [LLVMType]) --- function2LLVMType (TFun t xs) s = function2LLVMType xs (type2LlvmType t : s) --- function2LLVMType x s = (type2LlvmType x, s) +type2LlvmType (MIR.TLit id@(Ident name)) = case name of + "Int" -> I64 + _ -> CustomType id +type2LlvmType (MIR.TFun t xs) = do + let (t', xs') = function2LLVMType xs [type2LlvmType t] + Function t' xs' + where + function2LLVMType :: Type -> [LLVMType] -> (LLVMType, [LLVMType]) + function2LLVMType (TFun t xs) s = function2LLVMType xs (type2LlvmType t : s) + function2LLVMType x s = (type2LlvmType x, s) getType :: ExpT -> LLVMType getType (_, t) = type2LlvmType t From ce3971cf755212cb0a860644c3255678c95b8a39 Mon Sep 17 00:00:00 2001 From: sebastianselander Date: Fri, 24 Mar 2023 12:21:54 +0100 Subject: [PATCH 129/372] renamed stuff --- Grammar.cf | 6 +- src/Codegen/Codegen.hs | 587 +++++++++++++-------------- src/Main.hs | 45 +- src/Monomorphizer/Monomorphizer.hs | 44 +- src/Monomorphizer/MonomorphizerIr.hs | 14 +- src/Renamer/Renamer.hs | 11 +- src/TypeChecker/TypeChecker.hs | 76 ++-- src/TypeChecker/TypeCheckerIr.hs | 10 +- test_program | 30 +- 9 files changed, 414 insertions(+), 409 deletions(-) diff --git a/Grammar.cf b/Grammar.cf index 65d5782..540052f 100644 --- a/Grammar.cf +++ b/Grammar.cf @@ -24,7 +24,7 @@ Bind. Bind ::= LIdent [LIdent] "=" Exp ; TLit. Type2 ::= UIdent ; TVar. Type2 ::= TVar ; TAll. Type1 ::= "forall" TVar "." Type ; - TIndexed. Type1 ::= Indexed ; + TData. Type1 ::= UIdent "(" [Type] ")" ; internal TEVar. Type1 ::= TEVar ; TFun. Type ::= Type1 "->" Type ; @@ -37,9 +37,7 @@ internal MkTEVar. TEVar ::= LIdent ; Constructor. Constructor ::= UIdent ":" Type ; -Indexed. Indexed ::= UIdent "(" [Type] ")" ; - -Data. Data ::= "data" Indexed "where" "{" [Constructor] "}" ; +Data. Data ::= "data" Type "where" "{" [Constructor] "}" ; ------------------------------------------------------------------------------- -- * EXPRESSIONS diff --git a/src/Codegen/Codegen.hs b/src/Codegen/Codegen.hs index 333c7bb..f8da93e 100644 --- a/src/Codegen/Codegen.hs +++ b/src/Codegen/Codegen.hs @@ -1,22 +1,9 @@ -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} -module Codegen.Codegen (generateCode) where +module Codegen.Codegen where -import Auxiliary (snoc) -import Codegen.LlvmIr as LIR -import Control.Applicative ((<|>)) -import Control.Monad.State (StateT, execStateT, foldM_, - gets, modify) -import qualified Data.Bifunctor as BI -import Data.Coerce (coerce) -import Data.Map (Map) -import qualified Data.Map as Map -import Data.Maybe (fromJust, fromMaybe) -import Data.Tuple.Extra (dupe, first, second) -import qualified Grammar.Abs as GA -import Grammar.ErrM (Err) -import Monomorphizer.MonomorphizerIr as MIR +-- module Codegen.Codegen (generateCode) where -- | The record used as the code generator state data CodeGenerator = CodeGenerator @@ -27,42 +14,45 @@ data CodeGenerator = CodeGenerator , labelCount :: Integer } --- | A state type synonym -type CompilerState a = StateT CodeGenerator Err a +---- | The record used as the code generator state +-- data CodeGenerator = CodeGenerator +-- { instructions :: [LLVMIr] +-- , functions :: Map MIR.Id FunctionInfo +-- , constructors :: Map Ident ConstructorInfo +-- , variableCount :: Integer +-- , labelCount :: Integer +-- } -data FunctionInfo = FunctionInfo - { numArgs :: Int - , arguments :: [Id] - } - deriving (Show) -data ConstructorInfo = ConstructorInfo - { numArgsCI :: Int - , argumentsCI :: [Id] - , numCI :: Integer - } - deriving (Show) +---- | A state type synonym +-- type CompilerState a = StateT CodeGenerator Err a --- | Adds a instruction to the CodeGenerator state -emit :: LLVMIr -> CompilerState () -emit l = modify $ \t -> t{instructions = Auxiliary.snoc l $ instructions t} +-- data FunctionInfo = FunctionInfo +-- { numArgs :: Int +-- , arguments :: [Id] +-- } +-- deriving (Show) +-- data ConstructorInfo = ConstructorInfo +-- { numArgsCI :: Int +-- , argumentsCI :: [Id] +-- , numCI :: Integer +-- } +-- deriving (Show) --- | Increases the variable counter in the CodeGenerator state -increaseVarCount :: CompilerState () -increaseVarCount = modify $ \t -> t{variableCount = variableCount t + 1} +---- | Adds a instruction to the CodeGenerator state +-- emit :: LLVMIr -> CompilerState () +-- emit l = modify $ \t -> t{instructions = Auxiliary.snoc l $ instructions t} --- | Returns the variable count from the CodeGenerator state -getVarCount :: CompilerState Integer -getVarCount = gets variableCount +---- | Increases the variable counter in the CodeGenerator state +-- increaseVarCount :: CompilerState () +-- increaseVarCount = modify $ \t -> t{variableCount = variableCount t + 1} --- | Increases the variable count and returns it from the CodeGenerator state -getNewVar :: CompilerState GA.Ident -getNewVar = (GA.Ident . show) <$> (increaseVarCount >> getVarCount) +---- | Returns the variable count from the CodeGenerator state +-- getVarCount :: CompilerState Integer +-- getVarCount = gets variableCount --- | Increses the label count and returns a label from the CodeGenerator state -getNewLabel :: CompilerState Integer -getNewLabel = do - modify (\t -> t{labelCount = labelCount t + 1}) - gets labelCount +---- | Increases the variable count and returns it from the CodeGenerator state +-- getNewVar :: CompilerState GA.Ident +-- getNewVar = (GA.Ident . show) <$> (increaseVarCount >> getVarCount) {- | Produces a map of functions infos from a list of binds, which contains useful data for code generation. @@ -87,8 +77,28 @@ getFunctions bs = Map.fromList $ go bs cons <> go xs -createArgs :: [MIR.Type] -> [Id] -createArgs xs = fst $ foldl (\(acc, l) t -> (acc ++ [(GA.Ident ("arg_" <> show l), t)], l + 1)) ([], 0) xs +-- {- | Produces a map of functions infos from a list of binds, +-- which contains useful data for code generation. +---} +-- getFunctions :: [MIR.Def] -> Map Id FunctionInfo +-- getFunctions bs = Map.fromList $ go bs +-- where +-- go [] = [] +-- go (MIR.DBind (MIR.Bind id args _) : xs) = +-- (id, FunctionInfo{numArgs = length args, arguments = args}) +-- : go xs +-- go (MIR.DData (MIR.Constructor n cons) : xs) = undefined +-- {-do map +-- ( \(Constructor id xs) -> +-- ( (id, MIR.TLit n) +-- , FunctionInfo +-- { numArgs = length xs +-- , arguments = createArgs xs +-- } +-- ) +-- ) +-- cons +-- <> go xs-} {- | Produces a map of functions infos from a list of binds, which contains useful data for code generation. @@ -119,66 +129,53 @@ getConstructors bs = Map.fromList $ go bs <> go xs go (_ : xs) = go xs -initCodeGenerator :: [MIR.Def] -> CodeGenerator -initCodeGenerator scs = - CodeGenerator - { instructions = defaultStart - , functions = getFunctions scs - , constructors = getConstructors scs - , variableCount = 0 - , labelCount = 0 - } +-- {- | Produces a map of functions infos from a list of binds, +-- which contains useful data for code generation. +---} +-- getConstructors :: [MIR.Def] -> Map Ident ConstructorInfo +-- getConstructors bs = Map.fromList $ go bs +-- where +-- go [] = [] +-- go (MIR.DData (MIR.Constructor n cons) : xs) = undefined +-- {-do +-- fst +-- ( foldl +-- ( \(acc, i) (GA.Constructor (GA.Ident id) xs) -> +-- ( ( (GA.Ident (n <> "_" <> id), MIR.TLit (GA.Ident n)) +-- , ConstructorInfo +-- { numArgsCI = length xs +-- , argumentsCI = createArgs xs +-- , numCI = i +-- } +-- ) +-- : acc +-- , i + 1 +-- ) +-- ) +-- ([], 0) +-- cons +-- ) +-- <> go xs-} +-- go (_ : xs) = go xs -{- -run :: Err String -> IO () -run s = do - let s' = case s of - Right s -> s - Left _ -> error "yo" - writeFile "output/llvm.ll" s' - putStrLn . trim =<< readCreateProcess (shell "lli") s' +-- initCodeGenerator :: [MIR.Def] -> CodeGenerator +-- initCodeGenerator scs = +-- CodeGenerator +-- { instructions = defaultStart +-- , functions = getFunctions scs +-- , constructors = getConstructors scs +-- , variableCount = 0 +-- , labelCount = 0 +-- } -test :: Integer -> Program -test v = - Program - [ DataType - (GA.Ident "Craig") - [ Constructor (GA.Ident "Bob") [MIR.Type (GA.Ident "_Int")] - , Constructor (GA.Ident "Betty") [MIR.Type (GA.Ident "_Int")] - ] - , DataType - (GA.Ident "Alice") - [ Constructor (GA.Ident "Eve") [MIR.Type (GA.Ident "_Int")] -- , - -- (GA.Ident "Alice", [TInt, TInt]) - ] - , Bind (GA.Ident "fibonacci", MIR.Type (GA.Ident "_Int")) [(GA.Ident "x", MIR.Type (GA.Ident "_Int"))] (EId ("x", MIR.Type (GA.Ident "Craig")), MIR.Type (GA.Ident "Craig")) - , Bind (GA.Ident "main", MIR.Type (GA.Ident "_Int")) [] - -- (EApp (MIR.Type (GA.Ident "Craig")) (EId (GA.Ident "Craig_Bob", MIR.Type (GA.Ident "Craig")), MIR.Type (GA.Ident "Craig")) (ELit (LInt v), MIR.Type (GA.Ident "_Int")), MIR.Type (GA.Ident "Craig"))-- (EInt 92) - $ - eCaseInt - (EApp (MIR.TLit (GA.Ident "Craig")) (EId (GA.Ident "Craig_Bob", MIR.TLit (GA.Ident "Craig")), MIR.TLit (GA.Ident "Craig")) (ELit (LInt v), MIR.Type (GA.Ident "_Int")), MIR.Type (GA.Ident "Craig")) - [ injectionCons "Craig_Bob" "Craig" [CIdent (GA.Ident "x")] (EId (GA.Ident "x", MIR.Type (GA.Ident "_Int")), MIR.Type (GA.Ident "_Int")) - , injectionCons "Craig_Betty" "Craig" [CLit (LInt 5)] (int 2) - , Injection (CIdent (GA.Ident "z")) (int 3) - , -- , injectionInt 5 (int 6) - injectionCatchAll (int 10) - ] - ] - where - injectionCons x y xs = Injection (CCons (GA.Ident x, MIR.Type (GA.Ident y)) xs) - injectionInt x = Injection (CLit (LInt x)) - injectionCatchAll = Injection CatchAll - eCaseInt x xs = (ECase (MIR.TLit (MIR.Ident "_Int")) x xs, MIR.TLit (MIR.Ident "_Int")) - int x = (ELit (LInt x), MIR.TLit (MIR.Ident "_Int")) --} -{- | Compiles an AST and produces a LLVM Ir string. - An easy way to actually "compile" this output is to - Simply pipe it to LLI --} -generateCode :: MIR.Program -> Err String -generateCode (MIR.Program scs) = do - let codegen = initCodeGenerator scs - llvmIrToString . instructions <$> execStateT (compileScs scs) codegen +-- {- +-- run :: Err String -> IO () +-- run s = do +-- let s' = case s of +-- Right s -> s +-- Left _ -> error "yo" +-- writeFile "output/llvm.ll" s' +-- putStrLn . trim =<< readCreateProcess (shell "lli") s' compileScs :: [MIR.Def] -> CompilerState () compileScs [] = do @@ -270,50 +267,50 @@ compileScs (MIR.DData (MIR.Constructor (GA.UIdent outer_id) ts) : xs) = do types compileScs xs -mainContent :: LLVMValue -> [LLVMIr] -mainContent var = - [ UnsafeRaw $ - -- "%2 = alloca %Craig\n" <> - -- " store %Craig %1, ptr %2\n" <> - -- " %3 = bitcast %Craig* %2 to i72*\n" <> - -- " %4 = load i72, ptr %3\n" <> - -- " call i32 (ptr, ...) @printf(ptr noundef @.str, i72 noundef %4)\n" - "call i32 (ptr, ...) @printf(ptr noundef @.str, i64 noundef " <> toIr var <> ")\n" - , -- , SetVariable (GA.Ident "p") (Icmp LLEq I64 (VInteger 2) (VInteger 2)) - -- , BrCond (VIdent (GA.Ident "p")) (GA.Ident "b_1") (GA.Ident "b_2") - -- , Label (GA.Ident "b_1") - -- , UnsafeRaw - -- "call i32 (ptr, ...) @printf(ptr noundef @.str, i64 noundef 1)\n" - -- , Br (GA.Ident "end") - -- , Label (GA.Ident "b_2") - -- , UnsafeRaw - -- "call i32 (ptr, ...) @printf(ptr noundef @.str, i64 noundef 2)\n" - -- , Br (GA.Ident "end") - -- , Label (GA.Ident "end") - Ret I64 (VInteger 0) - ] +-- mainContent :: LLVMValue -> [LLVMIr] +-- mainContent var = +-- [ UnsafeRaw $ +-- -- "%2 = alloca %Craig\n" <> +-- -- " store %Craig %1, ptr %2\n" <> +-- -- " %3 = bitcast %Craig* %2 to i72*\n" <> +-- -- " %4 = load i72, ptr %3\n" <> +-- -- " call i32 (ptr, ...) @printf(ptr noundef @.str, i72 noundef %4)\n" +-- "call i32 (ptr, ...) @printf(ptr noundef @.str, i64 noundef " <> toIr var <> ")\n" +-- , -- , SetVariable (GA.Ident "p") (Icmp LLEq I64 (VInteger 2) (VInteger 2)) +-- -- , BrCond (VIdent (GA.Ident "p")) (GA.Ident "b_1") (GA.Ident "b_2") +-- -- , Label (GA.Ident "b_1") +-- -- , UnsafeRaw +-- -- "call i32 (ptr, ...) @printf(ptr noundef @.str, i64 noundef 1)\n" +-- -- , Br (GA.Ident "end") +-- -- , Label (GA.Ident "b_2") +-- -- , UnsafeRaw +-- -- "call i32 (ptr, ...) @printf(ptr noundef @.str, i64 noundef 2)\n" +-- -- , Br (GA.Ident "end") +-- -- , Label (GA.Ident "end") +-- Ret I64 (VInteger 0) +-- ] -defaultStart :: [LLVMIr] -defaultStart = - [ UnsafeRaw "target triple = \"x86_64-pc-linux-gnu\"\n" - , UnsafeRaw "target datalayout = \"e-m:o-i64:64-f80:128-n8:16:32:64-S128\"\n" - , UnsafeRaw "@.str = private unnamed_addr constant [3 x i8] c\"%x\n\", align 1\n" - , UnsafeRaw "declare i32 @printf(ptr noalias nocapture, ...)\n" - ] +-- defaultStart :: [LLVMIr] +-- defaultStart = +-- [ UnsafeRaw "target triple = \"x86_64-pc-linux-gnu\"\n" +-- , UnsafeRaw "target datalayout = \"e-m:o-i64:64-f80:128-n8:16:32:64-S128\"\n" +-- , UnsafeRaw "@.str = private unnamed_addr constant [3 x i8] c\"%x\n\", align 1\n" +-- , UnsafeRaw "declare i32 @printf(ptr noalias nocapture, ...)\n" +-- ] -compileExp :: ExpT -> CompilerState () -compileExp (MIR.ELit lit,t) = emitLit lit -compileExp (MIR.EAdd e1 e2,t) = emitAdd t e1 e2 --- compileExp (ESub t e1 e2) = emitSub t e1 e2 -compileExp (MIR.EId name,t) = emitIdent name -compileExp (MIR.EApp e1 e2,t) = emitApp t e1 e2 --- compileExp (EAbs t ti e) = emitAbs t ti e -compileExp (MIR.ELet binds e,t) = undefined -- emitLet binds (fst e) -compileExp (MIR.ECase e cs,t) = emitECased t e (map (t,) cs) +-- compileExp :: ExpT -> CompilerState () +-- compileExp (MIR.ELit lit,t) = emitLit lit +-- compileExp (MIR.EAdd e1 e2,t) = emitAdd t e1 e2 +---- compileExp (ESub t e1 e2) = emitSub t e1 e2 +-- compileExp (MIR.EId name,t) = emitIdent name +-- compileExp (MIR.EApp e1 e2,t) = emitApp t e1 e2 +---- compileExp (EAbs t ti e) = emitAbs t ti e +-- compileExp (MIR.ELet binds e,t) = undefined -- emitLet binds (fst e) +-- compileExp (MIR.ECase e cs,t) = emitECased t e (map (t,) cs) --- go (EMul e1 e2) = emitMul e1 e2 --- go (EDiv e1 e2) = emitDiv e1 e2 --- go (EMod e1 e2) = emitMod e1 e2 +---- go (EMul e1 e2) = emitMul e1 e2 +---- go (EDiv e1 e2) = emitDiv e1 e2 +---- go (EMod e1 e2) = emitMod e1 e2 --- aux functions --- emitECased :: MIR.Type -> ExpT -> [(MIR.Type, Injection)] -> CompilerState () @@ -336,89 +333,89 @@ emitECased t e cases = do cons <- gets constructors let r = fromJust $ Map.lookup (coerce consId, t) cons - lbl_failPos <- (\x -> GA.Ident $ "failed_" <> show x) <$> getNewLabel - lbl_succPos <- (\x -> GA.Ident $ "success_" <> show x) <$> getNewLabel +-- lbl_failPos <- (\x -> GA.Ident $ "failed_" <> show x) <$> getNewLabel +-- lbl_succPos <- (\x -> GA.Ident $ "success_" <> show x) <$> getNewLabel - consVal <- getNewVar - emit $ SetVariable consVal (ExtractValue rt vs 0) +-- consVal <- getNewVar +-- emit $ SetVariable consVal (ExtractValue rt vs 0) - consCheck <- getNewVar - emit $ SetVariable consCheck (Icmp LLEq I8 (VIdent consVal I8) (VInteger $ numCI r)) - emit $ BrCond (VIdent consCheck ty) lbl_succPos lbl_failPos - emit $ Label lbl_succPos +-- consCheck <- getNewVar +-- emit $ SetVariable consCheck (Icmp LLEq I8 (VIdent consVal I8) (VInteger $ numCI r)) +-- emit $ BrCond (VIdent consCheck ty) lbl_succPos lbl_failPos +-- emit $ Label lbl_succPos - castPtr <- getNewVar - castedPtr <- getNewVar - casted <- getNewVar - emit $ SetVariable castPtr (Alloca rt) - emit $ Store rt vs Ptr castPtr - emit $ SetVariable castedPtr (Bitcast Ptr (VIdent castPtr Ptr) Ptr) - emit $ SetVariable casted (Load (CustomType (coerce consId)) Ptr castedPtr) +-- castPtr <- getNewVar +-- castedPtr <- getNewVar +-- casted <- getNewVar +-- emit $ SetVariable castPtr (Alloca rt) +-- emit $ Store rt vs Ptr castPtr +-- emit $ SetVariable castedPtr (Bitcast Ptr (VIdent castPtr Ptr) Ptr) +-- emit $ SetVariable casted (Load (CustomType (coerce consId)) Ptr castedPtr) - val <- exprToValue exp - -- enumerateOneM_ - -- (\i c -> do - -- case c of - -- CIdent x -> do - -- emit . Comment $ "ident " <> show x - -- emit $ SetVariable x (ExtractValue (CustomType (fst consId)) (VIdent casted Ptr) i) - -- emit $ Store ty val Ptr stackPtr - -- CCons x cs -> error "nested constructor" - -- CLit l -> do - -- testVar <- getNewVar - -- emit $ SetVariable testVar (ExtractValue (CustomType (fst consId)) (VIdent casted Ptr) i) - -- case l of - -- LInt l -> emit $ Icmp LLEq I64 (VIdent testVar Ptr) (VInteger l) - -- LChar c -> emit $ Icmp LLEq I8 (VIdent testVar Ptr) (VChar c) - -- CCatch -> emit . Comment $ "Catch all" - -- emit . Comment $ "return this " <> toIr val - -- emit . Comment . show $ c - -- emit . Comment . show $ i - -- ) - -- cs - -- emit $ Store ty val Ptr stackPtr - emit $ Br label - emit $ Label lbl_failPos - emitCases rt ty label stackPtr vs (Injection (MIR.InitLit i, _) exp) = do - let i' = case i of - GA.LInt i -> VInteger i - GA.LChar i -> VChar i - ns <- getNewVar - lbl_failPos <- (\x -> GA.Ident $ "failed_" <> show x) <$> getNewLabel - lbl_succPos <- (\x -> GA.Ident $ "success_" <> show x) <$> getNewLabel - emit $ SetVariable ns (Icmp LLEq ty vs i') - emit $ BrCond (VIdent ns ty) lbl_succPos lbl_failPos - emit $ Label lbl_succPos - val <- exprToValue exp - emit $ Store ty val Ptr stackPtr - emit $ Br label - emit $ Label lbl_failPos --- emitCases rt ty label stackPtr vs (Injection (MIR.CIdent id) exp) = do --- -- //TODO this is pretty disgusting and would heavily benefit from a rewrite --- valPtr <- getNewVar --- emit $ SetVariable valPtr (Alloca rt) --- emit $ Store rt vs Ptr valPtr --- emit $ SetVariable id (Load rt Ptr valPtr) --- increaseVarCount --- val <- exprToValue (fst exp) --- emit $ Store ty val Ptr stackPtr --- emit $ Br label - emitCases _ ty label stackPtr _ (Injection (MIR.InitCatch, _) exp) = do - val <- exprToValue exp - emit $ Store ty val Ptr stackPtr - emit $ Br label +-- val <- exprToValue exp +-- -- enumerateOneM_ +-- -- (\i c -> do +-- -- case c of +-- -- CIdent x -> do +-- -- emit . Comment $ "ident " <> show x +-- -- emit $ SetVariable x (ExtractValue (CustomType (fst consId)) (VIdent casted Ptr) i) +-- -- emit $ Store ty val Ptr stackPtr +-- -- CCons x cs -> error "nested constructor" +-- -- CLit l -> do +-- -- testVar <- getNewVar +-- -- emit $ SetVariable testVar (ExtractValue (CustomType (fst consId)) (VIdent casted Ptr) i) +-- -- case l of +-- -- LInt l -> emit $ Icmp LLEq I64 (VIdent testVar Ptr) (VInteger l) +-- -- LChar c -> emit $ Icmp LLEq I8 (VIdent testVar Ptr) (VChar c) +-- -- CCatch -> emit . Comment $ "Catch all" +-- -- emit . Comment $ "return this " <> toIr val +-- -- emit . Comment . show $ c +-- -- emit . Comment . show $ i +-- -- ) +-- -- cs +-- -- emit $ Store ty val Ptr stackPtr +-- emit $ Br label +-- emit $ Label lbl_failPos +-- emitCases rt ty label stackPtr vs (Injection (MIR.InitLit i, _) exp) = do +-- let i' = case i of +-- GA.LInt i -> VInteger i +-- GA.LChar i -> VChar i +-- ns <- getNewVar +-- lbl_failPos <- (\x -> GA.Ident $ "failed_" <> show x) <$> getNewLabel +-- lbl_succPos <- (\x -> GA.Ident $ "success_" <> show x) <$> getNewLabel +-- emit $ SetVariable ns (Icmp LLEq ty vs i') +-- emit $ BrCond (VIdent ns ty) lbl_succPos lbl_failPos +-- emit $ Label lbl_succPos +-- val <- exprToValue exp +-- emit $ Store ty val Ptr stackPtr +-- emit $ Br label +-- emit $ Label lbl_failPos +---- emitCases rt ty label stackPtr vs (Injection (MIR.CIdent id) exp) = do +---- -- //TODO this is pretty disgusting and would heavily benefit from a rewrite +---- valPtr <- getNewVar +---- emit $ SetVariable valPtr (Alloca rt) +---- emit $ Store rt vs Ptr valPtr +---- emit $ SetVariable id (Load rt Ptr valPtr) +---- increaseVarCount +---- val <- exprToValue (fst exp) +---- emit $ Store ty val Ptr stackPtr +---- emit $ Br label +-- emitCases _ ty label stackPtr _ (Injection (MIR.InitCatch, _) exp) = do +-- val <- exprToValue exp +-- emit $ Store ty val Ptr stackPtr +-- emit $ Br label ---emitLet :: Bind -> Exp -> CompilerState () -emitLet xs e = do - emit $ - Comment $ - concat - [ "ELet (" - , show xs - , " = " - , show e - , ") is not implemented!" - ] +----emitLet :: Bind -> Exp -> CompilerState () +-- emitLet xs e = do +-- emit $ +-- Comment $ +-- concat +-- [ "ELet (" +-- , show xs +-- , " = " +-- , show e +-- , ") is not implemented!" +-- ] emitApp :: MIR.Type -> ExpT -> ExpT -> CompilerState () emitApp t e1 e2 = appEmitter e1 e2 [] @@ -443,60 +440,60 @@ emitApp t e1 e2 = appEmitter e1 e2 [] emit $ SetVariable vs call x -> error $ "The unspeakable happened: " <> show x -emitIdent :: GA.Ident -> CompilerState () -emitIdent id = do - -- !!this should never happen!! - emit $ Comment "This should not have happened!" - emit $ Variable id - emit $ UnsafeRaw "\n" +-- emitIdent :: GA.Ident -> CompilerState () +-- emitIdent id = do +-- -- !!this should never happen!! +-- emit $ Comment "This should not have happened!" +-- emit $ Variable id +-- emit $ UnsafeRaw "\n" -emitLit :: MIR.Lit -> CompilerState () -emitLit i = do - -- !!this should never happen!! - let (i', t) = case i of - (MIR.LInt i'') -> (VInteger i'', I64) - (MIR.LChar i'') -> (VChar i'', I8) - varCount <- getNewVar - emit $ Comment "This should not have happened!" - emit $ SetVariable (GA.Ident (show varCount)) (Add t i' (VInteger 0)) +-- emitLit :: MIR.Lit -> CompilerState () +-- emitLit i = do +-- -- !!this should never happen!! +-- let (i', t) = case i of +-- (MIR.LInt i'') -> (VInteger i'', I64) +-- (MIR.LChar i'') -> (VChar i'', I8) +-- varCount <- getNewVar +-- emit $ Comment "This should not have happened!" +-- emit $ SetVariable (GA.Ident (show varCount)) (Add t i' (VInteger 0)) -emitAdd :: MIR.Type -> ExpT -> ExpT -> CompilerState () -emitAdd t e1 e2 = do - v1 <- exprToValue e1 - v2 <- exprToValue e2 - v <- getNewVar - emit $ SetVariable (GA.Ident $ show v) (Add (type2LlvmType t) v1 v2) +-- emitAdd :: MIR.Type -> ExpT -> ExpT -> CompilerState () +-- emitAdd t e1 e2 = do +-- v1 <- exprToValue e1 +-- v2 <- exprToValue e2 +-- v <- getNewVar +-- emit $ SetVariable (GA.Ident $ show v) (Add (type2LlvmType t) v1 v2) -emitSub :: MIR.Type -> ExpT -> ExpT -> CompilerState () -emitSub t e1 e2 = do - v1 <- exprToValue e1 - v2 <- exprToValue e2 - v <- getNewVar - emit $ SetVariable v (Sub (type2LlvmType t) v1 v2) +-- emitSub :: MIR.Type -> ExpT -> ExpT -> CompilerState () +-- emitSub t e1 e2 = do +-- v1 <- exprToValue e1 +-- v2 <- exprToValue e2 +-- v <- getNewVar +-- emit $ SetVariable v (Sub (type2LlvmType t) v1 v2) -exprToValue :: ExpT -> CompilerState LLVMValue -exprToValue = \case - (MIR.ELit i, t) -> pure $ case i of - (MIR.LInt i) -> VInteger i - (MIR.LChar i) -> VChar i - (MIR.EId name, t) -> do - funcs <- gets functions - case Map.lookup (name, t) funcs of - Just fi -> do - if numArgs fi == 0 - then do - vc <- getNewVar - emit $ - SetVariable - vc - (Call FastCC (type2LlvmType t) Global name []) - pure $ VIdent vc (type2LlvmType t) - else pure $ VFunction name Global (type2LlvmType t) - Nothing -> pure $ VIdent name (type2LlvmType t) - e -> do - compileExp e - v <- getVarCount - pure $ VIdent (GA.Ident $ show v) (getType e) +-- exprToValue :: ExpT -> CompilerState LLVMValue +-- exprToValue = \case +-- (MIR.ELit i, t) -> pure $ case i of +-- (MIR.LInt i) -> VInteger i +-- (MIR.LChar i) -> VChar i +-- (MIR.EId name, t) -> do +-- funcs <- gets functions +-- case Map.lookup (name, t) funcs of +-- Just fi -> do +-- if numArgs fi == 0 +-- then do +-- vc <- getNewVar +-- emit $ +-- SetVariable +-- vc +-- (Call FastCC (type2LlvmType t) Global name []) +-- pure $ VIdent vc (type2LlvmType t) +-- else pure $ VFunction name Global (type2LlvmType t) +-- Nothing -> pure $ VIdent name (type2LlvmType t) +-- e -> do +-- compileExp e +-- v <- getVarCount +-- pure $ VIdent (GA.Ident $ show v) (getType e) type2LlvmType :: MIR.Type -> LLVMType type2LlvmType (MIR.TLit id@(Ident name)) = case name of @@ -510,26 +507,26 @@ type2LlvmType (MIR.TFun t xs) = do function2LLVMType (TFun t xs) s = function2LLVMType xs (type2LlvmType t : s) function2LLVMType x s = (type2LlvmType x, s) -getType :: ExpT -> LLVMType -getType (_, t) = type2LlvmType t +-- getType :: ExpT -> LLVMType +-- getType (_, t) = type2LlvmType t -valueGetType :: LLVMValue -> LLVMType -valueGetType (VInteger _) = I64 -valueGetType (VChar _) = I8 -valueGetType (VIdent _ t) = t -valueGetType (VConstant s) = Array (fromIntegral $ length s) I8 -valueGetType (VFunction _ _ t) = t +-- valueGetType :: LLVMValue -> LLVMType +-- valueGetType (VInteger _) = I64 +-- valueGetType (VChar _) = I8 +-- valueGetType (VIdent _ t) = t +-- valueGetType (VConstant s) = Array (fromIntegral $ length s) I8 +-- valueGetType (VFunction _ _ t) = t -typeByteSize :: LLVMType -> Integer -typeByteSize I1 = 1 -typeByteSize I8 = 1 -typeByteSize I32 = 4 -typeByteSize I64 = 8 -typeByteSize Ptr = 8 -typeByteSize (Ref _) = 8 -typeByteSize (Function _ _) = 8 -typeByteSize (Array n t) = n * typeByteSize t -typeByteSize (CustomType _) = 8 +-- typeByteSize :: LLVMType -> Integer +-- typeByteSize I1 = 1 +-- typeByteSize I8 = 1 +-- typeByteSize I32 = 4 +-- typeByteSize I64 = 8 +-- typeByteSize Ptr = 8 +-- typeByteSize (Ref _) = 8 +-- typeByteSize (Function _ _) = 8 +-- typeByteSize (Array n t) = n * typeByteSize t +-- typeByteSize (CustomType _) = 8 -enumerateOneM_ :: Monad m => (Integer -> a -> m b) -> [a] -> m () -enumerateOneM_ f = foldM_ (\i a -> f i a >> pure (i + 1)) 1 +-- enumerateOneM_ :: Monad m => (Integer -> a -> m b) -> [a] -> m () +-- enumerateOneM_ f = foldM_ (\i a -> f i a >> pure (i + 1)) 1 diff --git a/src/Main.hs b/src/Main.hs index fe64a96..d8ecdd6 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -2,26 +2,29 @@ module Main where -import Codegen.Codegen (generateCode) -import GHC.IO.Handle.Text (hPutStrLn) -import Grammar.ErrM (Err) -import Grammar.Par (myLexer, pProgram) -import Grammar.Print (printTree) -import Monomorphizer.Monomorphizer (monomorphize) +-- import Codegen.Codegen (generateCode) +import GHC.IO.Handle.Text (hPutStrLn) +import Grammar.ErrM (Err) +import Grammar.Par (myLexer, pProgram) +import Grammar.Print (printTree) +import Monomorphizer.Monomorphizer (monomorphize) -import Control.Monad (when) -import Data.List.Extra (isSuffixOf) +import Control.Monad (when) +import Data.List.Extra (isSuffixOf) -import Renamer.Renamer (rename) -import System.Directory (createDirectory, doesPathExist, - getDirectoryContents, - removeDirectoryRecursive, - setCurrentDirectory) -import System.Environment (getArgs) -import System.Exit (exitFailure, exitSuccess) -import System.IO (stderr) -import System.Process.Extra (spawnCommand, waitForProcess) -import TypeChecker.TypeChecker (typecheck) +import Renamer.Renamer (rename) +import System.Directory ( + createDirectory, + doesPathExist, + getDirectoryContents, + removeDirectoryRecursive, + setCurrentDirectory, + ) +import System.Environment (getArgs) +import System.Exit (exitFailure, exitSuccess) +import System.IO (stderr) +import System.Process.Extra (spawnCommand, waitForProcess) +import TypeChecker.TypeChecker (typecheck) main :: IO () main = @@ -50,9 +53,9 @@ main' debug s = do -- let lifted = lambdaLift typechecked -- printToErr $ printTree lifted -- - printToErr "\n -- Printing compiler output to stdout --" - compiled <- fromCompilerErr $ generateCode (monomorphize typechecked) - putStrLn compiled + -- printToErr "\n -- Printing compiler output to stdout --" + -- compiled <- fromCompilerErr $ generateCode (monomorphize typechecked) + -- putStrLn compiled -- check <- doesPathExist "output" -- when check (removeDirectoryRecursive "output") diff --git a/src/Monomorphizer/Monomorphizer.hs b/src/Monomorphizer/Monomorphizer.hs index 6af43b4..104c318 100644 --- a/src/Monomorphizer/Monomorphizer.hs +++ b/src/Monomorphizer/Monomorphizer.hs @@ -2,12 +2,13 @@ module Monomorphizer.Monomorphizer (monomorphize) where -import Data.Coerce (coerce) -import Grammar.Abs (Constructor (..), Ident (..), - Indexed (..)) -import qualified Grammar.Abs as GA -import qualified Monomorphizer.MonomorphizerIr as M -import qualified TypeChecker.TypeCheckerIr as T +import Data.Coerce (coerce) +import Grammar.Abs (Constructor (..), Ident (..)) +import Unsafe.Coerce (unsafeCoerce) + +import Grammar.Abs qualified as GA +import Monomorphizer.MonomorphizerIr qualified as M +import TypeChecker.TypeCheckerIr qualified as T monomorphize :: T.Program -> M.Program monomorphize (T.Program ds) = M.Program $ monoDefs ds @@ -17,14 +18,11 @@ monoDefs = map monoDef monoDef :: T.Def -> M.Def monoDef (T.DBind bind) = M.DBind $ monoBind bind -monoDef (T.DData d) = M.DData $ monoData d +monoDef (T.DData d) = M.DData $ unsafeCoerce d monoBind :: T.Bind -> M.Bind monoBind (T.Bind name args (e, t)) = M.Bind (monoId name) (map monoId args) (monoExpr e, monoType t) -monoData :: T.Data -> M.Constructor -monoData (T.Data (Indexed n _) cons) = M.Constructor n (map (\(Constructor n t) -> (n, monoAbsType t)) cons) - monoExpr :: T.Exp -> M.Exp monoExpr = \case T.EId (Ident i) -> M.EId (Ident i) @@ -36,29 +34,28 @@ monoExpr = \case T.ECase expt injs -> M.ECase (monoexpt expt) (monoInjs injs) monoAbsType :: GA.Type -> M.Type -monoAbsType (GA.TLit u) = M.TLit (coerce u) -monoAbsType (GA.TVar _v) = error "NOT POLYMORHPIC TYPES" -monoAbsType (GA.TAll _v _t) = error "NOT ALL TYPES" -monoAbsType (GA.TIndexed _i) = error "NOT INDEXED TYPES" -monoAbsType (GA.TEVar _v) = error "I DONT KNOW WHAT THIS IS" -monoAbsType (GA.TFun t1 t2) = M.TFun (monoAbsType t1) (monoAbsType t2) - +monoAbsType (GA.TLit u) = M.TLit (coerce u) +monoAbsType (GA.TVar _v) = error "NOT POLYMORHPIC TYPES" +monoAbsType (GA.TAll _v _t) = error "NOT ALL TYPES" +monoAbsType (GA.TData _ i) = error "NOT INDEXED TYPES" +monoAbsType (GA.TEVar _v) = error "I DONT KNOW WHAT THIS IS" +monoAbsType (GA.TFun t1 t2) = M.TFun (monoAbsType t1) (monoAbsType t2) monoType :: T.Type -> M.Type -monoType (T.TAll _ t) = monoType t +monoType (T.TAll _ t) = monoType t monoType (T.TVar (T.MkTVar i)) = error "NOT POLYMORPHIC TYPES" -monoType (T.TLit i) = M.TLit i -monoType (T.TFun t1 t2) = M.TFun (monoType t1) (monoType t2) -monoType (T.TIndexed _) = error "Not sure what this is" +monoType (T.TLit i) = M.TLit i +monoType (T.TFun t1 t2) = M.TFun (monoType t1) (monoType t2) +monoType (T.TData _ _) = error "Not sure what this is" monoexpt :: T.ExpT -> M.ExpT monoexpt (e, t) = (monoExpr e, monoType t) monoId :: T.Id -> M.Id -monoId (n,t) = (n, monoType t) +monoId (n, t) = (n, monoType t) monoLit :: T.Lit -> M.Lit -monoLit (T.LInt i) = M.LInt i +monoLit (T.LInt i) = M.LInt i monoLit (T.LChar c) = M.LChar c monoInjs :: [T.Inj] -> [M.Injection] @@ -69,4 +66,3 @@ monoInj (T.Inj (init, t) expt) = M.Injection (monoInit init, monoType t) (monoex monoInit :: T.Init -> M.Init monoInit = id - diff --git a/src/Monomorphizer/MonomorphizerIr.hs b/src/Monomorphizer/MonomorphizerIr.hs index f24bab5..07263a1 100644 --- a/src/Monomorphizer/MonomorphizerIr.hs +++ b/src/Monomorphizer/MonomorphizerIr.hs @@ -1,16 +1,18 @@ module Monomorphizer.MonomorphizerIr (module Monomorphizer.MonomorphizerIr, module RE, module GA) where -import Grammar.Abs (Ident (..), Init (..), UIdent) -import qualified Grammar.Abs as GA (Ident (..), Init (..)) -import qualified TypeChecker.TypeCheckerIr as RE (Indexed) -import TypeChecker.TypeCheckerIr (Indexed) +import Grammar.Abs (Ident (..), Init (..), UIdent) +import Grammar.Abs qualified as GA (Ident (..), Init (..)) +import TypeChecker.TypeCheckerIr qualified as RE type Id = (Ident, Type) newtype Program = Program [Def] deriving (Show, Ord, Eq) -data Def = DBind Bind | DData Constructor +data Def = DBind Bind | DData Data + deriving (Show, Ord, Eq) + +data Data = Data Type Constructor deriving (Show, Ord, Eq) data Bind = Bind Id [Id] ExpT @@ -43,4 +45,4 @@ data Type = TLit Ident | TFun Type Type flattenType :: Type -> [Type] flattenType (TFun t1 t2) = t1 : flattenType t2 -flattenType x = [x] +flattenType x = [x] diff --git a/src/Renamer/Renamer.hs b/src/Renamer/Renamer.hs index e60310e..c550a92 100644 --- a/src/Renamer/Renamer.hs +++ b/src/Renamer/Renamer.hs @@ -37,22 +37,23 @@ renameDefs defs = runIdentity $ runExceptT $ evalStateT (runRn $ mapM renameDef renameDef = \case DSig (Sig name typ) -> DSig . Sig name <$> renameTVars typ DBind bind -> DBind . snd <$> renameBind initNames bind - DData (Data (Indexed cname types) constrs) -> do + DData (Data (TData cname types) constrs) -> do tvars_ <- tvars tvars' <- mapM nextNameTVar tvars_ let tvars_lt = zip tvars_ tvars' typ' = map (substituteTVar tvars_lt) types constrs' = map (renameConstr tvars_lt) constrs - pure . DData $ Data (Indexed cname typ') constrs' + pure . DData $ Data (TData cname typ') constrs' where tvars = concat <$> mapM (collectTVars []) types collectTVars :: [TVar] -> Type -> Rn [TVar] collectTVars tvars = \case TAll tvar t -> collectTVars (tvar : tvars) t - TIndexed _ -> return tvars + TData _ _ -> return tvars -- Should be monad error TVar v -> return [v] _ -> throwError ("Bad data type definition: " ++ show types) + DData (Data types _) -> throwError ("Bad data type definition: " ++ show types) renameConstr :: [(TVar, TVar)] -> Constructor -> Constructor renameConstr new_types (Constructor name typ) = @@ -78,7 +79,7 @@ substituteTVar new_names typ = case typ of TAll tvar' $ substitute' t | otherwise -> TAll tvar $ substitute' t - TIndexed (Indexed name typs) -> TIndexed . Indexed name $ map substitute' typs + TData name typs -> TData name $ map substitute' typs _ -> error ("Impossible " ++ show typ) where substitute' = substituteTVar new_names @@ -169,7 +170,7 @@ substitute tvar1 tvar2 typ = case typ of | otherwise -> typ TFun t1 t2 -> on TFun substitute' t1 t2 TAll tvar t -> TAll tvar $ substitute' t - TIndexed (Indexed name typs) -> TIndexed . Indexed name $ map substitute' typs + TData name typs -> TData name $ map substitute' typs _ -> error "Impossible" where substitute' = substitute tvar1 tvar2 diff --git a/src/TypeChecker/TypeChecker.hs b/src/TypeChecker/TypeChecker.hs index 9f1879b..313612a 100644 --- a/src/TypeChecker/TypeChecker.hs +++ b/src/TypeChecker/TypeChecker.hs @@ -48,13 +48,13 @@ typecheck = run . checkPrg checkData :: Data -> Infer () checkData d = do case d of - (Data typ@(Indexed name ts) constrs) -> do + (Data typ@(TData name ts) constrs) -> do unless (all isPoly ts) (throwError $ unwords ["Data type incorrectly declared"]) traverse_ ( \(Constructor name' t') -> - if TIndexed typ == retType t' + if typ == retType t' then insertConstr (coerce name') (toNew t') else throwError $ @@ -68,6 +68,7 @@ checkData d = do ] ) constrs + _ -> throwError $ "incorrectly declared data type '" ++ printTree d ++ "'" retType :: Type -> Type retType (TFun _ t2) = retType t2 @@ -86,7 +87,14 @@ checkPrg (Program bs) = do preRun [] = return () preRun (x : xs) = case x of DSig (Sig n t) -> do - gets (M.member (coerce n) . sigs) >>= flip when (throwError $ "Duplicate signatures for function '" ++ printTree n ++ "'") + gets (M.member (coerce n) . sigs) + >>= flip + when + ( throwError $ + "Duplicate signatures for function '" + ++ printTree n + ++ "'" + ) insertSig (coerce n) (Just $ toNew t) >> preRun xs DBind (Bind n _ _) -> do s <- gets sigs @@ -140,7 +148,7 @@ isMoreSpecificOrEq :: T.Type -> T.Type -> Bool isMoreSpecificOrEq _ (T.TAll _ _) = True isMoreSpecificOrEq (T.TFun a b) (T.TFun c d) = isMoreSpecificOrEq a c && isMoreSpecificOrEq b d -isMoreSpecificOrEq (T.TIndexed (T.Indexed n1 ts1)) (T.TIndexed (T.Indexed n2 ts2)) = +isMoreSpecificOrEq (T.TData n1 ts1) (T.TData n2 ts2) = n1 == n2 && length ts1 == length ts2 && and (zipWith isMoreSpecificOrEq ts1 ts2) @@ -169,11 +177,11 @@ instance NewType Type T.Type where TVar v -> T.TVar $ toNew v TFun t1 t2 -> T.TFun (toNew t1) (toNew t2) TAll b t -> T.TAll (toNew b) (toNew t) - TIndexed i -> T.TIndexed (toNew i) + TData i ts -> T.TData (coerce i) (map toNew ts) TEVar _ -> error "Should not exist after typechecker" -instance NewType Indexed T.Indexed where - toNew (Indexed name vars) = T.Indexed (coerce name) (map toNew vars) +-- instance NewType Indexed T.TData where +-- toNew (Indexed name vars) = T.TData (coerce name) (map toNew vars) instance NewType TVar T.TVar where toNew (MkTVar i) = T.MkTVar $ coerce i @@ -181,8 +189,8 @@ instance NewType TVar T.TVar where algoW :: Exp -> Infer (Subst, T.ExpT) algoW = \case -- \| TODO: More testing need to be done. Unsure of the correctness of this - EAnn e t -> do - (s1, (e', t')) <- algoW e + err@(EAnn e t) -> do + (s1, (e', t')) <- exprErr (algoW e) err unless (toNew t `isMoreSpecificOrEq` t') ( throwError $ @@ -194,16 +202,14 @@ algoW = \case ] ) applySt s1 $ do - s2 <- unify (toNew t) t' + s2 <- exprErr (unify (toNew t) t') err let comp = s2 `compose` s1 return (comp, apply comp (e', toNew t)) -- \| ------------------ -- \| Γ ⊢ i : Int, ∅ - ELit lit -> - let lt = litType lit - in return (nullSubst, (T.ELit lit, lt)) + ELit lit -> return (nullSubst, (T.ELit lit, litType lit)) -- \| x : σ ∈ Γ   τ = inst(σ) -- \| ---------------------- -- \| Γ ⊢ x : τ, ∅ @@ -227,13 +233,16 @@ algoW = \case -- \| --------------------------------- -- \| Γ ⊢ w λx. e : Sτ → τ', S - EAbs name e -> do + err@(EAbs name e) -> do fr <- fresh - withBinding (coerce name) fr $ do - (s1, (e', t')) <- algoW e - let varType = apply s1 fr - let newArr = T.TFun varType t' - return (s1, apply s1 (T.EAbs (coerce name) (e', t'), newArr)) + exprErr + ( withBinding (coerce name) fr $ do + (s1, (e', t')) <- exprErr (algoW e) err + let varType = apply s1 fr + let newArr = T.TFun varType t' + return (s1, apply s1 (T.EAbs (coerce name) (e', t'), newArr)) + ) + err -- \| Γ ⊢ e₀ : τ₀, S₀ S₀Γ ⊢ e₁ : τ₁, S₁ -- \| s₂ = mgu(s₁τ₀, Int) s₃ = mgu(s₂τ₁, Int) @@ -241,13 +250,13 @@ algoW = \case -- \| Γ ⊢ e₀ + e₁ : Int, S₃S₂S₁S₀ -- This might be wrong - EAdd e0 e1 -> do + err@(EAdd e0 e1) -> do (s1, (e0', t0)) <- algoW e0 applySt s1 $ do (s2, (e1', t1)) <- algoW e1 -- applySt s2 $ do - s3 <- unify (apply s2 t0) int - s4 <- unify (apply s3 t1) int + s3 <- exprErr (unify (apply s2 t0) int) err + s4 <- exprErr (unify (apply s3 t1) int) err let comp = s4 `compose` s3 `compose` s2 `compose` s1 return ( comp @@ -259,12 +268,12 @@ algoW = \case -- \| -------------------------------------- -- \| Γ ⊢ e₀ e₁ : S₂τ', S₂S₁S₀ - EApp e0 e1 -> do + err@(EApp e0 e1) -> do fr <- fresh - (s0, (e0', t0)) <- algoW e0 + (s0, (e0', t0)) <- exprErr (algoW e0) err applySt s0 $ do - (s1, (e1', t1)) <- algoW e1 - s2 <- unify (apply s1 t0) (T.TFun t1 fr) + (s1, (e1', t1)) <- exprErr (algoW e1) err + s2 <- exprErr (unify (apply s1 t0) (T.TFun t1 fr)) err let t = apply s2 fr let comp = s2 `compose` s1 `compose` s0 return (comp, apply comp (T.EApp (e0', t0) (e1', t1), t)) @@ -275,9 +284,9 @@ algoW = \case -- The bar over S₀ and Γ means "generalize" - ELet b@(Bind name args e) e1 -> do - (s1, (_, t0)) <- algoW (makeLambda e (coerce args)) - bind' <- checkBind b + err@(ELet b@(Bind name args e) e1) -> do + (s1, (_, t0)) <- exprErr (algoW (makeLambda e (coerce args))) err + bind' <- exprErr (checkBind b) err env <- asks vars let t' = generalize (apply s1 env) t0 withBinding (coerce name) t' $ do @@ -311,7 +320,7 @@ unify t0 t1 = do (a, T.TAll _ t) -> unify a t (T.TLit a, T.TLit b) -> if a == b then return M.empty else throwError . unwords $ ["Can not unify", "'" ++ printTree (T.TLit a) ++ "'", "with", "'" ++ printTree (T.TLit b) ++ "'"] - (T.TIndexed (T.Indexed name t), T.TIndexed (T.Indexed name' t')) -> + (T.TData name t, T.TData name' t') -> if name == name' && length t == length t' then do xs <- zipWithM unify t t' @@ -399,7 +408,7 @@ instance FreeVars T.Type where free (T.TLit _) = mempty free (T.TFun a b) = free a `S.union` free b -- \| Not guaranteed to be correct - free (T.TIndexed (T.Indexed _ a)) = + free (T.TData _ a) = foldl' (\acc x -> free x `S.union` acc) S.empty a apply :: Subst -> T.Type -> T.Type @@ -413,7 +422,7 @@ instance FreeVars T.Type where Nothing -> T.TAll (T.MkTVar i) (apply sub t) Just _ -> apply sub t T.TFun a b -> T.TFun (apply sub a) (apply sub b) - T.TIndexed (T.Indexed name a) -> T.TIndexed (T.Indexed name (map (apply sub) a)) + T.TData name a -> T.TData name (map (apply sub) a) instance FreeVars (Map Ident T.Type) where free :: Map Ident T.Type -> Set Ident @@ -548,3 +557,6 @@ partitionType = go [] TAll tvar t' -> second (TAll tvar) $ go acc i t' TFun t1 t2 -> go (acc ++ [t1]) (i - 1) t2 _ -> error "Number of parameters and type doesn't match" + +exprErr :: Infer a -> Exp -> Infer a +exprErr ma exp = catchError ma (\x -> throwError $ x ++ " on expression: " ++ printTree exp) diff --git a/src/TypeChecker/TypeCheckerIr.hs b/src/TypeChecker/TypeCheckerIr.hs index 1113dbc..ceac8e9 100644 --- a/src/TypeChecker/TypeCheckerIr.hs +++ b/src/TypeChecker/TypeCheckerIr.hs @@ -52,7 +52,7 @@ data Type | TVar TVar | TFun Type Type | TAll TVar Type - | TIndexed Indexed + | TData Ident [Type] deriving (Show, Eq, Ord, Read) data Exp @@ -67,9 +67,6 @@ data Exp type ExpT = (Exp, Type) -data Indexed = Indexed Ident [Type] - deriving (Show, Read, Ord, Eq) - data Inj = Inj (Init, Type) ExpT deriving (C.Eq, C.Ord, C.Read, C.Show) @@ -205,8 +202,5 @@ instance Print Type where TLit uident -> prPrec i 2 (concatD [prt 0 uident]) TVar tvar -> prPrec i 2 (concatD [prt 0 tvar]) TAll tvar type_ -> prPrec i 1 (concatD [doc (showString "forall"), prt 0 tvar, doc (showString "."), prt 0 type_]) - TIndexed indexed -> prPrec i 1 (concatD [prt 0 indexed]) + TData ident types -> prPrec i 1 (concatD [prt 0 ident, prt 0 types]) TFun type_1 type_2 -> prPrec i 0 (concatD [prt 1 type_1, doc (showString "->"), prt 0 type_2]) - -instance Print Indexed where - prt i (Indexed u ts) = concatD [prt i u, prt i ts] diff --git a/test_program b/test_program index eb31907..28cd227 100644 --- a/test_program +++ b/test_program @@ -8,18 +8,18 @@ data Bool () where { False : Bool () }; --- hello_world = Cons 'h' (Cons 'e' (Cons 'l' (Cons 'l' (Cons 'o' (Cons ' ' (Cons 'w' (Cons 'o' (Cons 'r' (Cons 'l' (Cons 'd' Nil)))))))))) ; +hello_world = Cons 'h' (Cons 'e' (Cons 'l' (Cons 'l' (Cons 'o' (Cons ' ' (Cons 'w' (Cons 'o' (Cons 'r' (Cons 'l' (Cons 'd' Nil)))))))))) ; --- length : List (a) -> Int ; --- length xs = case xs of { --- Nil => 0 ; --- Cons x xs => length xs --- }; +length : List (a) -> Int ; +length xs = case xs of { + Nil => 0 ; + Cons x xs => length xs +}; --- head : List (a) -> a ; --- head xs = case xs of { --- Cons x xs => x --- }; +head : List (a) -> a ; +head xs = case xs of { + Cons x xs => x +}; firstIsOne : List (Int) -> Bool () ; firstIsOne : List (Int) -> Bool () ; @@ -34,9 +34,11 @@ firstIsOne xs = case xs of { _ => False }; --- firstIsOne :: [Int] -> Bool --- firstIsOne xs = case xs of --- (1 : xs) -> True --- _ -> False +firstIsOne :: [Int] -> Bool +firstIsOne xs = case xs of + (1 : xs) -> True + _ -> False main = firstIsOne (Cons 'a' Nil) + +data a -> b where From f4163bbb7d3d40b410349cb5b3802575a20f8995 Mon Sep 17 00:00:00 2001 From: sebastianselander Date: Fri, 24 Mar 2023 14:56:33 +0100 Subject: [PATCH 130/372] formatting --- src/TypeChecker/TypeChecker.hs | 68 +++++++++++++++++++++++----------- 1 file changed, 46 insertions(+), 22 deletions(-) diff --git a/src/TypeChecker/TypeChecker.hs b/src/TypeChecker/TypeChecker.hs index 313612a..2a19b6e 100644 --- a/src/TypeChecker/TypeChecker.hs +++ b/src/TypeChecker/TypeChecker.hs @@ -68,7 +68,11 @@ checkData d = do ] ) constrs - _ -> throwError $ "incorrectly declared data type '" ++ printTree d ++ "'" + _ -> + throwError $ + "incorrectly declared data type '" + <> printTree d + <> "'" retType :: Type -> Type retType (TFun _ t2) = retType t2 @@ -79,7 +83,7 @@ checkPrg (Program bs) = do preRun bs -- Type check the program twice to produce all top-level types in the first pass through bs' <- checkDef bs - trace ("FIRST ITERATION: " ++ printTree bs') pure () + trace ("FIRST ITERATION: " <> printTree bs') pure () bs'' <- checkDef bs return $ T.Program bs'' where @@ -92,8 +96,8 @@ checkPrg (Program bs) = do when ( throwError $ "Duplicate signatures for function '" - ++ printTree n - ++ "'" + <> printTree n + <> "'" ) insertSig (coerce n) (Just $ toNew t) >> preRun xs DBind (Bind n _ _) -> do @@ -138,11 +142,11 @@ checkBind (Bind name args e) = do -- Just Nothing -> return (b, t) -- _ -> [] -- (T.ELit _, _) -> [] - -- (T.ELet (T.Bind _ _ e1) e2, _) -> getFunctionTypes s e1 ++ getFunctionTypes s e2 - -- (T.EApp e1 e2, _) -> getFunctionTypes s e1 ++ getFunctionTypes s e2 - -- (T.EAdd e1 e2, _) -> getFunctionTypes s e1 ++ getFunctionTypes s e2 + -- (T.ELet (T.Bind _ _ e1) e2, _) -> getFunctionTypes s e1 <> getFunctionTypes s e2 + -- (T.EApp e1 e2, _) -> getFunctionTypes s e1 <> getFunctionTypes s e2 + -- (T.EAdd e1 e2, _) -> getFunctionTypes s e1 <> getFunctionTypes s e2 -- (T.EAbs _ e, _) -> getFunctionTypes s e - -- (T.ECase e injs, _) -> getFunctionTypes s e ++ concatMap (getFunctionTypes s . \(T.Inj _ e) -> e) injs + -- (T.ECase e injs, _) -> getFunctionTypes s e <> concatMap (getFunctionTypes s . \(T.Inj _ e) -> e) injs isMoreSpecificOrEq :: T.Type -> T.Type -> Bool isMoreSpecificOrEq _ (T.TAll _ _) = True @@ -221,13 +225,18 @@ algoW = \case sig <- gets sigs case M.lookup (coerce i) sig of Just (Just t) -> return (nullSubst, (T.EId $ coerce i, t)) - Just Nothing -> (\x -> (nullSubst, (T.EId $ coerce i, x))) <$> fresh - Nothing -> throwError $ "Unbound variable: " ++ printTree i + Just Nothing -> + (\x -> (nullSubst, (T.EId $ coerce i, x))) <$> fresh + Nothing -> throwError $ "Unbound variable: " <> printTree i ECons i -> do constr <- gets constructors case M.lookup (coerce i) constr of Just t -> return (nullSubst, (T.EId $ coerce i, t)) - Nothing -> throwError $ "Constructor: '" ++ printTree i ++ "' is not defined" + Nothing -> + throwError $ + "Constructor: '" + <> printTree i + <> "' is not defined" -- \| τ = newvar Γ, x : τ ⊢ e : τ', S -- \| --------------------------------- @@ -307,7 +316,7 @@ makeLambda = foldl (flip (EAbs . coerce)) -- | Unify two types producing a new substitution unify :: T.Type -> T.Type -> Infer Subst -unify t0 t1 | trace ("T0: " ++ show t0 ++ "\nT1: " ++ show t1) False = undefined +unify t0 t1 | trace ("T0: " <> show t0 <> "\nT1: " <> show t1) False = undefined unify t0 t1 = do case (t0, t1) of (T.TFun a b, T.TFun c d) -> do @@ -319,7 +328,16 @@ unify t0 t1 = do (T.TAll _ t, b) -> unify t b (a, T.TAll _ t) -> unify a t (T.TLit a, T.TLit b) -> - if a == b then return M.empty else throwError . unwords $ ["Can not unify", "'" ++ printTree (T.TLit a) ++ "'", "with", "'" ++ printTree (T.TLit b) ++ "'"] + if a == b + then return M.empty + else + throwError + . unwords + $ [ "Can not unify" + , "'" <> printTree (T.TLit a) <> "'" + , "with" + , "'" <> printTree (T.TLit b) <> "'" + ] (T.TData name t, T.TData name' t') -> if name == name' && length t == length t' then do @@ -330,16 +348,16 @@ unify t0 t1 = do unwords [ "T.Type constructor:" , printTree name - , "(" ++ printTree t ++ ")" + , "(" <> printTree t <> ")" , "does not match with:" , printTree name' - , "(" ++ printTree t' ++ ")" + , "(" <> printTree t' <> ")" ] (a, b) -> do throwError . unwords $ - [ "'" ++ printTree a ++ "'" + [ "'" <> printTree a <> "'" , "can't be unified with" - , "'" ++ printTree b ++ "'" + , "'" <> printTree b <> "'" ] {- | Check if a type is contained in another type. @@ -437,7 +455,12 @@ instance FreeVars T.ExpT where apply s = \case (T.EId i, outerT) -> (T.EId i, apply s outerT) (T.ELit lit, t) -> (T.ELit lit, apply s t) - (T.ELet (T.Bind (ident, t1) args e1) e2, t2) -> (T.ELet (T.Bind (ident, apply s t1) args (apply s e1)) (apply s e2), apply s t2) + (T.ELet (T.Bind (ident, t1) args e1) e2, t2) -> + ( T.ELet + (T.Bind (ident, apply s t1) args (apply s e1)) + (apply s e2) + , apply s t2 + ) (T.EApp e1 e2, t) -> (T.EApp (apply s e1) (apply s e2), apply s t) (T.EAdd e1 e2, t) -> (T.EAdd (apply s e1) (apply s e2), apply s t) (T.EAbs ident e, t1) -> (T.EAbs ident (apply s e), apply s t1) @@ -524,7 +547,7 @@ inferInit = \case gets (M.lookup (coerce fn) . constructors) >>= \case Nothing -> throwError $ - "Constructor: " ++ printTree fn ++ " does not exist" + "Constructor: " <> printTree fn <> " does not exist" Just a -> do case unsnoc $ flattenType a of Nothing -> throwError "Partial pattern match not allowed" @@ -536,7 +559,7 @@ inferInit = \case InitCatch -> (,mempty) <$> fresh flattenType :: T.Type -> [T.Type] -flattenType (T.TFun a b) = flattenType a ++ flattenType b +flattenType (T.TFun a b) = flattenType a <> flattenType b flattenType a = [a] litType :: Lit -> T.Type @@ -555,8 +578,9 @@ partitionType = go [] go acc 0 t = (acc, t) go acc i t = case t of TAll tvar t' -> second (TAll tvar) $ go acc i t' - TFun t1 t2 -> go (acc ++ [t1]) (i - 1) t2 + TFun t1 t2 -> go (acc <> [t1]) (i - 1) t2 _ -> error "Number of parameters and type doesn't match" exprErr :: Infer a -> Exp -> Infer a -exprErr ma exp = catchError ma (\x -> throwError $ x ++ " on expression: " ++ printTree exp) +exprErr ma exp = + catchError ma (\x -> throwError $ x <> " on expression: " <> printTree exp) From 50bea83a186548adf7df9989dc7e1f2767045c5c Mon Sep 17 00:00:00 2001 From: Samuel Hammersberg Date: Fri, 24 Mar 2023 13:55:06 +0100 Subject: [PATCH 131/372] Got some more stuff working. --- src/Codegen/Codegen.hs | 624 ++++++++++++++------------- src/Monomorphizer/Monomorphizer.hs | 32 +- src/Monomorphizer/MonomorphizerIr.hs | 10 +- 3 files changed, 338 insertions(+), 328 deletions(-) diff --git a/src/Codegen/Codegen.hs b/src/Codegen/Codegen.hs index f8da93e..4e95102 100644 --- a/src/Codegen/Codegen.hs +++ b/src/Codegen/Codegen.hs @@ -1,9 +1,22 @@ -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} -module Codegen.Codegen where +module Codegen.Codegen (generateCode) where --- module Codegen.Codegen (generateCode) where +import Auxiliary (snoc) +import Codegen.LlvmIr as LIR +import Control.Applicative ((<|>)) +import Control.Monad.State (StateT, execStateT, foldM_, + gets, modify) +import qualified Data.Bifunctor as BI +import Data.Coerce (coerce) +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Maybe (fromJust, fromMaybe) +import Data.Tuple.Extra (dupe, first, second) +import qualified Grammar.Abs as GA +import Grammar.ErrM (Err) +import Monomorphizer.MonomorphizerIr as MIR -- | The record used as the code generator state data CodeGenerator = CodeGenerator @@ -14,45 +27,42 @@ data CodeGenerator = CodeGenerator , labelCount :: Integer } ----- | The record used as the code generator state --- data CodeGenerator = CodeGenerator --- { instructions :: [LLVMIr] --- , functions :: Map MIR.Id FunctionInfo --- , constructors :: Map Ident ConstructorInfo --- , variableCount :: Integer --- , labelCount :: Integer --- } +-- | A state type synonym +type CompilerState a = StateT CodeGenerator Err a ----- | A state type synonym --- type CompilerState a = StateT CodeGenerator Err a +data FunctionInfo = FunctionInfo + { numArgs :: Int + , arguments :: [Id] + } + deriving (Show) +data ConstructorInfo = ConstructorInfo + { numArgsCI :: Int + , argumentsCI :: [Id] + , numCI :: Integer + } + deriving (Show) --- data FunctionInfo = FunctionInfo --- { numArgs :: Int --- , arguments :: [Id] --- } --- deriving (Show) --- data ConstructorInfo = ConstructorInfo --- { numArgsCI :: Int --- , argumentsCI :: [Id] --- , numCI :: Integer --- } --- deriving (Show) +-- | Adds a instruction to the CodeGenerator state +emit :: LLVMIr -> CompilerState () +emit l = modify $ \t -> t{instructions = Auxiliary.snoc l $ instructions t} ----- | Adds a instruction to the CodeGenerator state --- emit :: LLVMIr -> CompilerState () --- emit l = modify $ \t -> t{instructions = Auxiliary.snoc l $ instructions t} +-- | Increases the variable counter in the CodeGenerator state +increaseVarCount :: CompilerState () +increaseVarCount = modify $ \t -> t{variableCount = variableCount t + 1} ----- | Increases the variable counter in the CodeGenerator state --- increaseVarCount :: CompilerState () --- increaseVarCount = modify $ \t -> t{variableCount = variableCount t + 1} +-- | Returns the variable count from the CodeGenerator state +getVarCount :: CompilerState Integer +getVarCount = gets variableCount ----- | Returns the variable count from the CodeGenerator state --- getVarCount :: CompilerState Integer --- getVarCount = gets variableCount +-- | Increases the variable count and returns it from the CodeGenerator state +getNewVar :: CompilerState GA.Ident +getNewVar = (GA.Ident . show) <$> (increaseVarCount >> getVarCount) ----- | Increases the variable count and returns it from the CodeGenerator state --- getNewVar :: CompilerState GA.Ident --- getNewVar = (GA.Ident . show) <$> (increaseVarCount >> getVarCount) +-- | Increses the label count and returns a label from the CodeGenerator state +getNewLabel :: CompilerState Integer +getNewLabel = do + modify (\t -> t{labelCount = labelCount t + 1}) + gets labelCount {- | Produces a map of functions infos from a list of binds, which contains useful data for code generation. @@ -64,41 +74,21 @@ getFunctions bs = Map.fromList $ go bs go (MIR.DBind (MIR.Bind id args _) : xs) = (id, FunctionInfo{numArgs = length args, arguments = args}) : go xs - go (MIR.DData (MIR.Constructor n cons) : xs) = + go (MIR.DData (MIR.Data n cons) : xs) = do map - ( \(id, xs) -> - ( (coerce id, MIR.TLit (coerce n)) + ( \(Constructor id xs) -> + ( (coerce id, MIR.TLit (extractTypeName n)) , FunctionInfo - { numArgs = length (flattenType xs) - , arguments = createArgs (flattenType xs) + { numArgs = length xs + , arguments = createArgs (snd <$> xs) } ) ) cons <> go xs --- {- | Produces a map of functions infos from a list of binds, --- which contains useful data for code generation. ----} --- getFunctions :: [MIR.Def] -> Map Id FunctionInfo --- getFunctions bs = Map.fromList $ go bs --- where --- go [] = [] --- go (MIR.DBind (MIR.Bind id args _) : xs) = --- (id, FunctionInfo{numArgs = length args, arguments = args}) --- : go xs --- go (MIR.DData (MIR.Constructor n cons) : xs) = undefined --- {-do map --- ( \(Constructor id xs) -> --- ( (id, MIR.TLit n) --- , FunctionInfo --- { numArgs = length xs --- , arguments = createArgs xs --- } --- ) --- ) --- cons --- <> go xs-} +createArgs :: [MIR.Type] -> [Id] +createArgs xs = fst $ foldl (\(acc, l) t -> (acc ++ [(GA.Ident ("arg_" <> show l), t)], l + 1)) ([], 0) xs {- | Produces a map of functions infos from a list of binds, which contains useful data for code generation. @@ -107,15 +97,16 @@ getConstructors :: [MIR.Def] -> Map MIR.Id ConstructorInfo getConstructors bs = Map.fromList $ go bs where go [] = [] - go (MIR.DData (MIR.Constructor (GA.UIdent n) cons) : xs) = + go (MIR.DData (MIR.Data t cons) : xs) = do + let (GA.Ident n) = extractTypeName t fst ( foldl - ( \(acc, i) (GA.UIdent id, xs) -> + ( \(acc, i) (Constructor (GA.UIdent id) xs) -> ( ( (GA.Ident (n <> "_" <> id), MIR.TLit (coerce n)) , ConstructorInfo - { numArgsCI = length (flattenType xs) - , argumentsCI = createArgs (flattenType xs) + { numArgsCI = length xs + , argumentsCI = createArgs (snd <$> xs) , numCI = i } ) @@ -129,53 +120,66 @@ getConstructors bs = Map.fromList $ go bs <> go xs go (_ : xs) = go xs --- {- | Produces a map of functions infos from a list of binds, --- which contains useful data for code generation. ----} --- getConstructors :: [MIR.Def] -> Map Ident ConstructorInfo --- getConstructors bs = Map.fromList $ go bs --- where --- go [] = [] --- go (MIR.DData (MIR.Constructor n cons) : xs) = undefined --- {-do --- fst --- ( foldl --- ( \(acc, i) (GA.Constructor (GA.Ident id) xs) -> --- ( ( (GA.Ident (n <> "_" <> id), MIR.TLit (GA.Ident n)) --- , ConstructorInfo --- { numArgsCI = length xs --- , argumentsCI = createArgs xs --- , numCI = i --- } --- ) --- : acc --- , i + 1 --- ) --- ) --- ([], 0) --- cons --- ) --- <> go xs-} --- go (_ : xs) = go xs +initCodeGenerator :: [MIR.Def] -> CodeGenerator +initCodeGenerator scs = + CodeGenerator + { instructions = defaultStart + , functions = getFunctions scs + , constructors = getConstructors scs + , variableCount = 0 + , labelCount = 0 + } --- initCodeGenerator :: [MIR.Def] -> CodeGenerator --- initCodeGenerator scs = --- CodeGenerator --- { instructions = defaultStart --- , functions = getFunctions scs --- , constructors = getConstructors scs --- , variableCount = 0 --- , labelCount = 0 --- } +{- +run :: Err String -> IO () +run s = do + let s' = case s of + Right s -> s + Left _ -> error "yo" + writeFile "output/llvm.ll" s' + putStrLn . trim =<< readCreateProcess (shell "lli") s' --- {- --- run :: Err String -> IO () --- run s = do --- let s' = case s of --- Right s -> s --- Left _ -> error "yo" --- writeFile "output/llvm.ll" s' --- putStrLn . trim =<< readCreateProcess (shell "lli") s' +test :: Integer -> Program +test v = + Program + [ DataType + (GA.Ident "Craig") + [ Constructor (GA.Ident "Bob") [MIR.Type (GA.Ident "_Int")] + , Constructor (GA.Ident "Betty") [MIR.Type (GA.Ident "_Int")] + ] + , DataType + (GA.Ident "Alice") + [ Constructor (GA.Ident "Eve") [MIR.Type (GA.Ident "_Int")] -- , + -- (GA.Ident "Alice", [TInt, TInt]) + ] + , Bind (GA.Ident "fibonacci", MIR.Type (GA.Ident "_Int")) [(GA.Ident "x", MIR.Type (GA.Ident "_Int"))] (EId ("x", MIR.Type (GA.Ident "Craig")), MIR.Type (GA.Ident "Craig")) + , Bind (GA.Ident "main", MIR.Type (GA.Ident "_Int")) [] + -- (EApp (MIR.Type (GA.Ident "Craig")) (EId (GA.Ident "Craig_Bob", MIR.Type (GA.Ident "Craig")), MIR.Type (GA.Ident "Craig")) (ELit (LInt v), MIR.Type (GA.Ident "_Int")), MIR.Type (GA.Ident "Craig"))-- (EInt 92) + $ + eCaseInt + (EApp (MIR.TLit (GA.Ident "Craig")) (EId (GA.Ident "Craig_Bob", MIR.TLit (GA.Ident "Craig")), MIR.TLit (GA.Ident "Craig")) (ELit (LInt v), MIR.Type (GA.Ident "_Int")), MIR.Type (GA.Ident "Craig")) + [ injectionCons "Craig_Bob" "Craig" [CIdent (GA.Ident "x")] (EId (GA.Ident "x", MIR.Type (GA.Ident "_Int")), MIR.Type (GA.Ident "_Int")) + , injectionCons "Craig_Betty" "Craig" [CLit (LInt 5)] (int 2) + , Injection (CIdent (GA.Ident "z")) (int 3) + , -- , injectionInt 5 (int 6) + injectionCatchAll (int 10) + ] + ] + where + injectionCons x y xs = Injection (CCons (GA.Ident x, MIR.Type (GA.Ident y)) xs) + injectionInt x = Injection (CLit (LInt x)) + injectionCatchAll = Injection CatchAll + eCaseInt x xs = (ECase (MIR.TLit (MIR.Ident "_Int")) x xs, MIR.TLit (MIR.Ident "_Int")) + int x = (ELit (LInt x), MIR.TLit (MIR.Ident "_Int")) +-} +{- | Compiles an AST and produces a LLVM Ir string. + An easy way to actually "compile" this output is to + Simply pipe it to LLI +-} +generateCode :: MIR.Program -> Err String +generateCode (MIR.Program scs) = do + let codegen = initCodeGenerator scs + llvmIrToString . instructions <$> execStateT (compileScs scs) codegen compileScs :: [MIR.Def] -> CompilerState () compileScs [] = do @@ -256,61 +260,61 @@ compileScs (MIR.DBind (MIR.Bind (name, _t) args exp) : xs) = do emit DefineEnd modify $ \s -> s{variableCount = 0} compileScs xs -compileScs (MIR.DData (MIR.Constructor (GA.UIdent outer_id) ts) : xs) = do - let types = BI.second flattenType <$> ts - let biggestVariant = maximum $ sum . map (typeByteSize . type2LlvmType) <$> (snd <$> types) +compileScs (MIR.DData (MIR.Data typ ts) : xs) = do + let (Ident outer_id) = extractTypeName typ + let biggestVariant = maximum $ sum <$> (\(Constructor _ t) -> typeByteSize . type2LlvmType . snd <$> t) <$> ts emit $ LIR.Type (coerce outer_id) [I8, Array biggestVariant I8] mapM_ - ( \(GA.UIdent inner_id, fi) -> do - emit $ LIR.Type (GA.Ident $ outer_id <> "_" <> inner_id) (I8 : map type2LlvmType fi) + ( \(Constructor (GA.UIdent inner_id) fi) -> do + emit $ LIR.Type (GA.Ident $ outer_id <> "_" <> inner_id) (I8 : map type2LlvmType (snd <$> fi)) ) - types + ts compileScs xs --- mainContent :: LLVMValue -> [LLVMIr] --- mainContent var = --- [ UnsafeRaw $ --- -- "%2 = alloca %Craig\n" <> --- -- " store %Craig %1, ptr %2\n" <> --- -- " %3 = bitcast %Craig* %2 to i72*\n" <> --- -- " %4 = load i72, ptr %3\n" <> --- -- " call i32 (ptr, ...) @printf(ptr noundef @.str, i72 noundef %4)\n" --- "call i32 (ptr, ...) @printf(ptr noundef @.str, i64 noundef " <> toIr var <> ")\n" --- , -- , SetVariable (GA.Ident "p") (Icmp LLEq I64 (VInteger 2) (VInteger 2)) --- -- , BrCond (VIdent (GA.Ident "p")) (GA.Ident "b_1") (GA.Ident "b_2") --- -- , Label (GA.Ident "b_1") --- -- , UnsafeRaw --- -- "call i32 (ptr, ...) @printf(ptr noundef @.str, i64 noundef 1)\n" --- -- , Br (GA.Ident "end") --- -- , Label (GA.Ident "b_2") --- -- , UnsafeRaw --- -- "call i32 (ptr, ...) @printf(ptr noundef @.str, i64 noundef 2)\n" --- -- , Br (GA.Ident "end") --- -- , Label (GA.Ident "end") --- Ret I64 (VInteger 0) --- ] +mainContent :: LLVMValue -> [LLVMIr] +mainContent var = + [ UnsafeRaw $ + -- "%2 = alloca %Craig\n" <> + -- " store %Craig %1, ptr %2\n" <> + -- " %3 = bitcast %Craig* %2 to i72*\n" <> + -- " %4 = load i72, ptr %3\n" <> + -- " call i32 (ptr, ...) @printf(ptr noundef @.str, i72 noundef %4)\n" + "call i32 (ptr, ...) @printf(ptr noundef @.str, i64 noundef " <> toIr var <> ")\n" + , -- , SetVariable (GA.Ident "p") (Icmp LLEq I64 (VInteger 2) (VInteger 2)) + -- , BrCond (VIdent (GA.Ident "p")) (GA.Ident "b_1") (GA.Ident "b_2") + -- , Label (GA.Ident "b_1") + -- , UnsafeRaw + -- "call i32 (ptr, ...) @printf(ptr noundef @.str, i64 noundef 1)\n" + -- , Br (GA.Ident "end") + -- , Label (GA.Ident "b_2") + -- , UnsafeRaw + -- "call i32 (ptr, ...) @printf(ptr noundef @.str, i64 noundef 2)\n" + -- , Br (GA.Ident "end") + -- , Label (GA.Ident "end") + Ret I64 (VInteger 0) + ] --- defaultStart :: [LLVMIr] --- defaultStart = --- [ UnsafeRaw "target triple = \"x86_64-pc-linux-gnu\"\n" --- , UnsafeRaw "target datalayout = \"e-m:o-i64:64-f80:128-n8:16:32:64-S128\"\n" --- , UnsafeRaw "@.str = private unnamed_addr constant [3 x i8] c\"%x\n\", align 1\n" --- , UnsafeRaw "declare i32 @printf(ptr noalias nocapture, ...)\n" --- ] +defaultStart :: [LLVMIr] +defaultStart = + [ UnsafeRaw "target triple = \"x86_64-pc-linux-gnu\"\n" + , UnsafeRaw "target datalayout = \"e-m:o-i64:64-f80:128-n8:16:32:64-S128\"\n" + , UnsafeRaw "@.str = private unnamed_addr constant [3 x i8] c\"%x\n\", align 1\n" + , UnsafeRaw "declare i32 @printf(ptr noalias nocapture, ...)\n" + ] --- compileExp :: ExpT -> CompilerState () --- compileExp (MIR.ELit lit,t) = emitLit lit --- compileExp (MIR.EAdd e1 e2,t) = emitAdd t e1 e2 ----- compileExp (ESub t e1 e2) = emitSub t e1 e2 --- compileExp (MIR.EId name,t) = emitIdent name --- compileExp (MIR.EApp e1 e2,t) = emitApp t e1 e2 ----- compileExp (EAbs t ti e) = emitAbs t ti e --- compileExp (MIR.ELet binds e,t) = undefined -- emitLet binds (fst e) --- compileExp (MIR.ECase e cs,t) = emitECased t e (map (t,) cs) +compileExp :: ExpT -> CompilerState () +compileExp (MIR.ELit lit,t) = emitLit lit +compileExp (MIR.EAdd e1 e2,t) = emitAdd t e1 e2 +-- compileExp (ESub t e1 e2) = emitSub t e1 e2 +compileExp (MIR.EId name,t) = emitIdent name +compileExp (MIR.EApp e1 e2,t) = emitApp t e1 e2 +-- compileExp (EAbs t ti e) = emitAbs t ti e +compileExp (MIR.ELet binds e,t) = undefined -- emitLet binds (fst e) +compileExp (MIR.ECase e cs,t) = emitECased t e (map (t,) cs) ----- go (EMul e1 e2) = emitMul e1 e2 ----- go (EDiv e1 e2) = emitDiv e1 e2 ----- go (EMod e1 e2) = emitMod e1 e2 +-- go (EMul e1 e2) = emitMul e1 e2 +-- go (EDiv e1 e2) = emitDiv e1 e2 +-- go (EMod e1 e2) = emitMod e1 e2 --- aux functions --- emitECased :: MIR.Type -> ExpT -> [(MIR.Type, Injection)] -> CompilerState () @@ -333,89 +337,89 @@ emitECased t e cases = do cons <- gets constructors let r = fromJust $ Map.lookup (coerce consId, t) cons --- lbl_failPos <- (\x -> GA.Ident $ "failed_" <> show x) <$> getNewLabel --- lbl_succPos <- (\x -> GA.Ident $ "success_" <> show x) <$> getNewLabel + lbl_failPos <- (\x -> GA.Ident $ "failed_" <> show x) <$> getNewLabel + lbl_succPos <- (\x -> GA.Ident $ "success_" <> show x) <$> getNewLabel --- consVal <- getNewVar --- emit $ SetVariable consVal (ExtractValue rt vs 0) + consVal <- getNewVar + emit $ SetVariable consVal (ExtractValue rt vs 0) --- consCheck <- getNewVar --- emit $ SetVariable consCheck (Icmp LLEq I8 (VIdent consVal I8) (VInteger $ numCI r)) --- emit $ BrCond (VIdent consCheck ty) lbl_succPos lbl_failPos --- emit $ Label lbl_succPos + consCheck <- getNewVar + emit $ SetVariable consCheck (Icmp LLEq I8 (VIdent consVal I8) (VInteger $ numCI r)) + emit $ BrCond (VIdent consCheck ty) lbl_succPos lbl_failPos + emit $ Label lbl_succPos --- castPtr <- getNewVar --- castedPtr <- getNewVar --- casted <- getNewVar --- emit $ SetVariable castPtr (Alloca rt) --- emit $ Store rt vs Ptr castPtr --- emit $ SetVariable castedPtr (Bitcast Ptr (VIdent castPtr Ptr) Ptr) --- emit $ SetVariable casted (Load (CustomType (coerce consId)) Ptr castedPtr) + castPtr <- getNewVar + castedPtr <- getNewVar + casted <- getNewVar + emit $ SetVariable castPtr (Alloca rt) + emit $ Store rt vs Ptr castPtr + emit $ SetVariable castedPtr (Bitcast Ptr (VIdent castPtr Ptr) Ptr) + emit $ SetVariable casted (Load (CustomType (coerce consId)) Ptr castedPtr) --- val <- exprToValue exp --- -- enumerateOneM_ --- -- (\i c -> do --- -- case c of --- -- CIdent x -> do --- -- emit . Comment $ "ident " <> show x --- -- emit $ SetVariable x (ExtractValue (CustomType (fst consId)) (VIdent casted Ptr) i) --- -- emit $ Store ty val Ptr stackPtr --- -- CCons x cs -> error "nested constructor" --- -- CLit l -> do --- -- testVar <- getNewVar --- -- emit $ SetVariable testVar (ExtractValue (CustomType (fst consId)) (VIdent casted Ptr) i) --- -- case l of --- -- LInt l -> emit $ Icmp LLEq I64 (VIdent testVar Ptr) (VInteger l) --- -- LChar c -> emit $ Icmp LLEq I8 (VIdent testVar Ptr) (VChar c) --- -- CCatch -> emit . Comment $ "Catch all" --- -- emit . Comment $ "return this " <> toIr val --- -- emit . Comment . show $ c --- -- emit . Comment . show $ i --- -- ) --- -- cs --- -- emit $ Store ty val Ptr stackPtr --- emit $ Br label --- emit $ Label lbl_failPos --- emitCases rt ty label stackPtr vs (Injection (MIR.InitLit i, _) exp) = do --- let i' = case i of --- GA.LInt i -> VInteger i --- GA.LChar i -> VChar i --- ns <- getNewVar --- lbl_failPos <- (\x -> GA.Ident $ "failed_" <> show x) <$> getNewLabel --- lbl_succPos <- (\x -> GA.Ident $ "success_" <> show x) <$> getNewLabel --- emit $ SetVariable ns (Icmp LLEq ty vs i') --- emit $ BrCond (VIdent ns ty) lbl_succPos lbl_failPos --- emit $ Label lbl_succPos --- val <- exprToValue exp --- emit $ Store ty val Ptr stackPtr --- emit $ Br label --- emit $ Label lbl_failPos ----- emitCases rt ty label stackPtr vs (Injection (MIR.CIdent id) exp) = do ----- -- //TODO this is pretty disgusting and would heavily benefit from a rewrite ----- valPtr <- getNewVar ----- emit $ SetVariable valPtr (Alloca rt) ----- emit $ Store rt vs Ptr valPtr ----- emit $ SetVariable id (Load rt Ptr valPtr) ----- increaseVarCount ----- val <- exprToValue (fst exp) ----- emit $ Store ty val Ptr stackPtr ----- emit $ Br label --- emitCases _ ty label stackPtr _ (Injection (MIR.InitCatch, _) exp) = do --- val <- exprToValue exp --- emit $ Store ty val Ptr stackPtr --- emit $ Br label + val <- exprToValue exp + -- enumerateOneM_ + -- (\i c -> do + -- case c of + -- CIdent x -> do + -- emit . Comment $ "ident " <> show x + -- emit $ SetVariable x (ExtractValue (CustomType (fst consId)) (VIdent casted Ptr) i) + -- emit $ Store ty val Ptr stackPtr + -- CCons x cs -> error "nested constructor" + -- CLit l -> do + -- testVar <- getNewVar + -- emit $ SetVariable testVar (ExtractValue (CustomType (fst consId)) (VIdent casted Ptr) i) + -- case l of + -- LInt l -> emit $ Icmp LLEq I64 (VIdent testVar Ptr) (VInteger l) + -- LChar c -> emit $ Icmp LLEq I8 (VIdent testVar Ptr) (VChar c) + -- CCatch -> emit . Comment $ "Catch all" + -- emit . Comment $ "return this " <> toIr val + -- emit . Comment . show $ c + -- emit . Comment . show $ i + -- ) + -- cs + -- emit $ Store ty val Ptr stackPtr + emit $ Br label + emit $ Label lbl_failPos + emitCases rt ty label stackPtr vs (Injection (MIR.InitLit i, _) exp) = do + let i' = case i of + GA.LInt i -> VInteger i + GA.LChar i -> VChar i + ns <- getNewVar + lbl_failPos <- (\x -> GA.Ident $ "failed_" <> show x) <$> getNewLabel + lbl_succPos <- (\x -> GA.Ident $ "success_" <> show x) <$> getNewLabel + emit $ SetVariable ns (Icmp LLEq ty vs i') + emit $ BrCond (VIdent ns ty) lbl_succPos lbl_failPos + emit $ Label lbl_succPos + val <- exprToValue exp + emit $ Store ty val Ptr stackPtr + emit $ Br label + emit $ Label lbl_failPos +-- emitCases rt ty label stackPtr vs (Injection (MIR.CIdent id) exp) = do +-- -- //TODO this is pretty disgusting and would heavily benefit from a rewrite +-- valPtr <- getNewVar +-- emit $ SetVariable valPtr (Alloca rt) +-- emit $ Store rt vs Ptr valPtr +-- emit $ SetVariable id (Load rt Ptr valPtr) +-- increaseVarCount +-- val <- exprToValue (fst exp) +-- emit $ Store ty val Ptr stackPtr +-- emit $ Br label + emitCases _ ty label stackPtr _ (Injection (MIR.InitCatch, _) exp) = do + val <- exprToValue exp + emit $ Store ty val Ptr stackPtr + emit $ Br label -----emitLet :: Bind -> Exp -> CompilerState () --- emitLet xs e = do --- emit $ --- Comment $ --- concat --- [ "ELet (" --- , show xs --- , " = " --- , show e --- , ") is not implemented!" --- ] +--emitLet :: Bind -> Exp -> CompilerState () +emitLet xs e = do + emit $ + Comment $ + concat + [ "ELet (" + , show xs + , " = " + , show e + , ") is not implemented!" + ] emitApp :: MIR.Type -> ExpT -> ExpT -> CompilerState () emitApp t e1 e2 = appEmitter e1 e2 [] @@ -440,60 +444,60 @@ emitApp t e1 e2 = appEmitter e1 e2 [] emit $ SetVariable vs call x -> error $ "The unspeakable happened: " <> show x --- emitIdent :: GA.Ident -> CompilerState () --- emitIdent id = do --- -- !!this should never happen!! --- emit $ Comment "This should not have happened!" --- emit $ Variable id --- emit $ UnsafeRaw "\n" +emitIdent :: GA.Ident -> CompilerState () +emitIdent id = do + -- !!this should never happen!! + emit $ Comment "This should not have happened!" + emit $ Variable id + emit $ UnsafeRaw "\n" --- emitLit :: MIR.Lit -> CompilerState () --- emitLit i = do --- -- !!this should never happen!! --- let (i', t) = case i of --- (MIR.LInt i'') -> (VInteger i'', I64) --- (MIR.LChar i'') -> (VChar i'', I8) --- varCount <- getNewVar --- emit $ Comment "This should not have happened!" --- emit $ SetVariable (GA.Ident (show varCount)) (Add t i' (VInteger 0)) +emitLit :: MIR.Lit -> CompilerState () +emitLit i = do + -- !!this should never happen!! + let (i', t) = case i of + (MIR.LInt i'') -> (VInteger i'', I64) + (MIR.LChar i'') -> (VChar i'', I8) + varCount <- getNewVar + emit $ Comment "This should not have happened!" + emit $ SetVariable (GA.Ident (show varCount)) (Add t i' (VInteger 0)) --- emitAdd :: MIR.Type -> ExpT -> ExpT -> CompilerState () --- emitAdd t e1 e2 = do --- v1 <- exprToValue e1 --- v2 <- exprToValue e2 --- v <- getNewVar --- emit $ SetVariable (GA.Ident $ show v) (Add (type2LlvmType t) v1 v2) +emitAdd :: MIR.Type -> ExpT -> ExpT -> CompilerState () +emitAdd t e1 e2 = do + v1 <- exprToValue e1 + v2 <- exprToValue e2 + v <- getNewVar + emit $ SetVariable (GA.Ident $ show v) (Add (type2LlvmType t) v1 v2) --- emitSub :: MIR.Type -> ExpT -> ExpT -> CompilerState () --- emitSub t e1 e2 = do --- v1 <- exprToValue e1 --- v2 <- exprToValue e2 --- v <- getNewVar --- emit $ SetVariable v (Sub (type2LlvmType t) v1 v2) +emitSub :: MIR.Type -> ExpT -> ExpT -> CompilerState () +emitSub t e1 e2 = do + v1 <- exprToValue e1 + v2 <- exprToValue e2 + v <- getNewVar + emit $ SetVariable v (Sub (type2LlvmType t) v1 v2) --- exprToValue :: ExpT -> CompilerState LLVMValue --- exprToValue = \case --- (MIR.ELit i, t) -> pure $ case i of --- (MIR.LInt i) -> VInteger i --- (MIR.LChar i) -> VChar i --- (MIR.EId name, t) -> do --- funcs <- gets functions --- case Map.lookup (name, t) funcs of --- Just fi -> do --- if numArgs fi == 0 --- then do --- vc <- getNewVar --- emit $ --- SetVariable --- vc --- (Call FastCC (type2LlvmType t) Global name []) --- pure $ VIdent vc (type2LlvmType t) --- else pure $ VFunction name Global (type2LlvmType t) --- Nothing -> pure $ VIdent name (type2LlvmType t) --- e -> do --- compileExp e --- v <- getVarCount --- pure $ VIdent (GA.Ident $ show v) (getType e) +exprToValue :: ExpT -> CompilerState LLVMValue +exprToValue = \case + (MIR.ELit i, t) -> pure $ case i of + (MIR.LInt i) -> VInteger i + (MIR.LChar i) -> VChar i + (MIR.EId name, t) -> do + funcs <- gets functions + case Map.lookup (name, t) funcs of + Just fi -> do + if numArgs fi == 0 + then do + vc <- getNewVar + emit $ + SetVariable + vc + (Call FastCC (type2LlvmType t) Global name []) + pure $ VIdent vc (type2LlvmType t) + else pure $ VFunction name Global (type2LlvmType t) + Nothing -> pure $ VIdent name (type2LlvmType t) + e -> do + compileExp e + v <- getVarCount + pure $ VIdent (GA.Ident $ show v) (getType e) type2LlvmType :: MIR.Type -> LLVMType type2LlvmType (MIR.TLit id@(Ident name)) = case name of @@ -507,26 +511,32 @@ type2LlvmType (MIR.TFun t xs) = do function2LLVMType (TFun t xs) s = function2LLVMType xs (type2LlvmType t : s) function2LLVMType x s = (type2LlvmType x, s) --- getType :: ExpT -> LLVMType --- getType (_, t) = type2LlvmType t +getType :: ExpT -> LLVMType +getType (_, t) = type2LlvmType t --- valueGetType :: LLVMValue -> LLVMType --- valueGetType (VInteger _) = I64 --- valueGetType (VChar _) = I8 --- valueGetType (VIdent _ t) = t --- valueGetType (VConstant s) = Array (fromIntegral $ length s) I8 --- valueGetType (VFunction _ _ t) = t +extractTypeName :: MIR.Type -> Ident +extractTypeName (MIR.TLit id) = id +extractTypeName (MIR.TFun t xs) = let (Ident i) = extractTypeName t + (Ident is) = extractTypeName xs + in Ident $ i <> "_$_" <> is --- typeByteSize :: LLVMType -> Integer --- typeByteSize I1 = 1 --- typeByteSize I8 = 1 --- typeByteSize I32 = 4 --- typeByteSize I64 = 8 --- typeByteSize Ptr = 8 --- typeByteSize (Ref _) = 8 --- typeByteSize (Function _ _) = 8 --- typeByteSize (Array n t) = n * typeByteSize t --- typeByteSize (CustomType _) = 8 +valueGetType :: LLVMValue -> LLVMType +valueGetType (VInteger _) = I64 +valueGetType (VChar _) = I8 +valueGetType (VIdent _ t) = t +valueGetType (VConstant s) = Array (fromIntegral $ length s) I8 +valueGetType (VFunction _ _ t) = t --- enumerateOneM_ :: Monad m => (Integer -> a -> m b) -> [a] -> m () --- enumerateOneM_ f = foldM_ (\i a -> f i a >> pure (i + 1)) 1 +typeByteSize :: LLVMType -> Integer +typeByteSize I1 = 1 +typeByteSize I8 = 1 +typeByteSize I32 = 4 +typeByteSize I64 = 8 +typeByteSize Ptr = 8 +typeByteSize (Ref _) = 8 +typeByteSize (Function _ _) = 8 +typeByteSize (Array n t) = n * typeByteSize t +typeByteSize (CustomType _) = 8 + +enumerateOneM_ :: Monad m => (Integer -> a -> m b) -> [a] -> m () +enumerateOneM_ f = foldM_ (\i a -> f i a >> pure (i + 1)) 1 diff --git a/src/Monomorphizer/Monomorphizer.hs b/src/Monomorphizer/Monomorphizer.hs index 104c318..a4b92e1 100644 --- a/src/Monomorphizer/Monomorphizer.hs +++ b/src/Monomorphizer/Monomorphizer.hs @@ -2,13 +2,13 @@ module Monomorphizer.Monomorphizer (monomorphize) where -import Data.Coerce (coerce) -import Grammar.Abs (Constructor (..), Ident (..)) -import Unsafe.Coerce (unsafeCoerce) +import Data.Coerce (coerce) +import Grammar.Abs (Constructor (..), Ident (..)) +import Unsafe.Coerce (unsafeCoerce) -import Grammar.Abs qualified as GA -import Monomorphizer.MonomorphizerIr qualified as M -import TypeChecker.TypeCheckerIr qualified as T +import qualified Grammar.Abs as GA +import qualified Monomorphizer.MonomorphizerIr as M +import qualified TypeChecker.TypeCheckerIr as T monomorphize :: T.Program -> M.Program monomorphize (T.Program ds) = M.Program $ monoDefs ds @@ -18,7 +18,7 @@ monoDefs = map monoDef monoDef :: T.Def -> M.Def monoDef (T.DBind bind) = M.DBind $ monoBind bind -monoDef (T.DData d) = M.DData $ unsafeCoerce d +monoDef (T.DData d) = M.DData $ unsafeCoerce d monoBind :: T.Bind -> M.Bind monoBind (T.Bind name args (e, t)) = M.Bind (monoId name) (map monoId args) (monoExpr e, monoType t) @@ -34,19 +34,19 @@ monoExpr = \case T.ECase expt injs -> M.ECase (monoexpt expt) (monoInjs injs) monoAbsType :: GA.Type -> M.Type -monoAbsType (GA.TLit u) = M.TLit (coerce u) -monoAbsType (GA.TVar _v) = error "NOT POLYMORHPIC TYPES" +monoAbsType (GA.TLit u) = M.TLit (coerce u) +monoAbsType (GA.TVar _v) = error "NOT POLYMORHPIC TYPES" monoAbsType (GA.TAll _v _t) = error "NOT ALL TYPES" -monoAbsType (GA.TData _ i) = error "NOT INDEXED TYPES" -monoAbsType (GA.TEVar _v) = error "I DONT KNOW WHAT THIS IS" +monoAbsType (GA.TEVar _v) = error "I DONT KNOW WHAT THIS IS" monoAbsType (GA.TFun t1 t2) = M.TFun (monoAbsType t1) (monoAbsType t2) +monoAbsType (GA.TIndexed _) = error "NOT INDEXED TYPES" monoType :: T.Type -> M.Type -monoType (T.TAll _ t) = monoType t +monoType (T.TAll _ t) = monoType t monoType (T.TVar (T.MkTVar i)) = error "NOT POLYMORPHIC TYPES" -monoType (T.TLit i) = M.TLit i -monoType (T.TFun t1 t2) = M.TFun (monoType t1) (monoType t2) -monoType (T.TData _ _) = error "Not sure what this is" +monoType (T.TLit i) = M.TLit i +monoType (T.TFun t1 t2) = M.TFun (monoType t1) (monoType t2) +monoType (T.TData _ _) = error "Not sure what this is" monoexpt :: T.ExpT -> M.ExpT monoexpt (e, t) = (monoExpr e, monoType t) @@ -55,7 +55,7 @@ monoId :: T.Id -> M.Id monoId (n, t) = (n, monoType t) monoLit :: T.Lit -> M.Lit -monoLit (T.LInt i) = M.LInt i +monoLit (T.LInt i) = M.LInt i monoLit (T.LChar c) = M.LChar c monoInjs :: [T.Inj] -> [M.Injection] diff --git a/src/Monomorphizer/MonomorphizerIr.hs b/src/Monomorphizer/MonomorphizerIr.hs index 07263a1..4d71363 100644 --- a/src/Monomorphizer/MonomorphizerIr.hs +++ b/src/Monomorphizer/MonomorphizerIr.hs @@ -1,8 +1,8 @@ module Monomorphizer.MonomorphizerIr (module Monomorphizer.MonomorphizerIr, module RE, module GA) where -import Grammar.Abs (Ident (..), Init (..), UIdent) -import Grammar.Abs qualified as GA (Ident (..), Init (..)) -import TypeChecker.TypeCheckerIr qualified as RE +import Grammar.Abs (Ident (..), Init (..), UIdent) +import qualified Grammar.Abs as GA (Ident (..), Init (..)) +import qualified TypeChecker.TypeCheckerIr as RE type Id = (Ident, Type) @@ -12,7 +12,7 @@ newtype Program = Program [Def] data Def = DBind Bind | DData Data deriving (Show, Ord, Eq) -data Data = Data Type Constructor +data Data = Data Type [Constructor] deriving (Show, Ord, Eq) data Bind = Bind Id [Id] ExpT @@ -45,4 +45,4 @@ data Type = TLit Ident | TFun Type Type flattenType :: Type -> [Type] flattenType (TFun t1 t2) = t1 : flattenType t2 -flattenType x = [x] +flattenType x = [x] From 38680a4dcbd6e183e8357193c6b83fec0bfadf6d Mon Sep 17 00:00:00 2001 From: sebastianselander Date: Fri, 24 Mar 2023 16:10:25 +0100 Subject: [PATCH 132/372] adapted new tree to fuck with samuel --- Grammar.cf | 18 +++++---- src/TypeChecker/TypeCheckerIr.hs | 67 +++++++++++++++++++++++--------- 2 files changed, 59 insertions(+), 26 deletions(-) diff --git a/Grammar.cf b/Grammar.cf index 540052f..b0a7a4c 100644 --- a/Grammar.cf +++ b/Grammar.cf @@ -45,30 +45,31 @@ Data. Data ::= "data" Type "where" "{" [Constructor] "}" ; EAnn. Exp5 ::= "(" Exp ":" Type ")" ; EVar. Exp4 ::= LIdent ; -ECons. Exp4 ::= UIdent ; +EInj. Exp4 ::= UIdent ; ELit. Exp4 ::= Lit ; EApp. Exp3 ::= Exp3 Exp4 ; EAdd. Exp1 ::= Exp1 "+" Exp2 ; ELet. Exp ::= "let" Bind "in" Exp ; EAbs. Exp ::= "\\" LIdent "." Exp ; -ECase. Exp ::= "case" Exp "of" "{" [Inj] "}"; +ECase. Exp ::= "case" Exp "of" "{" [Branch] "}"; ------------------------------------------------------------------------------- -- * LITERALS ------------------------------------------------------------------------------- -LInt. Lit ::= Integer ; +LInt. Lit ::= Integer ; LChar. Lit ::= Char ; ------------------------------------------------------------------------------- -- * CASE ------------------------------------------------------------------------------- -Inj. Inj ::= Init "=>" Exp ; +Branch. Branch ::= Pattern "=>" Exp ; -InitLit. Init ::= Lit ; -InitConstructor. Init ::= UIdent [LIdent] ; -InitCatch. Init ::= "_" ; +PVar. Pattern ::= LIdent ; +PLit. Pattern ::= Lit ; +PInj. Pattern ::= UIdent [Pattern] ; +PCatch. Pattern ::= "_" ; ------------------------------------------------------------------------------- -- * AUX @@ -77,7 +78,8 @@ InitCatch. Init ::= "_" ; separator Def ";" ; separator nonempty Constructor "" ; separator Type " " ; -separator nonempty Inj ";" ; +separator Pattern " " ; +separator Branch "," ; separator Ident " "; separator LIdent " "; separator TVar " " ; diff --git a/src/TypeChecker/TypeCheckerIr.hs b/src/TypeChecker/TypeCheckerIr.hs index ceac8e9..09efb8b 100644 --- a/src/TypeChecker/TypeCheckerIr.hs +++ b/src/TypeChecker/TypeCheckerIr.hs @@ -2,7 +2,6 @@ module TypeChecker.TypeCheckerIr ( module TypeChecker.TypeCheckerIr, - module GA, ) where import Control.Monad.Except @@ -10,18 +9,7 @@ import Control.Monad.Reader import Control.Monad.State import Data.Functor.Identity (Identity) import Data.Map (Map) -import Grammar.Abs ( - Data (..), - Ident (..), - Init (..), - Lit (..), - ) -import Grammar.Abs qualified as GA ( - Data (..), - Ident (..), - Init (..), - Lit (..), - ) +import Data.String qualified import Grammar.Print import Prelude import Prelude qualified as C (Eq, Ord, Read, Show) @@ -44,6 +32,12 @@ type Infer = StateT Env (ReaderT Ctx (ExceptT Error Identity)) newtype Program = Program [Def] deriving (C.Eq, C.Ord, C.Show, C.Read) +data Data = Data Ident [Constructor] + deriving (Show, Eq, Ord, Read) + +data Constructor = Constructor Ident Type + deriving (Show, Eq, Ord, Read) + newtype TVar = MkTVar Ident deriving (Show, Eq, Ord, Read) @@ -62,26 +56,51 @@ data Exp | EApp ExpT ExpT | EAdd ExpT ExpT | EAbs Ident ExpT - | ECase ExpT [Inj] + | ECase ExpT [Branch] deriving (C.Eq, C.Ord, C.Read, C.Show) type ExpT = (Exp, Type) -data Inj = Inj (Init, Type) ExpT +data Branch = Branch (Pattern, Type) ExpT deriving (C.Eq, C.Ord, C.Read, C.Show) +data Pattern = PVar Id | PLit (Lit, Type) | PInj Ident [Pattern] | PCatch + deriving (C.Eq, C.Ord, C.Show, C.Read) + data Def = DBind Bind | DData Data deriving (C.Eq, C.Ord, C.Read, C.Show) type Id = (Ident, Type) +newtype Ident = Ident String + deriving (C.Eq, C.Ord, C.Show, C.Read, Data.String.IsString) + +data Lit = LInt Integer | LChar Char + deriving (Show, Eq, Ord, Read) + data Bind = Bind Id [Id] ExpT deriving (C.Eq, C.Ord, C.Show, C.Read) +instance Print Ident where + prt _ (Ident str) = prt 0 str + instance Print [Def] where prt _ [] = concatD [] prt _ (x : xs) = concatD [prt 0 x, doc (showString "\n\n"), prt 0 xs] +instance Print Data where + prt i = \case + Data type_ constructors -> prPrec i 0 (concatD [doc (showString "data"), prt 0 type_, doc (showString "where"), doc (showString "{"), prt 0 constructors, doc (showString "}")]) + +instance Print Constructor where + prt i = \case + Constructor uident type_ -> prPrec i 0 (concatD [prt 0 uident, doc (showString ":"), prt 0 type_]) + +instance Print [Constructor] where + prt _ [] = concatD [] + prt _ [x] = concatD [prt 0 x] + prt _ (x : xs) = concatD [prt 0 x, prt 0 xs] + instance Print Def where prt i (DBind bind) = prt i bind prt i (DData d) = prt i d @@ -185,11 +204,18 @@ instance Print Exp where instance Print ExpT where prt i (e, t) = concatD [doc $ showString "(", prt i e, doc (showString ":"), prt i t, doc $ showString ")"] -instance Print Inj where +instance Print Branch where prt i = \case - Inj (init, t) exp -> prPrec i 0 (concatD [prt 0 init, doc (showString ":"), prt 0 t, doc (showString "=>"), prt 0 exp]) + Branch (init, t) exp -> prPrec i 0 (concatD [prt 0 init, doc (showString ":"), prt 0 t, doc (showString "=>"), prt 0 exp]) -instance Print [Inj] where +instance Print Pattern where + prt i = \case + PVar lident -> prPrec i 0 (concatD [prtId 0 lident]) + PLit (lit, typ) -> prPrec i 0 (concatD [doc $ showString "(", prt 0 lit, doc $ showString ",", prt 0 typ, doc $ showString ")"]) + PInj uident patterns -> prPrec i 0 (concatD [prt 0 uident, prt 0 patterns]) + PCatch -> prPrec i 0 (concatD [doc (showString "_")]) + +instance Print [Branch] where prt _ [] = concatD [] prt _ [x] = concatD [prt 0 x] prt _ (x : xs) = concatD [prt 0 x, doc (showString ";"), prt 0 xs] @@ -204,3 +230,8 @@ instance Print Type where TAll tvar type_ -> prPrec i 1 (concatD [doc (showString "forall"), prt 0 tvar, doc (showString "."), prt 0 type_]) TData ident types -> prPrec i 1 (concatD [prt 0 ident, prt 0 types]) TFun type_1 type_2 -> prPrec i 0 (concatD [prt 1 type_1, doc (showString "->"), prt 0 type_2]) + +instance Print Lit where + prt i = \case + LInt n -> prPrec i 0 (concatD [prt 0 n]) + LChar c -> prPrec i 0 (concatD [prt 0 c]) From 481667f2d8a04d72e1cb955da358972d5d60e9a6 Mon Sep 17 00:00:00 2001 From: sebastianselander Date: Fri, 24 Mar 2023 16:10:46 +0100 Subject: [PATCH 133/372] added tc as well --- src/TypeChecker/TypeChecker.hs | 110 ++++++++++++++++++--------------- 1 file changed, 59 insertions(+), 51 deletions(-) diff --git a/src/TypeChecker/TypeChecker.hs b/src/TypeChecker/TypeChecker.hs index 2a19b6e..5b22999 100644 --- a/src/TypeChecker/TypeChecker.hs +++ b/src/TypeChecker/TypeChecker.hs @@ -4,6 +4,7 @@ -- | A module for type checking and inference using algorithm W, Hindley-Milner module TypeChecker.TypeChecker where +import Auxiliary import Control.Monad.Except import Control.Monad.Reader import Control.Monad.State @@ -113,7 +114,7 @@ checkPrg (Program bs) = do (DBind b) -> do b' <- checkBind b fmap (T.DBind b' :) (checkDef xs) - (DData d) -> fmap (T.DData d :) (checkDef xs) + (DData d) -> fmap (T.DData (toNew d) :) (checkDef xs) (DSig _) -> checkDef xs checkBind :: Bind -> Infer T.Bind @@ -136,7 +137,7 @@ checkBind (Bind name args e) = do insertSig (coerce name) (Just lambdaT) return (T.Bind (coerce name, lambdaT) (map coerce args) e) -- (apply s e) -- where - -- getFunctionTypes :: Map Ident (Maybe T.Type) -> T.ExpT -> [(Ident, T.Type)] + -- getFunctionTypes :: Map T.Ident (Maybe T.Type) -> T.ExpT -> [(T.Ident, T.Type)] -- getFunctionTypes s = \case -- (T.EId b, t) -> case M.lookup b s of -- Just Nothing -> return (b, t) @@ -184,12 +185,25 @@ instance NewType Type T.Type where TData i ts -> T.TData (coerce i) (map toNew ts) TEVar _ -> error "Should not exist after typechecker" --- instance NewType Indexed T.TData where --- toNew (Indexed name vars) = T.TData (coerce name) (map toNew vars) +instance NewType Lit T.Lit where + toNew (LInt i) = T.LInt i + toNew (LChar i) = T.LChar i + +instance NewType Data T.Data where + toNew (Data t xs) = T.Data (name $ retType t) (toNew xs) + where + name (TData n _) = coerce n + name _ = error "Bug in toNew Data -> T.Data" + +instance NewType Constructor T.Constructor where + toNew (Constructor name xs) = T.Constructor (coerce name) (toNew xs) instance NewType TVar T.TVar where toNew (MkTVar i) = T.MkTVar $ coerce i +instance NewType a b => NewType [a] [b] where + toNew = map toNew + algoW :: Exp -> Infer (Subst, T.ExpT) algoW = \case -- \| TODO: More testing need to be done. Unsure of the correctness of this @@ -213,7 +227,7 @@ algoW = \case -- \| ------------------ -- \| Γ ⊢ i : Int, ∅ - ELit lit -> return (nullSubst, (T.ELit lit, litType lit)) + ELit lit -> return (nullSubst, (T.ELit $ toNew lit, litType lit)) -- \| x : σ ∈ Γ   τ = inst(σ) -- \| ---------------------- -- \| Γ ⊢ x : τ, ∅ @@ -228,7 +242,7 @@ algoW = \case Just Nothing -> (\x -> (nullSubst, (T.EId $ coerce i, x))) <$> fresh Nothing -> throwError $ "Unbound variable: " <> printTree i - ECons i -> do + EInj i -> do constr <- gets constructors case M.lookup (coerce i) constr of Just t -> return (nullSubst, (T.EId $ coerce i, t)) @@ -311,7 +325,7 @@ algoW = \case let t' = apply comp ret_t return (comp, (T.ECase (e', t) injs, t')) -makeLambda :: Exp -> [Ident] -> Exp +makeLambda :: Exp -> [T.Ident] -> Exp makeLambda = foldl (flip (EAbs . coerce)) -- | Unify two types producing a new substitution @@ -364,7 +378,7 @@ unify t0 t1 = do I.E. { a = a -> b } is an unsolvable constraint since there is no substitution where these are equal -} -occurs :: Ident -> T.Type -> Infer Subst +occurs :: T.Ident -> T.Type -> Infer Subst occurs i t@(T.TVar _) = return (M.singleton i t) occurs i t = if S.member i (free t) @@ -379,12 +393,12 @@ occurs i t = else return $ M.singleton i t -- | Generalize a type over all free variables in the substitution set -generalize :: Map Ident T.Type -> T.Type -> T.Type +generalize :: Map T.Ident T.Type -> T.Type -> T.Type generalize env t = go freeVars $ removeForalls t where - freeVars :: [Ident] + freeVars :: [T.Ident] freeVars = S.toList $ free t S.\\ free env - go :: [Ident] -> T.Type -> T.Type + go :: [T.Ident] -> T.Type -> T.Type go [] t = t go (x : xs) t = T.TAll (T.MkTVar x) (go xs t) removeForalls :: T.Type -> T.Type @@ -414,13 +428,13 @@ compose m1 m2 = M.map (apply m1) m2 `M.union` m1 -- | A class representing free variables functions class FreeVars t where -- | Get all free variables from t - free :: t -> Set Ident + free :: t -> Set T.Ident -- | Apply a substitution to t apply :: Subst -> t -> t instance FreeVars T.Type where - free :: T.Type -> Set Ident + free :: T.Type -> Set T.Ident free (T.TVar (T.MkTVar a)) = S.singleton a free (T.TAll (T.MkTVar bound) t) = S.singleton bound `S.intersection` free t free (T.TLit _) = mempty @@ -442,14 +456,14 @@ instance FreeVars T.Type where T.TFun a b -> T.TFun (apply sub a) (apply sub b) T.TData name a -> T.TData name (map (apply sub) a) -instance FreeVars (Map Ident T.Type) where - free :: Map Ident T.Type -> Set Ident +instance FreeVars (Map T.Ident T.Type) where + free :: Map T.Ident T.Type -> Set T.Ident free m = foldl' S.union S.empty (map free $ M.elems m) - apply :: Subst -> Map Ident T.Type -> Map Ident T.Type + apply :: Subst -> Map T.Ident T.Type -> Map T.Ident T.Type apply s = M.map (apply s) instance FreeVars T.ExpT where - free :: T.ExpT -> Set Ident + free :: T.ExpT -> Set T.Ident free = error "free not implemented for T.Exp" apply :: Subst -> T.ExpT -> T.ExpT apply s = \case @@ -466,14 +480,14 @@ instance FreeVars T.ExpT where (T.EAbs ident e, t1) -> (T.EAbs ident (apply s e), apply s t1) (T.ECase e injs, t) -> (T.ECase (apply s e) (apply s injs), apply s t) -instance FreeVars T.Inj where - free :: T.Inj -> Set Ident +instance FreeVars T.Branch where + free :: T.Branch -> Set T.Ident free = undefined - apply :: Subst -> T.Inj -> T.Inj - apply s (T.Inj (i, t) e) = T.Inj (i, apply s t) (apply s e) + apply :: Subst -> T.Branch -> T.Branch + apply s (T.Branch (i, t) e) = T.Branch (i, apply s t) (apply s e) -instance FreeVars [T.Inj] where - free :: [T.Inj] -> Set Ident +instance FreeVars [T.Branch] where + free :: [T.Branch] -> Set T.Ident free = foldl' (\acc x -> free x `S.union` acc) mempty apply s = map (apply s) @@ -490,31 +504,31 @@ fresh :: Infer T.Type fresh = do n <- gets count modify (\st -> st{count = n + 1}) - return . T.TVar . T.MkTVar . Ident $ show n + return . T.TVar . T.MkTVar . T.Ident $ show n -- | Run the monadic action with an additional binding -withBinding :: (Monad m, MonadReader Ctx m) => Ident -> T.Type -> m a -> m a +withBinding :: (Monad m, MonadReader Ctx m) => T.Ident -> T.Type -> m a -> m a withBinding i p = local (\st -> st{vars = M.insert i p (vars st)}) -- | Run the monadic action with several additional bindings -withBindings :: (Monad m, MonadReader Ctx m) => [(Ident, T.Type)] -> m a -> m a +withBindings :: (Monad m, MonadReader Ctx m) => [(T.Ident, T.Type)] -> m a -> m a withBindings xs = local (\st -> st{vars = foldl' (flip (uncurry M.insert)) (vars st) xs}) -- | Insert a function signature into the environment -insertSig :: Ident -> Maybe T.Type -> Infer () +insertSig :: T.Ident -> Maybe T.Type -> Infer () insertSig i t = modify (\st -> st{sigs = M.insert i t (sigs st)}) -- | Insert a constructor with its data type -insertConstr :: Ident -> T.Type -> Infer () +insertConstr :: T.Ident -> T.Type -> Infer () insertConstr i t = modify (\st -> st{constructors = M.insert i t (constructors st)}) -------- PATTERN MATCHING --------- -checkCase :: T.Type -> [Inj] -> Infer (Subst, [T.Inj], T.Type) +checkCase :: T.Type -> [Branch] -> Infer (Subst, [T.Branch], T.Type) checkCase expT injs = do - (injTs, injs, returns) <- unzip3 <$> mapM checkInj injs + (injTs, injs, returns) <- unzip3 <$> mapM checkBranch injs (sub1, _) <- foldM ( \(sub, acc) x -> @@ -534,29 +548,23 @@ checkCase expT injs = do {- | fst = type of init | snd = type of expr -} -checkInj :: Inj -> Infer (T.Type, T.Inj, T.Type) -checkInj (Inj it expr) = do - (initT, vars) <- inferInit it +inferBranch :: Branch -> Infer (T.Type, T.Branch, T.Type) +inferBranch (Branch it expr) = do + (initT, vars) <- inferPattern it (e, exprT) <- withBindings vars (inferExp expr) - return (initT, T.Inj (it, initT) (e, exprT), exprT) + return (initT, T.Branch (it, initT) (e, exprT), exprT) -inferInit :: Init -> Infer (T.Type, [T.Id]) -inferInit = \case - InitLit lit -> return (litType lit, mempty) - InitConstructor fn vars -> do - gets (M.lookup (coerce fn) . constructors) >>= \case - Nothing -> - throwError $ - "Constructor: " <> printTree fn <> " does not exist" - Just a -> do - case unsnoc $ flattenType a of - Nothing -> throwError "Partial pattern match not allowed" - Just (vs, ret) -> - case length vars `compare` length vs of - EQ -> do - return (ret, zip (coerce vars) vs) - _ -> throwError "Partial pattern match not allowed" - InitCatch -> (,mempty) <$> fresh +inferPattern :: Pattern -> Infer (T.Pattern, T.Type) +inferPattern = \case + PLit lit -> return (T.PLit $ toNew lit, litType lit) + PInj constr patterns -> do + t <- gets (M.lookup (coerce constr) . constructors) + t <- maybeToRightM ("Constructor: " <> printTree constr <> " does not exist") t + (vs, ret) <- maybeToRightM (throwError "Partial pattern match not allowed") (unsnoc $ flattenType t) + patterns <- mapM inferPattern patterns + undefined + PCatch -> (T.PCatch,) <$> fresh + PVar x -> undefined flattenType :: T.Type -> [T.Type] flattenType (T.TFun a b) = flattenType a <> flattenType b From f404acdbad76762ee101f5dfd0ef33e7ecf1556f Mon Sep 17 00:00:00 2001 From: Samuel Hammersberg Date: Fri, 24 Mar 2023 17:00:31 +0100 Subject: [PATCH 134/372] Updated some more changes. --- src/Codegen/Codegen.hs | 14 +++++++------- src/Monomorphizer/Monomorphizer.hs | 19 +++++++++++-------- src/Monomorphizer/MonomorphizerIr.hs | 7 +++++-- 3 files changed, 23 insertions(+), 17 deletions(-) diff --git a/src/Codegen/Codegen.hs b/src/Codegen/Codegen.hs index 4e95102..ec20273 100644 --- a/src/Codegen/Codegen.hs +++ b/src/Codegen/Codegen.hs @@ -317,7 +317,7 @@ compileExp (MIR.ECase e cs,t) = emitECased t e (map (t,) cs) -- go (EMod e1 e2) = emitMod e1 e2 --- aux functions --- -emitECased :: MIR.Type -> ExpT -> [(MIR.Type, Injection)] -> CompilerState () +emitECased :: MIR.Type -> ExpT -> [(MIR.Type, Branch)] -> CompilerState () emitECased t e cases = do let cs = snd <$> cases let ty = type2LlvmType t @@ -332,8 +332,8 @@ emitECased t e cases = do res <- getNewVar emit $ SetVariable res (Load ty Ptr stackPtr) where - emitCases :: LLVMType -> LLVMType -> GA.Ident -> GA.Ident -> LLVMValue -> Injection -> CompilerState () - emitCases rt ty label stackPtr vs (Injection (MIR.InitConstructor consId cs, t) exp) = do + emitCases :: LLVMType -> LLVMType -> GA.Ident -> GA.Ident -> LLVMValue -> Branch -> CompilerState () + emitCases rt ty label stackPtr vs (Branch (MIR.PInj consId cs, t) exp) = do cons <- gets constructors let r = fromJust $ Map.lookup (coerce consId, t) cons @@ -380,10 +380,10 @@ emitECased t e cases = do -- emit $ Store ty val Ptr stackPtr emit $ Br label emit $ Label lbl_failPos - emitCases rt ty label stackPtr vs (Injection (MIR.InitLit i, _) exp) = do + emitCases rt ty label stackPtr vs (Branch (MIR.PLit i, _) exp) = do let i' = case i of - GA.LInt i -> VInteger i - GA.LChar i -> VChar i + (MIR.LInt i, _) -> VInteger i + (MIR.LChar i, _) -> VChar i ns <- getNewVar lbl_failPos <- (\x -> GA.Ident $ "failed_" <> show x) <$> getNewLabel lbl_succPos <- (\x -> GA.Ident $ "success_" <> show x) <$> getNewLabel @@ -404,7 +404,7 @@ emitECased t e cases = do -- val <- exprToValue (fst exp) -- emit $ Store ty val Ptr stackPtr -- emit $ Br label - emitCases _ ty label stackPtr _ (Injection (MIR.InitCatch, _) exp) = do + emitCases _ ty label stackPtr _ (Branch (MIR.PCatch, _) exp) = do val <- exprToValue exp emit $ Store ty val Ptr stackPtr emit $ Br label diff --git a/src/Monomorphizer/Monomorphizer.hs b/src/Monomorphizer/Monomorphizer.hs index a4b92e1..70483ad 100644 --- a/src/Monomorphizer/Monomorphizer.hs +++ b/src/Monomorphizer/Monomorphizer.hs @@ -25,7 +25,7 @@ monoBind (T.Bind name args (e, t)) = M.Bind (monoId name) (map monoId args) (mon monoExpr :: T.Exp -> M.Exp monoExpr = \case - T.EId (Ident i) -> M.EId (Ident i) + T.EId (T.Ident i) -> M.EId (Ident i) T.ELit lit -> M.ELit $ monoLit lit T.ELet bind expt -> M.ELet (monoBind bind) (monoexpt expt) T.EApp expt1 expt2 -> M.EApp (monoexpt expt1) (monoexpt expt2) @@ -44,7 +44,7 @@ monoAbsType (GA.TIndexed _) = error "NOT INDEXED TYPES" monoType :: T.Type -> M.Type monoType (T.TAll _ t) = monoType t monoType (T.TVar (T.MkTVar i)) = error "NOT POLYMORPHIC TYPES" -monoType (T.TLit i) = M.TLit i +monoType (T.TLit (T.Ident i)) = M.TLit (Ident i) monoType (T.TFun t1 t2) = M.TFun (monoType t1) (monoType t2) monoType (T.TData _ _) = error "Not sure what this is" @@ -52,17 +52,20 @@ monoexpt :: T.ExpT -> M.ExpT monoexpt (e, t) = (monoExpr e, monoType t) monoId :: T.Id -> M.Id -monoId (n, t) = (n, monoType t) +monoId (n, t) = (coerce n, monoType t) monoLit :: T.Lit -> M.Lit monoLit (T.LInt i) = M.LInt i monoLit (T.LChar c) = M.LChar c -monoInjs :: [T.Inj] -> [M.Injection] +monoInjs :: [T.Branch] -> [M.Branch] monoInjs = map monoInj -monoInj :: T.Inj -> M.Injection -monoInj (T.Inj (init, t) expt) = M.Injection (monoInit init, monoType t) (monoexpt expt) +monoInj :: T.Branch -> M.Branch +monoInj (T.Branch (init, t) expt) = M.Branch (monoInit init, monoType t) (monoexpt expt) -monoInit :: T.Init -> M.Init -monoInit = id +monoInit :: T.Pattern -> M.Pattern +monoInit (T.PVar (id, t)) = M.PVar (coerce id, monoType t) +monoInit (T.PLit (lit, t)) = M.PLit (monoLit lit, monoType t) +monoInit (T.PInj id ps) = M.PInj (coerce id) (monoInit <$> ps) +monoInit T.PCatch = M.PCatch diff --git a/src/Monomorphizer/MonomorphizerIr.hs b/src/Monomorphizer/MonomorphizerIr.hs index 4d71363..e4c4bad 100644 --- a/src/Monomorphizer/MonomorphizerIr.hs +++ b/src/Monomorphizer/MonomorphizerIr.hs @@ -24,10 +24,13 @@ data Exp | ELet Bind ExpT | EApp ExpT ExpT | EAdd ExpT ExpT - | ECase ExpT [Injection] + | ECase ExpT [Branch] deriving (Show, Ord, Eq) -data Injection = Injection (Init, Type) ExpT +data Pattern = PVar Id | PLit (Lit, Type) | PInj Ident [Pattern] | PCatch + deriving (Eq, Ord, Show) + +data Branch = Branch (Pattern, Type) ExpT deriving (Eq, Ord, Show) type ExpT = (Exp, Type) From 3c2cb1a713a023d90a15161b63392ac73f775357 Mon Sep 17 00:00:00 2001 From: sebastianselander Date: Fri, 24 Mar 2023 17:06:32 +0100 Subject: [PATCH 135/372] new good version works --- Grammar.cf | 12 +++++------ src/Main.hs | 3 ++- src/Renamer/Renamer.hs | 37 +++++++++++++++++++++------------- src/TypeChecker/TypeChecker.hs | 31 +++++++++++++++++++--------- test_program | 21 +++++++++---------- tests/Tests.hs | 2 +- 6 files changed, 63 insertions(+), 43 deletions(-) diff --git a/Grammar.cf b/Grammar.cf index b0a7a4c..51ff54b 100644 --- a/Grammar.cf +++ b/Grammar.cf @@ -43,11 +43,11 @@ Data. Data ::= "data" Type "where" "{" [Constructor] "}" ; -- * EXPRESSIONS ------------------------------------------------------------------------------- -EAnn. Exp5 ::= "(" Exp ":" Type ")" ; -EVar. Exp4 ::= LIdent ; -EInj. Exp4 ::= UIdent ; -ELit. Exp4 ::= Lit ; -EApp. Exp3 ::= Exp3 Exp4 ; +EAnn. Exp4 ::= "(" Exp ":" Type ")" ; +EVar. Exp3 ::= LIdent ; +EInj. Exp3 ::= UIdent ; +ELit. Exp3 ::= Lit ; +EApp. Exp2 ::= Exp2 Exp3 ; EAdd. Exp1 ::= Exp1 "+" Exp2 ; ELet. Exp ::= "let" Bind "in" Exp ; EAbs. Exp ::= "\\" LIdent "." Exp ; @@ -84,7 +84,7 @@ separator Ident " "; separator LIdent " "; separator TVar " " ; -coercions Exp 5 ; +coercions Exp 4 ; coercions Type 2 ; token UIdent (upper (letter | digit | '_')*) ; diff --git a/src/Main.hs b/src/Main.hs index d8ecdd6..7ae149b 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -7,7 +7,8 @@ import GHC.IO.Handle.Text (hPutStrLn) import Grammar.ErrM (Err) import Grammar.Par (myLexer, pProgram) import Grammar.Print (printTree) -import Monomorphizer.Monomorphizer (monomorphize) + +-- import Monomorphizer.Monomorphizer (monomorphize) import Control.Monad (when) import Data.List.Extra (isSuffixOf) diff --git a/src/Renamer/Renamer.hs b/src/Renamer/Renamer.hs index c550a92..5576793 100644 --- a/src/Renamer/Renamer.hs +++ b/src/Renamer/Renamer.hs @@ -2,11 +2,15 @@ {-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternSynonyms #-} +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} + +{-# HLINT ignore "Use mapAndUnzipM" #-} module Renamer.Renamer (rename) where import Auxiliary (mapAccumM) import Control.Applicative (Applicative (liftA2)) +import Control.Monad (foldM) import Control.Monad.Except (ExceptT, MonadError, runExceptT, throwError) import Control.Monad.Identity (Identity, runIdentity) import Control.Monad.State ( @@ -102,7 +106,7 @@ type Names = Map LIdent LIdent renameExp :: Names -> Exp -> Rn (Names, Exp) renameExp old_names = \case EVar n -> pure (coerce old_names, EVar . fromMaybe n $ Map.lookup n old_names) - ECons n -> pure (old_names, ECons n) + EInj n -> pure (old_names, EInj n) ELit lit -> pure (old_names, ELit lit) EApp e1 e2 -> do (env1, e1') <- renameExp old_names e1 @@ -128,27 +132,32 @@ renameExp old_names = \case pure (new_names, EAnn e' t') ECase e injs -> do (new_names, e') <- renameExp old_names e - (new_names', injs') <- renameInjs new_names injs + (new_names', injs') <- renameBranches new_names injs pure (new_names', ECase e' injs') -renameInjs :: Names -> [Inj] -> Rn (Names, [Inj]) -renameInjs ns xs = do - (new_names, xs') <- unzip <$> mapM (renameInj ns) xs +renameBranches :: Names -> [Branch] -> Rn (Names, [Branch]) +renameBranches ns xs = do + (new_names, xs') <- unzip <$> mapM (renameBranch ns) xs if null new_names then return (mempty, xs') else return (head new_names, xs') -renameInj :: Names -> Inj -> Rn (Names, Inj) -renameInj ns (Inj init e) = do - (new_names, init') <- renameInit ns init +renameBranch :: Names -> Branch -> Rn (Names, Branch) +renameBranch ns (Branch init e) = do + (new_names, init') <- renamePattern ns init (new_names', e') <- renameExp new_names e - return (new_names', Inj init' e') + return (new_names', Branch init' e') -renameInit :: Names -> Init -> Rn (Names, Init) -renameInit ns i = case i of - InitConstructor cs vars -> do - (ns_new, vars') <- newNames ns (coerce vars) - return (ns_new, InitConstructor cs (coerce vars')) +renamePattern :: Names -> Pattern -> Rn (Names, Pattern) +renamePattern ns i = case i of + PInj cs ps -> do + (ns_new, ps) <- renamePatterns ns ps + return (ns_new, PInj cs ps) rest -> return (ns, rest) +renamePatterns :: Names -> [Pattern] -> Rn (Names, [Pattern]) +renamePatterns ns xs = do + (new_names, xs') <- unzip <$> mapM (renamePattern ns) xs + if null new_names then return (mempty, xs') else return (head new_names, xs') + renameTVars :: Type -> Rn Type renameTVars typ = case typ of TAll tvar t -> do diff --git a/src/TypeChecker/TypeChecker.hs b/src/TypeChecker/TypeChecker.hs index 5b22999..e10023c 100644 --- a/src/TypeChecker/TypeChecker.hs +++ b/src/TypeChecker/TypeChecker.hs @@ -528,7 +528,7 @@ insertConstr i t = checkCase :: T.Type -> [Branch] -> Infer (Subst, [T.Branch], T.Type) checkCase expT injs = do - (injTs, injs, returns) <- unzip3 <$> mapM checkBranch injs + (injTs, injs, returns) <- unzip3 <$> mapM inferBranch injs (sub1, _) <- foldM ( \(sub, acc) x -> @@ -549,22 +549,35 @@ checkCase expT injs = do | snd = type of expr -} inferBranch :: Branch -> Infer (T.Type, T.Branch, T.Type) -inferBranch (Branch it expr) = do - (initT, vars) <- inferPattern it - (e, exprT) <- withBindings vars (inferExp expr) - return (initT, T.Branch (it, initT) (e, exprT), exprT) +inferBranch (Branch pat expr) = do + newPat@(pat, branchT) <- inferPattern pat + newExp@(_, exprT) <- withPattern pat (inferExp expr) + return (branchT, T.Branch newPat newExp, exprT) + +-- return (initT, T.Branch (it, initT) (e, exprT), exprT) + +withPattern :: T.Pattern -> Infer a -> Infer a +withPattern p ma = case p of + T.PVar (x, t) -> withBinding x t ma + T.PInj _ ps -> foldl' (flip withPattern) ma ps + T.PLit _ -> ma + T.PCatch -> ma inferPattern :: Pattern -> Infer (T.Pattern, T.Type) inferPattern = \case - PLit lit -> return (T.PLit $ toNew lit, litType lit) + PLit lit -> let lt = litType lit in return (T.PLit (toNew lit, lt), lt) PInj constr patterns -> do t <- gets (M.lookup (coerce constr) . constructors) t <- maybeToRightM ("Constructor: " <> printTree constr <> " does not exist") t - (vs, ret) <- maybeToRightM (throwError "Partial pattern match not allowed") (unsnoc $ flattenType t) + (vs, ret) <- maybeToRightM "Partial pattern match not allowed" (unsnoc $ flattenType t) patterns <- mapM inferPattern patterns - undefined + zipWithM_ unify vs (map snd patterns) + return (T.PInj (coerce constr) (map fst patterns), ret) PCatch -> (T.PCatch,) <$> fresh - PVar x -> undefined + PVar x -> do + fr <- fresh + let pvar = T.PVar (coerce x, fr) + return (pvar, fr) flattenType :: T.Type -> [T.Type] flattenType (T.TFun a b) = flattenType a <> flattenType b diff --git a/test_program b/test_program index 28cd227..0543b88 100644 --- a/test_program +++ b/test_program @@ -12,7 +12,7 @@ hello_world = Cons 'h' (Cons 'e' (Cons 'l' (Cons 'l' (Cons 'o' (Cons ' ' (Cons ' length : List (a) -> Int ; length xs = case xs of { - Nil => 0 ; + Nil => 0, Cons x xs => length xs }; @@ -21,24 +21,21 @@ head xs = case xs of { Cons x xs => x }; -firstIsOne : List (Int) -> Bool () ; firstIsOne : List (Int) -> Bool () ; firstIsOne xs = case xs of { Cons x xs => case x of { - 1 => True ; + 0 => True , _ => case xs of { - Cons x xs => False ; + Cons x xs => False , _ => False } - }; + }, _ => False }; -firstIsOne :: [Int] -> Bool -firstIsOne xs = case xs of - (1 : xs) -> True - _ -> False +main = firstIsOne (Cons 1 Nil); -main = firstIsOne (Cons 'a' Nil) - -data a -> b where +deepPat xs = case xs of { + Cons 1 _ => True , + _ => False + } diff --git a/tests/Tests.hs b/tests/Tests.hs index 9c5649f..bba6216 100644 --- a/tests/Tests.hs +++ b/tests/Tests.hs @@ -61,7 +61,7 @@ infer_eid = describe "algoW used on EVar" $ do property $ \x -> do let env = Env 0 mempty mempty let t = T.TVar $ T.MkTVar "a" - let ctx = Ctx (M.singleton (Ident (x :: String)) t) + let ctx = Ctx (M.singleton (T.Ident (x :: String)) t) getTypeC env ctx (EVar (LIdent x)) `shouldBe` Right (T.TVar $ T.MkTVar "a") infer_eabs = describe "algoW used on EAbs" $ do From b1209b335370f9476758f3434a90b54442bdead0 Mon Sep 17 00:00:00 2001 From: Samuel Hammersberg Date: Fri, 24 Mar 2023 17:13:56 +0100 Subject: [PATCH 136/372] Updated the monomorphizer to the new tree. --- sample-programs/basic-1 | 13 +++---- src/Main.hs | 55 +++++++++++++--------------- src/Monomorphizer/Monomorphizer.hs | 2 +- src/Monomorphizer/MonomorphizerIr.hs | 4 +- 4 files changed, 34 insertions(+), 40 deletions(-) diff --git a/sample-programs/basic-1 b/sample-programs/basic-1 index a2531b0..f28dc2f 100644 --- a/sample-programs/basic-1 +++ b/sample-programs/basic-1 @@ -1,8 +1,5 @@ -posMul: _Int - > _Int - > _Int; -posMul a b = a + b; { - - - case b of { - 0 => 0; - _ => a + posMul a(b - 1) - }; - -} \ No newline at end of file +add : Int -> Int -> Int ; +add x y = x + y; + +main : Int ; +main = add 4 6 ; diff --git a/src/Main.hs b/src/Main.hs index 7ae149b..9f81671 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -2,30 +2,27 @@ module Main where --- import Codegen.Codegen (generateCode) -import GHC.IO.Handle.Text (hPutStrLn) -import Grammar.ErrM (Err) -import Grammar.Par (myLexer, pProgram) -import Grammar.Print (printTree) +import Codegen.Codegen (generateCode) +import GHC.IO.Handle.Text (hPutStrLn) +import Grammar.ErrM (Err) +import Grammar.Par (myLexer, pProgram) +import Grammar.Print (printTree) --- import Monomorphizer.Monomorphizer (monomorphize) +import Monomorphizer.Monomorphizer (monomorphize) -import Control.Monad (when) -import Data.List.Extra (isSuffixOf) +import Control.Monad (when) +import Data.List.Extra (isSuffixOf) -import Renamer.Renamer (rename) -import System.Directory ( - createDirectory, - doesPathExist, - getDirectoryContents, - removeDirectoryRecursive, - setCurrentDirectory, - ) -import System.Environment (getArgs) -import System.Exit (exitFailure, exitSuccess) -import System.IO (stderr) -import System.Process.Extra (spawnCommand, waitForProcess) -import TypeChecker.TypeChecker (typecheck) +import Renamer.Renamer (rename) +import System.Directory (createDirectory, doesPathExist, + getDirectoryContents, + removeDirectoryRecursive, + setCurrentDirectory) +import System.Environment (getArgs) +import System.Exit (exitFailure, exitSuccess) +import System.IO (stderr) +import System.Process.Extra (spawnCommand, waitForProcess) +import TypeChecker.TypeChecker (typecheck) main :: IO () main = @@ -50,18 +47,18 @@ main' debug s = do typechecked <- fromTypeCheckerErr $ typecheck renamed printToErr $ printTree typechecked - -- printToErr "\n-- Lambda Lifter --" + printToErr "\n-- Lambda Lifter --" -- let lifted = lambdaLift typechecked -- printToErr $ printTree lifted -- - -- printToErr "\n -- Printing compiler output to stdout --" - -- compiled <- fromCompilerErr $ generateCode (monomorphize typechecked) - -- putStrLn compiled + printToErr "\n -- Printing compiler output to stdout --" + compiled <- fromCompilerErr $ generateCode (monomorphize typechecked) + putStrLn compiled - -- check <- doesPathExist "output" - -- when check (removeDirectoryRecursive "output") - -- createDirectory "output" - -- writeFile "output/llvm.ll" compiled + check <- doesPathExist "output" + when check (removeDirectoryRecursive "output") + createDirectory "output" + writeFile "output/llvm.ll" compiled -- if debug then debugDotViz else putStrLn compiled -- interpred <- fromInterpreterErr $ interpret lifted diff --git a/src/Monomorphizer/Monomorphizer.hs b/src/Monomorphizer/Monomorphizer.hs index 70483ad..1b1d2f6 100644 --- a/src/Monomorphizer/Monomorphizer.hs +++ b/src/Monomorphizer/Monomorphizer.hs @@ -39,7 +39,7 @@ monoAbsType (GA.TVar _v) = error "NOT POLYMORHPIC TYPES" monoAbsType (GA.TAll _v _t) = error "NOT ALL TYPES" monoAbsType (GA.TEVar _v) = error "I DONT KNOW WHAT THIS IS" monoAbsType (GA.TFun t1 t2) = M.TFun (monoAbsType t1) (monoAbsType t2) -monoAbsType (GA.TIndexed _) = error "NOT INDEXED TYPES" +monoAbsType (GA.TData _ _) = error "NOT INDEXED TYPES" monoType :: T.Type -> M.Type monoType (T.TAll _ t) = monoType t diff --git a/src/Monomorphizer/MonomorphizerIr.hs b/src/Monomorphizer/MonomorphizerIr.hs index e4c4bad..6214cdc 100644 --- a/src/Monomorphizer/MonomorphizerIr.hs +++ b/src/Monomorphizer/MonomorphizerIr.hs @@ -1,7 +1,7 @@ module Monomorphizer.MonomorphizerIr (module Monomorphizer.MonomorphizerIr, module RE, module GA) where -import Grammar.Abs (Ident (..), Init (..), UIdent) -import qualified Grammar.Abs as GA (Ident (..), Init (..)) +import Grammar.Abs (Ident (..), UIdent) +import qualified Grammar.Abs as GA (Ident (..)) import qualified TypeChecker.TypeCheckerIr as RE type Id = (Ident, Type) From d6d0fb714657efaa693cfe02fd7c4bb3eef746dd Mon Sep 17 00:00:00 2001 From: Samuel Hammersberg Date: Fri, 24 Mar 2023 17:29:00 +0100 Subject: [PATCH 137/372] Enabled compiling to llvm again. --- sample-programs/basic-1 | 6 +++--- src/Main.hs | 2 +- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/sample-programs/basic-1 b/sample-programs/basic-1 index f28dc2f..ac5556b 100644 --- a/sample-programs/basic-1 +++ b/sample-programs/basic-1 @@ -1,5 +1,5 @@ -add : Int -> Int -> Int ; -add x y = x + y; +add : Int ; +add = 5; main : Int ; -main = add 4 6 ; +main = add ; diff --git a/src/Main.hs b/src/Main.hs index 9f81671..02c49d0 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -59,7 +59,7 @@ main' debug s = do when check (removeDirectoryRecursive "output") createDirectory "output" writeFile "output/llvm.ll" compiled - -- if debug then debugDotViz else putStrLn compiled + if debug then debugDotViz else putStrLn compiled -- interpred <- fromInterpreterErr $ interpret lifted -- putStrLn "\n-- interpret" From 41fc8636586b46d0d8563afc95e386104ed49236 Mon Sep 17 00:00:00 2001 From: sebastianselander Date: Fri, 24 Mar 2023 17:39:10 +0100 Subject: [PATCH 138/372] added PEnum --- Grammar.cf | 16 +++++++++------- sample-programs/basic-9 | 14 ++++++++++++++ src/TypeChecker/TypeChecker.hs | 5 +++++ src/TypeChecker/TypeCheckerIr.hs | 2 +- test_program | 26 ++++++++++++++------------ 5 files changed, 43 insertions(+), 20 deletions(-) create mode 100644 sample-programs/basic-9 diff --git a/Grammar.cf b/Grammar.cf index 51ff54b..78dfa65 100644 --- a/Grammar.cf +++ b/Grammar.cf @@ -66,26 +66,28 @@ LChar. Lit ::= Char ; Branch. Branch ::= Pattern "=>" Exp ; -PVar. Pattern ::= LIdent ; -PLit. Pattern ::= Lit ; -PInj. Pattern ::= UIdent [Pattern] ; -PCatch. Pattern ::= "_" ; +PVar. Pattern1 ::= LIdent ; +PLit. Pattern1 ::= Lit ; +PCatch. Pattern1 ::= "_" ; +PEnum. Pattern1 ::= UIdent ; +PInj. Pattern ::= UIdent [Pattern1] ; ------------------------------------------------------------------------------- -- * AUX ------------------------------------------------------------------------------- -separator Def ";" ; +terminator Def ";" ; separator nonempty Constructor "" ; separator Type " " ; -separator Pattern " " ; -separator Branch "," ; +separator nonempty Pattern1 " " ; +terminator Branch ";" ; separator Ident " "; separator LIdent " "; separator TVar " " ; coercions Exp 4 ; coercions Type 2 ; +coercions Pattern 1 ; token UIdent (upper (letter | digit | '_')*) ; token LIdent (lower (letter | digit | '_')*) ; diff --git a/sample-programs/basic-9 b/sample-programs/basic-9 new file mode 100644 index 0000000..2a7ef99 --- /dev/null +++ b/sample-programs/basic-9 @@ -0,0 +1,14 @@ +data List (a) where { + Nil : List (a) + Cons : a -> List (a) -> List (a) +}; + +test xs = case xs of { + Cons Nil _ => 0 ; +}; + + + +List a /= List (List a) + +a /= List a diff --git a/src/TypeChecker/TypeChecker.hs b/src/TypeChecker/TypeChecker.hs index e10023c..76013bd 100644 --- a/src/TypeChecker/TypeChecker.hs +++ b/src/TypeChecker/TypeChecker.hs @@ -562,6 +562,7 @@ withPattern p ma = case p of T.PInj _ ps -> foldl' (flip withPattern) ma ps T.PLit _ -> ma T.PCatch -> ma + T.PEnum _ -> ma inferPattern :: Pattern -> Infer (T.Pattern, T.Type) inferPattern = \case @@ -574,6 +575,10 @@ inferPattern = \case zipWithM_ unify vs (map snd patterns) return (T.PInj (coerce constr) (map fst patterns), ret) PCatch -> (T.PCatch,) <$> fresh + PEnum p -> do + t <- gets (M.lookup (coerce p) . constructors) + t <- maybeToRightM ("Constructor: " <> printTree p <> " does not exist") t + return (T.PEnum $ coerce p, t) PVar x -> do fr <- fresh let pvar = T.PVar (coerce x, fr) diff --git a/src/TypeChecker/TypeCheckerIr.hs b/src/TypeChecker/TypeCheckerIr.hs index 09efb8b..be54d35 100644 --- a/src/TypeChecker/TypeCheckerIr.hs +++ b/src/TypeChecker/TypeCheckerIr.hs @@ -64,7 +64,7 @@ type ExpT = (Exp, Type) data Branch = Branch (Pattern, Type) ExpT deriving (C.Eq, C.Ord, C.Read, C.Show) -data Pattern = PVar Id | PLit (Lit, Type) | PInj Ident [Pattern] | PCatch +data Pattern = PVar Id | PLit (Lit, Type) | PInj Ident [Pattern] | PCatch | PEnum Ident deriving (C.Eq, C.Ord, C.Show, C.Read) data Def = DBind Bind | DData Data diff --git a/test_program b/test_program index 0543b88..c5d39f6 100644 --- a/test_program +++ b/test_program @@ -12,30 +12,32 @@ hello_world = Cons 'h' (Cons 'e' (Cons 'l' (Cons 'l' (Cons 'o' (Cons ' ' (Cons ' length : List (a) -> Int ; length xs = case xs of { - Nil => 0, - Cons x xs => length xs + Nil => 0; + Cons x xs => length xs; }; head : List (a) -> a ; head xs = case xs of { - Cons x xs => x + Cons x xs => x; }; firstIsOne : List (Int) -> Bool () ; firstIsOne xs = case xs of { Cons x xs => case x of { - 0 => True , + 0 => True; _ => case xs of { - Cons x xs => False , - _ => False - } - }, - _ => False + Cons x xs => False; + _ => False; + }; + }; + _ => False; }; main = firstIsOne (Cons 1 Nil); deepPat xs = case xs of { - Cons 1 _ => True , - _ => False - } + Cons (Nil) _ => True; + _ => False; + }; + + From 867485be125c4f367d87baf8a73873ae96e0f64d Mon Sep 17 00:00:00 2001 From: sebastianselander Date: Fri, 24 Mar 2023 17:40:57 +0100 Subject: [PATCH 139/372] removed trace --- src/TypeChecker/TypeChecker.hs | 2 -- 1 file changed, 2 deletions(-) diff --git a/src/TypeChecker/TypeChecker.hs b/src/TypeChecker/TypeChecker.hs index 76013bd..03126e7 100644 --- a/src/TypeChecker/TypeChecker.hs +++ b/src/TypeChecker/TypeChecker.hs @@ -84,7 +84,6 @@ checkPrg (Program bs) = do preRun bs -- Type check the program twice to produce all top-level types in the first pass through bs' <- checkDef bs - trace ("FIRST ITERATION: " <> printTree bs') pure () bs'' <- checkDef bs return $ T.Program bs'' where @@ -330,7 +329,6 @@ makeLambda = foldl (flip (EAbs . coerce)) -- | Unify two types producing a new substitution unify :: T.Type -> T.Type -> Infer Subst -unify t0 t1 | trace ("T0: " <> show t0 <> "\nT1: " <> show t1) False = undefined unify t0 t1 = do case (t0, t1) of (T.TFun a b, T.TFun c d) -> do From 56ccd793acb1dda0607cbc9cd289579a21b9edae Mon Sep 17 00:00:00 2001 From: sebastianselander Date: Fri, 24 Mar 2023 18:21:07 +0100 Subject: [PATCH 140/372] more error messages and better unification --- sample-programs/basic-1 | 7 ++- src/Main.hs | 41 +++++++++--------- src/Monomorphizer/Monomorphizer.hs | 41 +++++++++--------- src/TypeChecker/TypeChecker.hs | 68 ++++++++++++++---------------- src/TypeChecker/TypeCheckerIr.hs | 1 + test_program | 62 +++++++++++++-------------- 6 files changed, 110 insertions(+), 110 deletions(-) diff --git a/sample-programs/basic-1 b/sample-programs/basic-1 index ac5556b..5acb832 100644 --- a/sample-programs/basic-1 +++ b/sample-programs/basic-1 @@ -1,5 +1,8 @@ add : Int ; -add = 5; +add = 4; main : Int ; -main = add ; +main = case add of { + 5 => 0; + _ => 1; +}; diff --git a/src/Main.hs b/src/Main.hs index 02c49d0..d0f544c 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -2,27 +2,30 @@ module Main where -import Codegen.Codegen (generateCode) -import GHC.IO.Handle.Text (hPutStrLn) -import Grammar.ErrM (Err) -import Grammar.Par (myLexer, pProgram) -import Grammar.Print (printTree) +import Codegen.Codegen (generateCode) +import GHC.IO.Handle.Text (hPutStrLn) +import Grammar.ErrM (Err) +import Grammar.Par (myLexer, pProgram) +import Grammar.Print (printTree) -import Monomorphizer.Monomorphizer (monomorphize) +import Monomorphizer.Monomorphizer (monomorphize) -import Control.Monad (when) -import Data.List.Extra (isSuffixOf) +import Control.Monad (when) +import Data.List.Extra (isSuffixOf) -import Renamer.Renamer (rename) -import System.Directory (createDirectory, doesPathExist, - getDirectoryContents, - removeDirectoryRecursive, - setCurrentDirectory) -import System.Environment (getArgs) -import System.Exit (exitFailure, exitSuccess) -import System.IO (stderr) -import System.Process.Extra (spawnCommand, waitForProcess) -import TypeChecker.TypeChecker (typecheck) +import Renamer.Renamer (rename) +import System.Directory ( + createDirectory, + doesPathExist, + getDirectoryContents, + removeDirectoryRecursive, + setCurrentDirectory, + ) +import System.Environment (getArgs) +import System.Exit (exitFailure, exitSuccess) +import System.IO (stderr) +import System.Process.Extra (spawnCommand, waitForProcess) +import TypeChecker.TypeChecker (typecheck) main :: IO () main = @@ -59,7 +62,7 @@ main' debug s = do when check (removeDirectoryRecursive "output") createDirectory "output" writeFile "output/llvm.ll" compiled - if debug then debugDotViz else putStrLn compiled + -- if debug then debugDotViz else putStrLn compiled -- interpred <- fromInterpreterErr $ interpret lifted -- putStrLn "\n-- interpret" diff --git a/src/Monomorphizer/Monomorphizer.hs b/src/Monomorphizer/Monomorphizer.hs index 1b1d2f6..051641e 100644 --- a/src/Monomorphizer/Monomorphizer.hs +++ b/src/Monomorphizer/Monomorphizer.hs @@ -1,14 +1,15 @@ {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} module Monomorphizer.Monomorphizer (monomorphize) where -import Data.Coerce (coerce) -import Grammar.Abs (Constructor (..), Ident (..)) -import Unsafe.Coerce (unsafeCoerce) +import Data.Coerce (coerce) +import Grammar.Abs (Constructor (..), Ident (..)) +import Unsafe.Coerce (unsafeCoerce) -import qualified Grammar.Abs as GA -import qualified Monomorphizer.MonomorphizerIr as M -import qualified TypeChecker.TypeCheckerIr as T +import Grammar.Abs qualified as GA +import Monomorphizer.MonomorphizerIr qualified as M +import TypeChecker.TypeCheckerIr qualified as T monomorphize :: T.Program -> M.Program monomorphize (T.Program ds) = M.Program $ monoDefs ds @@ -18,7 +19,7 @@ monoDefs = map monoDef monoDef :: T.Def -> M.Def monoDef (T.DBind bind) = M.DBind $ monoBind bind -monoDef (T.DData d) = M.DData $ unsafeCoerce d +monoDef (T.DData d) = M.DData $ unsafeCoerce d monoBind :: T.Bind -> M.Bind monoBind (T.Bind name args (e, t)) = M.Bind (monoId name) (map monoId args) (monoExpr e, monoType t) @@ -34,19 +35,19 @@ monoExpr = \case T.ECase expt injs -> M.ECase (monoexpt expt) (monoInjs injs) monoAbsType :: GA.Type -> M.Type -monoAbsType (GA.TLit u) = M.TLit (coerce u) -monoAbsType (GA.TVar _v) = error "NOT POLYMORHPIC TYPES" +monoAbsType (GA.TLit u) = M.TLit (coerce u) +monoAbsType (GA.TVar _v) = M.TLit "Int" monoAbsType (GA.TAll _v _t) = error "NOT ALL TYPES" -monoAbsType (GA.TEVar _v) = error "I DONT KNOW WHAT THIS IS" +monoAbsType (GA.TEVar _v) = error "I DONT KNOW WHAT THIS IS" monoAbsType (GA.TFun t1 t2) = M.TFun (monoAbsType t1) (monoAbsType t2) -monoAbsType (GA.TData _ _) = error "NOT INDEXED TYPES" +monoAbsType (GA.TData _ _) = error "NOT INDEXED TYPES" monoType :: T.Type -> M.Type -monoType (T.TAll _ t) = monoType t -monoType (T.TVar (T.MkTVar i)) = error "NOT POLYMORPHIC TYPES" -monoType (T.TLit (T.Ident i)) = M.TLit (Ident i) -monoType (T.TFun t1 t2) = M.TFun (monoType t1) (monoType t2) -monoType (T.TData _ _) = error "Not sure what this is" +monoType (T.TAll _ t) = monoType t +monoType (T.TVar (T.MkTVar i)) = M.TLit "Int" +monoType (T.TLit (T.Ident i)) = M.TLit (Ident i) +monoType (T.TFun t1 t2) = M.TFun (monoType t1) (monoType t2) +monoType (T.TData _ _) = error "Not sure what this is" monoexpt :: T.ExpT -> M.ExpT monoexpt (e, t) = (monoExpr e, monoType t) @@ -55,7 +56,7 @@ monoId :: T.Id -> M.Id monoId (n, t) = (coerce n, monoType t) monoLit :: T.Lit -> M.Lit -monoLit (T.LInt i) = M.LInt i +monoLit (T.LInt i) = M.LInt i monoLit (T.LChar c) = M.LChar c monoInjs :: [T.Branch] -> [M.Branch] @@ -65,7 +66,7 @@ monoInj :: T.Branch -> M.Branch monoInj (T.Branch (init, t) expt) = M.Branch (monoInit init, monoType t) (monoexpt expt) monoInit :: T.Pattern -> M.Pattern -monoInit (T.PVar (id, t)) = M.PVar (coerce id, monoType t) +monoInit (T.PVar (id, t)) = M.PVar (coerce id, monoType t) monoInit (T.PLit (lit, t)) = M.PLit (monoLit lit, monoType t) -monoInit (T.PInj id ps) = M.PInj (coerce id) (monoInit <$> ps) -monoInit T.PCatch = M.PCatch +monoInit (T.PInj id ps) = M.PInj (coerce id) (monoInit <$> ps) +monoInit T.PCatch = M.PCatch diff --git a/src/TypeChecker/TypeChecker.hs b/src/TypeChecker/TypeChecker.hs index 03126e7..9bcb67b 100644 --- a/src/TypeChecker/TypeChecker.hs +++ b/src/TypeChecker/TypeChecker.hs @@ -117,36 +117,22 @@ checkPrg (Program bs) = do (DSig _) -> checkDef xs checkBind :: Bind -> Infer T.Bind -checkBind (Bind name args e) = do +checkBind err@(Bind name args e) = do let lambda = makeLambda e (reverse (coerce args)) (_, lambdaT) <- inferExp lambda args <- zip args <$> mapM (const fresh) args withBindings (map coerce args) $ do e@(_, _) <- inferExp e s <- gets sigs - -- let fs = map (second Just) (getFunctionTypes s e) - -- mapM_ (uncurry insertSig) fs case M.lookup (coerce name) s of Just (Just t) -> do - sub <- unify t lambdaT + sub <- bindErr (unify t lambdaT) err let newT = apply sub t insertSig (coerce name) (Just newT) return $ T.Bind (coerce name, newT) (map coerce args) e _ -> do insertSig (coerce name) (Just lambdaT) return (T.Bind (coerce name, lambdaT) (map coerce args) e) -- (apply s e) - -- where - -- getFunctionTypes :: Map T.Ident (Maybe T.Type) -> T.ExpT -> [(T.Ident, T.Type)] - -- getFunctionTypes s = \case - -- (T.EId b, t) -> case M.lookup b s of - -- Just Nothing -> return (b, t) - -- _ -> [] - -- (T.ELit _, _) -> [] - -- (T.ELet (T.Bind _ _ e1) e2, _) -> getFunctionTypes s e1 <> getFunctionTypes s e2 - -- (T.EApp e1 e2, _) -> getFunctionTypes s e1 <> getFunctionTypes s e2 - -- (T.EAdd e1 e2, _) -> getFunctionTypes s e1 <> getFunctionTypes s e2 - -- (T.EAbs _ e, _) -> getFunctionTypes s e - -- (T.ECase e injs, _) -> getFunctionTypes s e <> concatMap (getFunctionTypes s . \(T.Inj _ e) -> e) injs isMoreSpecificOrEq :: T.Type -> T.Type -> Bool isMoreSpecificOrEq _ (T.TAll _ _) = True @@ -292,9 +278,9 @@ algoW = \case err@(EApp e0 e1) -> do fr <- fresh - (s0, (e0', t0)) <- exprErr (algoW e0) err + (s0, (e0', t0)) <- algoW e0 applySt s0 $ do - (s1, (e1', t1)) <- exprErr (algoW e1) err + (s1, (e1', t1)) <- algoW e1 s2 <- exprErr (unify (apply s1 t0) (T.TFun t1 fr)) err let t = apply s2 fr let comp = s2 `compose` s1 `compose` s0 @@ -307,7 +293,7 @@ algoW = \case -- The bar over S₀ and Γ means "generalize" err@(ELet b@(Bind name args e) e1) -> do - (s1, (_, t0)) <- exprErr (algoW (makeLambda e (coerce args))) err + (s1, (_, t0)) <- algoW (makeLambda e (coerce args)) bind' <- exprErr (checkBind b) err env <- asks vars let t' = generalize (apply s1 env) t0 @@ -322,7 +308,7 @@ algoW = \case (subst, injs, ret_t) <- checkCase t injs let comp = subst `compose` sub let t' = apply comp ret_t - return (comp, (T.ECase (e', t) injs, t')) + return (comp, apply comp (T.ECase (e', t) injs, t')) makeLambda :: Exp -> [T.Ident] -> Exp makeLambda = foldl (flip (EAbs . coerce)) @@ -424,13 +410,14 @@ compose m1 m2 = M.map (apply m1) m2 `M.union` m1 -- and one for applying substitutions -- | A class representing free variables functions +class SubstType t where + -- | Apply a substitution to t + apply :: Subst -> t -> t + class FreeVars t where -- | Get all free variables from t free :: t -> Set T.Ident - -- | Apply a substitution to t - apply :: Subst -> t -> t - instance FreeVars T.Type where free :: T.Type -> Set T.Ident free (T.TVar (T.MkTVar a)) = S.singleton a @@ -441,6 +428,7 @@ instance FreeVars T.Type where free (T.TData _ a) = foldl' (\acc x -> free x `S.union` acc) S.empty a +instance SubstType T.Type where apply :: Subst -> T.Type -> T.Type apply sub t = do case t of @@ -453,16 +441,15 @@ instance FreeVars T.Type where Just _ -> apply sub t T.TFun a b -> T.TFun (apply sub a) (apply sub b) T.TData name a -> T.TData name (map (apply sub) a) - instance FreeVars (Map T.Ident T.Type) where free :: Map T.Ident T.Type -> Set T.Ident free m = foldl' S.union S.empty (map free $ M.elems m) + +instance SubstType (Map T.Ident T.Type) where apply :: Subst -> Map T.Ident T.Type -> Map T.Ident T.Type apply s = M.map (apply s) -instance FreeVars T.ExpT where - free :: T.ExpT -> Set T.Ident - free = error "free not implemented for T.Exp" +instance SubstType T.ExpT where apply :: Subst -> T.ExpT -> T.ExpT apply s = \case (T.EId i, outerT) -> (T.EId i, apply s outerT) @@ -476,17 +463,22 @@ instance FreeVars T.ExpT where (T.EApp e1 e2, t) -> (T.EApp (apply s e1) (apply s e2), apply s t) (T.EAdd e1 e2, t) -> (T.EAdd (apply s e1) (apply s e2), apply s t) (T.EAbs ident e, t1) -> (T.EAbs ident (apply s e), apply s t1) - (T.ECase e injs, t) -> (T.ECase (apply s e) (apply s injs), apply s t) + (T.ECase e brnch, t) -> (T.ECase (apply s e) (apply s brnch), apply s t) -instance FreeVars T.Branch where - free :: T.Branch -> Set T.Ident - free = undefined +instance SubstType T.Branch where apply :: Subst -> T.Branch -> T.Branch - apply s (T.Branch (i, t) e) = T.Branch (i, apply s t) (apply s e) + apply s (T.Branch (i, t) e) = T.Branch (apply s i, apply s t) (apply s e) -instance FreeVars [T.Branch] where - free :: [T.Branch] -> Set T.Ident - free = foldl' (\acc x -> free x `S.union` acc) mempty +instance SubstType T.Pattern where + apply :: Subst -> T.Pattern -> T.Pattern + apply s = \case + T.PVar (iden, t) -> T.PVar (iden, apply s t) + T.PLit (lit, t) -> T.PLit (lit, apply s t) + T.PInj i ps -> T.PInj i $ apply s ps + T.PCatch -> T.PCatch + T.PEnum i -> T.PEnum i + +instance SubstType a => SubstType [a] where apply s = map (apply s) -- | Apply substitutions to the environment. @@ -552,8 +544,6 @@ inferBranch (Branch pat expr) = do newExp@(_, exprT) <- withPattern pat (inferExp expr) return (branchT, T.Branch newPat newExp, exprT) --- return (initT, T.Branch (it, initT) (e, exprT), exprT) - withPattern :: T.Pattern -> Infer a -> Infer a withPattern p ma = case p of T.PVar (x, t) -> withBinding x t ma @@ -608,3 +598,7 @@ partitionType = go [] exprErr :: Infer a -> Exp -> Infer a exprErr ma exp = catchError ma (\x -> throwError $ x <> " on expression: " <> printTree exp) + +bindErr :: Infer a -> Bind -> Infer a +bindErr ma exp = + catchError ma (\x -> throwError $ x <> " on expression: " <> printTree exp) diff --git a/src/TypeChecker/TypeCheckerIr.hs b/src/TypeChecker/TypeCheckerIr.hs index be54d35..d14c736 100644 --- a/src/TypeChecker/TypeCheckerIr.hs +++ b/src/TypeChecker/TypeCheckerIr.hs @@ -214,6 +214,7 @@ instance Print Pattern where PLit (lit, typ) -> prPrec i 0 (concatD [doc $ showString "(", prt 0 lit, doc $ showString ",", prt 0 typ, doc $ showString ")"]) PInj uident patterns -> prPrec i 0 (concatD [prt 0 uident, prt 0 patterns]) PCatch -> prPrec i 0 (concatD [doc (showString "_")]) + PEnum p -> prt i p instance Print [Branch] where prt _ [] = concatD [] diff --git a/test_program b/test_program index c5d39f6..ee74589 100644 --- a/test_program +++ b/test_program @@ -3,41 +3,39 @@ data List (a) where { Cons : a -> List (a) -> List (a) }; -data Bool () where { - True : Bool () - False : Bool () - }; +-- data Bool () where { +-- True : Bool () +-- False : Bool () +-- }; -hello_world = Cons 'h' (Cons 'e' (Cons 'l' (Cons 'l' (Cons 'o' (Cons ' ' (Cons 'w' (Cons 'o' (Cons 'r' (Cons 'l' (Cons 'd' Nil)))))))))) ; +-- hello_world = Cons 'h' (Cons 'e' (Cons 'l' (Cons 'l' (Cons 'o' (Cons ' ' (Cons 'w' (Cons 'o' (Cons 'r' (Cons 'l' (Cons 'd' Nil)))))))))) ; -length : List (a) -> Int ; -length xs = case xs of { - Nil => 0; - Cons x xs => length xs; -}; +-- length : List (a) -> Int ; +-- length xs = case xs of { +-- Nil => 0; +-- Cons x xs => length xs; +-- }; -head : List (a) -> a ; -head xs = case xs of { - Cons x xs => x; -}; +-- head : List (a) -> a ; +-- head xs = case xs of { +-- Cons x xs => x; +-- }; -firstIsOne : List (Int) -> Bool () ; -firstIsOne xs = case xs of { - Cons x xs => case x of { - 0 => True; - _ => case xs of { - Cons x xs => False; - _ => False; - }; - }; - _ => False; - }; - -main = firstIsOne (Cons 1 Nil); - -deepPat xs = case xs of { - Cons (Nil) _ => True; - _ => False; - }; +-- firstIsOne : List (Int) -> Bool () ; +-- firstIsOne xs = case xs of { +-- Cons x xs => case x of { +-- 0 => True; +-- _ => case xs of { +-- Cons x xs => False; +-- _ => False; +-- }; +-- }; +-- _ => False; +-- }; +-- main = firstIsOne (Cons 1 Nil); +test xs = case xs of { + 1 => 0; + lol => 1; + }; From 23c174607b9ddf62891427c1b7808d06692ad446 Mon Sep 17 00:00:00 2001 From: Samuel Hammersberg Date: Fri, 24 Mar 2023 18:22:37 +0100 Subject: [PATCH 141/372] temp merge --- language.cabal | 2 ++ src/Compiler.hs | 27 ++++++++++++++++++++++++ src/Main.hs | 55 +++++++++++++++++++++++++------------------------ 3 files changed, 57 insertions(+), 27 deletions(-) create mode 100644 src/Compiler.hs diff --git a/language.cabal b/language.cabal index a098bd7..bfdaa0f 100644 --- a/language.cabal +++ b/language.cabal @@ -69,6 +69,7 @@ Test-suite language-testsuite TypeChecker.TypeChecker TypeChecker.TypeCheckerIr Renamer.Renamer + Compiler hs-source-dirs: src, tests @@ -81,5 +82,6 @@ Test-suite language-testsuite , array , hspec , QuickCheck + , process default-language: GHC2021 diff --git a/src/Compiler.hs b/src/Compiler.hs new file mode 100644 index 0000000..76a3a1d --- /dev/null +++ b/src/Compiler.hs @@ -0,0 +1,27 @@ +module Compiler where + +import Grammar.ErrM (Err) +import System.Exit (exitFailure, exitSuccess) +import System.IO (BufferMode (NoBuffering), hClose, hFlush, + hGetContents, hPutStr, hPutStrLn, + hSetBuffering, stderr) +import System.Process.Extra (CreateProcess (..), + StdStream (CreatePipe), createProcess, + proc, readCreateProcess, shell, + spawnCommand, waitForProcess) + +--spawnWait s = spawnCommand s >>= \s >>= waitForProcess + +optimize :: String -> IO String +optimize prg = do + result <- readCreateProcess (shell "opt --O3") prg + putStrLn result + + + -- (Just hin, Just hout, _, _) <- createProcess (proc "opt" ["--O3"]){ std_in = CreatePipe, std_out = CreatePipe } + -- hSetBuffering hin NoBuffering + -- hPutStrLn hin prg + -- hFlush hin + --bytes <- hGetContents hout + --putStrLn bytes + pure "" diff --git a/src/Main.hs b/src/Main.hs index d0f544c..ba5b387 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -2,30 +2,28 @@ module Main where -import Codegen.Codegen (generateCode) -import GHC.IO.Handle.Text (hPutStrLn) -import Grammar.ErrM (Err) -import Grammar.Par (myLexer, pProgram) -import Grammar.Print (printTree) +import Codegen.Codegen (generateCode) +import GHC.IO.Handle.Text (hPutStrLn) +import Grammar.ErrM (Err) +import Grammar.Par (myLexer, pProgram) +import Grammar.Print (printTree) -import Monomorphizer.Monomorphizer (monomorphize) +import Monomorphizer.Monomorphizer (monomorphize) -import Control.Monad (when) -import Data.List.Extra (isSuffixOf) +import Control.Monad (when) +import Data.List.Extra (isSuffixOf) -import Renamer.Renamer (rename) -import System.Directory ( - createDirectory, - doesPathExist, - getDirectoryContents, - removeDirectoryRecursive, - setCurrentDirectory, - ) -import System.Environment (getArgs) -import System.Exit (exitFailure, exitSuccess) -import System.IO (stderr) -import System.Process.Extra (spawnCommand, waitForProcess) -import TypeChecker.TypeChecker (typecheck) +import Compiler (optimize) +import Renamer.Renamer (rename) +import System.Directory (createDirectory, doesPathExist, + getDirectoryContents, + removeDirectoryRecursive, + setCurrentDirectory) +import System.Environment (getArgs) +import System.Exit (exitFailure, exitSuccess) +import System.IO (stderr) +import System.Process.Extra (spawnCommand, waitForProcess) +import TypeChecker.TypeChecker (typecheck) main :: IO () main = @@ -50,19 +48,22 @@ main' debug s = do typechecked <- fromTypeCheckerErr $ typecheck renamed printToErr $ printTree typechecked - printToErr "\n-- Lambda Lifter --" + -- printToErr "\n-- Lambda Lifter --" -- let lifted = lambdaLift typechecked -- printToErr $ printTree lifted -- - printToErr "\n -- Printing compiler output to stdout --" - compiled <- fromCompilerErr $ generateCode (monomorphize typechecked) - putStrLn compiled + printToErr "\n -- Compiler --" + generatedCode <- fromCompilerErr $ generateCode (monomorphize typechecked) + --putStrLn generatedCode check <- doesPathExist "output" when check (removeDirectoryRecursive "output") createDirectory "output" - writeFile "output/llvm.ll" compiled - -- if debug then debugDotViz else putStrLn compiled + when debug $ do + writeFile "output/llvm.ll" generatedCode + debugDotViz + + optimize generatedCode -- interpred <- fromInterpreterErr $ interpret lifted -- putStrLn "\n-- interpret" From b4cae11c0d9d02c963f3d0dfde5701b99d705ac7 Mon Sep 17 00:00:00 2001 From: sebastianselander Date: Fri, 24 Mar 2023 18:26:59 +0100 Subject: [PATCH 142/372] added debug info --- src/Main.hs | 50 ++++++++++++++++++---------------- src/TypeChecker/TypeChecker.hs | 5 +++- 2 files changed, 31 insertions(+), 24 deletions(-) diff --git a/src/Main.hs b/src/Main.hs index ba5b387..9f44c18 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -2,28 +2,32 @@ module Main where -import Codegen.Codegen (generateCode) -import GHC.IO.Handle.Text (hPutStrLn) -import Grammar.ErrM (Err) -import Grammar.Par (myLexer, pProgram) -import Grammar.Print (printTree) +import Codegen.Codegen (generateCode) +import Data.Bool (bool) +import GHC.IO.Handle.Text (hPutStrLn) +import Grammar.ErrM (Err) +import Grammar.Par (myLexer, pProgram) +import Grammar.Print (printTree) -import Monomorphizer.Monomorphizer (monomorphize) +import Monomorphizer.Monomorphizer (monomorphize) -import Control.Monad (when) -import Data.List.Extra (isSuffixOf) +import Control.Monad (when) +import Data.List.Extra (isSuffixOf) -import Compiler (optimize) -import Renamer.Renamer (rename) -import System.Directory (createDirectory, doesPathExist, - getDirectoryContents, - removeDirectoryRecursive, - setCurrentDirectory) -import System.Environment (getArgs) -import System.Exit (exitFailure, exitSuccess) -import System.IO (stderr) -import System.Process.Extra (spawnCommand, waitForProcess) -import TypeChecker.TypeChecker (typecheck) +import Compiler (optimize) +import Renamer.Renamer (rename) +import System.Directory ( + createDirectory, + doesPathExist, + getDirectoryContents, + removeDirectoryRecursive, + setCurrentDirectory, + ) +import System.Environment (getArgs) +import System.Exit (exitFailure, exitSuccess) +import System.IO (stderr) +import System.Process.Extra (spawnCommand, waitForProcess) +import TypeChecker.TypeChecker (typecheck) main :: IO () main = @@ -38,15 +42,15 @@ main' debug s = do printToErr "-- Parse Tree -- " parsed <- fromSyntaxErr . pProgram $ myLexer file - printToErr $ printTree parsed + bool (printToErr $ printTree parsed) (printToErr $ printTree parsed) debug printToErr "\n-- Renamer --" renamed <- fromRenamerErr . rename $ parsed - printToErr $ printTree renamed + bool (printToErr $ printTree renamed) (printToErr $ show renamed) debug printToErr "\n-- TypeChecker --" typechecked <- fromTypeCheckerErr $ typecheck renamed - printToErr $ printTree typechecked + bool (printToErr $ printTree typechecked) (printToErr $ show typechecked) debug -- printToErr "\n-- Lambda Lifter --" -- let lifted = lambdaLift typechecked @@ -54,7 +58,7 @@ main' debug s = do -- printToErr "\n -- Compiler --" generatedCode <- fromCompilerErr $ generateCode (monomorphize typechecked) - --putStrLn generatedCode + -- putStrLn generatedCode check <- doesPathExist "output" when check (removeDirectoryRecursive "output") diff --git a/src/TypeChecker/TypeChecker.hs b/src/TypeChecker/TypeChecker.hs index 9bcb67b..a114007 100644 --- a/src/TypeChecker/TypeChecker.hs +++ b/src/TypeChecker/TypeChecker.hs @@ -129,7 +129,7 @@ checkBind err@(Bind name args e) = do sub <- bindErr (unify t lambdaT) err let newT = apply sub t insertSig (coerce name) (Just newT) - return $ T.Bind (coerce name, newT) (map coerce args) e + return $ T.Bind (apply sub (coerce name, newT)) (map coerce args) e _ -> do insertSig (coerce name) (Just lambdaT) return (T.Bind (coerce name, lambdaT) (map coerce args) e) -- (apply s e) @@ -481,6 +481,9 @@ instance SubstType T.Pattern where instance SubstType a => SubstType [a] where apply s = map (apply s) +instance SubstType T.Id where + apply s (name, t) = (name, apply s t) + -- | Apply substitutions to the environment. applySt :: Subst -> Infer a -> Infer a applySt s = local (\st -> st{vars = apply s (vars st)}) From e0c78f5783f3f2b6b4be4a77784cd387fb1b5336 Mon Sep 17 00:00:00 2001 From: sebastianselander Date: Fri, 24 Mar 2023 18:32:33 +0100 Subject: [PATCH 143/372] debug for parse tree --- src/Main.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Main.hs b/src/Main.hs index 9f44c18..51fca6a 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -42,7 +42,7 @@ main' debug s = do printToErr "-- Parse Tree -- " parsed <- fromSyntaxErr . pProgram $ myLexer file - bool (printToErr $ printTree parsed) (printToErr $ printTree parsed) debug + bool (printToErr $ printTree parsed) (printToErr $ show parsed) debug printToErr "\n-- Renamer --" renamed <- fromRenamerErr . rename $ parsed From e500c7052973a3608ab4afd85b9e117cf9864592 Mon Sep 17 00:00:00 2001 From: Samuel Hammersberg Date: Fri, 24 Mar 2023 18:46:12 +0100 Subject: [PATCH 144/372] Programs are now actually compiled all the way through. --- language.cabal | 2 ++ src/Compiler.hs | 17 ++++++----------- src/Main.hs | 46 +++++++++++++++++++++------------------------- 3 files changed, 29 insertions(+), 36 deletions(-) diff --git a/language.cabal b/language.cabal index bfdaa0f..66932e1 100644 --- a/language.cabal +++ b/language.cabal @@ -51,6 +51,7 @@ executable language , hspec , QuickCheck , directory + , process default-language: GHC2021 @@ -83,5 +84,6 @@ Test-suite language-testsuite , hspec , QuickCheck , process + , bytestring default-language: GHC2021 diff --git a/src/Compiler.hs b/src/Compiler.hs index 76a3a1d..489387a 100644 --- a/src/Compiler.hs +++ b/src/Compiler.hs @@ -1,4 +1,4 @@ -module Compiler where +module Compiler (compile) where import Grammar.ErrM (Err) import System.Exit (exitFailure, exitSuccess) @@ -13,15 +13,10 @@ import System.Process.Extra (CreateProcess (..), --spawnWait s = spawnCommand s >>= \s >>= waitForProcess optimize :: String -> IO String -optimize prg = do - result <- readCreateProcess (shell "opt --O3") prg - putStrLn result +optimize = readCreateProcess (shell "opt --O3 -S") +compileClang :: String -> IO String +compileClang = readCreateProcess (shell "clang -x ir -o hello_world -") - -- (Just hin, Just hout, _, _) <- createProcess (proc "opt" ["--O3"]){ std_in = CreatePipe, std_out = CreatePipe } - -- hSetBuffering hin NoBuffering - -- hPutStrLn hin prg - -- hFlush hin - --bytes <- hGetContents hout - --putStrLn bytes - pure "" +compile :: String -> IO String +compile s = optimize s >>= compileClang diff --git a/src/Main.hs b/src/Main.hs index 51fca6a..9736ada 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -2,32 +2,29 @@ module Main where -import Codegen.Codegen (generateCode) -import Data.Bool (bool) -import GHC.IO.Handle.Text (hPutStrLn) -import Grammar.ErrM (Err) -import Grammar.Par (myLexer, pProgram) -import Grammar.Print (printTree) +import Codegen.Codegen (generateCode) +import Data.Bool (bool) +import GHC.IO.Handle.Text (hPutStrLn) +import Grammar.ErrM (Err) +import Grammar.Par (myLexer, pProgram) +import Grammar.Print (printTree) -import Monomorphizer.Monomorphizer (monomorphize) +import Monomorphizer.Monomorphizer (monomorphize) -import Control.Monad (when) -import Data.List.Extra (isSuffixOf) +import Control.Monad (when) +import Data.List.Extra (isSuffixOf) -import Compiler (optimize) -import Renamer.Renamer (rename) -import System.Directory ( - createDirectory, - doesPathExist, - getDirectoryContents, - removeDirectoryRecursive, - setCurrentDirectory, - ) -import System.Environment (getArgs) -import System.Exit (exitFailure, exitSuccess) -import System.IO (stderr) -import System.Process.Extra (spawnCommand, waitForProcess) -import TypeChecker.TypeChecker (typecheck) +import Compiler (compile) +import Renamer.Renamer (rename) +import System.Directory (createDirectory, doesPathExist, + getDirectoryContents, + removeDirectoryRecursive, + setCurrentDirectory) +import System.Environment (getArgs) +import System.Exit (exitFailure, exitSuccess) +import System.IO (stderr) +import System.Process.Extra (spawnCommand, waitForProcess) +import TypeChecker.TypeChecker (typecheck) main :: IO () main = @@ -67,8 +64,7 @@ main' debug s = do writeFile "output/llvm.ll" generatedCode debugDotViz - optimize generatedCode - + compile generatedCode -- interpred <- fromInterpreterErr $ interpret lifted -- putStrLn "\n-- interpret" -- print interpred From b08ae7aef11967c2360ad3366874b4bb215c7d70 Mon Sep 17 00:00:00 2001 From: sebastianselander Date: Fri, 24 Mar 2023 18:48:40 +0100 Subject: [PATCH 145/372] rewrote unification for data type and variable. could definitely be wrong. have to double check --- src/TypeChecker/TypeChecker.hs | 7 +++++-- src/TypeChecker/TypeCheckerIr.hs | 6 +++++- test_program | 13 +++++++++---- 3 files changed, 19 insertions(+), 7 deletions(-) diff --git a/src/TypeChecker/TypeChecker.hs b/src/TypeChecker/TypeChecker.hs index a114007..70fb894 100644 --- a/src/TypeChecker/TypeChecker.hs +++ b/src/TypeChecker/TypeChecker.hs @@ -83,7 +83,7 @@ checkPrg :: Program -> Infer T.Program checkPrg (Program bs) = do preRun bs -- Type check the program twice to produce all top-level types in the first pass through - bs' <- checkDef bs + _ <- checkDef bs bs'' <- checkDef bs return $ T.Program bs'' where @@ -132,7 +132,7 @@ checkBind err@(Bind name args e) = do return $ T.Bind (apply sub (coerce name, newT)) (map coerce args) e _ -> do insertSig (coerce name) (Just lambdaT) - return (T.Bind (coerce name, lambdaT) (map coerce args) e) -- (apply s e) + return (T.Bind (coerce name, lambdaT) (map coerce args) e) isMoreSpecificOrEq :: T.Type -> T.Type -> Bool isMoreSpecificOrEq _ (T.TAll _ _) = True @@ -321,6 +321,9 @@ unify t0 t1 = do s1 <- unify a c s2 <- unify (apply s1 b) (apply s1 d) return $ s1 `compose` s2 + -- TODO: BEWARY. THIS IS PROBABLY WRONG!!! + (T.TVar (T.MkTVar a), t@(T.TData _ _)) -> return $ M.singleton a t + (t@(T.TData _ _), T.TVar (T.MkTVar b)) -> return $ M.singleton b t (T.TVar (T.MkTVar a), t) -> occurs a t (t, T.TVar (T.MkTVar b)) -> occurs b t (T.TAll _ t, b) -> unify t b diff --git a/src/TypeChecker/TypeCheckerIr.hs b/src/TypeChecker/TypeCheckerIr.hs index d14c736..692fec8 100644 --- a/src/TypeChecker/TypeCheckerIr.hs +++ b/src/TypeChecker/TypeCheckerIr.hs @@ -7,6 +7,7 @@ module TypeChecker.TypeCheckerIr ( import Control.Monad.Except import Control.Monad.Reader import Control.Monad.State +import Data.Char (isDigit) import Data.Functor.Identity (Identity) import Data.Map (Map) import Data.String qualified @@ -227,7 +228,10 @@ instance Print TVar where instance Print Type where prt i = \case TLit uident -> prPrec i 2 (concatD [prt 0 uident]) - TVar tvar -> prPrec i 2 (concatD [prt 0 tvar]) + TVar tvar@(MkTVar (Ident iden)) -> + if all isDigit iden + then prPrec i 2 (concatD [prt 0 $ TVar (MkTVar (Ident ("a" <> iden)))]) + else prPrec i 2 (concatD [prt 0 tvar]) TAll tvar type_ -> prPrec i 1 (concatD [doc (showString "forall"), prt 0 tvar, doc (showString "."), prt 0 type_]) TData ident types -> prPrec i 1 (concatD [prt 0 ident, prt 0 types]) TFun type_1 type_2 -> prPrec i 0 (concatD [prt 1 type_1, doc (showString "->"), prt 0 type_2]) diff --git a/test_program b/test_program index ee74589..33f69ce 100644 --- a/test_program +++ b/test_program @@ -35,7 +35,12 @@ data List (a) where { -- main = firstIsOne (Cons 1 Nil); -test xs = case xs of { - 1 => 0; - lol => 1; - }; +-- test xs = case xs of { +-- 1 => 0; +-- lol => 1; + -- }; + +deepList xs = case xs of { + Cons Nil _ => 1 ; + _ => 0 ; +}; From 3e31fe0ea520fd28aa8678f095345b757a80045e Mon Sep 17 00:00:00 2001 From: Samuel Hammersberg Date: Fri, 24 Mar 2023 18:52:12 +0100 Subject: [PATCH 146/372] The compiler now also runs the outputed program. --- src/Main.hs | 12 ++++++++---- 1 file changed, 8 insertions(+), 4 deletions(-) diff --git a/src/Main.hs b/src/Main.hs index 9736ada..432e038 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -21,9 +21,11 @@ import System.Directory (createDirectory, doesPathExist, removeDirectoryRecursive, setCurrentDirectory) import System.Environment (getArgs) -import System.Exit (exitFailure, exitSuccess) +import System.Exit (ExitCode, exitFailure, + exitSuccess) import System.IO (stderr) -import System.Process.Extra (spawnCommand, waitForProcess) +import System.Process.Extra (readCreateProcess, shell, + spawnCommand, waitForProcess) import TypeChecker.TypeChecker (typecheck) main :: IO () @@ -65,6 +67,7 @@ main' debug s = do debugDotViz compile generatedCode + spawnWait "./hello_world" -- interpred <- fromInterpreterErr $ interpret lifted -- putStrLn "\n-- interpret" -- print interpred @@ -80,8 +83,9 @@ debugDotViz = do mapM_ spawnWait commands setCurrentDirectory ".." return () - where - spawnWait s = spawnCommand s >>= waitForProcess + +spawnWait :: String -> IO ExitCode +spawnWait s = spawnCommand s >>= waitForProcess printToErr :: String -> IO () printToErr = hPutStrLn stderr From 2566c53f58905b3a7accee35642e6b52f97e3e23 Mon Sep 17 00:00:00 2001 From: sebastianselander Date: Fri, 24 Mar 2023 19:01:33 +0100 Subject: [PATCH 147/372] mono adapt --- src/Monomorphizer/Monomorphizer.hs | 2 +- test_program | 53 +++++------------------------- 2 files changed, 9 insertions(+), 46 deletions(-) diff --git a/src/Monomorphizer/Monomorphizer.hs b/src/Monomorphizer/Monomorphizer.hs index 051641e..a217b87 100644 --- a/src/Monomorphizer/Monomorphizer.hs +++ b/src/Monomorphizer/Monomorphizer.hs @@ -47,7 +47,7 @@ monoType (T.TAll _ t) = monoType t monoType (T.TVar (T.MkTVar i)) = M.TLit "Int" monoType (T.TLit (T.Ident i)) = M.TLit (Ident i) monoType (T.TFun t1 t2) = M.TFun (monoType t1) (monoType t2) -monoType (T.TData _ _) = error "Not sure what this is" +monoType (T.TData (T.Ident n) t) = M.TLit (Ident (n ++ concatMap show t)) monoexpt :: T.ExpT -> M.ExpT monoexpt (e, t) = (monoExpr e, monoType t) diff --git a/test_program b/test_program index 33f69ce..b43a99a 100644 --- a/test_program +++ b/test_program @@ -1,46 +1,9 @@ -data List (a) where { - Nil : List (a) - Cons : a -> List (a) -> List (a) -}; +data Bool () where { + True : Bool () + False : Bool () + }; --- data Bool () where { --- True : Bool () --- False : Bool () --- }; - --- hello_world = Cons 'h' (Cons 'e' (Cons 'l' (Cons 'l' (Cons 'o' (Cons ' ' (Cons 'w' (Cons 'o' (Cons 'r' (Cons 'l' (Cons 'd' Nil)))))))))) ; - --- length : List (a) -> Int ; --- length xs = case xs of { --- Nil => 0; --- Cons x xs => length xs; --- }; - --- head : List (a) -> a ; --- head xs = case xs of { --- Cons x xs => x; --- }; - --- firstIsOne : List (Int) -> Bool () ; --- firstIsOne xs = case xs of { --- Cons x xs => case x of { --- 0 => True; --- _ => case xs of { --- Cons x xs => False; --- _ => False; --- }; --- }; --- _ => False; --- }; - --- main = firstIsOne (Cons 1 Nil); - --- test xs = case xs of { --- 1 => 0; --- lol => 1; - -- }; - -deepList xs = case xs of { - Cons Nil _ => 1 ; - _ => 0 ; -}; +main = case True of { + True => 1; + False => 0; + }; From f531afb3ab18a5236a5545a07e0c02b6c4a8f05f Mon Sep 17 00:00:00 2001 From: sebastianselander Date: Fri, 24 Mar 2023 19:04:29 +0100 Subject: [PATCH 148/372] added comment when codegen ok --- src/Main.hs | 55 ++++++++++++++++++++++++++++++++--------------------- 1 file changed, 33 insertions(+), 22 deletions(-) diff --git a/src/Main.hs b/src/Main.hs index 432e038..7a718ad 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -2,31 +2,41 @@ module Main where -import Codegen.Codegen (generateCode) -import Data.Bool (bool) -import GHC.IO.Handle.Text (hPutStrLn) -import Grammar.ErrM (Err) -import Grammar.Par (myLexer, pProgram) -import Grammar.Print (printTree) +import Codegen.Codegen (generateCode) +import Data.Bool (bool) +import GHC.IO.Handle.Text (hPutStrLn) +import Grammar.ErrM (Err) +import Grammar.Par (myLexer, pProgram) +import Grammar.Print (printTree) -import Monomorphizer.Monomorphizer (monomorphize) +import Monomorphizer.Monomorphizer (monomorphize) -import Control.Monad (when) -import Data.List.Extra (isSuffixOf) +import Control.Monad (when) +import Data.List.Extra (isSuffixOf) -import Compiler (compile) -import Renamer.Renamer (rename) -import System.Directory (createDirectory, doesPathExist, - getDirectoryContents, - removeDirectoryRecursive, - setCurrentDirectory) -import System.Environment (getArgs) -import System.Exit (ExitCode, exitFailure, - exitSuccess) -import System.IO (stderr) -import System.Process.Extra (readCreateProcess, shell, - spawnCommand, waitForProcess) -import TypeChecker.TypeChecker (typecheck) +import Compiler (compile) +import Renamer.Renamer (rename) +import System.Directory ( + createDirectory, + doesPathExist, + getDirectoryContents, + removeDirectoryRecursive, + setCurrentDirectory, + ) +import System.Environment (getArgs) +import System.Exit ( + ExitCode, + exitFailure, + exitSuccess, + ) +import System.IO (stderr) +import System.Process.Extra ( + readCreateProcess, + shell, + spawnCommand, + waitForProcess, + ) +import TypeChecker.TypeChecker (typecheck) main :: IO () main = @@ -57,6 +67,7 @@ main' debug s = do -- printToErr "\n -- Compiler --" generatedCode <- fromCompilerErr $ generateCode (monomorphize typechecked) + putStrLn "Generation of code successful" -- putStrLn generatedCode check <- doesPathExist "output" From 7e246a94e51d8e67f6e6445b59dc616ee85913df Mon Sep 17 00:00:00 2001 From: Samuel Hammersberg Date: Fri, 24 Mar 2023 19:57:49 +0100 Subject: [PATCH 149/372] Fixed a segfault. --- sample-programs/basic-1 | 15 ++++---- src/Codegen/Codegen.hs | 41 +++++++++++++------- src/Main.hs | 57 +++++++++++----------------- src/Monomorphizer/Monomorphizer.hs | 43 +++++++++++---------- src/Monomorphizer/MonomorphizerIr.hs | 2 +- 5 files changed, 82 insertions(+), 76 deletions(-) diff --git a/sample-programs/basic-1 b/sample-programs/basic-1 index 5acb832..91317cd 100644 --- a/sample-programs/basic-1 +++ b/sample-programs/basic-1 @@ -1,8 +1,9 @@ -add : Int ; -add = 4; - -main : Int ; -main = case add of { - 5 => 0; - _ => 1; +data True() where { + True: True() }; +main: Int; +main = + case True of { + True => 1; + _ => 0; + }; \ No newline at end of file diff --git a/src/Codegen/Codegen.hs b/src/Codegen/Codegen.hs index ec20273..601387d 100644 --- a/src/Codegen/Codegen.hs +++ b/src/Codegen/Codegen.hs @@ -102,7 +102,7 @@ getConstructors bs = Map.fromList $ go bs let (GA.Ident n) = extractTypeName t fst ( foldl - ( \(acc, i) (Constructor (GA.UIdent id) xs) -> + ( \(acc, i) (Constructor (GA.Ident id) xs) -> ( ( (GA.Ident (n <> "_" <> id), MIR.TLit (coerce n)) , ConstructorInfo { numArgsCI = length xs @@ -215,6 +215,7 @@ compileScs [] = do -- emit $ UnsafeRaw "\n" + -- warning this segfaults!! enumerateOneM_ ( \i (GA.Ident arg_n, arg_t) -> do let arg_t' = type2LlvmType arg_t @@ -262,10 +263,10 @@ compileScs (MIR.DBind (MIR.Bind (name, _t) args exp) : xs) = do compileScs xs compileScs (MIR.DData (MIR.Data typ ts) : xs) = do let (Ident outer_id) = extractTypeName typ - let biggestVariant = maximum $ sum <$> (\(Constructor _ t) -> typeByteSize . type2LlvmType . snd <$> t) <$> ts - emit $ LIR.Type (coerce outer_id) [I8, Array biggestVariant I8] + let biggestVariant = 1--maximum (sum . (\(Constructor _ t) -> typeByteSize . type2LlvmType . snd <$> t) <$> ts) + emit $ LIR.Type (Ident outer_id) [I8, Array biggestVariant I8] mapM_ - ( \(Constructor (GA.UIdent inner_id) fi) -> do + ( \(Constructor (GA.Ident inner_id) fi) -> do emit $ LIR.Type (GA.Ident $ outer_id <> "_" <> inner_id) (I8 : map type2LlvmType (snd <$> fi)) ) ts @@ -274,6 +275,18 @@ compileScs (MIR.DData (MIR.Data typ ts) : xs) = do mainContent :: LLVMValue -> [LLVMIr] mainContent var = [ UnsafeRaw $ + -- "%2 = alloca %Craig\n" <> + -- " store %Craig %1, ptr %2\n" <> + -- " %3 = bitcast %Craig* %2 to i72*\n" <> + -- " %4 = load i72, ptr %3\n" <> + -- " call i32 (ptr, ...) @printf(ptr noundef @.str, i72 noundef %4)\n" + + -- "%2 = alloca %Craig\n" <> + -- " store %Craig %1, ptr %2\n" <> + -- " %3 = bitcast %Craig* %2 to i72*\n" <> + -- " %4 = load i72, ptr %3\n" <> + -- " call i32 (ptr, ...) @printf(ptr noundef @.str, i72 noundef %4)\n" + -- "%2 = alloca %Craig\n" <> -- " store %Craig %1, ptr %2\n" <> -- " %3 = bitcast %Craig* %2 to i72*\n" <> @@ -394,16 +407,16 @@ emitECased t e cases = do emit $ Store ty val Ptr stackPtr emit $ Br label emit $ Label lbl_failPos --- emitCases rt ty label stackPtr vs (Injection (MIR.CIdent id) exp) = do --- -- //TODO this is pretty disgusting and would heavily benefit from a rewrite --- valPtr <- getNewVar --- emit $ SetVariable valPtr (Alloca rt) --- emit $ Store rt vs Ptr valPtr --- emit $ SetVariable id (Load rt Ptr valPtr) --- increaseVarCount --- val <- exprToValue (fst exp) --- emit $ Store ty val Ptr stackPtr --- emit $ Br label + emitCases rt ty label stackPtr vs (Branch (MIR.PVar (id,_), _) exp) = do + -- //TODO this is pretty disgusting and would heavily benefit from a rewrite + valPtr <- getNewVar + emit $ SetVariable valPtr (Alloca rt) + emit $ Store rt vs Ptr valPtr + emit $ SetVariable id (Load rt Ptr valPtr) + increaseVarCount + val <- exprToValue exp + emit $ Store ty val Ptr stackPtr + emit $ Br label emitCases _ ty label stackPtr _ (Branch (MIR.PCatch, _) exp) = do val <- exprToValue exp emit $ Store ty val Ptr stackPtr diff --git a/src/Main.hs b/src/Main.hs index 7a718ad..59f486d 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -2,41 +2,31 @@ module Main where -import Codegen.Codegen (generateCode) -import Data.Bool (bool) -import GHC.IO.Handle.Text (hPutStrLn) -import Grammar.ErrM (Err) -import Grammar.Par (myLexer, pProgram) -import Grammar.Print (printTree) +import Codegen.Codegen (generateCode) +import Data.Bool (bool) +import GHC.IO.Handle.Text (hPutStrLn) +import Grammar.ErrM (Err) +import Grammar.Par (myLexer, pProgram) +import Grammar.Print (printTree) -import Monomorphizer.Monomorphizer (monomorphize) +import Monomorphizer.Monomorphizer (monomorphize) -import Control.Monad (when) -import Data.List.Extra (isSuffixOf) +import Control.Monad (when) +import Data.List.Extra (isSuffixOf) -import Compiler (compile) -import Renamer.Renamer (rename) -import System.Directory ( - createDirectory, - doesPathExist, - getDirectoryContents, - removeDirectoryRecursive, - setCurrentDirectory, - ) -import System.Environment (getArgs) -import System.Exit ( - ExitCode, - exitFailure, - exitSuccess, - ) -import System.IO (stderr) -import System.Process.Extra ( - readCreateProcess, - shell, - spawnCommand, - waitForProcess, - ) -import TypeChecker.TypeChecker (typecheck) +import Compiler (compile) +import Renamer.Renamer (rename) +import System.Directory (createDirectory, doesPathExist, + getDirectoryContents, + removeDirectoryRecursive, + setCurrentDirectory) +import System.Environment (getArgs) +import System.Exit (ExitCode, exitFailure, + exitSuccess) +import System.IO (stderr) +import System.Process.Extra (readCreateProcess, shell, + spawnCommand, waitForProcess) +import TypeChecker.TypeChecker (typecheck) main :: IO () main = @@ -67,8 +57,7 @@ main' debug s = do -- printToErr "\n -- Compiler --" generatedCode <- fromCompilerErr $ generateCode (monomorphize typechecked) - putStrLn "Generation of code successful" - -- putStrLn generatedCode + putStrLn generatedCode check <- doesPathExist "output" when check (removeDirectoryRecursive "output") diff --git a/src/Monomorphizer/Monomorphizer.hs b/src/Monomorphizer/Monomorphizer.hs index a217b87..4294a2f 100644 --- a/src/Monomorphizer/Monomorphizer.hs +++ b/src/Monomorphizer/Monomorphizer.hs @@ -1,15 +1,14 @@ -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} module Monomorphizer.Monomorphizer (monomorphize) where -import Data.Coerce (coerce) -import Grammar.Abs (Constructor (..), Ident (..)) -import Unsafe.Coerce (unsafeCoerce) +import Data.Coerce (coerce) +import Grammar.Abs (Constructor (..), Ident (..)) -import Grammar.Abs qualified as GA -import Monomorphizer.MonomorphizerIr qualified as M -import TypeChecker.TypeCheckerIr qualified as T +import qualified Grammar.Abs as GA +import qualified Monomorphizer.MonomorphizerIr as M +import qualified TypeChecker.TypeCheckerIr as T monomorphize :: T.Program -> M.Program monomorphize (T.Program ds) = M.Program $ monoDefs ds @@ -19,11 +18,14 @@ monoDefs = map monoDef monoDef :: T.Def -> M.Def monoDef (T.DBind bind) = M.DBind $ monoBind bind -monoDef (T.DData d) = M.DData $ unsafeCoerce d +monoDef (T.DData d) = M.DData $ monoData d monoBind :: T.Bind -> M.Bind monoBind (T.Bind name args (e, t)) = M.Bind (monoId name) (map monoId args) (monoExpr e, monoType t) +monoData :: T.Data -> M.Data +monoData (T.Data (T.Ident id) cs) = M.Data (M.TLit (Ident id)) [] + monoExpr :: T.Exp -> M.Exp monoExpr = \case T.EId (T.Ident i) -> M.EId (Ident i) @@ -35,18 +37,18 @@ monoExpr = \case T.ECase expt injs -> M.ECase (monoexpt expt) (monoInjs injs) monoAbsType :: GA.Type -> M.Type -monoAbsType (GA.TLit u) = M.TLit (coerce u) -monoAbsType (GA.TVar _v) = M.TLit "Int" +monoAbsType (GA.TLit u) = M.TLit (coerce u) +monoAbsType (GA.TVar _v) = M.TLit "Int" monoAbsType (GA.TAll _v _t) = error "NOT ALL TYPES" -monoAbsType (GA.TEVar _v) = error "I DONT KNOW WHAT THIS IS" +monoAbsType (GA.TEVar _v) = error "I DONT KNOW WHAT THIS IS" monoAbsType (GA.TFun t1 t2) = M.TFun (monoAbsType t1) (monoAbsType t2) -monoAbsType (GA.TData _ _) = error "NOT INDEXED TYPES" +monoAbsType (GA.TData _ _) = error "NOT INDEXED TYPES" monoType :: T.Type -> M.Type -monoType (T.TAll _ t) = monoType t -monoType (T.TVar (T.MkTVar i)) = M.TLit "Int" -monoType (T.TLit (T.Ident i)) = M.TLit (Ident i) -monoType (T.TFun t1 t2) = M.TFun (monoType t1) (monoType t2) +monoType (T.TAll _ t) = monoType t +monoType (T.TVar (T.MkTVar i)) = M.TLit "Int" +monoType (T.TLit (T.Ident i)) = M.TLit (Ident i) +monoType (T.TFun t1 t2) = M.TFun (monoType t1) (monoType t2) monoType (T.TData (T.Ident n) t) = M.TLit (Ident (n ++ concatMap show t)) monoexpt :: T.ExpT -> M.ExpT @@ -56,7 +58,7 @@ monoId :: T.Id -> M.Id monoId (n, t) = (coerce n, monoType t) monoLit :: T.Lit -> M.Lit -monoLit (T.LInt i) = M.LInt i +monoLit (T.LInt i) = M.LInt i monoLit (T.LChar c) = M.LChar c monoInjs :: [T.Branch] -> [M.Branch] @@ -66,7 +68,8 @@ monoInj :: T.Branch -> M.Branch monoInj (T.Branch (init, t) expt) = M.Branch (monoInit init, monoType t) (monoexpt expt) monoInit :: T.Pattern -> M.Pattern -monoInit (T.PVar (id, t)) = M.PVar (coerce id, monoType t) +monoInit (T.PVar (id, t)) = M.PVar (coerce id, monoType t) monoInit (T.PLit (lit, t)) = M.PLit (monoLit lit, monoType t) -monoInit (T.PInj id ps) = M.PInj (coerce id) (monoInit <$> ps) -monoInit T.PCatch = M.PCatch +monoInit (T.PInj id ps) = M.PInj (coerce id) (monoInit <$> ps) +monoInit (T.PEnum id) = undefined +monoInit T.PCatch = M.PCatch diff --git a/src/Monomorphizer/MonomorphizerIr.hs b/src/Monomorphizer/MonomorphizerIr.hs index 6214cdc..b961a27 100644 --- a/src/Monomorphizer/MonomorphizerIr.hs +++ b/src/Monomorphizer/MonomorphizerIr.hs @@ -35,7 +35,7 @@ data Branch = Branch (Pattern, Type) ExpT type ExpT = (Exp, Type) -data Constructor = Constructor UIdent [(UIdent, Type)] +data Constructor = Constructor Ident [(Ident, Type)] deriving (Show, Ord, Eq) data Lit From accbd4eea6d5d764b27b5233e111a58316783284 Mon Sep 17 00:00:00 2001 From: sebastian Date: Fri, 24 Mar 2023 22:03:43 +0100 Subject: [PATCH 150/372] dummy monomorphizer complete --- src/Monomorphizer/Monomorphizer.hs | 53 ++++++++++++++-------------- src/Monomorphizer/MonomorphizerIr.hs | 12 +++---- 2 files changed, 33 insertions(+), 32 deletions(-) diff --git a/src/Monomorphizer/Monomorphizer.hs b/src/Monomorphizer/Monomorphizer.hs index 4294a2f..7062b79 100644 --- a/src/Monomorphizer/Monomorphizer.hs +++ b/src/Monomorphizer/Monomorphizer.hs @@ -1,14 +1,12 @@ -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} module Monomorphizer.Monomorphizer (monomorphize) where -import Data.Coerce (coerce) -import Grammar.Abs (Constructor (..), Ident (..)) +import Data.Coerce (coerce) -import qualified Grammar.Abs as GA -import qualified Monomorphizer.MonomorphizerIr as M -import qualified TypeChecker.TypeCheckerIr as T +import Monomorphizer.MonomorphizerIr qualified as M +import TypeChecker.TypeCheckerIr qualified as T monomorphize :: T.Program -> M.Program monomorphize (T.Program ds) = M.Program $ monoDefs ds @@ -18,17 +16,20 @@ monoDefs = map monoDef monoDef :: T.Def -> M.Def monoDef (T.DBind bind) = M.DBind $ monoBind bind -monoDef (T.DData d) = M.DData $ monoData d +monoDef (T.DData d) = M.DData $ monoData d monoBind :: T.Bind -> M.Bind monoBind (T.Bind name args (e, t)) = M.Bind (monoId name) (map monoId args) (monoExpr e, monoType t) monoData :: T.Data -> M.Data -monoData (T.Data (T.Ident id) cs) = M.Data (M.TLit (Ident id)) [] +monoData (T.Data (T.Ident id) cs) = M.Data (M.TLit (M.Ident id)) (map monoConstructor cs) + +monoConstructor :: T.Constructor -> M.Constructor +monoConstructor (T.Constructor (T.Ident i) t) = M.Constructor (M.Ident i) (monoType t) monoExpr :: T.Exp -> M.Exp monoExpr = \case - T.EId (T.Ident i) -> M.EId (Ident i) + T.EId (T.Ident i) -> M.EId (M.Ident i) T.ELit lit -> M.ELit $ monoLit lit T.ELet bind expt -> M.ELet (monoBind bind) (monoexpt expt) T.EApp expt1 expt2 -> M.EApp (monoexpt expt1) (monoexpt expt2) @@ -36,20 +37,19 @@ monoExpr = \case T.EAbs _i _expt -> error "BUG" T.ECase expt injs -> M.ECase (monoexpt expt) (monoInjs injs) -monoAbsType :: GA.Type -> M.Type -monoAbsType (GA.TLit u) = M.TLit (coerce u) -monoAbsType (GA.TVar _v) = M.TLit "Int" -monoAbsType (GA.TAll _v _t) = error "NOT ALL TYPES" -monoAbsType (GA.TEVar _v) = error "I DONT KNOW WHAT THIS IS" -monoAbsType (GA.TFun t1 t2) = M.TFun (monoAbsType t1) (monoAbsType t2) -monoAbsType (GA.TData _ _) = error "NOT INDEXED TYPES" +monoAbsType :: T.Type -> M.Type +monoAbsType (T.TLit u) = M.TLit (coerce u) +monoAbsType (T.TVar _v) = M.TLit "Int" +monoAbsType (T.TAll _v _t) = error "NOT ALL TYPES" +monoAbsType (T.TFun t1 t2) = M.TFun (monoAbsType t1) (monoAbsType t2) +monoAbsType (T.TData _ _) = error "NOT INDEXED TYPES" monoType :: T.Type -> M.Type -monoType (T.TAll _ t) = monoType t -monoType (T.TVar (T.MkTVar i)) = M.TLit "Int" -monoType (T.TLit (T.Ident i)) = M.TLit (Ident i) -monoType (T.TFun t1 t2) = M.TFun (monoType t1) (monoType t2) -monoType (T.TData (T.Ident n) t) = M.TLit (Ident (n ++ concatMap show t)) +monoType (T.TAll _ t) = monoType t +monoType (T.TVar (T.MkTVar i)) = M.TLit "Int" +monoType (T.TLit (T.Ident i)) = M.TLit (M.Ident i) +monoType (T.TFun t1 t2) = M.TFun (monoType t1) (monoType t2) +monoType (T.TData (T.Ident n) t) = M.TLit (M.Ident (n ++ concatMap show t)) monoexpt :: T.ExpT -> M.ExpT monoexpt (e, t) = (monoExpr e, monoType t) @@ -58,7 +58,7 @@ monoId :: T.Id -> M.Id monoId (n, t) = (coerce n, monoType t) monoLit :: T.Lit -> M.Lit -monoLit (T.LInt i) = M.LInt i +monoLit (T.LInt i) = M.LInt i monoLit (T.LChar c) = M.LChar c monoInjs :: [T.Branch] -> [M.Branch] @@ -68,8 +68,9 @@ monoInj :: T.Branch -> M.Branch monoInj (T.Branch (init, t) expt) = M.Branch (monoInit init, monoType t) (monoexpt expt) monoInit :: T.Pattern -> M.Pattern -monoInit (T.PVar (id, t)) = M.PVar (coerce id, monoType t) +monoInit (T.PVar (id, t)) = M.PVar (coerce id, monoType t) monoInit (T.PLit (lit, t)) = M.PLit (monoLit lit, monoType t) -monoInit (T.PInj id ps) = M.PInj (coerce id) (monoInit <$> ps) -monoInit (T.PEnum id) = undefined -monoInit T.PCatch = M.PCatch +monoInit (T.PInj id ps) = M.PInj (coerce id) (monoInit <$> ps) +-- DO NOT DO THIS FOR REAL THOUGH +monoInit (T.PEnum (T.Ident i)) = M.PInj (M.Ident i) [] +monoInit T.PCatch = M.PCatch diff --git a/src/Monomorphizer/MonomorphizerIr.hs b/src/Monomorphizer/MonomorphizerIr.hs index b961a27..76fefbf 100644 --- a/src/Monomorphizer/MonomorphizerIr.hs +++ b/src/Monomorphizer/MonomorphizerIr.hs @@ -1,8 +1,8 @@ module Monomorphizer.MonomorphizerIr (module Monomorphizer.MonomorphizerIr, module RE, module GA) where -import Grammar.Abs (Ident (..), UIdent) -import qualified Grammar.Abs as GA (Ident (..)) -import qualified TypeChecker.TypeCheckerIr as RE +import Grammar.Abs (Ident (..), UIdent) +import Grammar.Abs qualified as GA (Ident (..)) +import TypeChecker.TypeCheckerIr qualified as RE type Id = (Ident, Type) @@ -27,7 +27,7 @@ data Exp | ECase ExpT [Branch] deriving (Show, Ord, Eq) -data Pattern = PVar Id | PLit (Lit, Type) | PInj Ident [Pattern] | PCatch +data Pattern = PVar Id | PLit (Lit, Type) | PInj Ident [Pattern] | PCatch | PEnum Ident deriving (Eq, Ord, Show) data Branch = Branch (Pattern, Type) ExpT @@ -35,7 +35,7 @@ data Branch = Branch (Pattern, Type) ExpT type ExpT = (Exp, Type) -data Constructor = Constructor Ident [(Ident, Type)] +data Constructor = Constructor Ident Type deriving (Show, Ord, Eq) data Lit @@ -48,4 +48,4 @@ data Type = TLit Ident | TFun Type Type flattenType :: Type -> [Type] flattenType (TFun t1 t2) = t1 : flattenType t2 -flattenType x = [x] +flattenType x = [x] From 05333c568909ca694cf155ecba9f1740ff976f55 Mon Sep 17 00:00:00 2001 From: sebastian Date: Sat, 25 Mar 2023 00:02:38 +0100 Subject: [PATCH 151/372] started on cleaner unit tests --- tests/DoStrings.hs | 9 +++ tests/Tests.hs | 162 +++++++++++++++++++-------------------------- 2 files changed, 78 insertions(+), 93 deletions(-) create mode 100644 tests/DoStrings.hs diff --git a/tests/DoStrings.hs b/tests/DoStrings.hs new file mode 100644 index 0000000..9c1ec16 --- /dev/null +++ b/tests/DoStrings.hs @@ -0,0 +1,9 @@ +module DoStrings where + +import Prelude hiding ((>>), (>>=)) + +(>>) :: String -> String -> String +(>>) str1 str2 = str1 ++ "\n" ++ str2 + +(>>=) :: String -> (String -> String) -> String +(>>=) str f = f str diff --git a/tests/Tests.hs b/tests/Tests.hs index bba6216..7a08977 100644 --- a/tests/Tests.hs +++ b/tests/Tests.hs @@ -1,109 +1,85 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} - -{-# HLINT ignore "Use <$>" #-} -{-# HLINT ignore "Use camelCase" #-} +{-# LANGUAGE QualifiedDo #-} +{-# LANGUAGE NoImplicitPrelude #-} module Main where -import Data.Either (isLeft, isRight) -import Data.Map (Map) -import Data.Map qualified as M -import Grammar.Abs +import Control.Monad ((<=<)) +import DoStrings qualified as D +import Grammar.Par (myLexer, pProgram) import Test.Hspec -import Test.QuickCheck -import TypeChecker.TypeChecker -import TypeChecker.TypeCheckerIr ( - Ctx (..), - Env (..), - Error, - Infer, - ) -import TypeChecker.TypeCheckerIr qualified as T +import Prelude (Bool (..), Either (..), IO, fmap, not, ($), (.)) + +-- import Test.QuickCheck +import TypeChecker.TypeChecker (typecheck) main :: IO () main = hspec $ do - infer_elit - infer_eann - infer_eid - infer_eabs - test_id_function + ok1 + ok2 + bad1 + bad2 -infer_elit = describe "algoW used on ELit" $ do - it "infers the type mono Int" $ do - getType (ELit (LInt 0)) `shouldBe` Right (T.TLit "Int") +ok1 = + specify "Basic polymorphism with multiple type variables" $ + run + ( D.do + const + "main = const 'a' 65 ;" + ) + `shouldSatisfy` ok +ok2 = + specify "Head with a correct signature is accepted" $ + run + ( D.do + list + headSig + head + ) + `shouldSatisfy` ok - it "infers the type mono Int" $ do - getType (ELit (LInt 9999)) `shouldBe` Right (T.TLit "Int") +bad1 = + specify "Infinite type unification should not succeed" $ + run + ( D.do + "main = \\x. x x ;" + ) + `shouldSatisfy` bad -infer_eann = describe "algoW used on EAnn" $ do - it "infers the type and checks if the annotated type matches" $ do - getType (EAnn (ELit $ LInt 0) (TLit "Int")) `shouldBe` Right (T.TLit "Int") +bad2 = + specify "Pattern matching using different types should not succeed" $ + run + ( D.do + list + "bad xs = case xs of {" + " 1 => 0 ;" + " Nil => 0 ;" + "};" + ) + `shouldSatisfy` bad - it "fails if the annotated type does not match with the inferred type" $ do - getType (EAnn (ELit $ LInt 0) (TVar $ MkTVar "a")) `shouldSatisfy` isLeft +run = typecheck <=< pProgram . myLexer - it "should be possible to annotate with a more specific type" $ do - let annotated_lambda = EAnn (EAbs "x" (EVar "x")) (TFun (TLit "Int") (TLit "Int")) - in getType annotated_lambda `shouldBe` Right (T.TFun (T.TLit "Int") (T.TLit "Int")) +ok (Right _) = True +ok (Left _) = False - it "should fail if the annotated type is more general than the inferred type" $ do - getType (EAnn (ELit (LInt 0)) (TVar $ MkTVar "a")) `shouldSatisfy` isLeft +bad = not . ok - it "should fail if the annotated type is an arrow but the annotated type is not" $ do - getType (EAnn (EAbs "x" (EVar "x")) (TVar $ MkTVar "a")) `shouldSatisfy` isLeft +-- FUNCTIONS -infer_eid = describe "algoW used on EVar" $ do - it "should fail if the variable is not added to the environment" $ do - property $ \x -> getType (EVar (LIdent (x :: String))) `shouldSatisfy` isLeft +const = D.do + "const : a -> b -> a ;" + "const x y = x ;" +list = D.do + "data List (a) where" + " {" + " Nil : List (a)" + " Cons : a -> List (a) -> List (a)" + " };" - it "should succeed if the type exist in the environment" $ do - property $ \x -> do - let env = Env 0 mempty mempty - let t = T.TVar $ T.MkTVar "a" - let ctx = Ctx (M.singleton (T.Ident (x :: String)) t) - getTypeC env ctx (EVar (LIdent x)) `shouldBe` Right (T.TVar $ T.MkTVar "a") - -infer_eabs = describe "algoW used on EAbs" $ do - it "should infer the argument type as int if the variable is used as an int" $ do - let lambda = EAbs "x" (EAdd (EVar "x") (ELit (LInt 0))) - getType lambda `shouldBe` Right (T.TFun (T.TLit "Int") (T.TLit "Int")) - - it "should infer the argument type as polymorphic if it is not used in the lambda" $ do - let lambda = EAbs "x" (ELit (LInt 0)) - getType lambda `shouldSatisfy` isArrowPolyToMono - - it "should infer a variable as function if used as one" $ do - let lambda = EAbs "f" (EAbs "x" (EApp (EVar "f") (EVar "x"))) - let isOk (Right (T.TFun (T.TFun (T.TVar _) (T.TVar _)) (T.TFun (T.TVar _) (T.TVar _)))) = True - isOk _ = False - getType lambda `shouldSatisfy` isOk - -churf_id :: Bind -churf_id = Bind "id" ["x"] (EVar "x") - -churf_add :: Bind -churf_add = Bind "add" ["x", "y"] (EAdd (EVar "x") (EVar "y")) - -churf_main :: Bind -churf_main = Bind "main" [] (EApp (EApp (EVar "id") (EVar "add")) (ELit (LInt 0))) - -prg = Program [DBind churf_main, DBind churf_add, DBind churf_id] - -test_id_function :: SpecWith () -test_id_function = - describe "typechecking a program with id, add and main, where id is applied to add in main" $ do - it "should succeed to find the correct type" $ do - typecheck prg `shouldSatisfy` isRight - -isArrowPolyToMono :: Either Error T.Type -> Bool -isArrowPolyToMono (Right (T.TFun (T.TVar _) (T.TLit _))) = True -isArrowPolyToMono _ = False - --- | Empty environment -getType :: Exp -> Either Error T.Type -getType e = pure snd <*> run (inferExp e) - --- | Custom environment -getTypeC :: Env -> Ctx -> Exp -> Either Error T.Type -getTypeC env ctx e = pure snd <*> runC env ctx (inferExp e) +headSig = D.do + "head : List (a) -> a ;" +head = D.do + "head xs = " + " case xs of {" + " Cons x xs => x ;" + " };" From 368413515bcfa125729e41c6f05ef93ea42e20e2 Mon Sep 17 00:00:00 2001 From: sebastian Date: Sat, 25 Mar 2023 12:04:00 +0100 Subject: [PATCH 152/372] found incorrectly accepted program. added test --- tests/Tests.hs | 25 +++++++++++++++++++++++++ 1 file changed, 25 insertions(+) diff --git a/tests/Tests.hs b/tests/Tests.hs index 7a08977..55ae9ab 100644 --- a/tests/Tests.hs +++ b/tests/Tests.hs @@ -18,6 +18,7 @@ main = hspec $ do ok2 bad1 bad2 + bad3 ok1 = specify "Basic polymorphism with multiple type variables" $ @@ -57,6 +58,17 @@ bad2 = ) `shouldSatisfy` bad +bad3 = + specify "Using a concrete function on a skolem variable should not succeed" $ + run + ( D.do + bool + _not + "f : a -> Bool () ;" + " f x = not x ;" + ) + `shouldSatisfy` bad + run = typecheck <=< pProgram . myLexer ok (Right _) = True @@ -83,3 +95,16 @@ head = D.do " case xs of {" " Cons x xs => x ;" " };" + +bool = D.do + "data Bool () where {" + " True : Bool ()" + " False : Bool ()" + "};" + +_not = D.do + "not : Bool () -> Bool () ;" + "not x = case x of {" + " True => False ;" + " False => True ;" + "};" From 30824443474e0124df2c86415ee523b225fc9d2d Mon Sep 17 00:00:00 2001 From: sebastian Date: Sat, 25 Mar 2023 18:42:11 +0100 Subject: [PATCH 153/372] fixed bugs potentially. tests are working atleast --- src/TypeChecker/TypeChecker.hs | 62 +++++++++++++++++++++--------- tests/Tests.hs | 70 +++++++++++++++++++++++++++++++++- 2 files changed, 112 insertions(+), 20 deletions(-) diff --git a/src/TypeChecker/TypeChecker.hs b/src/TypeChecker/TypeChecker.hs index 70fb894..152669e 100644 --- a/src/TypeChecker/TypeChecker.hs +++ b/src/TypeChecker/TypeChecker.hs @@ -119,23 +119,45 @@ checkPrg (Program bs) = do checkBind :: Bind -> Infer T.Bind checkBind err@(Bind name args e) = do let lambda = makeLambda e (reverse (coerce args)) - (_, lambdaT) <- inferExp lambda - args <- zip args <$> mapM (const fresh) args - withBindings (map coerce args) $ do - e@(_, _) <- inferExp e - s <- gets sigs - case M.lookup (coerce name) s of - Just (Just t) -> do - sub <- bindErr (unify t lambdaT) err - let newT = apply sub t - insertSig (coerce name) (Just newT) - return $ T.Bind (apply sub (coerce name, newT)) (map coerce args) e - _ -> do - insertSig (coerce name) (Just lambdaT) - return (T.Bind (coerce name, lambdaT) (map coerce args) e) + e@(_, args_t) <- inferExp lambda + -- args <- zip args <$> mapM (const fresh) args + -- withBindings (coerce args) $ do + -- e@(_, t) <- inferExp e + -- let args_t = foldl' T.TFun t (reverse (map snd args)) + s <- gets sigs + case M.lookup (coerce name) s of + Just (Just t') -> do + -- sub <- bindErr (unify args_t t') err + -- let newT = apply sub args_t + -- insertSig (coerce name) (Just newT) + -- return $ T.Bind (apply sub (coerce name, newT)) [] e + unless + (args_t `typeEq` t') + ( throwError $ + "Inferred type '" + ++ printTree args_t + ++ " does not match specified type '" + ++ printTree t' + ++ "'" + ) + return $ T.Bind (coerce name, t') [] e + _ -> do + insertSig (coerce name) (Just args_t) + return (T.Bind (coerce name, args_t) [] e) + +typeEq :: T.Type -> T.Type -> Bool +typeEq (T.TFun l r) (T.TFun l' r') = typeEq l l' && typeEq r r' +typeEq (T.TLit a) (T.TLit b) = a == b +typeEq (T.TData name a) (T.TData name' b) = + length a == length b + && name == name' + && and (zipWith typeEq a b) +typeEq (T.TAll _ t1) (T.TAll _ t2) = t1 `typeEq` t2 +typeEq (T.TVar _) (T.TVar _) = True +typeEq _ _ = False isMoreSpecificOrEq :: T.Type -> T.Type -> Bool -isMoreSpecificOrEq _ (T.TAll _ _) = True +isMoreSpecificOrEq t1 (T.TAll _ t2) = isMoreSpecificOrEq t1 t2 isMoreSpecificOrEq (T.TFun a b) (T.TFun c d) = isMoreSpecificOrEq a c && isMoreSpecificOrEq b d isMoreSpecificOrEq (T.TData n1 ts1) (T.TData n2 ts2) = @@ -224,8 +246,10 @@ algoW = \case sig <- gets sigs case M.lookup (coerce i) sig of Just (Just t) -> return (nullSubst, (T.EId $ coerce i, t)) - Just Nothing -> - (\x -> (nullSubst, (T.EId $ coerce i, x))) <$> fresh + Just Nothing -> do + fr <- fresh + insertSig (coerce i) (Just fr) + return (nullSubst, (T.EId $ coerce i, fr)) Nothing -> throwError $ "Unbound variable: " <> printTree i EInj i -> do constr <- gets constructors @@ -315,15 +339,17 @@ makeLambda = foldl (flip (EAbs . coerce)) -- | Unify two types producing a new substitution unify :: T.Type -> T.Type -> Infer Subst +-- unify t0 t1 | trace ("T0: " ++ show t0 ++ "\nT1: " ++ show t1 ++ "\n") False = undefined unify t0 t1 = do case (t0, t1) of (T.TFun a b, T.TFun c d) -> do s1 <- unify a c s2 <- unify (apply s1 b) (apply s1 d) return $ s1 `compose` s2 - -- TODO: BEWARY. THIS IS PROBABLY WRONG!!! + ----------- TODO: CAREFUL!!!! THIS IS PROBABLY WRONG!!! ----------- (T.TVar (T.MkTVar a), t@(T.TData _ _)) -> return $ M.singleton a t (t@(T.TData _ _), T.TVar (T.MkTVar b)) -> return $ M.singleton b t + ------------------------------------------------------------------- (T.TVar (T.MkTVar a), t) -> occurs a t (t, T.TVar (T.MkTVar b)) -> occurs b t (T.TAll _ t, b) -> unify t b diff --git a/tests/Tests.hs b/tests/Tests.hs index 55ae9ab..99c49e6 100644 --- a/tests/Tests.hs +++ b/tests/Tests.hs @@ -7,7 +7,7 @@ import Control.Monad ((<=<)) import DoStrings qualified as D import Grammar.Par (myLexer, pProgram) import Test.Hspec -import Prelude (Bool (..), Either (..), IO, fmap, not, ($), (.)) +import Prelude (Bool (..), Either (..), IO, not, ($), (.)) -- import Test.QuickCheck import TypeChecker.TypeChecker (typecheck) @@ -16,9 +16,14 @@ main :: IO () main = hspec $ do ok1 ok2 + ok3 + ok4 + ok5 bad1 bad2 bad3 + bad4 + bad5 ok1 = specify "Basic polymorphism with multiple type variables" $ @@ -38,6 +43,41 @@ ok2 = ) `shouldSatisfy` ok +ok3 = + specify "A basic arithmetic function should be able to be inferred" $ + run + ( D.do + "plusOne x = x + 1 ;" + "main x = plusOne x ;" + ) + `shouldBe` run + ( D.do + "plusOne : Int -> Int ;" + "plusOne x = x + 1 ;" + "main : Int -> Int ;" + "main x = plusOne x ;" + ) + +ok4 = + specify "A basic arithmetic function should be able to be inferred" $ + run + ( D.do + "plusOne x = x + 1 ;" + ) + `shouldBe` run + ( D.do + "plusOne : Int -> Int ;" + "plusOne x = x + 1 ;" + ) + +ok5 = + specify "Most simple inference possible" $ + run + ( D.do + "id x = x ;" + ) + `shouldSatisfy` ok + bad1 = specify "Infinite type unification should not succeed" $ run @@ -59,7 +99,7 @@ bad2 = `shouldSatisfy` bad bad3 = - specify "Using a concrete function on a skolem variable should not succeed" $ + specify "Using a concrete function (data type) on a skolem variable should not succeed" $ run ( D.do bool @@ -69,6 +109,26 @@ bad3 = ) `shouldSatisfy` bad +bad4 = + specify "Using a concrete function (primitive type) on a skolem variable should not succeed" $ + run + ( D.do + "plusOne : Int -> Int ;" + "plusOne x = x + 1 ;" + "f : a -> Int ;" + " f x = plusOne x ;" + ) + `shouldSatisfy` bad + +bad5 = + specify "A function without signature used in an incompatible context should not succeed" $ + run + ( D.do + "main = id 1 2 ;" + "id x = x ;" + ) + `shouldSatisfy` bad + run = typecheck <=< pProgram . myLexer ok (Right _) = True @@ -90,6 +150,7 @@ list = D.do headSig = D.do "head : List (a) -> a ;" + head = D.do "head xs = " " case xs of {" @@ -108,3 +169,8 @@ _not = D.do " True => False ;" " False => True ;" "};" + +{- + [a, b, c] | (Int -> Int) + (a -> (b -> (c -> (Int -> Int)))) +-} From 88eaa466e49deef1626af522e115c3f07c826568 Mon Sep 17 00:00:00 2001 From: sebastian Date: Sat, 25 Mar 2023 19:17:46 +0100 Subject: [PATCH 154/372] Nested pattern matching should work correctly, added more tests --- src/TypeChecker/TypeChecker.hs | 6 +-- tests/Tests.hs | 86 ++++++++++++++++------------------ 2 files changed, 44 insertions(+), 48 deletions(-) diff --git a/src/TypeChecker/TypeChecker.hs b/src/TypeChecker/TypeChecker.hs index 152669e..4944071 100644 --- a/src/TypeChecker/TypeChecker.hs +++ b/src/TypeChecker/TypeChecker.hs @@ -339,7 +339,6 @@ makeLambda = foldl (flip (EAbs . coerce)) -- | Unify two types producing a new substitution unify :: T.Type -> T.Type -> Infer Subst --- unify t0 t1 | trace ("T0: " ++ show t0 ++ "\nT1: " ++ show t1 ++ "\n") False = undefined unify t0 t1 = do case (t0, t1) of (T.TFun a b, T.TFun c d) -> do @@ -573,6 +572,7 @@ checkCase expT injs = do inferBranch :: Branch -> Infer (T.Type, T.Branch, T.Type) inferBranch (Branch pat expr) = do newPat@(pat, branchT) <- inferPattern pat + trace ("BRANCH TYPE: " ++ show branchT) pure () newExp@(_, exprT) <- withPattern pat (inferExp expr) return (branchT, T.Branch newPat newExp, exprT) @@ -592,8 +592,8 @@ inferPattern = \case t <- maybeToRightM ("Constructor: " <> printTree constr <> " does not exist") t (vs, ret) <- maybeToRightM "Partial pattern match not allowed" (unsnoc $ flattenType t) patterns <- mapM inferPattern patterns - zipWithM_ unify vs (map snd patterns) - return (T.PInj (coerce constr) (map fst patterns), ret) + sub <- foldl' compose nullSubst <$> zipWithM unify vs (map snd patterns) + return (T.PInj (coerce constr) (map fst patterns), apply sub ret) PCatch -> (T.PCatch,) <$> fresh PEnum p -> do t <- gets (M.lookup (coerce p) . constructors) diff --git a/tests/Tests.hs b/tests/Tests.hs index 99c49e6..c6a92da 100644 --- a/tests/Tests.hs +++ b/tests/Tests.hs @@ -7,34 +7,25 @@ import Control.Monad ((<=<)) import DoStrings qualified as D import Grammar.Par (myLexer, pProgram) import Test.Hspec -import Prelude (Bool (..), Either (..), IO, not, ($), (.)) +import Prelude (Bool (..), Either (..), IO, mapM_, not, ($), (.)) -- import Test.QuickCheck import TypeChecker.TypeChecker (typecheck) main :: IO () -main = hspec $ do - ok1 - ok2 - ok3 - ok4 - ok5 - bad1 - bad2 - bad3 - bad4 - bad5 +main = do + mapM_ hspec goods + mapM_ hspec bads -ok1 = - specify "Basic polymorphism with multiple type variables" $ +goods = + [ specify "Basic polymorphism with multiple type variables" $ run ( D.do const "main = const 'a' 65 ;" ) `shouldSatisfy` ok -ok2 = - specify "Head with a correct signature is accepted" $ + , specify "Head with a correct signature is accepted" $ run ( D.do list @@ -42,9 +33,7 @@ ok2 = head ) `shouldSatisfy` ok - -ok3 = - specify "A basic arithmetic function should be able to be inferred" $ + , specify "A basic arithmetic function should be able to be inferred" $ run ( D.do "plusOne x = x + 1 ;" @@ -57,9 +46,7 @@ ok3 = "main : Int -> Int ;" "main x = plusOne x ;" ) - -ok4 = - specify "A basic arithmetic function should be able to be inferred" $ + , specify "A basic arithmetic function should be able to be inferred" $ run ( D.do "plusOne x = x + 1 ;" @@ -69,25 +56,33 @@ ok4 = "plusOne : Int -> Int ;" "plusOne x = x + 1 ;" ) - -ok5 = - specify "Most simple inference possible" $ + , specify "Most simple inference possible" $ run ( D.do "id x = x ;" ) `shouldSatisfy` ok + , specify "Pattern matching on a nested list" $ + run + ( D.do + list + "main : List (List (a)) -> Int ;" + "main xs = case xs of {" + " Cons Nil _ => 1 ;" + " _ => 0 ;" + "};" + ) + `shouldSatisfy` ok + ] -bad1 = - specify "Infinite type unification should not succeed" $ +bads = + [ specify "Infinite type unification should not succeed" $ run ( D.do "main = \\x. x x ;" ) `shouldSatisfy` bad - -bad2 = - specify "Pattern matching using different types should not succeed" $ + , specify "Pattern matching using different types should not succeed" $ run ( D.do list @@ -97,20 +92,16 @@ bad2 = "};" ) `shouldSatisfy` bad - -bad3 = - specify "Using a concrete function (data type) on a skolem variable should not succeed" $ + , specify "Using a concrete function (data type) on a skolem variable should not succeed" $ run ( D.do bool _not "f : a -> Bool () ;" - " f x = not x ;" + "f x = not x ;" ) `shouldSatisfy` bad - -bad4 = - specify "Using a concrete function (primitive type) on a skolem variable should not succeed" $ + , specify "Using a concrete function (primitive type) on a skolem variable should not succeed" $ run ( D.do "plusOne : Int -> Int ;" @@ -119,15 +110,25 @@ bad4 = " f x = plusOne x ;" ) `shouldSatisfy` bad - -bad5 = - specify "A function without signature used in an incompatible context should not succeed" $ + , specify "A function without signature used in an incompatible context should not succeed" $ run ( D.do "main = id 1 2 ;" "id x = x ;" ) `shouldSatisfy` bad + , specify "Pattern matching on literal and list should not succeed" $ + run + ( D.do + list + "length : List (c) -> Int;" + "length list = case list of {" + " 0 => 0;" + " Cons x xs => 1 + length xs;" + "};" + ) + `shouldSatisfy` bad + ] run = typecheck <=< pProgram . myLexer @@ -169,8 +170,3 @@ _not = D.do " True => False ;" " False => True ;" "};" - -{- - [a, b, c] | (Int -> Int) - (a -> (b -> (c -> (Int -> Int)))) --} From 975dd340630eaa2223144f1ecc276ee6bd17615c Mon Sep 17 00:00:00 2001 From: sebastian Date: Sat, 25 Mar 2023 20:43:19 +0100 Subject: [PATCH 155/372] Better inference & stuff on pattern matches, added more tests for regression --- Justfile | 1 + src/TypeChecker/TypeChecker.hs | 91 +++++++++++++++++----------------- tests/Tests.hs | 66 +++++++++++++++++------- 3 files changed, 94 insertions(+), 64 deletions(-) diff --git a/Justfile b/Justfile index 8079213..7787dc8 100644 --- a/Justfile +++ b/Justfile @@ -5,6 +5,7 @@ build: clean: rm -r src/Grammar rm language + rm -r dist-newstyle/ # run all tests test: diff --git a/src/TypeChecker/TypeChecker.hs b/src/TypeChecker/TypeChecker.hs index 4944071..2b53760 100644 --- a/src/TypeChecker/TypeChecker.hs +++ b/src/TypeChecker/TypeChecker.hs @@ -6,19 +6,19 @@ module TypeChecker.TypeChecker where import Auxiliary import Control.Monad.Except +import Control.Monad.Identity (runIdentity) import Control.Monad.Reader import Control.Monad.State import Data.Bifunctor (second) import Data.Coerce (coerce) import Data.Foldable (traverse_) -import Data.Functor.Identity (runIdentity) import Data.List (foldl') import Data.List.Extra (unsnoc) import Data.Map (Map) import Data.Map qualified as M +import Data.Maybe (fromJust) import Data.Set (Set) import Data.Set qualified as S -import Debug.Trace (trace) import Grammar.Abs import Grammar.Print (printTree) import TypeChecker.TypeCheckerIr ( @@ -117,20 +117,12 @@ checkPrg (Program bs) = do (DSig _) -> checkDef xs checkBind :: Bind -> Infer T.Bind -checkBind err@(Bind name args e) = do +checkBind (Bind name args e) = do let lambda = makeLambda e (reverse (coerce args)) e@(_, args_t) <- inferExp lambda - -- args <- zip args <$> mapM (const fresh) args - -- withBindings (coerce args) $ do - -- e@(_, t) <- inferExp e - -- let args_t = foldl' T.TFun t (reverse (map snd args)) s <- gets sigs case M.lookup (coerce name) s of Just (Just t') -> do - -- sub <- bindErr (unify args_t t') err - -- let newT = apply sub args_t - -- insertSig (coerce name) (Just newT) - -- return $ T.Bind (apply sub (coerce name, newT)) [] e unless (args_t `typeEq` t') ( throwError $ @@ -152,7 +144,8 @@ typeEq (T.TData name a) (T.TData name' b) = length a == length b && name == name' && and (zipWith typeEq a b) -typeEq (T.TAll _ t1) (T.TAll _ t2) = t1 `typeEq` t2 +typeEq (T.TAll _ t1) t2 = t1 `typeEq` t2 +typeEq t1 (T.TAll _ t2) = t1 `typeEq` t2 typeEq (T.TVar _) (T.TVar _) = True typeEq _ _ = False @@ -164,6 +157,7 @@ isMoreSpecificOrEq (T.TData n1 ts1) (T.TData n2 ts2) = n1 == n2 && length ts1 == length ts2 && and (zipWith isMoreSpecificOrEq ts1 ts2) +isMoreSpecificOrEq _ (T.TVar _) = True isMoreSpecificOrEq a b = a == b isPoly :: Type -> Bool @@ -175,10 +169,7 @@ inferExp :: Exp -> Infer T.ExpT inferExp e = do (s, (e', t)) <- algoW e let subbed = apply s t - return $ replace subbed (e', t) - -replace :: T.Type -> T.ExpT -> T.ExpT -replace t = second (const t) + return $ second (const subbed) (e', t) class NewType a b where toNew :: a -> b @@ -200,7 +191,7 @@ instance NewType Data T.Data where toNew (Data t xs) = T.Data (name $ retType t) (toNew xs) where name (TData n _) = coerce n - name _ = error "Bug in toNew Data -> T.Data" + name _ = error "Bug: Data types should not be able to be typed over non type variables" instance NewType Constructor T.Constructor where toNew (Constructor name xs) = T.Constructor (coerce name) (toNew xs) @@ -213,7 +204,6 @@ instance NewType a b => NewType [a] [b] where algoW :: Exp -> Infer (Subst, T.ExpT) algoW = \case - -- \| TODO: More testing need to be done. Unsure of the correctness of this err@(EAnn e t) -> do (s1, (e', t')) <- exprErr (algoW e) err unless @@ -434,6 +424,9 @@ inst = \case compose :: Subst -> Subst -> Subst compose m1 m2 = M.map (apply m1) m2 `M.union` m1 +composeAll :: [Subst] -> Subst +composeAll = foldl' compose nullSubst + -- TODO: Split this class into two separate classes, one for free variables -- and one for applying substitutions @@ -477,21 +470,19 @@ instance SubstType (Map T.Ident T.Type) where apply :: Subst -> Map T.Ident T.Type -> Map T.Ident T.Type apply s = M.map (apply s) -instance SubstType T.ExpT where - apply :: Subst -> T.ExpT -> T.ExpT +instance SubstType T.Exp where + apply :: Subst -> T.Exp -> T.Exp apply s = \case - (T.EId i, outerT) -> (T.EId i, apply s outerT) - (T.ELit lit, t) -> (T.ELit lit, apply s t) - (T.ELet (T.Bind (ident, t1) args e1) e2, t2) -> - ( T.ELet + T.EId i -> T.EId i + T.ELit lit -> T.ELit lit + T.ELet (T.Bind (ident, t1) args e1) e2 -> + T.ELet (T.Bind (ident, apply s t1) args (apply s e1)) (apply s e2) - , apply s t2 - ) - (T.EApp e1 e2, t) -> (T.EApp (apply s e1) (apply s e2), apply s t) - (T.EAdd e1 e2, t) -> (T.EAdd (apply s e1) (apply s e2), apply s t) - (T.EAbs ident e, t1) -> (T.EAbs ident (apply s e), apply s t1) - (T.ECase e brnch, t) -> (T.ECase (apply s e) (apply s brnch), apply s t) + T.EApp e1 e2 -> T.EApp (apply s e1) (apply s e2) + T.EAdd e1 e2 -> T.EAdd (apply s e1) (apply s e2) + T.EAbs ident e -> T.EAbs ident (apply s e) + T.ECase e brnch -> T.ECase (apply s e) (apply s brnch) instance SubstType T.Branch where apply :: Subst -> T.Branch -> T.Branch @@ -509,6 +500,9 @@ instance SubstType T.Pattern where instance SubstType a => SubstType [a] where apply s = map (apply s) +instance (SubstType a, SubstType b) => SubstType (a, b) where + apply s (a, b) = (apply s a, apply s b) + instance SubstType T.Id where apply s (name, t) = (name, apply s t) @@ -548,8 +542,10 @@ insertConstr i t = -------- PATTERN MATCHING --------- checkCase :: T.Type -> [Branch] -> Infer (Subst, [T.Branch], T.Type) -checkCase expT injs = do - (injTs, injs, returns) <- unzip3 <$> mapM inferBranch injs +checkCase _ [] = throwError "Atleast one case required" +checkCase expT brnchs = do + (subs, injTs, injs, returns) <- unzip4 <$> mapM inferBranch brnchs + let sub0 = composeAll subs (sub1, _) <- foldM ( \(sub, acc) x -> @@ -564,17 +560,14 @@ checkCase expT injs = do ) (nullSubst, head returns) (tail returns) - return (sub2 `compose` sub1, injs, returns_type) + let comp = sub2 `compose` sub1 `compose` sub0 + return (comp, apply comp injs, apply comp returns_type) -{- | fst = type of init - | snd = type of expr --} -inferBranch :: Branch -> Infer (T.Type, T.Branch, T.Type) +inferBranch :: Branch -> Infer (Subst, T.Type, T.Branch, T.Type) inferBranch (Branch pat expr) = do newPat@(pat, branchT) <- inferPattern pat - trace ("BRANCH TYPE: " ++ show branchT) pure () - newExp@(_, exprT) <- withPattern pat (inferExp expr) - return (branchT, T.Branch newPat newExp, exprT) + (sub, newExp@(_, exprT)) <- withPattern pat (algoW expr) + return (sub, branchT, T.Branch (apply sub newPat) (apply sub newExp), apply sub exprT) withPattern :: T.Pattern -> Infer a -> Infer a withPattern p ma = case p of @@ -590,14 +583,17 @@ inferPattern = \case PInj constr patterns -> do t <- gets (M.lookup (coerce constr) . constructors) t <- maybeToRightM ("Constructor: " <> printTree constr <> " does not exist") t - (vs, ret) <- maybeToRightM "Partial pattern match not allowed" (unsnoc $ flattenType t) + let numArgs = typeLength t - 1 + let (vs, ret) = fromJust (unsnoc $ flattenType t) patterns <- mapM inferPattern patterns - sub <- foldl' compose nullSubst <$> zipWithM unify vs (map snd patterns) + unless (length patterns == numArgs) (throwError $ "The constructor '" ++ printTree constr ++ "'" ++ " should have " ++ show numArgs ++ " arguments but has been given " ++ show (length patterns)) + sub <- composeAll <$> zipWithM unify vs (map snd patterns) return (T.PInj (coerce constr) (map fst patterns), apply sub ret) PCatch -> (T.PCatch,) <$> fresh PEnum p -> do t <- gets (M.lookup (coerce p) . constructors) t <- maybeToRightM ("Constructor: " <> printTree p <> " does not exist") t + unless (typeLength t == 1) (throwError $ "The constructor '" ++ printTree p ++ "'" ++ " should have " ++ show (typeLength t - 1) ++ " arguments but has been given 0") return (T.PEnum $ coerce p, t) PVar x -> do fr <- fresh @@ -608,6 +604,10 @@ flattenType :: T.Type -> [T.Type] flattenType (T.TFun a b) = flattenType a <> flattenType b flattenType a = [a] +typeLength :: T.Type -> Int +typeLength (T.TFun a b) = typeLength a + typeLength b +typeLength _ = 1 + litType :: Lit -> T.Type litType (LInt _) = int litType (LChar _) = char @@ -629,8 +629,7 @@ partitionType = go [] exprErr :: Infer a -> Exp -> Infer a exprErr ma exp = - catchError ma (\x -> throwError $ x <> " on expression: " <> printTree exp) + catchError ma (\x -> throwError $ x <> " in expression: \n" <> printTree exp) -bindErr :: Infer a -> Bind -> Infer a -bindErr ma exp = - catchError ma (\x -> throwError $ x <> " on expression: " <> printTree exp) +unzip4 :: [(a, b, c, d)] -> ([a], [b], [c], [d]) +unzip4 = foldl' (\(as, bs, cs, ds) (a, b, c, d) -> (as ++ [a], bs ++ [b], cs ++ [c], ds ++ [d])) ([], [], [], []) diff --git a/tests/Tests.hs b/tests/Tests.hs index c6a92da..d1b87a6 100644 --- a/tests/Tests.hs +++ b/tests/Tests.hs @@ -21,16 +21,16 @@ goods = [ specify "Basic polymorphism with multiple type variables" $ run ( D.do - const + _const "main = const 'a' 65 ;" ) `shouldSatisfy` ok , specify "Head with a correct signature is accepted" $ run ( D.do - list - headSig - head + _list + _headSig + _head ) `shouldSatisfy` ok , specify "A basic arithmetic function should be able to be inferred" $ @@ -59,13 +59,13 @@ goods = , specify "Most simple inference possible" $ run ( D.do - "id x = x ;" + _id ) `shouldSatisfy` ok , specify "Pattern matching on a nested list" $ run ( D.do - list + _list "main : List (List (a)) -> Int ;" "main xs = case xs of {" " Cons Nil _ => 1 ;" @@ -73,6 +73,24 @@ goods = "};" ) `shouldSatisfy` ok + , specify "List of function Int -> Int functions should be inferred corretly" $ + run + ( D.do + _list + "main xs = case xs of {" + " Cons f _ => f 1 ;" + " Nil => 0 ;" + " };" + ) + `shouldBe` run + ( D.do + _list + "main : List (Int -> Int) -> Int ;" + "main xs = case xs of {" + " Cons f _ => f 1 ;" + " Nil => 0 ;" + " };" + ) ] bads = @@ -85,7 +103,7 @@ bads = , specify "Pattern matching using different types should not succeed" $ run ( D.do - list + _list "bad xs = case xs of {" " 1 => 0 ;" " Nil => 0 ;" @@ -95,7 +113,7 @@ bads = , specify "Using a concrete function (data type) on a skolem variable should not succeed" $ run ( D.do - bool + _bool _not "f : a -> Bool () ;" "f x = not x ;" @@ -113,21 +131,32 @@ bads = , specify "A function without signature used in an incompatible context should not succeed" $ run ( D.do - "main = id 1 2 ;" - "id x = x ;" + "main = _id 1 2 ;" + "_id x = x ;" ) `shouldSatisfy` bad - , specify "Pattern matching on literal and list should not succeed" $ + , specify "Pattern matching on literal and _list should not succeed" $ run ( D.do - list + _list "length : List (c) -> Int;" - "length list = case list of {" + "length _list = case _list of {" " 0 => 0;" " Cons x xs => 1 + length xs;" "};" ) `shouldSatisfy` bad + , specify "List of function Int -> Int functions should not be usable on Char" $ + run + ( D.do + _list + "main : List (Int -> Int) -> Int ;" + "main xs = case xs of {" + " Cons f _ => f 'a' ;" + " Nil => 0 ;" + " };" + ) + `shouldSatisfy` bad ] run = typecheck <=< pProgram . myLexer @@ -139,26 +168,26 @@ bad = not . ok -- FUNCTIONS -const = D.do +_const = D.do "const : a -> b -> a ;" "const x y = x ;" -list = D.do +_list = D.do "data List (a) where" " {" " Nil : List (a)" " Cons : a -> List (a) -> List (a)" " };" -headSig = D.do +_headSig = D.do "head : List (a) -> a ;" -head = D.do +_head = D.do "head xs = " " case xs of {" " Cons x xs => x ;" " };" -bool = D.do +_bool = D.do "data Bool () where {" " True : Bool ()" " False : Bool ()" @@ -170,3 +199,4 @@ _not = D.do " True => False ;" " False => True ;" "};" +_id = "id x = x ;" From ac43af8110a9563d074fd11209848acbb67bf5d7 Mon Sep 17 00:00:00 2001 From: sebastian Date: Sat, 25 Mar 2023 22:40:15 +0100 Subject: [PATCH 156/372] fixed a substitution bug where `ap` was incorrectly inferred. also added cleaner fresh variables --- cabal.project.local | 2 - cabal.project.local~ | 2 - src/TypeChecker/TypeChecker.hs | 147 +++++++++++----- src/TypeChecker/TypeCheckerIr.hs | 3 + test_program | 35 +++- tests/Tests.hs | 292 ++++++++++++++++--------------- 6 files changed, 287 insertions(+), 194 deletions(-) delete mode 100644 cabal.project.local delete mode 100644 cabal.project.local~ diff --git a/cabal.project.local b/cabal.project.local deleted file mode 100644 index 0432756..0000000 --- a/cabal.project.local +++ /dev/null @@ -1,2 +0,0 @@ -ignore-project: False -tests: True diff --git a/cabal.project.local~ b/cabal.project.local~ deleted file mode 100644 index 40fdf41..0000000 --- a/cabal.project.local~ +++ /dev/null @@ -1,2 +0,0 @@ -ignore-project: False -tests: False diff --git a/src/TypeChecker/TypeChecker.hs b/src/TypeChecker/TypeChecker.hs index 2b53760..9cc37ee 100644 --- a/src/TypeChecker/TypeChecker.hs +++ b/src/TypeChecker/TypeChecker.hs @@ -19,6 +19,7 @@ import Data.Map qualified as M import Data.Maybe (fromJust) import Data.Set (Set) import Data.Set qualified as S +import Debug.Trace (trace) import Grammar.Abs import Grammar.Print (printTree) import TypeChecker.TypeCheckerIr ( @@ -31,8 +32,7 @@ import TypeChecker.TypeCheckerIr ( import TypeChecker.TypeCheckerIr qualified as T initCtx = Ctx mempty - -initEnv = Env 0 mempty mempty +initEnv = Env 0 'a' mempty mempty mempty runPretty :: Exp -> Either Error String runPretty = fmap (printTree . fst) . run . inferExp @@ -82,39 +82,39 @@ retType a = a checkPrg :: Program -> Infer T.Program checkPrg (Program bs) = do preRun bs - -- Type check the program twice to produce all top-level types in the first pass through - _ <- checkDef bs - bs'' <- checkDef bs - return $ T.Program bs'' - where - preRun :: [Def] -> Infer () - preRun [] = return () - preRun (x : xs) = case x of - DSig (Sig n t) -> do - gets (M.member (coerce n) . sigs) - >>= flip - when - ( throwError $ - "Duplicate signatures for function '" - <> printTree n - <> "'" - ) - insertSig (coerce n) (Just $ toNew t) >> preRun xs - DBind (Bind n _ _) -> do - s <- gets sigs - case M.lookup (coerce n) s of - Nothing -> insertSig (coerce n) Nothing >> preRun xs - Just _ -> preRun xs - DData d@(Data _ _) -> checkData d >> preRun xs + bs' <- checkDef bs + return $ T.Program bs' - checkDef :: [Def] -> Infer [T.Def] - checkDef [] = return [] - checkDef (x : xs) = case x of - (DBind b) -> do - b' <- checkBind b - fmap (T.DBind b' :) (checkDef xs) - (DData d) -> fmap (T.DData (toNew d) :) (checkDef xs) - (DSig _) -> checkDef xs +preRun :: [Def] -> Infer () +preRun [] = return () +preRun (x : xs) = case x of + DSig (Sig n t) -> do + collect (collectTypeVars t) + gets (M.member (coerce n) . sigs) + >>= flip + when + ( throwError $ + "Duplicate signatures for function '" + <> printTree n + <> "'" + ) + insertSig (coerce n) (Just $ toNew t) >> preRun xs + DBind (Bind n _ e) -> do + collect (collectTypeVars e) + s <- gets sigs + case M.lookup (coerce n) s of + Nothing -> insertSig (coerce n) Nothing >> preRun xs + Just _ -> preRun xs + DData d@(Data t _) -> collect (collectTypeVars t) >> checkData d >> preRun xs + +checkDef :: [Def] -> Infer [T.Def] +checkDef [] = return [] +checkDef (x : xs) = case x of + (DBind b) -> do + b' <- checkBind b + fmap (T.DBind b' :) (checkDef xs) + (DData d) -> fmap (T.DData (toNew d) :) (checkDef xs) + (DSig _) -> checkDef xs checkBind :: Bind -> Infer T.Bind checkBind (Bind name args e) = do @@ -171,6 +171,23 @@ inferExp e = do let subbed = apply s t return $ second (const subbed) (e', t) +class CollectTVars a where + collectTypeVars :: a -> Set T.Ident + +instance CollectTVars Exp where + collectTypeVars (EAnn e t) = collectTypeVars t `S.union` collectTypeVars e + collectTypeVars _ = S.empty + +instance CollectTVars Type where + collectTypeVars (TVar (MkTVar i)) = S.singleton (coerce i) + collectTypeVars (TAll _ t) = collectTypeVars t + collectTypeVars (TFun t1 t2) = collectTypeVars t1 `S.union` collectTypeVars t2 + collectTypeVars (TData _ ts) = foldl' (\acc x -> acc `S.union` collectTypeVars x) S.empty ts + collectTypeVars _ = S.empty + +collect :: Set T.Ident -> Infer () +collect s = modify (\st -> st{takenTypeVars = s `S.union` takenTypeVars st}) + class NewType a b where toNew :: a -> b @@ -321,8 +338,9 @@ algoW = \case (sub, (e', t)) <- algoW caseExpr (subst, injs, ret_t) <- checkCase t injs let comp = subst `compose` sub - let t' = apply comp ret_t - return (comp, apply comp (T.ECase (e', t) injs, t')) + trace ("EXPR: " ++ show (apply comp t)) pure () + trace ("CASES: " ++ show (apply comp ret_t)) pure () + return (comp, apply comp (T.ECase (e', t) injs, ret_t)) makeLambda :: Exp -> [T.Ident] -> Exp makeLambda = foldl (flip (EAbs . coerce)) @@ -335,7 +353,7 @@ unify t0 t1 = do s1 <- unify a c s2 <- unify (apply s1 b) (apply s1 d) return $ s1 `compose` s2 - ----------- TODO: CAREFUL!!!! THIS IS PROBABLY WRONG!!! ----------- + ----------- TODO: BE CAREFUL!!!! THIS IS PROBABLY WRONG!!! ----------- (T.TVar (T.MkTVar a), t@(T.TData _ _)) -> return $ M.singleton a t (t@(T.TData _ _), T.TVar (T.MkTVar b)) -> return $ M.singleton b t ------------------------------------------------------------------- @@ -517,9 +535,24 @@ nullSubst = M.empty -- | Generate a new fresh variable and increment the state counter fresh :: Infer T.Type fresh = do + c <- gets nextChar n <- gets count - modify (\st -> st{count = n + 1}) - return . T.TVar . T.MkTVar . T.Ident $ show n + taken <- gets takenTypeVars + if c == 'z' + then do + modify (\st -> st{count = succ (count st), nextChar = 'a'}) + else modify (\st -> st{nextChar = next (nextChar st)}) + if coerce [c] `S.member` taken + then do + fresh + else + if n == 0 + then return . T.TVar . T.MkTVar . T.Ident $ [c] + else return . T.TVar . T.MkTVar . T.Ident $ [c] ++ show n + +next :: Char -> Char +next 'z' = 'a' +next a = succ a -- | Run the monadic action with an additional binding withBinding :: (Monad m, MonadReader Ctx m) => T.Ident -> T.Type -> m a -> m a @@ -567,7 +600,7 @@ inferBranch :: Branch -> Infer (Subst, T.Type, T.Branch, T.Type) inferBranch (Branch pat expr) = do newPat@(pat, branchT) <- inferPattern pat (sub, newExp@(_, exprT)) <- withPattern pat (algoW expr) - return (sub, branchT, T.Branch (apply sub newPat) (apply sub newExp), apply sub exprT) + return (sub, apply sub branchT, T.Branch (apply sub newPat) (apply sub newExp), apply sub exprT) withPattern :: T.Pattern -> Infer a -> Infer a withPattern p ma = case p of @@ -586,15 +619,36 @@ inferPattern = \case let numArgs = typeLength t - 1 let (vs, ret) = fromJust (unsnoc $ flattenType t) patterns <- mapM inferPattern patterns - unless (length patterns == numArgs) (throwError $ "The constructor '" ++ printTree constr ++ "'" ++ " should have " ++ show numArgs ++ " arguments but has been given " ++ show (length patterns)) + unless + (length patterns == numArgs) + ( throwError $ + "The constructor '" + ++ printTree constr + ++ "'" + ++ " should have " + ++ show numArgs + ++ " arguments but has been given " + ++ show (length patterns) + ) sub <- composeAll <$> zipWithM unify vs (map snd patterns) return (T.PInj (coerce constr) (map fst patterns), apply sub ret) PCatch -> (T.PCatch,) <$> fresh PEnum p -> do t <- gets (M.lookup (coerce p) . constructors) t <- maybeToRightM ("Constructor: " <> printTree p <> " does not exist") t - unless (typeLength t == 1) (throwError $ "The constructor '" ++ printTree p ++ "'" ++ " should have " ++ show (typeLength t - 1) ++ " arguments but has been given 0") - return (T.PEnum $ coerce p, t) + unless + (typeLength t == 1) + ( throwError $ + "The constructor '" + ++ printTree p + ++ "'" + ++ " should have " + ++ show (typeLength t - 1) + ++ " arguments but has been given 0" + ) + let (T.TData _data _ts) = t -- nasty nasty + frs <- mapM (const fresh) _ts + return (T.PEnum $ coerce p, T.TData _data frs) PVar x -> do fr <- fresh let pvar = T.PVar (coerce x, fr) @@ -632,4 +686,9 @@ exprErr ma exp = catchError ma (\x -> throwError $ x <> " in expression: \n" <> printTree exp) unzip4 :: [(a, b, c, d)] -> ([a], [b], [c], [d]) -unzip4 = foldl' (\(as, bs, cs, ds) (a, b, c, d) -> (as ++ [a], bs ++ [b], cs ++ [c], ds ++ [d])) ([], [], [], []) +unzip4 = + foldl' + ( \(as, bs, cs, ds) (a, b, c, d) -> + (as ++ [a], bs ++ [b], cs ++ [c], ds ++ [d]) + ) + ([], [], [], []) diff --git a/src/TypeChecker/TypeCheckerIr.hs b/src/TypeChecker/TypeCheckerIr.hs index 692fec8..f2419d5 100644 --- a/src/TypeChecker/TypeCheckerIr.hs +++ b/src/TypeChecker/TypeCheckerIr.hs @@ -10,6 +10,7 @@ import Control.Monad.State import Data.Char (isDigit) import Data.Functor.Identity (Identity) import Data.Map (Map) +import Data.Set (Set) import Data.String qualified import Grammar.Print import Prelude @@ -20,8 +21,10 @@ newtype Ctx = Ctx {vars :: Map Ident Type} data Env = Env { count :: Int + , nextChar :: Char , sigs :: Map Ident (Maybe Type) , constructors :: Map Ident Type + , takenTypeVars :: Set Ident } deriving (Show) diff --git a/test_program b/test_program index b43a99a..ac209ea 100644 --- a/test_program +++ b/test_program @@ -1,9 +1,28 @@ -data Bool () where { - True : Bool () - False : Bool () - }; +data Maybe (a) where { + Nothing : Maybe (a) + Just : a -> Maybe (a) + }; -main = case True of { - True => 1; - False => 0; - }; +fmap : (a -> b) -> Maybe (a) -> Maybe (b) ; +fmap f ma = case ma of { + Nothing => Nothing ; + Just a => Just (f a) ; +}; + +pure : a -> Maybe (a) ; +pure x = Just x ; + +ap mf ma = case mf of { + Just f => case ma of { + Nothing => Nothing; + Just a => Just (f a); + }; + Nothing => Nothing; +}; + +return = pure; + +bind ma f = case ma of { + Nothing => Nothing ; + Just a => f a ; +}; diff --git a/tests/Tests.hs b/tests/Tests.hs index d1b87a6..eb28db8 100644 --- a/tests/Tests.hs +++ b/tests/Tests.hs @@ -16,149 +16,153 @@ main :: IO () main = do mapM_ hspec goods mapM_ hspec bads + mapM_ hspec bes goods = - [ specify "Basic polymorphism with multiple type variables" $ - run - ( D.do - _const - "main = const 'a' 65 ;" - ) - `shouldSatisfy` ok - , specify "Head with a correct signature is accepted" $ - run - ( D.do - _list - _headSig - _head - ) - `shouldSatisfy` ok - , specify "A basic arithmetic function should be able to be inferred" $ - run - ( D.do - "plusOne x = x + 1 ;" - "main x = plusOne x ;" - ) - `shouldBe` run - ( D.do - "plusOne : Int -> Int ;" - "plusOne x = x + 1 ;" - "main : Int -> Int ;" - "main x = plusOne x ;" - ) - , specify "A basic arithmetic function should be able to be inferred" $ - run - ( D.do - "plusOne x = x + 1 ;" - ) - `shouldBe` run - ( D.do - "plusOne : Int -> Int ;" - "plusOne x = x + 1 ;" - ) - , specify "Most simple inference possible" $ - run - ( D.do - _id - ) - `shouldSatisfy` ok - , specify "Pattern matching on a nested list" $ - run - ( D.do - _list - "main : List (List (a)) -> Int ;" - "main xs = case xs of {" - " Cons Nil _ => 1 ;" - " _ => 0 ;" - "};" - ) - `shouldSatisfy` ok - , specify "List of function Int -> Int functions should be inferred corretly" $ - run - ( D.do - _list - "main xs = case xs of {" - " Cons f _ => f 1 ;" - " Nil => 0 ;" - " };" - ) - `shouldBe` run - ( D.do - _list - "main : List (Int -> Int) -> Int ;" - "main xs = case xs of {" - " Cons f _ => f 1 ;" - " Nil => 0 ;" - " };" - ) + [ testSatisfy + "Basic polymorphism with multiple type variables" + ( D.do + _const + "main = const 'a' 65 ;" + ) + ok + , testSatisfy + "Head with a correct signature is accepted" + ( D.do + _List + _headSig + _head + ) + ok + , testSatisfy + "Most simple inference possible" + ( D.do + _id + ) + ok + , testSatisfy + "Pattern matching on a nested list" + ( D.do + _List + "main : List (List (a)) -> Int ;" + "main xs = case xs of {" + " Cons Nil _ => 1 ;" + " _ => 0 ;" + "};" + ) + ok ] bads = - [ specify "Infinite type unification should not succeed" $ - run - ( D.do - "main = \\x. x x ;" - ) - `shouldSatisfy` bad - , specify "Pattern matching using different types should not succeed" $ - run - ( D.do - _list - "bad xs = case xs of {" - " 1 => 0 ;" - " Nil => 0 ;" - "};" - ) - `shouldSatisfy` bad - , specify "Using a concrete function (data type) on a skolem variable should not succeed" $ - run - ( D.do - _bool - _not - "f : a -> Bool () ;" - "f x = not x ;" - ) - `shouldSatisfy` bad - , specify "Using a concrete function (primitive type) on a skolem variable should not succeed" $ - run - ( D.do - "plusOne : Int -> Int ;" - "plusOne x = x + 1 ;" - "f : a -> Int ;" - " f x = plusOne x ;" - ) - `shouldSatisfy` bad - , specify "A function without signature used in an incompatible context should not succeed" $ - run - ( D.do - "main = _id 1 2 ;" - "_id x = x ;" - ) - `shouldSatisfy` bad - , specify "Pattern matching on literal and _list should not succeed" $ - run - ( D.do - _list - "length : List (c) -> Int;" - "length _list = case _list of {" - " 0 => 0;" - " Cons x xs => 1 + length xs;" - "};" - ) - `shouldSatisfy` bad - , specify "List of function Int -> Int functions should not be usable on Char" $ - run - ( D.do - _list - "main : List (Int -> Int) -> Int ;" - "main xs = case xs of {" - " Cons f _ => f 'a' ;" - " Nil => 0 ;" - " };" - ) - `shouldSatisfy` bad + [ testSatisfy + "Infinite type unification should not succeed" + ( D.do + "main = \\x. x x ;" + ) + bad + , testSatisfy + "Pattern matching using different types should not succeed" + ( D.do + _List + "bad xs = case xs of {" + " 1 => 0 ;" + " Nil => 0 ;" + "};" + ) + bad + , testSatisfy + "Using a concrete function (data type) on a skolem variable should not succeed" + ( D.do + _Bool + _not + "f : a -> Bool () ;" + "f x = not x ;" + ) + bad + , testSatisfy + "Using a concrete function (primitive type) on a skolem variable should not succeed" + ( D.do + "plusOne : Int -> Int ;" + "plusOne x = x + 1 ;" + "f : a -> Int ;" + "f x = plusOne x ;" + ) + bad + , testSatisfy + "A function without signature used in an incompatible context should not succeed" + ( D.do + "main = _id 1 2 ;" + "_id x = x ;" + ) + bad + , testSatisfy + "Pattern matching on literal and _List should not succeed" + ( D.do + _List + "length : List (c) -> Int;" + "length _List = case _List of {" + " 0 => 0;" + " Cons x xs => 1 + length xs;" + "};" + ) + bad + , testSatisfy + "List of function Int -> Int functions should not be usable on Char" + ( D.do + _List + "main : List (Int -> Int) -> Int ;" + "main xs = case xs of {" + " Cons f _ => f 'a' ;" + " Nil => 0 ;" + " };" + ) + bad ] +bes = + [ testBe + "A basic arithmetic function should be able to be inferred" + ( D.do + "plusOne x = x + 1 ;" + "main x = plusOne x ;" + ) + ( D.do + "plusOne : Int -> Int ;" + "plusOne x = x + 1 ;" + "main : Int -> Int ;" + "main x = plusOne x ;" + ) + , testBe + "A basic arithmetic function should be able to be inferred" + ( D.do + "plusOne x = x + 1 ;" + ) + ( D.do + "plusOne : Int -> Int ;" + "plusOne x = x + 1 ;" + ) + , testBe + "List of function Int -> Int functions should be inferred corretly" + ( D.do + _List + "main xs = case xs of {" + " Cons f _ => f 1 ;" + " Nil => 0 ;" + " };" + ) + ( D.do + _List + "main : List (Int -> Int) -> Int ;" + "main xs = case xs of {" + " Cons f _ => f 1 ;" + " Nil => 0 ;" + " };" + ) + ] + +testSatisfy desc test satisfaction = specify desc $ run test `shouldSatisfy` satisfaction +testBe desc test shouldbe = specify desc $ run test `shouldBe` run shouldbe + run = typecheck <=< pProgram . myLexer ok (Right _) = True @@ -171,7 +175,7 @@ bad = not . ok _const = D.do "const : a -> b -> a ;" "const x y = x ;" -_list = D.do +_List = D.do "data List (a) where" " {" " Nil : List (a)" @@ -187,7 +191,7 @@ _head = D.do " Cons x xs => x ;" " };" -_bool = D.do +_Bool = D.do "data Bool () where {" " True : Bool ()" " False : Bool ()" @@ -200,3 +204,15 @@ _not = D.do " False => True ;" "};" _id = "id x = x ;" + +_Maybe = D.do + "data Maybe (a) where {" + " Nothing : Maybe (a)" + " Just : a -> Maybe (a)" + " };" + +_fmap = D.do + "fmap f ma = case ma of {" + " Nothing => Nothing ;" + " Just a => Just (f a) ;" + "};" From d49e2401bfff517e65d6ee5ba3536e71b3620bba Mon Sep 17 00:00:00 2001 From: sebastian Date: Sun, 26 Mar 2023 00:09:47 +0100 Subject: [PATCH 157/372] added file suffix and check --- src/Main.hs | 65 ++++++++++++++++++++------------ test_program => test_program.chf | 2 + 2 files changed, 42 insertions(+), 25 deletions(-) rename test_program => test_program.chf (99%) diff --git a/src/Main.hs b/src/Main.hs index 59f486d..3bb12d4 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -2,38 +2,53 @@ module Main where -import Codegen.Codegen (generateCode) -import Data.Bool (bool) -import GHC.IO.Handle.Text (hPutStrLn) -import Grammar.ErrM (Err) -import Grammar.Par (myLexer, pProgram) -import Grammar.Print (printTree) +import Codegen.Codegen (generateCode) +import Data.Bool (bool) +import GHC.IO.Handle.Text (hPutStrLn) +import Grammar.ErrM (Err) +import Grammar.Par (myLexer, pProgram) +import Grammar.Print (printTree) -import Monomorphizer.Monomorphizer (monomorphize) +import Monomorphizer.Monomorphizer (monomorphize) -import Control.Monad (when) -import Data.List.Extra (isSuffixOf) +import Control.Monad (when) +import Data.List.Extra (isSuffixOf) -import Compiler (compile) -import Renamer.Renamer (rename) -import System.Directory (createDirectory, doesPathExist, - getDirectoryContents, - removeDirectoryRecursive, - setCurrentDirectory) -import System.Environment (getArgs) -import System.Exit (ExitCode, exitFailure, - exitSuccess) -import System.IO (stderr) -import System.Process.Extra (readCreateProcess, shell, - spawnCommand, waitForProcess) -import TypeChecker.TypeChecker (typecheck) +import Compiler (compile) +import Renamer.Renamer (rename) +import System.Directory ( + createDirectory, + doesPathExist, + getDirectoryContents, + removeDirectoryRecursive, + setCurrentDirectory, + ) +import System.Environment (getArgs) +import System.Exit ( + ExitCode, + exitFailure, + exitSuccess, + ) +import System.IO (stderr) +import System.Process.Extra ( + readCreateProcess, + shell, + spawnCommand, + waitForProcess, + ) +import TypeChecker.TypeChecker (typecheck) main :: IO () main = getArgs >>= \case - [] -> print "Required file path missing" - ("-d" : s : _) -> main' True s - (s : _) -> main' False s + [] -> putStrLn "Required file path missing" + ["-d", s] -> do + when (".crf" `isSuffixOf` s) (main' True s) + putStrLn $ "File '" ++ s ++ "' is not a churf file" + [s] -> do + when (".crf" `isSuffixOf` s) (main' False s) + putStrLn $ "File '" ++ s ++ "' is not a churf file" + xs -> putStrLn $ "Can't process: " ++ unwords xs main' :: Bool -> String -> IO () main' debug s = do diff --git a/test_program b/test_program.chf similarity index 99% rename from test_program rename to test_program.chf index ac209ea..ccc6291 100644 --- a/test_program +++ b/test_program.chf @@ -26,3 +26,5 @@ bind ma f = case ma of { Nothing => Nothing ; Just a => f a ; }; + + From 2974c10c0c62cc8dbe03840b9ed9ff17278f47f0 Mon Sep 17 00:00:00 2001 From: sebastian Date: Sun, 26 Mar 2023 00:13:10 +0100 Subject: [PATCH 158/372] moved tests --- language.cabal | 2 +- tests/{ => TypecheckingHM}/DoStrings.hs | 0 tests/{ => TypecheckingHM}/Tests.hs | 0 3 files changed, 1 insertion(+), 1 deletion(-) rename tests/{ => TypecheckingHM}/DoStrings.hs (100%) rename tests/{ => TypecheckingHM}/Tests.hs (100%) diff --git a/language.cabal b/language.cabal index 66932e1..9783156 100644 --- a/language.cabal +++ b/language.cabal @@ -72,7 +72,7 @@ Test-suite language-testsuite Renamer.Renamer Compiler - hs-source-dirs: src, tests + hs-source-dirs: src, tests, tests/TypecheckingHM build-depends: base >=4.16 diff --git a/tests/DoStrings.hs b/tests/TypecheckingHM/DoStrings.hs similarity index 100% rename from tests/DoStrings.hs rename to tests/TypecheckingHM/DoStrings.hs diff --git a/tests/Tests.hs b/tests/TypecheckingHM/Tests.hs similarity index 100% rename from tests/Tests.hs rename to tests/TypecheckingHM/Tests.hs From 213741407bb65499a673845247096d674f1eb346 Mon Sep 17 00:00:00 2001 From: sebastian Date: Sun, 26 Mar 2023 00:41:26 +0100 Subject: [PATCH 159/372] small add to Justfile --- Justfile | 9 ++------- 1 file changed, 2 insertions(+), 7 deletions(-) diff --git a/Justfile b/Justfile index 7787dc8..2e2f216 100644 --- a/Justfile +++ b/Justfile @@ -1,5 +1,7 @@ +# build from scratch build: bnfc -o src -d Grammar.cf + cabal install --installdir=. --overwrite-policy=always # clean the generated directories clean: @@ -11,13 +13,6 @@ clean: test: cabal test -ctest: - cabal run language sample-programs/basic-1 - cabal run language sample-programs/basic-2 - cabal run language sample-programs/basic-3 - cabal run language sample-programs/basic-4 - cabal run language sample-programs/basic-5 - # compile a specific file run FILE: cabal run language {{FILE}} From 2af7855a77aebfb868246236831ee4f4eaa2de96 Mon Sep 17 00:00:00 2001 From: sebastian Date: Sun, 26 Mar 2023 14:12:09 +0200 Subject: [PATCH 160/372] documented 3 bugs --- src/TypeChecker/Bugs.md | 29 +++++++++++++++++++++++++++++ test_program.chf | 30 ------------------------------ test_program.crf | 28 ++++++++++++++++++++++++++++ 3 files changed, 57 insertions(+), 30 deletions(-) create mode 100644 src/TypeChecker/Bugs.md delete mode 100644 test_program.chf create mode 100644 test_program.crf diff --git a/src/TypeChecker/Bugs.md b/src/TypeChecker/Bugs.md new file mode 100644 index 0000000..b111435 --- /dev/null +++ b/src/TypeChecker/Bugs.md @@ -0,0 +1,29 @@ +# Bugs + +## Using uninstantiated type variables + +Program below should not type check + +```hs +data Test (a) where { + Test : b -> Test (a) + }; +``` + +## Duplicate definitions of functions + +Program below should not type check + +```hs +id x = x ; +id x = x ; +``` + +## What? + +Program below should not type check + +```hs +main : a -> b ; +main x = x; +``` diff --git a/test_program.chf b/test_program.chf deleted file mode 100644 index ccc6291..0000000 --- a/test_program.chf +++ /dev/null @@ -1,30 +0,0 @@ -data Maybe (a) where { - Nothing : Maybe (a) - Just : a -> Maybe (a) - }; - -fmap : (a -> b) -> Maybe (a) -> Maybe (b) ; -fmap f ma = case ma of { - Nothing => Nothing ; - Just a => Just (f a) ; -}; - -pure : a -> Maybe (a) ; -pure x = Just x ; - -ap mf ma = case mf of { - Just f => case ma of { - Nothing => Nothing; - Just a => Just (f a); - }; - Nothing => Nothing; -}; - -return = pure; - -bind ma f = case ma of { - Nothing => Nothing ; - Just a => f a ; -}; - - diff --git a/test_program.crf b/test_program.crf new file mode 100644 index 0000000..0c7ce1e --- /dev/null +++ b/test_program.crf @@ -0,0 +1,28 @@ +-- data Maybe (a) where { +-- Nothing : Maybe (a) +-- Just : a -> Maybe (a) +-- }; + +-- fmap : (a -> b) -> Maybe (a) -> Maybe (b) ; +-- fmap f ma = case ma of { +-- Nothing => Nothing ; +-- Just a => Just (f a) ; +-- }; + +-- pure : a -> Maybe (a) ; +-- pure x = Just x ; + +-- ap mf ma = case mf of { +-- Just f => case ma of { +-- Nothing => Nothing; +-- Just a => Just (f a); +-- }; +-- Nothing => Nothing; +-- }; + +-- return = pure; + +-- bind ma f = case ma of { +-- Nothing => Nothing ; +-- Just a => f a ; +-- }; From 4e92f86d60fc25ac4968f61c8dd6eb5cae6748b9 Mon Sep 17 00:00:00 2001 From: sebastian Date: Sun, 26 Mar 2023 16:57:34 +0200 Subject: [PATCH 161/372] added test for bug. experimented with solutions, none found --- src/TypeChecker/TypeChecker.hs | 15 ++++++++++----- 1 file changed, 10 insertions(+), 5 deletions(-) diff --git a/src/TypeChecker/TypeChecker.hs b/src/TypeChecker/TypeChecker.hs index 9cc37ee..8b7625e 100644 --- a/src/TypeChecker/TypeChecker.hs +++ b/src/TypeChecker/TypeChecker.hs @@ -12,6 +12,7 @@ import Control.Monad.State import Data.Bifunctor (second) import Data.Coerce (coerce) import Data.Foldable (traverse_) +import Data.Function (on) import Data.List (foldl') import Data.List.Extra (unsnoc) import Data.Map (Map) @@ -149,6 +150,12 @@ typeEq t1 (T.TAll _ t2) = t1 `typeEq` t2 typeEq (T.TVar _) (T.TVar _) = True typeEq _ _ = False +skolem :: T.Type -> T.Type +skolem (T.TVar (T.MkTVar a)) = T.TLit a +skolem (T.TAll x t) = T.TAll x (skolem t) +skolem (T.TFun t1 t2) = (T.TFun `on` skolem) t1 t2 +skolem t = t + isMoreSpecificOrEq :: T.Type -> T.Type -> Bool isMoreSpecificOrEq t1 (T.TAll _ t2) = isMoreSpecificOrEq t1 t2 isMoreSpecificOrEq (T.TFun a b) (T.TFun c d) = @@ -181,7 +188,7 @@ instance CollectTVars Exp where instance CollectTVars Type where collectTypeVars (TVar (MkTVar i)) = S.singleton (coerce i) collectTypeVars (TAll _ t) = collectTypeVars t - collectTypeVars (TFun t1 t2) = collectTypeVars t1 `S.union` collectTypeVars t2 + collectTypeVars (TFun t1 t2) = (S.union `on` collectTypeVars) t1 t2 collectTypeVars (TData _ ts) = foldl' (\acc x -> acc `S.union` collectTypeVars x) S.empty ts collectTypeVars _ = S.empty @@ -195,7 +202,7 @@ instance NewType Type T.Type where toNew = \case TLit i -> T.TLit $ coerce i TVar v -> T.TVar $ toNew v - TFun t1 t2 -> T.TFun (toNew t1) (toNew t2) + TFun t1 t2 -> (T.TFun `on` toNew) t1 t2 TAll b t -> T.TAll (toNew b) (toNew t) TData i ts -> T.TData (coerce i) (map toNew ts) TEVar _ -> error "Should not exist after typechecker" @@ -414,10 +421,8 @@ occurs i t = -- | Generalize a type over all free variables in the substitution set generalize :: Map T.Ident T.Type -> T.Type -> T.Type -generalize env t = go freeVars $ removeForalls t +generalize env t = go (S.toList $ free t S.\\ free env) (removeForalls t) where - freeVars :: [T.Ident] - freeVars = S.toList $ free t S.\\ free env go :: [T.Ident] -> T.Type -> T.Type go [] t = t go (x : xs) t = T.TAll (T.MkTVar x) (go xs t) From ebac8697618350345d002d7b1fc058b45c0555a2 Mon Sep 17 00:00:00 2001 From: Samuel Hammersberg Date: Sun, 26 Mar 2023 18:24:12 +0200 Subject: [PATCH 162/372] Fixed a type error in teh codegen. --- src/Codegen/Codegen.hs | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/src/Codegen/Codegen.hs b/src/Codegen/Codegen.hs index 601387d..188c4f5 100644 --- a/src/Codegen/Codegen.hs +++ b/src/Codegen/Codegen.hs @@ -79,8 +79,8 @@ getFunctions bs = Map.fromList $ go bs ( \(Constructor id xs) -> ( (coerce id, MIR.TLit (extractTypeName n)) , FunctionInfo - { numArgs = length xs - , arguments = createArgs (snd <$> xs) + { numArgs = length (flattenType xs) + , arguments = createArgs (flattenType xs) } ) ) @@ -105,8 +105,8 @@ getConstructors bs = Map.fromList $ go bs ( \(acc, i) (Constructor (GA.Ident id) xs) -> ( ( (GA.Ident (n <> "_" <> id), MIR.TLit (coerce n)) , ConstructorInfo - { numArgsCI = length xs - , argumentsCI = createArgs (snd <$> xs) + { numArgsCI = length (flattenType xs) + , argumentsCI = createArgs (flattenType xs) , numCI = i } ) @@ -267,7 +267,7 @@ compileScs (MIR.DData (MIR.Data typ ts) : xs) = do emit $ LIR.Type (Ident outer_id) [I8, Array biggestVariant I8] mapM_ ( \(Constructor (GA.Ident inner_id) fi) -> do - emit $ LIR.Type (GA.Ident $ outer_id <> "_" <> inner_id) (I8 : map type2LlvmType (snd <$> fi)) + emit $ LIR.Type (GA.Ident $ outer_id <> "_" <> inner_id) (I8 : map type2LlvmType (flattenType fi)) ) ts compileScs xs From 9ea3a3dc56f1d12ac768bf1ffcd2dbf362f03d5e Mon Sep 17 00:00:00 2001 From: Samuel Hammersberg Date: Sun, 26 Mar 2023 18:37:55 +0200 Subject: [PATCH 163/372] Added another bug. --- src/TypeChecker/Bugs.md | 36 ++++++++++++++++++++++++++++++++++++ 1 file changed, 36 insertions(+) diff --git a/src/TypeChecker/Bugs.md b/src/TypeChecker/Bugs.md index b111435..2eefcc0 100644 --- a/src/TypeChecker/Bugs.md +++ b/src/TypeChecker/Bugs.md @@ -27,3 +27,39 @@ Program below should not type check main : a -> b ; main x = x; ``` + +## Bugged error message +```hs +data Maybe () where { + Nothing : Maybe + Just : Int -> Maybe + }; + +fmap : (Int -> Int) -> Maybe -> Maybe ; +fmap f ma = case ma of { + Nothing => Nothing ; + Just a => Just (f a) ; +}; + +pure : Int -> Maybe ; +pure x = Just x ; + +ap mf ma = case mf of { + Just f => case ma of { + Nothing => Nothing; + Just a => Just (f a); + }; + Nothing => Nothing; +}; + +return = pure; + +bind ma f = case ma of { + Nothing => Nothing ; + Just a => f a ; +}; +``` +``` +TYPECHECKER ERROR +Inferred type '("c" -> "Int") -> "Maybe" -> "Maybe" does not match specified type '("Int" -> "Int") -> "Maybe" -> "Maybe"' +``` \ No newline at end of file From ccfae195416fa7e750a72a657f332f81266e37b2 Mon Sep 17 00:00:00 2001 From: Samuel Hammersberg Date: Sun, 26 Mar 2023 18:38:07 +0200 Subject: [PATCH 164/372] Added .crf to every sample-program --- sample-programs/{basic-1 => basic-1.crf} | 0 sample-programs/{basic-2 => basic-2.crf} | 0 sample-programs/{basic-3 => basic-3.crf} | 0 sample-programs/{basic-4 => basic-4.crf} | 0 sample-programs/{basic-5 => basic-5.crf} | 0 sample-programs/{basic-6 => basic-6.crf} | 0 sample-programs/{basic-7 => basic-7.crf} | 0 sample-programs/{basic-8 => basic-8.crf} | 0 sample-programs/{basic-9 => basic-9.crf} | 0 test_program.crf | 46 ++++++++++++------------ 10 files changed, 23 insertions(+), 23 deletions(-) rename sample-programs/{basic-1 => basic-1.crf} (100%) rename sample-programs/{basic-2 => basic-2.crf} (100%) rename sample-programs/{basic-3 => basic-3.crf} (100%) rename sample-programs/{basic-4 => basic-4.crf} (100%) rename sample-programs/{basic-5 => basic-5.crf} (100%) rename sample-programs/{basic-6 => basic-6.crf} (100%) rename sample-programs/{basic-7 => basic-7.crf} (100%) rename sample-programs/{basic-8 => basic-8.crf} (100%) rename sample-programs/{basic-9 => basic-9.crf} (100%) diff --git a/sample-programs/basic-1 b/sample-programs/basic-1.crf similarity index 100% rename from sample-programs/basic-1 rename to sample-programs/basic-1.crf diff --git a/sample-programs/basic-2 b/sample-programs/basic-2.crf similarity index 100% rename from sample-programs/basic-2 rename to sample-programs/basic-2.crf diff --git a/sample-programs/basic-3 b/sample-programs/basic-3.crf similarity index 100% rename from sample-programs/basic-3 rename to sample-programs/basic-3.crf diff --git a/sample-programs/basic-4 b/sample-programs/basic-4.crf similarity index 100% rename from sample-programs/basic-4 rename to sample-programs/basic-4.crf diff --git a/sample-programs/basic-5 b/sample-programs/basic-5.crf similarity index 100% rename from sample-programs/basic-5 rename to sample-programs/basic-5.crf diff --git a/sample-programs/basic-6 b/sample-programs/basic-6.crf similarity index 100% rename from sample-programs/basic-6 rename to sample-programs/basic-6.crf diff --git a/sample-programs/basic-7 b/sample-programs/basic-7.crf similarity index 100% rename from sample-programs/basic-7 rename to sample-programs/basic-7.crf diff --git a/sample-programs/basic-8 b/sample-programs/basic-8.crf similarity index 100% rename from sample-programs/basic-8 rename to sample-programs/basic-8.crf diff --git a/sample-programs/basic-9 b/sample-programs/basic-9.crf similarity index 100% rename from sample-programs/basic-9 rename to sample-programs/basic-9.crf diff --git a/test_program.crf b/test_program.crf index 0c7ce1e..1977b7e 100644 --- a/test_program.crf +++ b/test_program.crf @@ -1,28 +1,28 @@ --- data Maybe (a) where { --- Nothing : Maybe (a) --- Just : a -> Maybe (a) --- }; +data Maybe () where { + Nothing : Maybe + Just : Int -> Maybe + }; --- fmap : (a -> b) -> Maybe (a) -> Maybe (b) ; --- fmap f ma = case ma of { --- Nothing => Nothing ; --- Just a => Just (f a) ; --- }; +fmap : (Int -> Int) -> Maybe -> Maybe ; +fmap f ma = case ma of { + Nothing => Nothing ; + Just a => Just (f a) ; +}; --- pure : a -> Maybe (a) ; --- pure x = Just x ; +pure : Int -> Maybe ; +pure x = Just x ; --- ap mf ma = case mf of { --- Just f => case ma of { --- Nothing => Nothing; --- Just a => Just (f a); --- }; --- Nothing => Nothing; --- }; +ap mf ma = case mf of { + Just f => case ma of { + Nothing => Nothing; + Just a => Just (f a); + }; + Nothing => Nothing; +}; --- return = pure; +return = pure; --- bind ma f = case ma of { --- Nothing => Nothing ; --- Just a => f a ; --- }; +bind ma f = case ma of { + Nothing => Nothing ; + Just a => f a ; +}; From c37db414312d71123381e345d4bb9520012c335d Mon Sep 17 00:00:00 2001 From: sebastian Date: Sun, 26 Mar 2023 18:52:25 +0200 Subject: [PATCH 165/372] fixed bug --- src/TypeChecker/TypeChecker.hs | 10 ++++------ tests/TypecheckingHM/Tests.hs | 13 +++++++++++++ 2 files changed, 17 insertions(+), 6 deletions(-) diff --git a/src/TypeChecker/TypeChecker.hs b/src/TypeChecker/TypeChecker.hs index 8b7625e..7e7f17f 100644 --- a/src/TypeChecker/TypeChecker.hs +++ b/src/TypeChecker/TypeChecker.hs @@ -50,7 +50,7 @@ typecheck = run . checkPrg checkData :: Data -> Infer () checkData d = do case d of - (Data typ@(TData name ts) constrs) -> do + (Data typ@(TData _ ts) constrs) -> do unless (all isPoly ts) (throwError $ unwords ["Data type incorrectly declared"]) @@ -62,7 +62,7 @@ checkData d = do throwError $ unwords [ "return type of constructor:" - , printTree name + , printTree name' , "with type:" , printTree (retType t') , "does not match data: " @@ -345,8 +345,6 @@ algoW = \case (sub, (e', t)) <- algoW caseExpr (subst, injs, ret_t) <- checkCase t injs let comp = subst `compose` sub - trace ("EXPR: " ++ show (apply comp t)) pure () - trace ("CASES: " ++ show (apply comp ret_t)) pure () return (comp, apply comp (T.ECase (e', t) injs, ret_t)) makeLambda :: Exp -> [T.Ident] -> Exp @@ -635,8 +633,8 @@ inferPattern = \case ++ " arguments but has been given " ++ show (length patterns) ) - sub <- composeAll <$> zipWithM unify vs (map snd patterns) - return (T.PInj (coerce constr) (map fst patterns), apply sub ret) + sub <- composeAll <$> zipWithM unify (map snd patterns) vs + return (T.PInj (coerce constr) (apply sub (map fst patterns)), apply sub ret) PCatch -> (T.PCatch,) <$> fresh PEnum p -> do t <- gets (M.lookup (coerce p) . constructors) diff --git a/tests/TypecheckingHM/Tests.hs b/tests/TypecheckingHM/Tests.hs index eb28db8..b5d14c6 100644 --- a/tests/TypecheckingHM/Tests.hs +++ b/tests/TypecheckingHM/Tests.hs @@ -117,6 +117,19 @@ bads = " };" ) bad + , testSatisfy + "id with incorrect signature" + ( D.do + "id : a -> b;" + "id x = x;" + ) + bad + , testSatisfy + "incorrect type signature on id lambda" + ( D.do + "id = ((\\x. x) : a -> b);" + ) + bad ] bes = From 9952eb02796f36fda2e866761999f803721546bc Mon Sep 17 00:00:00 2001 From: Samuel Hammersberg Date: Sun, 26 Mar 2023 21:10:20 +0200 Subject: [PATCH 166/372] Fixed the printing of TypeCheckerIr --- src/TypeChecker/TypeCheckerIr.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/TypeChecker/TypeCheckerIr.hs b/src/TypeChecker/TypeCheckerIr.hs index f2419d5..74dc649 100644 --- a/src/TypeChecker/TypeCheckerIr.hs +++ b/src/TypeChecker/TypeCheckerIr.hs @@ -86,7 +86,7 @@ data Bind = Bind Id [Id] ExpT deriving (C.Eq, C.Ord, C.Show, C.Read) instance Print Ident where - prt _ (Ident str) = prt 0 str + prt _ (Ident str) = doc . showString $ str instance Print [Def] where prt _ [] = concatD [] From 91cfb21a356b1e2f5f3c1223e5df2496ca18d299 Mon Sep 17 00:00:00 2001 From: Samuel Hammersberg Date: Sun, 26 Mar 2023 22:21:44 +0200 Subject: [PATCH 167/372] Almost got a lot of bugs fixed. --- src/Codegen/Codegen.hs | 124 ++++++++++++++++++++--------------------- src/Codegen/LlvmIr.hs | 8 ++- src/Main.hs | 60 +++++++++----------- test_program.crf | 45 ++++++++------- 4 files changed, 114 insertions(+), 123 deletions(-) diff --git a/src/Codegen/Codegen.hs b/src/Codegen/Codegen.hs index 188c4f5..1a1ef63 100644 --- a/src/Codegen/Codegen.hs +++ b/src/Codegen/Codegen.hs @@ -14,6 +14,7 @@ import Data.Map (Map) import qualified Data.Map as Map import Data.Maybe (fromJust, fromMaybe) import Data.Tuple.Extra (dupe, first, second) +import Debug.Trace (trace) import qualified Grammar.Abs as GA import Grammar.ErrM (Err) import Monomorphizer.MonomorphizerIr as MIR @@ -22,7 +23,7 @@ import Monomorphizer.MonomorphizerIr as MIR data CodeGenerator = CodeGenerator { instructions :: [LLVMIr] , functions :: Map MIR.Id FunctionInfo - , constructors :: Map MIR.Id ConstructorInfo + , constructors :: Map GA.Ident ConstructorInfo , variableCount :: Integer , labelCount :: Integer } @@ -36,9 +37,10 @@ data FunctionInfo = FunctionInfo } deriving (Show) data ConstructorInfo = ConstructorInfo - { numArgsCI :: Int - , argumentsCI :: [Id] - , numCI :: Integer + { numArgsCI :: Int + , argumentsCI :: [Id] + , numCI :: Integer + , returnTypeCI :: MIR.Type } deriving (Show) @@ -56,7 +58,7 @@ getVarCount = gets variableCount -- | Increases the variable count and returns it from the CodeGenerator state getNewVar :: CompilerState GA.Ident -getNewVar = (GA.Ident . show) <$> (increaseVarCount >> getVarCount) +getNewVar = GA.Ident . show <$> (increaseVarCount >> getVarCount) -- | Increses the label count and returns a label from the CodeGenerator state getNewLabel :: CompilerState Integer @@ -74,18 +76,7 @@ getFunctions bs = Map.fromList $ go bs go (MIR.DBind (MIR.Bind id args _) : xs) = (id, FunctionInfo{numArgs = length args, arguments = args}) : go xs - go (MIR.DData (MIR.Data n cons) : xs) = - do map - ( \(Constructor id xs) -> - ( (coerce id, MIR.TLit (extractTypeName n)) - , FunctionInfo - { numArgs = length (flattenType xs) - , arguments = createArgs (flattenType xs) - } - ) - ) - cons - <> go xs + go (_ : xs) = go xs createArgs :: [MIR.Type] -> [Id] createArgs xs = fst $ foldl (\(acc, l) t -> (acc ++ [(GA.Ident ("arg_" <> show l), t)], l + 1)) ([], 0) xs @@ -93,21 +84,20 @@ createArgs xs = fst $ foldl (\(acc, l) t -> (acc ++ [(GA.Ident ("arg_" <> show l {- | Produces a map of functions infos from a list of binds, which contains useful data for code generation. -} -getConstructors :: [MIR.Def] -> Map MIR.Id ConstructorInfo +getConstructors :: [MIR.Def] -> Map GA.Ident ConstructorInfo getConstructors bs = Map.fromList $ go bs where go [] = [] go (MIR.DData (MIR.Data t cons) : xs) = - do - let (GA.Ident n) = extractTypeName t fst ( foldl - ( \(acc, i) (Constructor (GA.Ident id) xs) -> - ( ( (GA.Ident (n <> "_" <> id), MIR.TLit (coerce n)) + ( \(acc, i) (Constructor id xs) -> + ( ( id , ConstructorInfo - { numArgsCI = length (flattenType xs) - , argumentsCI = createArgs (flattenType xs) + { numArgsCI = length (init . flattenType $ xs) + , argumentsCI = createArgs (init . flattenType $ xs) , numCI = i + , returnTypeCI = t --last . flattenType $ xs } ) : acc @@ -183,11 +173,13 @@ generateCode (MIR.Program scs) = do compileScs :: [MIR.Def] -> CompilerState () compileScs [] = do + emit $ UnsafeRaw "\n" -- as a last step create all the constructors -- //TODO maybe merge this with the data type match? c <- gets (Map.toList . constructors) mapM_ - ( \((id, t), ci) -> do + ( \(id, ci) -> do + let t = returnTypeCI ci let t' = type2LlvmType t let x = BI.second type2LlvmType <$> argumentsCI ci emit $ Define FastCC t' id x @@ -213,9 +205,6 @@ compileScs [] = do ptr' <- getNewVar emit $ SetVariable ptr' (Bitcast (Ref t') (VIdent top Ptr) (Ref $ CustomType id)) - -- emit $ UnsafeRaw "\n" - - -- warning this segfaults!! enumerateOneM_ ( \i (GA.Ident arg_n, arg_t) -> do let arg_t' = type2LlvmType arg_t @@ -237,14 +226,13 @@ compileScs [] = do ) (argumentsCI ci) - -- emit $ UnsafeRaw "\n" - -- load and return the constructed value emit $ Comment "Return the newly constructed value" load <- getNewVar emit $ SetVariable load (Load t' Ptr top) emit $ Ret t' (VIdent load t') emit DefineEnd + emit $ UnsafeRaw "\n" modify $ \s -> s{variableCount = 0} ) @@ -263,11 +251,12 @@ compileScs (MIR.DBind (MIR.Bind (name, _t) args exp) : xs) = do compileScs xs compileScs (MIR.DData (MIR.Data typ ts) : xs) = do let (Ident outer_id) = extractTypeName typ - let biggestVariant = 1--maximum (sum . (\(Constructor _ t) -> typeByteSize . type2LlvmType . snd <$> t) <$> ts) + let variantTypes fi = init $ map type2LlvmType (flattenType fi) + let biggestVariant = maximum (sum . (\(Constructor _ fi) -> typeByteSize <$> variantTypes fi) <$> ts) emit $ LIR.Type (Ident outer_id) [I8, Array biggestVariant I8] mapM_ - ( \(Constructor (GA.Ident inner_id) fi) -> do - emit $ LIR.Type (GA.Ident $ outer_id <> "_" <> inner_id) (I8 : map type2LlvmType (flattenType fi)) + ( \(Constructor inner_id fi) -> do + emit $ LIR.Type inner_id (I8 : variantTypes fi) ) ts compileScs xs @@ -348,7 +337,7 @@ emitECased t e cases = do emitCases :: LLVMType -> LLVMType -> GA.Ident -> GA.Ident -> LLVMValue -> Branch -> CompilerState () emitCases rt ty label stackPtr vs (Branch (MIR.PInj consId cs, t) exp) = do cons <- gets constructors - let r = fromJust $ Map.lookup (coerce consId, t) cons + let r = fromJust $ Map.lookup consId cons lbl_failPos <- (\x -> GA.Ident $ "failed_" <> show x) <$> getNewLabel lbl_succPos <- (\x -> GA.Ident $ "success_" <> show x) <$> getNewLabel @@ -362,35 +351,38 @@ emitECased t e cases = do emit $ Label lbl_succPos castPtr <- getNewVar - castedPtr <- getNewVar casted <- getNewVar emit $ SetVariable castPtr (Alloca rt) emit $ Store rt vs Ptr castPtr - emit $ SetVariable castedPtr (Bitcast Ptr (VIdent castPtr Ptr) Ptr) - emit $ SetVariable casted (Load (CustomType (coerce consId)) Ptr castedPtr) + emit $ SetVariable casted (Load (CustomType (coerce consId)) Ptr castPtr) val <- exprToValue exp - -- enumerateOneM_ - -- (\i c -> do - -- case c of - -- CIdent x -> do - -- emit . Comment $ "ident " <> show x - -- emit $ SetVariable x (ExtractValue (CustomType (fst consId)) (VIdent casted Ptr) i) - -- emit $ Store ty val Ptr stackPtr - -- CCons x cs -> error "nested constructor" - -- CLit l -> do - -- testVar <- getNewVar - -- emit $ SetVariable testVar (ExtractValue (CustomType (fst consId)) (VIdent casted Ptr) i) - -- case l of - -- LInt l -> emit $ Icmp LLEq I64 (VIdent testVar Ptr) (VInteger l) - -- LChar c -> emit $ Icmp LLEq I8 (VIdent testVar Ptr) (VChar c) - -- CCatch -> emit . Comment $ "Catch all" - -- emit . Comment $ "return this " <> toIr val - -- emit . Comment . show $ c - -- emit . Comment . show $ i - -- ) - -- cs - -- emit $ Store ty val Ptr stackPtr + enumerateOneM_ + (\i c -> do + case c of + PVar x -> do + emit . Comment $ "ident " <> show x + emit $ SetVariable (fst x) (ExtractValue (CustomType (coerce consId)) (VIdent casted Ptr) i) + PLit (l, t) -> undefined + PInj id ps -> undefined + PCatch -> undefined + PEnum id -> undefined + --case c of + -- CIdent x -> do + -- emit . Comment $ "ident " <> show x + -- emit $ SetVariable x (ExtractValue (CustomType (fst consId)) (VIdent casted Ptr) i) + -- emit $ Store ty val Ptr stackPtr + -- CCons x cs -> error "nested constructor" + -- CLit l -> do + -- testVar <- getNewVar + -- emit $ SetVariable testVar (ExtractValue (CustomType (fst consId)) (VIdent casted Ptr) i) + -- case l of + -- LInt l -> emit $ Icmp LLEq I64 (VIdent testVar Ptr) (VInteger l) + -- LChar c -> emit $ Icmp LLEq I8 (VIdent testVar Ptr) (VChar c) + -- CCatch -> emit . Comment $ "Catch all" + ) + cs + emit $ Store ty val Ptr stackPtr emit $ Br label emit $ Label lbl_failPos emitCases rt ty label stackPtr vs (Branch (MIR.PLit i, _) exp) = do @@ -417,6 +409,10 @@ emitECased t e cases = do val <- exprToValue exp emit $ Store ty val Ptr stackPtr emit $ Br label + emitCases rt ty label stackPtr vs (Branch (MIR.PEnum id, _) exp) = do + val <- exprToValue exp + emit $ Store ty val Ptr stackPtr + emit $ Br label emitCases _ ty label stackPtr _ (Branch (MIR.PCatch, _) exp) = do val <- exprToValue exp emit $ Store ty val Ptr stackPtr @@ -435,13 +431,13 @@ emitLet xs e = do ] emitApp :: MIR.Type -> ExpT -> ExpT -> CompilerState () -emitApp t e1 e2 = appEmitter e1 e2 [] +emitApp rt e1 e2 = appEmitter e1 e2 [] where appEmitter :: ExpT -> ExpT -> [ExpT] -> CompilerState () appEmitter e1 e2 stack = do let newStack = e2 : stack case e1 of - (MIR.EApp e1' e2', t) -> appEmitter e1' e2' newStack + (MIR.EApp e1' e2', _) -> appEmitter e1' e2' newStack (MIR.EId name, t) -> do args <- traverse exprToValue newStack vs <- getNewVar @@ -449,11 +445,13 @@ emitApp t e1 e2 = appEmitter e1 e2 [] consts <- gets constructors let visibility = fromMaybe Local $ - Global <$ Map.lookup (name, t) consts - <|> Global <$ Map.lookup (name,t) funcs + Global <$ Map.lookup name consts + <|> + Global <$ Map.lookup (name, t) funcs -- this piece of code could probably be improved, i.e remove the double `const Global` args' = map (first valueGetType . dupe) args - call = Call FastCC (type2LlvmType t) visibility name args' + call = Call FastCC (type2LlvmType rt) visibility name args' + emit $ Comment $ show rt emit $ SetVariable vs call x -> error $ "The unspeakable happened: " <> show x diff --git a/src/Codegen/LlvmIr.hs b/src/Codegen/LlvmIr.hs index 41ab538..3c11ae1 100644 --- a/src/Codegen/LlvmIr.hs +++ b/src/Codegen/LlvmIr.hs @@ -14,7 +14,7 @@ module Codegen.LlvmIr ( import Data.List (intercalate) import Grammar.Abs (Ident (..)) -data CallingConvention = TailCC | FastCC | CCC | ColdCC +data CallingConvention = TailCC | FastCC | CCC | ColdCC deriving Show instance ToIr CallingConvention where toIr :: CallingConvention -> String toIr TailCC = "tailcc" @@ -33,6 +33,7 @@ data LLVMType | Function LLVMType [LLVMType] | Array Integer LLVMType | CustomType Ident + deriving Show class ToIr a where toIr :: a -> String @@ -61,6 +62,7 @@ data LLVMComp | LLSge | LLSlt | LLSle + deriving Show instance ToIr LLVMComp where toIr :: LLVMComp -> String toIr = \case @@ -75,7 +77,7 @@ instance ToIr LLVMComp where LLSlt -> "slt" LLSle -> "sle" -data Visibility = Local | Global +data Visibility = Local | Global deriving Show instance ToIr Visibility where toIr :: Visibility -> String toIr Local = "%" @@ -89,6 +91,7 @@ data LLVMValue | VIdent Ident LLVMType | VConstant String | VFunction Ident Visibility LLVMType + deriving Show instance ToIr LLVMValue where toIr :: LLVMValue -> String @@ -132,6 +135,7 @@ data LLVMIr | Comment String | UnsafeRaw String -- This should generally be avoided, and proper -- instructions should be used in its place + deriving Show -- | Converts a list of LLVMIr instructions to a string llvmIrToString :: [LLVMIr] -> String diff --git a/src/Main.hs b/src/Main.hs index 3bb12d4..77e9087 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -2,41 +2,31 @@ module Main where -import Codegen.Codegen (generateCode) -import Data.Bool (bool) -import GHC.IO.Handle.Text (hPutStrLn) -import Grammar.ErrM (Err) -import Grammar.Par (myLexer, pProgram) -import Grammar.Print (printTree) +import Codegen.Codegen (generateCode) +import Data.Bool (bool) +import GHC.IO.Handle.Text (hPutStrLn) +import Grammar.ErrM (Err) +import Grammar.Par (myLexer, pProgram) +import Grammar.Print (printTree) -import Monomorphizer.Monomorphizer (monomorphize) +import Monomorphizer.Monomorphizer (monomorphize) -import Control.Monad (when) -import Data.List.Extra (isSuffixOf) +import Control.Monad (when) +import Data.List.Extra (isSuffixOf) -import Compiler (compile) -import Renamer.Renamer (rename) -import System.Directory ( - createDirectory, - doesPathExist, - getDirectoryContents, - removeDirectoryRecursive, - setCurrentDirectory, - ) -import System.Environment (getArgs) -import System.Exit ( - ExitCode, - exitFailure, - exitSuccess, - ) -import System.IO (stderr) -import System.Process.Extra ( - readCreateProcess, - shell, - spawnCommand, - waitForProcess, - ) -import TypeChecker.TypeChecker (typecheck) +import Compiler (compile) +import Renamer.Renamer (rename) +import System.Directory (createDirectory, doesPathExist, + getDirectoryContents, + removeDirectoryRecursive, + setCurrentDirectory) +import System.Environment (getArgs) +import System.Exit (ExitCode, exitFailure, + exitSuccess) +import System.IO (stderr) +import System.Process.Extra (readCreateProcess, shell, + spawnCommand, waitForProcess) +import TypeChecker.TypeChecker (typecheck) main :: IO () main = @@ -70,15 +60,15 @@ main' debug s = do -- let lifted = lambdaLift typechecked -- printToErr $ printTree lifted -- - printToErr "\n -- Compiler --" + --printToErr "\n -- Compiler --" generatedCode <- fromCompilerErr $ generateCode (monomorphize typechecked) - putStrLn generatedCode + --putStrLn generatedCode check <- doesPathExist "output" when check (removeDirectoryRecursive "output") createDirectory "output" when debug $ do - writeFile "output/llvm.ll" generatedCode + _ <- writeFile "output/llvm.ll" generatedCode debugDotViz compile generatedCode diff --git a/test_program.crf b/test_program.crf index 1977b7e..bd3538d 100644 --- a/test_program.crf +++ b/test_program.crf @@ -1,28 +1,27 @@ data Maybe () where { - Nothing : Maybe - Just : Int -> Maybe + Nothing : Maybe () + Just : Int -> Maybe () }; -fmap : (Int -> Int) -> Maybe -> Maybe ; -fmap f ma = case ma of { - Nothing => Nothing ; - Just a => Just (f a) ; +-- fmap : (Int -> Int) -> Maybe () -> Maybe () ; +-- fmap f ma = case ma of { +-- Nothing => Nothing ; +-- Just a => Just (f a) ; +-- }; + +main = case (Just 5) of { + Just a => a ; + Nothing => 1 ; + _ => 66 ; }; -pure : Int -> Maybe ; -pure x = Just x ; - -ap mf ma = case mf of { - Just f => case ma of { - Nothing => Nothing; - Just a => Just (f a); - }; - Nothing => Nothing; -}; - -return = pure; - -bind ma f = case ma of { - Nothing => Nothing ; - Just a => f a ; -}; +-- pure : Int -> Maybe () ; +-- pure x = Just x ; +-- +-- return = pure; +-- +-- bind : Maybe () -> (Int -> Maybe ()) -> Maybe () ; +-- bind ma f = case ma of { +-- Nothing => Nothing ; +-- Just a => f a ; +-- }; From 5062356cefe508bf395a15c19feab024e008d445 Mon Sep 17 00:00:00 2001 From: Samuel Hammersberg Date: Mon, 27 Mar 2023 10:05:39 +0200 Subject: [PATCH 168/372] Fixed broken padding on datatypes. --- src/Codegen/Codegen.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Codegen/Codegen.hs b/src/Codegen/Codegen.hs index 1a1ef63..ea187fc 100644 --- a/src/Codegen/Codegen.hs +++ b/src/Codegen/Codegen.hs @@ -252,7 +252,7 @@ compileScs (MIR.DBind (MIR.Bind (name, _t) args exp) : xs) = do compileScs (MIR.DData (MIR.Data typ ts) : xs) = do let (Ident outer_id) = extractTypeName typ let variantTypes fi = init $ map type2LlvmType (flattenType fi) - let biggestVariant = maximum (sum . (\(Constructor _ fi) -> typeByteSize <$> variantTypes fi) <$> ts) + let biggestVariant = 7 + maximum (sum . (\(Constructor _ fi) -> typeByteSize <$> variantTypes fi) <$> ts) emit $ LIR.Type (Ident outer_id) [I8, Array biggestVariant I8] mapM_ ( \(Constructor inner_id fi) -> do From 582747a997d2c069f0fa9acdd5f0d030276cd042 Mon Sep 17 00:00:00 2001 From: Samuel Hammersberg Date: Mon, 27 Mar 2023 10:07:04 +0200 Subject: [PATCH 169/372] The created binary is now saved in the output folder. --- src/Compiler.hs | 2 +- src/Main.hs | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Compiler.hs b/src/Compiler.hs index 489387a..180914f 100644 --- a/src/Compiler.hs +++ b/src/Compiler.hs @@ -16,7 +16,7 @@ optimize :: String -> IO String optimize = readCreateProcess (shell "opt --O3 -S") compileClang :: String -> IO String -compileClang = readCreateProcess (shell "clang -x ir -o hello_world -") +compileClang = readCreateProcess (shell "clang -x ir -o output/hello_world -") compile :: String -> IO String compile s = optimize s >>= compileClang diff --git a/src/Main.hs b/src/Main.hs index 77e9087..16f1442 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -72,7 +72,7 @@ main' debug s = do debugDotViz compile generatedCode - spawnWait "./hello_world" + spawnWait "./output/hello_world" -- interpred <- fromInterpreterErr $ interpret lifted -- putStrLn "\n-- interpret" -- print interpred From bd3cf3c3f12cd74aa0e02e3cad717aaf1473290e Mon Sep 17 00:00:00 2001 From: Samuel Hammersberg Date: Mon, 27 Mar 2023 13:40:18 +0200 Subject: [PATCH 170/372] Fixed simple pattern matching. --- Justfile | 2 +- src/Codegen/Codegen.hs | 9 ++++++++- src/Monomorphizer/MonomorphizerIr.hs | 12 ++++++------ test_program.crf | 5 ++--- 4 files changed, 17 insertions(+), 11 deletions(-) diff --git a/Justfile b/Justfile index 2e2f216..d804399 100644 --- a/Justfile +++ b/Justfile @@ -15,4 +15,4 @@ test: # compile a specific file run FILE: - cabal run language {{FILE}} + cabal run language -- -d {{FILE}} diff --git a/src/Codegen/Codegen.hs b/src/Codegen/Codegen.hs index ea187fc..041671d 100644 --- a/src/Codegen/Codegen.hs +++ b/src/Codegen/Codegen.hs @@ -300,8 +300,10 @@ defaultStart :: [LLVMIr] defaultStart = [ UnsafeRaw "target triple = \"x86_64-pc-linux-gnu\"\n" , UnsafeRaw "target datalayout = \"e-m:o-i64:64-f80:128-n8:16:32:64-S128\"\n" - , UnsafeRaw "@.str = private unnamed_addr constant [3 x i8] c\"%x\n\", align 1\n" + , UnsafeRaw "@.str = private unnamed_addr constant [3 x i8] c\"%i\n\", align 1\n" + , UnsafeRaw "@.non_exhaustive_patterns = private unnamed_addr constant [41 x i8] c\"Non-exhaustive patterns in case at %i:%i\n\"" , UnsafeRaw "declare i32 @printf(ptr noalias nocapture, ...)\n" + , UnsafeRaw "declare i32 @exit(i32)\n" ] compileExp :: ExpT -> CompilerState () @@ -330,6 +332,11 @@ emitECased t e cases = do stackPtr <- getNewVar emit $ SetVariable stackPtr (Alloca ty) mapM_ (emitCases rt ty label stackPtr vs) cs + emit . UnsafeRaw $ "call i32 (ptr, ...) @printf(ptr noundef @.non_exhaustive_patterns, i64 noundef 6, i64 noundef 6)\n" + emit . UnsafeRaw $ "call i32 @exit(i32 1)\n" + emit . UnsafeRaw $ "unreachable\n" + increaseVarCount >> increaseVarCount >> increaseVarCount + emit $ Br label emit $ Label label res <- getNewVar emit $ SetVariable res (Load ty Ptr stackPtr) diff --git a/src/Monomorphizer/MonomorphizerIr.hs b/src/Monomorphizer/MonomorphizerIr.hs index 76fefbf..e0e7383 100644 --- a/src/Monomorphizer/MonomorphizerIr.hs +++ b/src/Monomorphizer/MonomorphizerIr.hs @@ -1,8 +1,7 @@ -module Monomorphizer.MonomorphizerIr (module Monomorphizer.MonomorphizerIr, module RE, module GA) where +module Monomorphizer.MonomorphizerIr (module Monomorphizer.MonomorphizerIr, module GA) where -import Grammar.Abs (Ident (..), UIdent) -import Grammar.Abs qualified as GA (Ident (..)) -import TypeChecker.TypeCheckerIr qualified as RE +import Grammar.Abs (Ident (..)) +import qualified Grammar.Abs as GA (Ident (..)) type Id = (Ident, Type) @@ -27,7 +26,8 @@ data Exp | ECase ExpT [Branch] deriving (Show, Ord, Eq) -data Pattern = PVar Id | PLit (Lit, Type) | PInj Ident [Pattern] | PCatch | PEnum Ident +data Pattern = PVar Id | PLit (Lit, Type) | PInj Ident [Pattern] + | PCatch | PEnum Ident deriving (Eq, Ord, Show) data Branch = Branch (Pattern, Type) ExpT @@ -48,4 +48,4 @@ data Type = TLit Ident | TFun Type Type flattenType :: Type -> [Type] flattenType (TFun t1 t2) = t1 : flattenType t2 -flattenType x = [x] +flattenType x = [x] diff --git a/test_program.crf b/test_program.crf index bd3538d..72593d2 100644 --- a/test_program.crf +++ b/test_program.crf @@ -1,7 +1,7 @@ data Maybe () where { Nothing : Maybe () Just : Int -> Maybe () - }; +}; -- fmap : (Int -> Int) -> Maybe () -> Maybe () ; -- fmap f ma = case ma of { @@ -9,10 +9,9 @@ data Maybe () where { -- Just a => Just (f a) ; -- }; -main = case (Just 5) of { +main = case (Just 10) of { Just a => a ; Nothing => 1 ; - _ => 66 ; }; -- pure : Int -> Maybe () ; From aa4a615c2859e9ef9a453fe173b01f8072a2dc5c Mon Sep 17 00:00:00 2001 From: sebastianselander Date: Mon, 27 Mar 2023 14:44:21 +0200 Subject: [PATCH 171/372] fixed one bug --- src/TypeChecker/TypeChecker.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/TypeChecker/TypeChecker.hs b/src/TypeChecker/TypeChecker.hs index 7e7f17f..ba07616 100644 --- a/src/TypeChecker/TypeChecker.hs +++ b/src/TypeChecker/TypeChecker.hs @@ -633,7 +633,7 @@ inferPattern = \case ++ " arguments but has been given " ++ show (length patterns) ) - sub <- composeAll <$> zipWithM unify (map snd patterns) vs + sub <- composeAll <$> zipWithM unify vs (map snd patterns) return (T.PInj (coerce constr) (apply sub (map fst patterns)), apply sub ret) PCatch -> (T.PCatch,) <$> fresh PEnum p -> do From 2fa30faa8784c2c276f5bc1c4620bf472410c397 Mon Sep 17 00:00:00 2001 From: sebastianselander Date: Mon, 27 Mar 2023 15:37:58 +0200 Subject: [PATCH 172/372] renamed stuff --- Justfile | 3 +++ src/TypeChecker/Bugs.md | 1 - src/TypeChecker/{TypeChecker.hs => TypeCheckerHm.hs} | 0 tests/{TypecheckingHM => TestTypeChekerHm.hs}/DoStrings.hs | 0 tests/{TypecheckingHM => TestTypeChekerHm.hs}/Tests.hs | 0 5 files changed, 3 insertions(+), 1 deletion(-) rename src/TypeChecker/{TypeChecker.hs => TypeCheckerHm.hs} (100%) rename tests/{TypecheckingHM => TestTypeChekerHm.hs}/DoStrings.hs (100%) rename tests/{TypecheckingHM => TestTypeChekerHm.hs}/Tests.hs (100%) diff --git a/Justfile b/Justfile index d804399..a880195 100644 --- a/Justfile +++ b/Justfile @@ -15,4 +15,7 @@ test: # compile a specific file run FILE: + cabal run language {{FILE}} + +debug FILE: cabal run language -- -d {{FILE}} diff --git a/src/TypeChecker/Bugs.md b/src/TypeChecker/Bugs.md index 2eefcc0..8dad339 100644 --- a/src/TypeChecker/Bugs.md +++ b/src/TypeChecker/Bugs.md @@ -62,4 +62,3 @@ bind ma f = case ma of { ``` TYPECHECKER ERROR Inferred type '("c" -> "Int") -> "Maybe" -> "Maybe" does not match specified type '("Int" -> "Int") -> "Maybe" -> "Maybe"' -``` \ No newline at end of file diff --git a/src/TypeChecker/TypeChecker.hs b/src/TypeChecker/TypeCheckerHm.hs similarity index 100% rename from src/TypeChecker/TypeChecker.hs rename to src/TypeChecker/TypeCheckerHm.hs diff --git a/tests/TypecheckingHM/DoStrings.hs b/tests/TestTypeChekerHm.hs/DoStrings.hs similarity index 100% rename from tests/TypecheckingHM/DoStrings.hs rename to tests/TestTypeChekerHm.hs/DoStrings.hs diff --git a/tests/TypecheckingHM/Tests.hs b/tests/TestTypeChekerHm.hs/Tests.hs similarity index 100% rename from tests/TypecheckingHM/Tests.hs rename to tests/TestTypeChekerHm.hs/Tests.hs From ac3f222753f642ee699b0e73228f9d1e89e974d7 Mon Sep 17 00:00:00 2001 From: Martin Fredin Date: Sat, 18 Feb 2023 14:49:33 +0100 Subject: [PATCH 173/372] Add bidirectional type checker, lambda lifter. --- Grammar.cf | 96 +-- language.cabal | 17 +- sample-programs/basic-0 | 11 + sample-programs/basic-2.crf | 1 + spec.txt | 121 ++++ src/Auxiliary.hs | 2 + src/Codegen/Codegen.hs | 114 +++- src/Codegen/LlvmIr.hs | 7 +- src/LambdaLifter.hs | 242 +++++++ src/Main.hs | 118 +++- src/Monomorphizer/Monomorphizer.hs | 59 +- src/Monomorphizer/MonomorphizerIr.hs | 8 +- src/Renamer/Renamer.hs | 289 ++++----- src/Renamer/RenamerOld.hs | 206 ++++++ src/TypeChecker/RemoveTEVar.hs | 73 +++ src/TypeChecker/TypeCheckerBidir.hs | 858 +++++++++++++++++++++++++ src/TypeChecker/TypeCheckerHm.hs | 116 ++-- src/TypeChecker/TypeCheckerIr.hs | 322 +++------- tests/TestTypeCheckerBidir.hs | 232 +++++++ tests/TestTypeCheckerHm.hs | 113 ++++ tests/TestTypeChekerHm.hs/DoStrings.hs | 2 +- tests/Tests.hs | 10 + 22 files changed, 2440 insertions(+), 577 deletions(-) create mode 100644 sample-programs/basic-0 create mode 100644 spec.txt create mode 100644 src/LambdaLifter.hs create mode 100644 src/Renamer/RenamerOld.hs create mode 100644 src/TypeChecker/RemoveTEVar.hs create mode 100644 src/TypeChecker/TypeCheckerBidir.hs create mode 100644 tests/TestTypeCheckerBidir.hs create mode 100644 tests/TestTypeCheckerHm.hs create mode 100644 tests/Tests.hs diff --git a/Grammar.cf b/Grammar.cf index 78dfa65..09d0f2e 100644 --- a/Grammar.cf +++ b/Grammar.cf @@ -3,94 +3,94 @@ -- * PROGRAM ------------------------------------------------------------------------------- -Program. Program ::= [Def] ; +Program. Program ::= [Def]; ------------------------------------------------------------------------------- -- * TOP-LEVEL ------------------------------------------------------------------------------- -DBind. Def ::= Bind ; -DSig. Def ::= Sig ; -DData. Def ::= Data ; +DBind. Def ::= Bind; +DSig. Def ::= Sig; +DData. Def ::= Data; -Sig. Sig ::= LIdent ":" Type ; - -Bind. Bind ::= LIdent [LIdent] "=" Exp ; +Sig. Sig ::= LIdent ":" Type; +Bind. Bind ::= LIdent [LIdent] "=" Exp; ------------------------------------------------------------------------------- --- * TYPES +-- * Types ------------------------------------------------------------------------------- - TLit. Type2 ::= UIdent ; - TVar. Type2 ::= TVar ; - TAll. Type1 ::= "forall" TVar "." Type ; - TData. Type1 ::= UIdent "(" [Type] ")" ; -internal TEVar. Type1 ::= TEVar ; - TFun. Type ::= Type1 "->" Type ; + TLit. Type1 ::= UIdent; -- τ + TVar. Type1 ::= TVar; -- α +internal TEVar. Type1 ::= TEVar; -- ά + TData. Type1 ::= UIdent "(" [Type] ")"; -- D () + TFun. Type ::= Type1 "->" Type; -- A → A + TAll. Type ::= "forall" TVar "." Type; -- ∀α. A - MkTVar. TVar ::= LIdent ; -internal MkTEVar. TEVar ::= LIdent ; + MkTVar. TVar ::= LIdent; +internal MkTEVar. TEVar ::= LIdent; ------------------------------------------------------------------------------- -- * DATA TYPES ------------------------------------------------------------------------------- -Constructor. Constructor ::= UIdent ":" Type ; +Data. Data ::= "data" Type "where" "{" [Inj] "}" ; -Data. Data ::= "data" Type "where" "{" [Constructor] "}" ; +Inj. Inj ::= UIdent ":" Type ; +separator nonempty Inj " " ; ------------------------------------------------------------------------------- --- * EXPRESSIONS +-- * Expressions ------------------------------------------------------------------------------- -EAnn. Exp4 ::= "(" Exp ":" Type ")" ; -EVar. Exp3 ::= LIdent ; -EInj. Exp3 ::= UIdent ; -ELit. Exp3 ::= Lit ; -EApp. Exp2 ::= Exp2 Exp3 ; -EAdd. Exp1 ::= Exp1 "+" Exp2 ; -ELet. Exp ::= "let" Bind "in" Exp ; -EAbs. Exp ::= "\\" LIdent "." Exp ; -ECase. Exp ::= "case" Exp "of" "{" [Branch] "}"; +EAnn. Exp4 ::= "(" Exp ":" Type ")"; +EVar. Exp3 ::= LIdent; +EInj. Exp3 ::= UIdent; +ELit. Exp3 ::= Lit; +EApp. Exp2 ::= Exp2 Exp3; +EAdd. Exp1 ::= Exp1 "+" Exp2; +ELet. Exp ::= "let" Bind "in" Exp; +EAbs. Exp ::= "\\" LIdent "." Exp; +ECase. Exp ::= "case" Exp "of" "{" [Branch] "}"; ------------------------------------------------------------------------------- -- * LITERALS ------------------------------------------------------------------------------- -LInt. Lit ::= Integer ; -LChar. Lit ::= Char ; +LInt. Lit ::= Integer; +LChar. Lit ::= Character; ------------------------------------------------------------------------------- --- * CASE +-- * PATTERN MATCHING ------------------------------------------------------------------------------- Branch. Branch ::= Pattern "=>" Exp ; -PVar. Pattern1 ::= LIdent ; -PLit. Pattern1 ::= Lit ; -PCatch. Pattern1 ::= "_" ; -PEnum. Pattern1 ::= UIdent ; -PInj. Pattern ::= UIdent [Pattern1] ; +PVar. Pattern1 ::= LIdent; +PLit. Pattern1 ::= Lit; +PCatch. Pattern1 ::= "_"; +PEnum. Pattern1 ::= UIdent; +PInj. Pattern ::= UIdent [Pattern1]; ------------------------------------------------------------------------------- -- * AUX ------------------------------------------------------------------------------- -terminator Def ";" ; -separator nonempty Constructor "" ; -separator Type " " ; -separator nonempty Pattern1 " " ; +terminator Def ";"; terminator Branch ";" ; -separator Ident " "; -separator LIdent " "; -separator TVar " " ; -coercions Exp 4 ; -coercions Type 2 ; -coercions Pattern 1 ; +separator LIdent ""; +separator Type " "; +separator TVar " "; +separator nonempty Pattern1 " "; +coercions Pattern 1; +coercions Exp 4; +coercions Type 1 ; + +token Character '\''(char)'\'' ; token UIdent (upper (letter | digit | '_')*) ; token LIdent (lower (letter | digit | '_')*) ; -comment "--" ; -comment "{-" "-}" ; +comment "--"; +comment "{-" "-}"; diff --git a/language.cabal b/language.cabal index 9783156..61724ee 100644 --- a/language.cabal +++ b/language.cabal @@ -31,13 +31,18 @@ executable language Grammar.Skel Grammar.ErrM Auxiliary + Renamer.Renamer TypeChecker.TypeChecker + TypeChecker.TypeCheckerHm + TypeChecker.TypeCheckerBidir TypeChecker.TypeCheckerIr + TypeChecker.RemoveTEVar + LambdaLifter Monomorphizer.Monomorphizer Monomorphizer.MonomorphizerIr - Renamer.Renamer Codegen.Codegen Codegen.LlvmIr + Compiler hs-source-dirs: src @@ -60,6 +65,9 @@ Test-suite language-testsuite main-is: Tests.hs other-modules: + TestTypeCheckerBidir + TestTypeCheckerHm + Grammar.Abs Grammar.Lex Grammar.Par @@ -67,9 +75,11 @@ Test-suite language-testsuite Grammar.Skel Grammar.ErrM Auxiliary - TypeChecker.TypeChecker - TypeChecker.TypeCheckerIr Renamer.Renamer + TypeChecker.TypeCheckerHm + TypeChecker.TypeCheckerBidir + TypeChecker.RemoveTEVar + TypeChecker.TypeCheckerIr Compiler hs-source-dirs: src, tests, tests/TypecheckingHM @@ -87,3 +97,4 @@ Test-suite language-testsuite , bytestring default-language: GHC2021 + diff --git a/sample-programs/basic-0 b/sample-programs/basic-0 new file mode 100644 index 0000000..4738fb6 --- /dev/null +++ b/sample-programs/basic-0 @@ -0,0 +1,11 @@ +data forall a. List (a) where { + Nil : List (a) + Cons : a -> List (a) -> List (a) +}; + +length : forall c. List (c) -> Int; +length = \list. case list of { + Nil => 0; + Cons x xs => 1 + length xs; + Cons x (Cons y Nil) => 2; +}; diff --git a/sample-programs/basic-2.crf b/sample-programs/basic-2.crf index 2db6128..5ce4da5 100644 --- a/sample-programs/basic-2.crf +++ b/sample-programs/basic-2.crf @@ -3,3 +3,4 @@ add x = \y. x+y; main : Int ; main = (\z. z+z) ((add 4) 6) ; + diff --git a/spec.txt b/spec.txt new file mode 100644 index 0000000..2273846 --- /dev/null +++ b/spec.txt @@ -0,0 +1,121 @@ +--------------------------------------------------------------------------- +-- * Parser +--------------------------------------------------------------------------- + +data Program = Program [Def] + +data Def = DSig Ident Type | DBind Bind + +data Bind = Bind Ident [Ident] Exp + +data Exp + = EId Ident + | ELit Lit + | EAnn Exp Type + | ELet Ident Exp Exp + | EApp Exp Exp + | EAdd Exp Exp + | EAbs Ident Exp + +data Lit = LInt Integer + | LChar Character + +data Type + = TLit Ident -- τ + | TVar TVar -- α + | TFun Type Type -- A → A + | TAll TVar Type -- ∀α. A + | TEVar TEVar -- ά (internal) + +data TVar = MkTVar Ident +data TEVar = MkTEVar Ident + +--------------------------------------------------------------------------- +-- * Type checker +--------------------------------------------------------------------------- + +-- • Def and DSig are removed in favor on just Bind +-- • Typed expressions +-- • TEVar is removed (NOT IMPLEMENTED) + +newtype Program = Program [Bind] + +data Bind = Bind Id [Id] ExpT + +data Exp + = EId Ident + | ELit Lit + | ELet Bind ExpT + | EApp ExpT ExpT + | EAdd ExpT ExpT + | EAbs Ident ExpT + +type Id = (Ident, Type) +type ExpT = (Exp, Type) + + +data Lit = LInt Integer + | LChar Character + +data Type + = TLit Ident -- τ + | TVar TVar -- α + | TFun Type Type -- A → A + | TAll TVar Type -- ∀α. A + +data TVar = MkTVar Ident + +--------------------------------------------------------------------------- +-- * Lambda lifter +--------------------------------------------------------------------------- +-- • EAbs are removed (NOT IMPLEMENTED) +-- • ELet only allow constant expressions (NOT IMPLEMENTED) + +newtype Program = Program [Bind] + +data Bind = Bind Id [Id] ExpT + +data Exp + = EId Ident + | ELit Lit + | ELet Ident ExpT ExpT + | EApp ExpT ExpT + | EAdd ExpT ExpT + +type Id = (Ident, Type) +type ExpT = (Exp, Type) + +data Lit = LInt Integer + | LChar Character + +data Type + = TLit Ident -- τ + | TVar TVar -- α + | TFun Type Type -- A → A + | TAll TVar Type -- ∀α. A + +data TVar = MkTVar Ident + +--------------------------------------------------------------------------- +-- * Monomorpher +--------------------------------------------------------------------------- +-- • Polymorphic types are removed (NOT IMPLEMENTED) + +newtype Program = Program [Bind] + +data Bind = Bind Id [Id] ExpT + +data Exp + = EId Ident + | ELit Lit + | ELet Ident ExpT ExpT + | EApp ExpT ExpT + | EAdd ExpT ExpT + +type Id = (Ident, Type) +type ExpT = (Exp, Type) + +data Lit = LInt Integer + | LChar Character + +data Type = Type Ident diff --git a/src/Auxiliary.hs b/src/Auxiliary.hs index 735d804..d27ac24 100644 --- a/src/Auxiliary.hs +++ b/src/Auxiliary.hs @@ -3,6 +3,7 @@ module Auxiliary (module Auxiliary) where import Control.Monad.Error.Class (liftEither) import Control.Monad.Except (MonadError) import Data.Either.Combinators (maybeToRight) +import TypeChecker.TypeCheckerIr (Type (TFun)) snoc :: a -> [a] -> [a] snoc x xs = xs ++ [x] @@ -19,3 +20,4 @@ mapAccumM f = go (acc', x') <- f acc x (acc'', xs') <- go acc' xs pure (acc'', x':xs') + diff --git a/src/Codegen/Codegen.hs b/src/Codegen/Codegen.hs index 041671d..5e7e37d 100644 --- a/src/Codegen/Codegen.hs +++ b/src/Codegen/Codegen.hs @@ -17,6 +17,7 @@ import Data.Tuple.Extra (dupe, first, second) import Debug.Trace (trace) import qualified Grammar.Abs as GA import Grammar.ErrM (Err) +import Monomorphizer.MonomorphizerIr (Ident (..)) import Monomorphizer.MonomorphizerIr as MIR -- | The record used as the code generator state @@ -57,8 +58,13 @@ getVarCount :: CompilerState Integer getVarCount = gets variableCount -- | Increases the variable count and returns it from the CodeGenerator state +<<<<<<< HEAD getNewVar :: CompilerState GA.Ident getNewVar = GA.Ident . show <$> (increaseVarCount >> getVarCount) +======= +getNewVar :: CompilerState Ident +getNewVar = (Ident . show) <$> (increaseVarCount >> getVarCount) +>>>>>>> da28c6d (Add bidirectional type checker, lambda lifter.) -- | Increses the label count and returns a label from the CodeGenerator state getNewLabel :: CompilerState Integer @@ -76,10 +82,25 @@ getFunctions bs = Map.fromList $ go bs go (MIR.DBind (MIR.Bind id args _) : xs) = (id, FunctionInfo{numArgs = length args, arguments = args}) : go xs +<<<<<<< HEAD go (_ : xs) = go xs +======= + go (MIR.DData (MIR.Data n cons) : xs) = + do map + ( \(Inj id xs) -> + ( (coerce id, MIR.TLit (extractTypeName n)) + , FunctionInfo + { numArgs = undefined -- TODO + , arguments = createArgs (snd <$> undefined) -- TODO + } + ) + ) + cons + <> go xs +>>>>>>> da28c6d (Add bidirectional type checker, lambda lifter.) createArgs :: [MIR.Type] -> [Id] -createArgs xs = fst $ foldl (\(acc, l) t -> (acc ++ [(GA.Ident ("arg_" <> show l), t)], l + 1)) ([], 0) xs +createArgs xs = fst $ foldl (\(acc, l) t -> (acc ++ [(Ident ("arg_" <> show l), t)], l + 1)) ([], 0) xs {- | Produces a map of functions infos from a list of binds, which contains useful data for code generation. @@ -89,6 +110,7 @@ getConstructors bs = Map.fromList $ go bs where go [] = [] go (MIR.DData (MIR.Data t cons) : xs) = +<<<<<<< HEAD fst ( foldl ( \(acc, i) (Constructor id xs) -> @@ -96,6 +118,17 @@ getConstructors bs = Map.fromList $ go bs , ConstructorInfo { numArgsCI = length (init . flattenType $ xs) , argumentsCI = createArgs (init . flattenType $ xs) +======= + do + let (Ident n) = extractTypeName t + fst + ( foldl + ( \(acc, i) (Inj (Ident id) xs) -> + ( ( (Ident (n <> "_" <> id), MIR.TLit (coerce n)) + , ConstructorInfo + { numArgsCI = undefined -- TODO + , argumentsCI = createArgs (snd <$> undefined) -- TODO +>>>>>>> da28c6d (Add bidirectional type checker, lambda lifter.) , numCI = i , returnTypeCI = t --last . flattenType $ xs } @@ -133,30 +166,30 @@ test :: Integer -> Program test v = Program [ DataType - (GA.Ident "Craig") - [ Constructor (GA.Ident "Bob") [MIR.Type (GA.Ident "_Int")] - , Constructor (GA.Ident "Betty") [MIR.Type (GA.Ident "_Int")] + (Ident "Craig") + [ Constructor (Ident "Bob") [MIR.Type (Ident "_Int")] + , Constructor (Ident "Betty") [MIR.Type (Ident "_Int")] ] , DataType - (GA.Ident "Alice") - [ Constructor (GA.Ident "Eve") [MIR.Type (GA.Ident "_Int")] -- , - -- (GA.Ident "Alice", [TInt, TInt]) + (Ident "Alice") + [ Constructor (Ident "Eve") [MIR.Type (Ident "_Int")] -- , + -- (Ident "Alice", [TInt, TInt]) ] - , Bind (GA.Ident "fibonacci", MIR.Type (GA.Ident "_Int")) [(GA.Ident "x", MIR.Type (GA.Ident "_Int"))] (EId ("x", MIR.Type (GA.Ident "Craig")), MIR.Type (GA.Ident "Craig")) - , Bind (GA.Ident "main", MIR.Type (GA.Ident "_Int")) [] - -- (EApp (MIR.Type (GA.Ident "Craig")) (EId (GA.Ident "Craig_Bob", MIR.Type (GA.Ident "Craig")), MIR.Type (GA.Ident "Craig")) (ELit (LInt v), MIR.Type (GA.Ident "_Int")), MIR.Type (GA.Ident "Craig"))-- (EInt 92) + , Bind (Ident "fibonacci", MIR.Type (Ident "_Int")) [(Ident "x", MIR.Type (Ident "_Int"))] (EVar ("x", MIR.Type (Ident "Craig")), MIR.Type (Ident "Craig")) + , Bind (Ident "main", MIR.Type (Ident "_Int")) [] + -- (EApp (MIR.Type (Ident "Craig")) (EVar (Ident "Craig_Bob", MIR.Type (Ident "Craig")), MIR.Type (Ident "Craig")) (ELit (LInt v), MIR.Type (Ident "_Int")), MIR.Type (Ident "Craig"))-- (EInt 92) $ eCaseInt - (EApp (MIR.TLit (GA.Ident "Craig")) (EId (GA.Ident "Craig_Bob", MIR.TLit (GA.Ident "Craig")), MIR.TLit (GA.Ident "Craig")) (ELit (LInt v), MIR.Type (GA.Ident "_Int")), MIR.Type (GA.Ident "Craig")) - [ injectionCons "Craig_Bob" "Craig" [CIdent (GA.Ident "x")] (EId (GA.Ident "x", MIR.Type (GA.Ident "_Int")), MIR.Type (GA.Ident "_Int")) + (EApp (MIR.TLit (Ident "Craig")) (EVar (Ident "Craig_Bob", MIR.TLit (Ident "Craig")), MIR.TLit (Ident "Craig")) (ELit (LInt v), MIR.Type (Ident "_Int")), MIR.Type (Ident "Craig")) + [ injectionCons "Craig_Bob" "Craig" [CIdent (Ident "x")] (EVar (Ident "x", MIR.Type (Ident "_Int")), MIR.Type (Ident "_Int")) , injectionCons "Craig_Betty" "Craig" [CLit (LInt 5)] (int 2) - , Injection (CIdent (GA.Ident "z")) (int 3) + , Injection (CIdent (Ident "z")) (int 3) , -- , injectionInt 5 (int 6) injectionCatchAll (int 10) ] ] where - injectionCons x y xs = Injection (CCons (GA.Ident x, MIR.Type (GA.Ident y)) xs) + injectionCons x y xs = Injection (CCons (Ident x, MIR.Type (Ident y)) xs) injectionInt x = Injection (CLit (LInt x)) injectionCatchAll = Injection CatchAll eCaseInt x xs = (ECase (MIR.TLit (MIR.Ident "_Int")) x xs, MIR.TLit (MIR.Ident "_Int")) @@ -206,7 +239,7 @@ compileScs [] = do emit $ SetVariable ptr' (Bitcast (Ref t') (VIdent top Ptr) (Ref $ CustomType id)) enumerateOneM_ - ( \i (GA.Ident arg_n, arg_t) -> do + ( \i (Ident arg_n, arg_t) -> do let arg_t' = type2LlvmType arg_t emit $ Comment (toIr arg_t' <> " " <> arg_n <> " " <> show i) elemPtr <- getNewVar @@ -222,7 +255,7 @@ compileScs [] = do I32 (VInteger i) ) - emit $ Store arg_t' (VIdent (GA.Ident arg_n) arg_t') Ptr elemPtr + emit $ Store arg_t' (VIdent (Ident arg_n) arg_t') Ptr elemPtr ) (argumentsCI ci) @@ -255,8 +288,13 @@ compileScs (MIR.DData (MIR.Data typ ts) : xs) = do let biggestVariant = 7 + maximum (sum . (\(Constructor _ fi) -> typeByteSize <$> variantTypes fi) <$> ts) emit $ LIR.Type (Ident outer_id) [I8, Array biggestVariant I8] mapM_ +<<<<<<< HEAD ( \(Constructor inner_id fi) -> do emit $ LIR.Type inner_id (I8 : variantTypes fi) +======= + ( \(Inj (Ident inner_id) fi) -> do + emit $ LIR.Type (Ident $ outer_id <> "_" <> inner_id) (I8 : map type2LlvmType (snd <$> undefined)) -- TODO +>>>>>>> da28c6d (Add bidirectional type checker, lambda lifter.) ) ts compileScs xs @@ -282,17 +320,17 @@ mainContent var = -- " %4 = load i72, ptr %3\n" <> -- " call i32 (ptr, ...) @printf(ptr noundef @.str, i72 noundef %4)\n" "call i32 (ptr, ...) @printf(ptr noundef @.str, i64 noundef " <> toIr var <> ")\n" - , -- , SetVariable (GA.Ident "p") (Icmp LLEq I64 (VInteger 2) (VInteger 2)) - -- , BrCond (VIdent (GA.Ident "p")) (GA.Ident "b_1") (GA.Ident "b_2") - -- , Label (GA.Ident "b_1") + , -- , SetVariable (Ident "p") (Icmp LLEq I64 (VInteger 2) (VInteger 2)) + -- , BrCond (VIdent (Ident "p")) (Ident "b_1") (Ident "b_2") + -- , Label (Ident "b_1") -- , UnsafeRaw -- "call i32 (ptr, ...) @printf(ptr noundef @.str, i64 noundef 1)\n" - -- , Br (GA.Ident "end") - -- , Label (GA.Ident "b_2") + -- , Br (Ident "end") + -- , Label (Ident "b_2") -- , UnsafeRaw -- "call i32 (ptr, ...) @printf(ptr noundef @.str, i64 noundef 2)\n" - -- , Br (GA.Ident "end") - -- , Label (GA.Ident "end") + -- , Br (Ident "end") + -- , Label (Ident "end") Ret I64 (VInteger 0) ] @@ -310,7 +348,7 @@ compileExp :: ExpT -> CompilerState () compileExp (MIR.ELit lit,t) = emitLit lit compileExp (MIR.EAdd e1 e2,t) = emitAdd t e1 e2 -- compileExp (ESub t e1 e2) = emitSub t e1 e2 -compileExp (MIR.EId name,t) = emitIdent name +compileExp (MIR.EVar name,t) = emitIdent name compileExp (MIR.EApp e1 e2,t) = emitApp t e1 e2 -- compileExp (EAbs t ti e) = emitAbs t ti e compileExp (MIR.ELet binds e,t) = undefined -- emitLet binds (fst e) @@ -328,7 +366,7 @@ emitECased t e cases = do let rt = type2LlvmType (snd e) vs <- exprToValue e lbl <- getNewLabel - let label = GA.Ident $ "escape_" <> show lbl + let label = Ident $ "escape_" <> show lbl stackPtr <- getNewVar emit $ SetVariable stackPtr (Alloca ty) mapM_ (emitCases rt ty label stackPtr vs) cs @@ -341,13 +379,13 @@ emitECased t e cases = do res <- getNewVar emit $ SetVariable res (Load ty Ptr stackPtr) where - emitCases :: LLVMType -> LLVMType -> GA.Ident -> GA.Ident -> LLVMValue -> Branch -> CompilerState () + emitCases :: LLVMType -> LLVMType -> Ident -> Ident -> LLVMValue -> Branch -> CompilerState () emitCases rt ty label stackPtr vs (Branch (MIR.PInj consId cs, t) exp) = do cons <- gets constructors let r = fromJust $ Map.lookup consId cons - lbl_failPos <- (\x -> GA.Ident $ "failed_" <> show x) <$> getNewLabel - lbl_succPos <- (\x -> GA.Ident $ "success_" <> show x) <$> getNewLabel + lbl_failPos <- (\x -> Ident $ "failed_" <> show x) <$> getNewLabel + lbl_succPos <- (\x -> Ident $ "success_" <> show x) <$> getNewLabel consVal <- getNewVar emit $ SetVariable consVal (ExtractValue rt vs 0) @@ -397,8 +435,8 @@ emitECased t e cases = do (MIR.LInt i, _) -> VInteger i (MIR.LChar i, _) -> VChar i ns <- getNewVar - lbl_failPos <- (\x -> GA.Ident $ "failed_" <> show x) <$> getNewLabel - lbl_succPos <- (\x -> GA.Ident $ "success_" <> show x) <$> getNewLabel + lbl_failPos <- (\x -> Ident $ "failed_" <> show x) <$> getNewLabel + lbl_succPos <- (\x -> Ident $ "success_" <> show x) <$> getNewLabel emit $ SetVariable ns (Icmp LLEq ty vs i') emit $ BrCond (VIdent ns ty) lbl_succPos lbl_failPos emit $ Label lbl_succPos @@ -444,8 +482,13 @@ emitApp rt e1 e2 = appEmitter e1 e2 [] appEmitter e1 e2 stack = do let newStack = e2 : stack case e1 of +<<<<<<< HEAD (MIR.EApp e1' e2', _) -> appEmitter e1' e2' newStack (MIR.EId name, t) -> do +======= + (MIR.EApp e1' e2', t) -> appEmitter e1' e2' newStack + (MIR.EVar name, t) -> do +>>>>>>> da28c6d (Add bidirectional type checker, lambda lifter.) args <- traverse exprToValue newStack vs <- getNewVar funcs <- gets functions @@ -462,7 +505,7 @@ emitApp rt e1 e2 = appEmitter e1 e2 [] emit $ SetVariable vs call x -> error $ "The unspeakable happened: " <> show x -emitIdent :: GA.Ident -> CompilerState () +emitIdent :: Ident -> CompilerState () emitIdent id = do -- !!this should never happen!! emit $ Comment "This should not have happened!" @@ -477,14 +520,14 @@ emitLit i = do (MIR.LChar i'') -> (VChar i'', I8) varCount <- getNewVar emit $ Comment "This should not have happened!" - emit $ SetVariable (GA.Ident (show varCount)) (Add t i' (VInteger 0)) + emit $ SetVariable (Ident (show varCount)) (Add t i' (VInteger 0)) emitAdd :: MIR.Type -> ExpT -> ExpT -> CompilerState () emitAdd t e1 e2 = do v1 <- exprToValue e1 v2 <- exprToValue e2 v <- getNewVar - emit $ SetVariable (GA.Ident $ show v) (Add (type2LlvmType t) v1 v2) + emit $ SetVariable (Ident $ show v) (Add (type2LlvmType t) v1 v2) emitSub :: MIR.Type -> ExpT -> ExpT -> CompilerState () emitSub t e1 e2 = do @@ -498,7 +541,7 @@ exprToValue = \case (MIR.ELit i, t) -> pure $ case i of (MIR.LInt i) -> VInteger i (MIR.LChar i) -> VChar i - (MIR.EId name, t) -> do + (MIR.EVar name, t) -> do funcs <- gets functions case Map.lookup (name, t) funcs of Just fi -> do @@ -515,7 +558,7 @@ exprToValue = \case e -> do compileExp e v <- getVarCount - pure $ VIdent (GA.Ident $ show v) (getType e) + pure $ VIdent (Ident $ show v) (getType e) type2LlvmType :: MIR.Type -> LLVMType type2LlvmType (MIR.TLit id@(Ident name)) = case name of @@ -558,3 +601,4 @@ typeByteSize (CustomType _) = 8 enumerateOneM_ :: Monad m => (Integer -> a -> m b) -> [a] -> m () enumerateOneM_ f = foldM_ (\i a -> f i a >> pure (i + 1)) 1 + diff --git a/src/Codegen/LlvmIr.hs b/src/Codegen/LlvmIr.hs index 3c11ae1..0baf35a 100644 --- a/src/Codegen/LlvmIr.hs +++ b/src/Codegen/LlvmIr.hs @@ -11,8 +11,9 @@ module Codegen.LlvmIr ( ToIr(..) ) where -import Data.List (intercalate) -import Grammar.Abs (Ident (..)) +import Data.List (intercalate) +import Grammar.Abs (Character) +import TypeChecker.TypeCheckerIr (Ident (..)) data CallingConvention = TailCC | FastCC | CCC | ColdCC deriving Show instance ToIr CallingConvention where @@ -87,7 +88,7 @@ instance ToIr Visibility where -- or a string contstant data LLVMValue = VInteger Integer - | VChar Char + | VChar Character | VIdent Ident LLVMType | VConstant String | VFunction Ident Visibility LLVMType diff --git a/src/LambdaLifter.hs b/src/LambdaLifter.hs new file mode 100644 index 0000000..b85dd8b --- /dev/null +++ b/src/LambdaLifter.hs @@ -0,0 +1,242 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} + + +module LambdaLifter (lambdaLift, freeVars, abstract, collectScs) where + +import Auxiliary (snoc) +import Control.Applicative (Applicative (liftA2)) +import Control.Monad.State (MonadState (get, put), State, + evalState) +import Data.List (partition) +import Data.Set (Set) +import qualified Data.Set as Set +import Prelude hiding (exp) +import TypeChecker.TypeCheckerIr + + +-- | Lift lambdas and let expression into supercombinators. +-- Three phases: +-- @freeVars@ annotates all the free variables. +-- @abstract@ converts lambdas into let expressions. +-- @collectScs@ moves every non-constant let expression to a top-level function. +lambdaLift :: Program -> Program +lambdaLift (Program defs) = Program $ datatypes ++ ll binds + where + ll = map DBind . collectScs . abstract . freeVars . map (\(DBind b) -> b) + (binds, datatypes) = partition isBind defs + isBind = \case + DBind _ -> True + _ -> False + +-- | Annotate free variables +freeVars :: [Bind] -> AnnBinds +freeVars binds = [ (n, xs, freeVarsExp (Set.fromList $ map fst xs) e) + | Bind n xs e <- binds + ] + +freeVarsExp :: Set Ident -> ExpT -> AnnExpT +freeVarsExp localVars (exp, t) = case exp of + EVar n | Set.member n localVars -> (Set.singleton n, (AVar n, t)) + | otherwise -> (mempty, (AVar n, t)) + + ELit lit -> (mempty, (ALit lit, t)) + + EApp e1 e2 -> (Set.union (freeVarsOf e1') (freeVarsOf e2'), (AApp e1' e2', t)) + where + e1' = freeVarsExp localVars e1 + e2' = freeVarsExp localVars e2 + + EAdd e1 e2 -> (Set.union (freeVarsOf e1') (freeVarsOf e2'), (AAdd e1' e2', t)) + where + e1' = freeVarsExp localVars e1 + e2' = freeVarsExp localVars e2 + + EAbs par e -> (Set.delete par $ freeVarsOf e', (AAbs par e', t)) + where + e' = freeVarsExp (Set.insert par localVars) e + + -- Sum free variables present in bind and the expression + ELet (Bind (name, t_bind) parms rhs) e -> (Set.union binders_frees e_free, (ALet new_bind e', t)) + where + binders_frees = Set.delete name $ freeVarsOf rhs' + e_free = Set.delete name $ freeVarsOf e' + + rhs' = freeVarsExp e_localVars rhs + new_bind = ABind (name, t_bind) parms rhs' + + e' = freeVarsExp e_localVars e + e_localVars = Set.insert name localVars + + +freeVarsOf :: AnnExpT -> Set Ident +freeVarsOf = fst + +-- AST annotated with free variables +type AnnBinds = [(Id, [Id], AnnExpT)] + +type AnnExpT = (Set Ident, AnnExpT') + +data ABind = ABind Id [Id] AnnExpT deriving Show + +type AnnExpT' = (AnnExp, Type) + +data AnnExp = AVar Ident + | AInj Ident + | ALit Lit + | ALet ABind AnnExpT + | AApp AnnExpT AnnExpT + | AAdd AnnExpT AnnExpT + | AAbs Ident AnnExpT + deriving Show + +-- | Lift lambdas to let expression of the form @let sc = \v₁ x₁ -> e₁@. +-- Free variables are @v₁ v₂ .. vₙ@ are bound. +abstract :: AnnBinds -> [Bind] +abstract prog = evalState (mapM go prog) 0 + where + go :: (Id, [Id], AnnExpT) -> State Int Bind + go (name, parms, rhs) = Bind name (parms ++ parms1) <$> abstractExp rhs' + where + (rhs', parms1) = flattenLambdasAnn rhs + + +-- | Flatten nested lambdas and collect the parameters +-- @\x.\y.\z. ae → (ae, [x,y,z])@ +flattenLambdasAnn :: AnnExpT -> (AnnExpT, [Id]) +flattenLambdasAnn ae = go (ae, []) + where + go :: (AnnExpT, [Id]) -> (AnnExpT, [Id]) + go ((free, (e, t)), acc) + | AAbs par (free1, e1) <- e + , TFun t_par _ <- t + = go ((Set.delete par free1, e1), snoc (par, t_par) acc) + | otherwise = ((free, (e, t)), acc) + +abstractExp :: AnnExpT -> State Int ExpT +abstractExp (free, (exp, typ)) = case exp of + AVar n -> pure (EVar n, typ) + ALit lit -> pure (ELit lit, typ) + AApp e1 e2 -> (, typ) <$> liftA2 EApp (abstractExp e1) (abstractExp e2) + AAdd e1 e2 -> (, typ) <$> liftA2 EAdd (abstractExp e1) (abstractExp e2) + ALet b e -> (, typ) <$> liftA2 ELet (go b) (abstractExp e) + where + go (ABind name parms rhs) = do + (rhs', parms1) <- flattenLambdas <$> skipLambdas abstractExp rhs + pure $ Bind name (parms ++ parms1) rhs' + + skipLambdas :: (AnnExpT -> State Int ExpT) -> AnnExpT -> State Int ExpT + skipLambdas f (free, (ae, t)) = case ae of + AAbs par ae1 -> do + ae1' <- skipLambdas f ae1 + pure (EAbs par ae1', t) + _ -> f (free, (ae, t)) + + -- Lift lambda into let and bind free variables + AAbs parm e -> do + i <- nextNumber + rhs <- abstractExp e + + let sc_name = Ident ("sc_" ++ show i) + sc = (ELet (Bind (sc_name, typ) vars rhs) (EVar sc_name, typ), typ) + pure $ foldl applyVars sc freeList + + where + freeList = Set.toList free + vars = zip names $ getVars typ + names = snoc parm freeList + applyVars (e, t) name = (EApp (e, t) (EVar name, t_var), t_return) + where + (t_var, t_return) = applyVarType t + +applyVarType :: Type -> (Type, Type) +applyVarType typ = (t1, foldr ($) t2 foralls) + + where + (t1, t2) = case typ' of + TFun t1 t2 -> (t1, t2) + _ -> error "Not a function!" + + (foralls, typ') = skipForalls [] typ + + + skipForalls acc = \case + TAll tvar t -> skipForalls (snoc (TAll tvar) acc) t + t -> (acc, t) + +nextNumber :: State Int Int +nextNumber = do + i <- get + put $ succ i + pure i + +-- | Collects supercombinators by lifting non-constant let expressions +collectScs :: [Bind] -> [Bind] +collectScs = concatMap collectFromRhs + where + collectFromRhs (Bind name parms rhs) = + let (rhs_scs, rhs') = collectScsExp rhs + in Bind name parms rhs' : rhs_scs + + +collectScsExp :: ExpT -> ([Bind], ExpT) +collectScsExp expT@(exp, typ) = case exp of + EVar _ -> ([], expT) + ELit _ -> ([], expT) + + EApp e1 e2 -> (scs1 ++ scs2, (EApp e1' e2', typ)) + where + (scs1, e1') = collectScsExp e1 + (scs2, e2') = collectScsExp e2 + + EAdd e1 e2 -> (scs1 ++ scs2, (EAdd e1' e2', typ)) + where + (scs1, e1') = collectScsExp e1 + (scs2, e2') = collectScsExp e2 + + EAbs par e -> (scs, (EAbs par e', typ)) + where + (scs, e') = collectScsExp e + + -- Collect supercombinators from bind, the rhss, and the expression. + -- + -- > f = let sc x y = rhs in e + -- + ELet (Bind name parms rhs) e -> if null parms + then ( rhs_scs ++ et_scs, (ELet bind et', snd et')) + else (bind : rhs_scs ++ et_scs, et') + where + bind = Bind name parms rhs' + (rhs_scs, rhs') = collectScsExp rhs + (et_scs, et') = collectScsExp e + + +-- @\x.\y.\z. e → (e, [x,y,z])@ +flattenLambdas :: ExpT -> (ExpT, [Id]) +flattenLambdas = go . (, []) + where + go ((e, t), acc) = case e of + EAbs name e1 -> go (e1, snoc (name, t_var) acc) + where t_var = head $ getVars t + _ -> ((e, t), acc) + +getVars :: Type -> [Type] +getVars = fst . partitionType + +partitionType :: Type -> ([Type], Type) +partitionType = go [] . skipForalls' + where + + go acc t = case t of + TFun t1 t2 -> go (snoc t1 acc) t2 + _ -> (acc, t) + +skipForalls' :: Type -> Type +skipForalls' = snd . skipForalls + +skipForalls :: Type -> ([Type -> Type], Type) +skipForalls = go [] + where + go acc typ = case typ of + TAll tvar t -> go (snoc (TAll tvar) acc) t + _ -> (acc, typ) diff --git a/src/Main.hs b/src/Main.hs index 16f1442..210916d 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -1,66 +1,114 @@ -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedRecordDot #-} module Main where -import Codegen.Codegen (generateCode) -import Data.Bool (bool) -import GHC.IO.Handle.Text (hPutStrLn) -import Grammar.ErrM (Err) -import Grammar.Par (myLexer, pProgram) -import Grammar.Print (printTree) - -import Monomorphizer.Monomorphizer (monomorphize) - import Control.Monad (when) +import Data.Bool (bool) import Data.List.Extra (isSuffixOf) - -import Compiler (compile) -import Renamer.Renamer (rename) +import Data.Maybe (fromJust, isNothing) +import GHC.IO.Handle.Text (hPutStrLn) +import System.Console.GetOpt (ArgDescr (NoArg, ReqArg), + ArgOrder (RequireOrder), + OptDescr (Option), getOpt, + usageInfo) import System.Directory (createDirectory, doesPathExist, getDirectoryContents, removeDirectoryRecursive, setCurrentDirectory) import System.Environment (getArgs) -import System.Exit (ExitCode, exitFailure, - exitSuccess) +import System.Exit (ExitCode (ExitFailure), + exitFailure, exitSuccess, + exitWith) import System.IO (stderr) -import System.Process.Extra (readCreateProcess, shell, - spawnCommand, waitForProcess) -import TypeChecker.TypeChecker (typecheck) + + +import Codegen.Codegen (generateCode) +import Compiler (compile) +import Grammar.ErrM (Err) +import Grammar.Par (myLexer, pProgram) +import Grammar.Print (printTree) +import LambdaLifter (lambdaLift) +import Monomorphizer.Monomorphizer (monomorphize) +import Renamer.Renamer (rename) +import System.Process (spawnCommand, waitForProcess) +import TypeChecker.TypeChecker (TypeChecker (Bi, Hm), typecheck) main :: IO () -main = - getArgs >>= \case - [] -> putStrLn "Required file path missing" - ["-d", s] -> do - when (".crf" `isSuffixOf` s) (main' True s) - putStrLn $ "File '" ++ s ++ "' is not a churf file" - [s] -> do - when (".crf" `isSuffixOf` s) (main' False s) - putStrLn $ "File '" ++ s ++ "' is not a churf file" - xs -> putStrLn $ "Can't process: " ++ unwords xs +main = getArgs >>= parseArgs >>= uncurry main' -main' :: Bool -> String -> IO () -main' debug s = do +parseArgs :: [String] -> IO (Options, String) +parseArgs argv = case getOpt RequireOrder flags argv of + (os, f:_, []) + | opts.help || isNothing opts.typechecker -> do + hPutStrLn stderr (usageInfo header flags) + exitSuccess + | otherwise -> pure (opts, f) + where + opts = foldr ($) initOpts os + (_, _, errs) -> do + hPutStrLn stderr (concat errs ++ usageInfo header flags) + exitWith (ExitFailure 1) + where + header = "Usage: language [--help] [-d|--debug] [-t|type-checker bi/hm] FILE \n" + +flags :: [OptDescr (Options -> Options)] +flags = + [ Option ['d'] ["debug"] (NoArg enableDebug) "Print debug messages." + , Option ['t'] ["type-checker"] (ReqArg chooseTypechecker "bi/hm") "Choose type checker. Possible options are bi and hm" + , Option [] ["help"] (NoArg enableHelp) "Print this help message" + ] + +initOpts :: Options +initOpts = Options { help = False + , debug = False + , typechecker = Nothing + } + +enableHelp :: Options -> Options +enableHelp opts = opts { help = True } + +enableDebug :: Options -> Options +enableDebug opts = opts { debug = True } + +chooseTypechecker :: String -> Options -> Options +chooseTypechecker s options = options { typechecker = tc } + where + tc = case s of + "hm" -> pure Hm + "bi" -> pure Bi + _ -> Nothing + +data Options = Options + { help :: Bool + , debug :: Bool + , typechecker :: Maybe TypeChecker + } + +main' :: Options -> String -> IO () +main' opts s = do file <- readFile s printToErr "-- Parse Tree -- " parsed <- fromSyntaxErr . pProgram $ myLexer file - bool (printToErr $ printTree parsed) (printToErr $ show parsed) debug + bool (printToErr $ printTree parsed) (printToErr $ show parsed) opts.debug printToErr "\n-- Renamer --" renamed <- fromRenamerErr . rename $ parsed - bool (printToErr $ printTree renamed) (printToErr $ show renamed) debug + bool (printToErr $ printTree renamed) (printToErr $ show renamed) opts.debug printToErr "\n-- TypeChecker --" - typechecked <- fromTypeCheckerErr $ typecheck renamed - bool (printToErr $ printTree typechecked) (printToErr $ show typechecked) debug + typechecked <- fromTypeCheckerErr $ typecheck (fromJust opts.typechecker) renamed + bool (printToErr $ printTree typechecked) (printToErr $ show typechecked) opts.debug + + printToErr "\n-- Lambda Lifter --" + let lifted = lambdaLift typechecked + printToErr $ printTree lifted -- printToErr "\n-- Lambda Lifter --" -- let lifted = lambdaLift typechecked -- printToErr $ printTree lifted -- - --printToErr "\n -- Compiler --" + printToErr "\n -- Compiler --" generatedCode <- fromCompilerErr $ generateCode (monomorphize typechecked) --putStrLn generatedCode diff --git a/src/Monomorphizer/Monomorphizer.hs b/src/Monomorphizer/Monomorphizer.hs index 7062b79..5440bab 100644 --- a/src/Monomorphizer/Monomorphizer.hs +++ b/src/Monomorphizer/Monomorphizer.hs @@ -1,12 +1,13 @@ -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} module Monomorphizer.Monomorphizer (monomorphize) where -import Data.Coerce (coerce) +import Data.Coerce (coerce) -import Monomorphizer.MonomorphizerIr qualified as M -import TypeChecker.TypeCheckerIr qualified as T +import qualified Monomorphizer.MonomorphizerIr as M +import qualified TypeChecker.TypeCheckerIr as T +import TypeChecker.TypeCheckerIr (Ident (..)) monomorphize :: T.Program -> M.Program monomorphize (T.Program ds) = M.Program $ monoDefs ds @@ -16,40 +17,40 @@ monoDefs = map monoDef monoDef :: T.Def -> M.Def monoDef (T.DBind bind) = M.DBind $ monoBind bind -monoDef (T.DData d) = M.DData $ monoData d +--monoDef (T.DData d) = M.DData $ monoData d monoBind :: T.Bind -> M.Bind monoBind (T.Bind name args (e, t)) = M.Bind (monoId name) (map monoId args) (monoExpr e, monoType t) -monoData :: T.Data -> M.Data -monoData (T.Data (T.Ident id) cs) = M.Data (M.TLit (M.Ident id)) (map monoConstructor cs) +--monoData :: T.Data -> M.Data +--monoData (T.Data (Ident id) cs) = M.Data (M.TLit (M.Ident id)) (map monoConstructor cs) -monoConstructor :: T.Constructor -> M.Constructor -monoConstructor (T.Constructor (T.Ident i) t) = M.Constructor (M.Ident i) (monoType t) +monoConstructor :: T.Inj -> M.Inj +monoConstructor (T.Inj (Ident i) t) = M.Inj (M.Ident i) (monoType t) monoExpr :: T.Exp -> M.Exp monoExpr = \case - T.EId (T.Ident i) -> M.EId (M.Ident i) - T.ELit lit -> M.ELit $ monoLit lit - T.ELet bind expt -> M.ELet (monoBind bind) (monoexpt expt) + T.EVar (Ident i) -> M.EVar (M.Ident i) + T.ELit lit -> M.ELit $ monoLit lit + T.ELet bind expt -> M.ELet (monoBind bind) (monoexpt expt) T.EApp expt1 expt2 -> M.EApp (monoexpt expt1) (monoexpt expt2) T.EAdd expt1 expt2 -> M.EAdd (monoexpt expt1) (monoexpt expt2) - T.EAbs _i _expt -> error "BUG" - T.ECase expt injs -> M.ECase (monoexpt expt) (monoInjs injs) + T.EAbs _i _expt -> error "BUG" + T.ECase expt injs -> M.ECase (monoexpt expt) (monoInjs injs) monoAbsType :: T.Type -> M.Type -monoAbsType (T.TLit u) = M.TLit (coerce u) -monoAbsType (T.TVar _v) = M.TLit "Int" +monoAbsType (T.TLit u) = M.TLit (coerce u) +monoAbsType (T.TVar _v) = M.TLit "Int" monoAbsType (T.TAll _v _t) = error "NOT ALL TYPES" monoAbsType (T.TFun t1 t2) = M.TFun (monoAbsType t1) (monoAbsType t2) -monoAbsType (T.TData _ _) = error "NOT INDEXED TYPES" +monoAbsType (T.TData _ _) = error "NOT INDEXED TYPES" monoType :: T.Type -> M.Type -monoType (T.TAll _ t) = monoType t +monoType (T.TAll _ t) = monoType t monoType (T.TVar (T.MkTVar i)) = M.TLit "Int" -monoType (T.TLit (T.Ident i)) = M.TLit (M.Ident i) -monoType (T.TFun t1 t2) = M.TFun (monoType t1) (monoType t2) -monoType (T.TData (T.Ident n) t) = M.TLit (M.Ident (n ++ concatMap show t)) +monoType (T.TLit (Ident i)) = M.TLit (M.Ident i) +monoType (T.TFun t1 t2) = M.TFun (monoType t1) (monoType t2) +monoType (T.TData (Ident n) t) = M.TLit (M.Ident (n ++ concatMap show t)) monoexpt :: T.ExpT -> M.ExpT monoexpt (e, t) = (monoExpr e, monoType t) @@ -58,19 +59,19 @@ monoId :: T.Id -> M.Id monoId (n, t) = (coerce n, monoType t) monoLit :: T.Lit -> M.Lit -monoLit (T.LInt i) = M.LInt i +monoLit (T.LInt i) = M.LInt i monoLit (T.LChar c) = M.LChar c monoInjs :: [T.Branch] -> [M.Branch] monoInjs = map monoInj monoInj :: T.Branch -> M.Branch -monoInj (T.Branch (init, t) expt) = M.Branch (monoInit init, monoType t) (monoexpt expt) +monoInj (T.Branch (patt, t) expt) = M.Branch (monoPattern patt, monoType t) (monoexpt expt) -monoInit :: T.Pattern -> M.Pattern -monoInit (T.PVar (id, t)) = M.PVar (coerce id, monoType t) -monoInit (T.PLit (lit, t)) = M.PLit (monoLit lit, monoType t) -monoInit (T.PInj id ps) = M.PInj (coerce id) (monoInit <$> ps) +monoPattern :: T.Pattern -> M.Pattern +monoPattern (T.PVar (id, t)) = M.PVar (id, monoType t) +monoPattern (T.PLit (lit, t)) = M.PLit (monoLit lit, monoType t) +monoPattern (T.PInj id ps) = M.PInj (coerce id) (map monoPattern ps) -- DO NOT DO THIS FOR REAL THOUGH -monoInit (T.PEnum (T.Ident i)) = M.PInj (M.Ident i) [] -monoInit T.PCatch = M.PCatch +monoPattern (T.PEnum (Ident i)) = M.PInj (M.Ident i) [] +monoPattern T.PCatch = M.PCatch diff --git a/src/Monomorphizer/MonomorphizerIr.hs b/src/Monomorphizer/MonomorphizerIr.hs index e0e7383..c80ad65 100644 --- a/src/Monomorphizer/MonomorphizerIr.hs +++ b/src/Monomorphizer/MonomorphizerIr.hs @@ -11,14 +11,14 @@ newtype Program = Program [Def] data Def = DBind Bind | DData Data deriving (Show, Ord, Eq) -data Data = Data Type [Constructor] +data Data = Data Type [Inj] deriving (Show, Ord, Eq) data Bind = Bind Id [Id] ExpT deriving (Show, Ord, Eq) data Exp - = EId Ident + = EVar Ident | ELit Lit | ELet Bind ExpT | EApp ExpT ExpT @@ -35,12 +35,12 @@ data Branch = Branch (Pattern, Type) ExpT type ExpT = (Exp, Type) -data Constructor = Constructor Ident Type +data Inj = Inj Ident Type deriving (Show, Ord, Eq) data Lit = LInt Integer - | LChar Char + | LChar Character deriving (Show, Ord, Eq) data Type = TLit Ident | TFun Type Type diff --git a/src/Renamer/Renamer.hs b/src/Renamer/Renamer.hs index 5576793..0a67e22 100644 --- a/src/Renamer/Renamer.hs +++ b/src/Renamer/Renamer.hs @@ -1,131 +1,124 @@ -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedRecordDot #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PatternSynonyms #-} -{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} - -{-# HLINT ignore "Use mapAndUnzipM" #-} module Renamer.Renamer (rename) where -import Auxiliary (mapAccumM) -import Control.Applicative (Applicative (liftA2)) -import Control.Monad (foldM) -import Control.Monad.Except (ExceptT, MonadError, runExceptT, throwError) -import Control.Monad.Identity (Identity, runIdentity) -import Control.Monad.State ( - MonadState, - StateT, - evalStateT, - gets, - modify, - ) -import Data.Coerce (coerce) -import Data.Function (on) -import Data.Map (Map) -import Data.Map qualified as Map -import Data.Maybe (fromMaybe) -import Data.Tuple.Extra (dupe) -import Grammar.Abs +import Auxiliary (mapAccumM) +import Control.Applicative (Applicative (liftA2)) +import Control.Monad.Except (ExceptT, MonadError (throwError), + runExceptT) +import Control.Monad.State (MonadState, State, evalState, gets, + mapAndUnzipM, modify) +import Data.Function (on) +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Maybe (fromMaybe) +import Data.Tuple.Extra (dupe, second) +import Grammar.Abs +import Grammar.ErrM (Err) + -- | Rename all variables and local binds -rename :: Program -> Either String Program +rename :: Program -> Err Program rename (Program defs) = Program <$> renameDefs defs -renameDefs :: [Def] -> Either String [Def] -renameDefs defs = runIdentity $ runExceptT $ evalStateT (runRn $ mapM renameDef defs) initCxt - where - initNames = Map.fromList [dupe (coerce name) | DBind (Bind name _ _) <- defs] - - renameDef :: Def -> Rn Def - renameDef = \case - DSig (Sig name typ) -> DSig . Sig name <$> renameTVars typ - DBind bind -> DBind . snd <$> renameBind initNames bind - DData (Data (TData cname types) constrs) -> do - tvars_ <- tvars - tvars' <- mapM nextNameTVar tvars_ - let tvars_lt = zip tvars_ tvars' - typ' = map (substituteTVar tvars_lt) types - constrs' = map (renameConstr tvars_lt) constrs - pure . DData $ Data (TData cname typ') constrs' - where - tvars = concat <$> mapM (collectTVars []) types - collectTVars :: [TVar] -> Type -> Rn [TVar] - collectTVars tvars = \case - TAll tvar t -> collectTVars (tvar : tvars) t - TData _ _ -> return tvars - -- Should be monad error - TVar v -> return [v] - _ -> throwError ("Bad data type definition: " ++ show types) - DData (Data types _) -> throwError ("Bad data type definition: " ++ show types) - - renameConstr :: [(TVar, TVar)] -> Constructor -> Constructor - renameConstr new_types (Constructor name typ) = - Constructor name $ substituteTVar new_types typ - -renameBind :: Names -> Bind -> Rn (Names, Bind) -renameBind old_names (Bind name vars rhs) = do - (new_names, vars') <- newNames old_names (coerce vars) - (newer_names, rhs') <- renameExp new_names rhs - pure (newer_names, Bind name (coerce vars') rhs') - -substituteTVar :: [(TVar, TVar)] -> Type -> Type -substituteTVar new_names typ = case typ of - TLit _ -> typ - TVar tvar - | Just tvar' <- lookup tvar new_names -> - TVar tvar' - | otherwise -> - typ - TFun t1 t2 -> on TFun substitute' t1 t2 - TAll tvar t - | Just tvar' <- lookup tvar new_names -> - TAll tvar' $ substitute' t - | otherwise -> - TAll tvar $ substitute' t - TData name typs -> TData name $ map substitute' typs - _ -> error ("Impossible " ++ show typ) - where - substitute' = substituteTVar new_names - initCxt :: Cxt initCxt = Cxt 0 0 -data Cxt = Cxt - { var_counter :: Int - , tvar_counter :: Int - } +data Cxt = Cxt { var_counter :: Int + , tvar_counter :: Int + } + -- | Rename monad. State holds the number of renamed names. -newtype Rn a = Rn {runRn :: StateT Cxt (ExceptT String Identity) a} - deriving (Functor, Applicative, Monad, MonadState Cxt, MonadError String) +newtype Rn a = Rn { runRn :: ExceptT String (State Cxt) a } + deriving (Functor, Applicative, Monad, MonadState Cxt, MonadError String) -- | Maps old to new name -type Names = Map LIdent LIdent +type Names = Map String String + +renameDefs :: [Def] -> Err [Def] +renameDefs defs = evalState (runExceptT (runRn $ mapM renameDef defs)) initCxt + where + initNames = Map.fromList [ dupe s | DBind (Bind (LIdent s) _ _) <- defs] + + renameDef :: Def -> Rn Def + renameDef = \case + DSig (Sig name typ) -> DSig . Sig name <$> renameTVars typ + DBind (Bind name vars rhs) -> do + (new_names, vars') <- newNamesL initNames vars + rhs' <- snd <$> renameExp new_names rhs + pure . DBind $ Bind name vars' rhs' + DData (Data typ injs) -> do + tvars <- collectTVars [] typ + tvars' <- mapM nextNameTVar tvars + let tvars_lt = zip tvars tvars' + typ' = substituteTVar tvars_lt typ + injs' = map (renameInj tvars_lt) injs + pure . DData $ Data typ' injs' + where + collectTVars tvars = \case + TAll tvar t -> collectTVars (tvar:tvars) t + TData _ _ -> pure tvars + _ -> throwError ("Bad data type definition: " ++ show typ) + + renameInj :: [(TVar, TVar)] -> Inj -> Inj + renameInj new_types (Inj name typ) = + Inj name $ substituteTVar new_types typ + + +substituteTVar :: [(TVar, TVar)] -> Type -> Type +substituteTVar new_names typ = case typ of + TLit _ -> typ + + TVar tvar | Just tvar' <- lookup tvar new_names + -> TVar tvar' + | otherwise + -> typ + + TFun t1 t2 -> on TFun substitute' t1 t2 + + TAll tvar t | Just tvar' <- lookup tvar new_names + -> TAll tvar' $ substitute' t + | otherwise + -> TAll tvar $ substitute' t + + TData name typs -> TData name $ map substitute' typs + _ -> error ("Impossible " ++ show typ) + where + substitute' = substituteTVar new_names + renameExp :: Names -> Exp -> Rn (Names, Exp) renameExp old_names = \case - EVar n -> pure (coerce old_names, EVar . fromMaybe n $ Map.lookup n old_names) - EInj n -> pure (old_names, EInj n) - ELit lit -> pure (old_names, ELit lit) + EVar (LIdent n) -> pure (old_names, EVar . LIdent . fromMaybe n $ Map.lookup n old_names) + EInj (UIdent n) -> pure (old_names, EInj . UIdent . fromMaybe n $ Map.lookup n old_names) + + ELit lit -> pure (old_names, ELit lit) + EApp e1 e2 -> do (env1, e1') <- renameExp old_names e1 (env2, e2') <- renameExp old_names e2 pure (Map.union env1 env2, EApp e1' e2') + EAdd e1 e2 -> do (env1, e1') <- renameExp old_names e1 (env2, e2') <- renameExp old_names e2 pure (Map.union env1 env2, EAdd e1' e2') -- TODO fix shadowing - ELet bind e -> do - (new_names, bind') <- renameBind old_names bind - (new_names', e') <- renameExp new_names e - pure (new_names', ELet bind' e') - EAbs par e -> do - (new_names, par') <- newName old_names (coerce par) - (new_names', e') <- renameExp new_names e - pure (new_names', EAbs (coerce par') e') + ELet (Bind name vars rhs) e -> do + (new_names, name') <- newNameL old_names name + (new_names', vars') <- newNamesL new_names vars + (new_names'', rhs') <- renameExp new_names' rhs + (new_names''', e') <- renameExp new_names'' e + pure (new_names''', ELet (Bind name' vars' rhs') e') + + EAbs par e -> do + (new_names, par') <- newNameL old_names par + (new_names', e') <- renameExp new_names e + pure (new_names', EAbs par' e') + EAnn e t -> do (new_names, e') <- renameExp old_names e t' <- renameTVars t @@ -137,26 +130,23 @@ renameExp old_names = \case renameBranches :: Names -> [Branch] -> Rn (Names, [Branch]) renameBranches ns xs = do - (new_names, xs') <- unzip <$> mapM (renameBranch ns) xs + (new_names, xs') <- mapAndUnzipM (renameBranch ns) xs if null new_names then return (mempty, xs') else return (head new_names, xs') renameBranch :: Names -> Branch -> Rn (Names, Branch) -renameBranch ns (Branch init e) = do - (new_names, init') <- renamePattern ns init +renameBranch ns (Branch patt e) = do + (new_names, patt') <- renamePattern ns patt (new_names', e') <- renameExp new_names e - return (new_names', Branch init' e') + return (new_names', Branch patt' e') renamePattern :: Names -> Pattern -> Rn (Names, Pattern) -renamePattern ns i = case i of +renamePattern ns p = case p of PInj cs ps -> do - (ns_new, ps) <- renamePatterns ns ps - return (ns_new, PInj cs ps) - rest -> return (ns, rest) + (ns_new, ps') <- mapAccumM renamePattern ns ps + return (ns_new, PInj cs ps') + PVar name -> second PVar <$> newNameL ns name + _ -> return (ns, p) -renamePatterns :: Names -> [Pattern] -> Rn (Names, [Pattern]) -renamePatterns ns xs = do - (new_names, xs') <- unzip <$> mapM (renamePattern ns) xs - if null new_names then return (mempty, xs') else return (head new_names, xs') renameTVars :: Type -> Rn Type renameTVars typ = case typ of @@ -167,44 +157,57 @@ renameTVars typ = case typ of TFun t1 t2 -> liftA2 TFun (renameTVars t1) (renameTVars t2) _ -> pure typ -substitute :: - TVar -> -- α - TVar -> -- α_n - Type -> -- A - Type -- [α_n/α]A +substitute :: TVar -- α + -> TVar -- α_n + -> Type -- A + -> Type -- [α_n/α]A substitute tvar1 tvar2 typ = case typ of - TLit _ -> typ - TVar tvar' - | tvar' == tvar1 -> TVar tvar2 - | otherwise -> typ - TFun t1 t2 -> on TFun substitute' t1 t2 - TAll tvar t -> TAll tvar $ substitute' t - TData name typs -> TData name $ map substitute' typs - _ -> error "Impossible" + TLit _ -> typ + TVar tvar | tvar == tvar1 -> TVar tvar2 + | otherwise -> typ + TFun t1 t2 -> on TFun substitute' t1 t2 + TAll tvar t | tvar == tvar1 -> TAll tvar2 $ substitute' t + | otherwise -> TAll tvar $ substitute' t + TData name typs -> TData name $ map substitute' typs + _ -> error "Impossible" where substitute' = substitute tvar1 tvar2 --- | Create a new name and add it to name environment. -newName :: Names -> LIdent -> Rn (Names, LIdent) -newName env old_name = do - new_name <- makeName old_name - pure (Map.insert old_name new_name env, new_name) + -- | Create multiple names and add them to the name environment -newNames :: Names -> [LIdent] -> Rn (Names, [LIdent]) -newNames = mapAccumM newName +newNamesL :: Names -> [LIdent] -> Rn (Names, [LIdent]) +newNamesL = mapAccumM newNameL + +-- | Create a new name and add it to name environment. +newNameL :: Names -> LIdent -> Rn (Names, LIdent) +newNameL env (LIdent old_name) = do + new_name <- makeName old_name + pure (Map.insert old_name new_name env, LIdent new_name) + + +-- | Create multiple names and add them to the name environment +newNamesU :: Names -> [UIdent] -> Rn (Names, [UIdent]) +newNamesU = mapAccumM newNameU + +-- | Create a new name and add it to name environment. +newNameU :: Names -> UIdent -> Rn (Names, UIdent) +newNameU env (UIdent old_name) = do + new_name <- makeName old_name + pure (Map.insert old_name new_name env, UIdent new_name) + -- | Annotate name with number and increment the number @prefix ⇒ prefix_number@. -makeName :: LIdent -> Rn LIdent -makeName (LIdent prefix) = do - i <- gets var_counter - let name = LIdent $ prefix ++ "_" ++ show i - modify $ \cxt -> cxt{var_counter = succ cxt.var_counter} - pure name +makeName :: String -> Rn String +makeName prefix = do + i <- gets var_counter + let name = prefix ++ "_" ++ show i + modify $ \cxt -> cxt { var_counter = succ cxt.var_counter} + pure name nextNameTVar :: TVar -> Rn TVar -nextNameTVar (MkTVar (LIdent s)) = do - i <- gets tvar_counter - let tvar = MkTVar $ coerce $ s ++ "_" ++ show i - modify $ \cxt -> cxt{tvar_counter = succ cxt.tvar_counter} - pure tvar +nextNameTVar (MkTVar (LIdent s))= do + i <- gets tvar_counter + let tvar = MkTVar . LIdent $ s ++ "_" ++ show i + modify $ \cxt -> cxt { tvar_counter = succ cxt.tvar_counter} + pure tvar diff --git a/src/Renamer/RenamerOld.hs b/src/Renamer/RenamerOld.hs new file mode 100644 index 0000000..bf21c9f --- /dev/null +++ b/src/Renamer/RenamerOld.hs @@ -0,0 +1,206 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} + +{-# HLINT ignore "Use mapAndUnzipM" #-} + +module Renamer.Renamer (rename) where + +import Auxiliary (mapAccumM) +import Control.Applicative (Applicative (liftA2)) +import Control.Monad (foldM) +import Control.Monad.Except (ExceptT, MonadError, runExceptT, + throwError) +import Control.Monad.Identity (Identity, runIdentity) +import Control.Monad.State (MonadState, StateT, evalStateT, gets, + modify) +import Data.Coerce (coerce) +import Data.Function (on) +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Maybe (fromMaybe) +import Data.Tuple.Extra (dupe) +import Grammar.Abs + +-- | Rename all variables and local binds +rename :: Program -> Either String Program +rename (Program defs) = Program <$> renameDefs defs + +renameDefs :: [Def] -> Either String [Def] +renameDefs defs = runIdentity $ runExceptT $ evalStateT (runRn $ mapM renameDef defs) initCxt + where + initNames = Map.fromList [dupe (coerce name) | DBind (Bind name _ _) <- defs] + + renameDef :: Def -> Rn Def + renameDef = \case + DSig (Sig name typ) -> DSig . Sig name <$> renameTVars typ + DBind bind -> DBind . snd <$> renameBind initNames bind + DData (Data (TData cname types) constrs) -> do + tvars_ <- tvars + tvars' <- mapM nextNameTVar tvars_ + let tvars_lt = zip tvars_ tvars' + typ' = map (substituteTVar tvars_lt) types + constrs' = map (renameConstr tvars_lt) constrs + pure . DData $ Data (TData cname typ') constrs' + where + tvars = concat <$> mapM (collectTVars []) types + collectTVars :: [TVar] -> Type -> Rn [TVar] + collectTVars tvars = \case + TAll tvar t -> collectTVars (tvar : tvars) t + TData _ _ -> return tvars + -- Should be monad error + TVar v -> return [v] + _ -> throwError ("Bad data type definition: " ++ show types) + DData (Data types _) -> throwError ("Bad data type definition: " ++ show types) + + renameConstr :: [(TVar, TVar)] -> Inj -> Inj + renameConstr new_types (Inj name typ) = + Inj name $ substituteTVar new_types typ + +renameBind :: Names -> Bind -> Rn (Names, Bind) +renameBind old_names (Bind name vars rhs) = do + (new_names, vars') <- newNames old_names (coerce vars) + (newer_names, rhs') <- renameExp new_names rhs + pure (newer_names, Bind name (coerce vars') rhs') + +substituteTVar :: [(TVar, TVar)] -> Type -> Type +substituteTVar new_names typ = case typ of + TLit _ -> typ + TVar tvar + | Just tvar' <- lookup tvar new_names -> + TVar tvar' + | otherwise -> + typ + TFun t1 t2 -> on TFun substitute' t1 t2 + TAll tvar t + | Just tvar' <- lookup tvar new_names -> + TAll tvar' $ substitute' t + | otherwise -> + TAll tvar $ substitute' t + TData name typs -> TData name $ map substitute' typs + _ -> error ("Impossible " ++ show typ) + where + substitute' = substituteTVar new_names + +initCxt :: Cxt +initCxt = Cxt 0 0 + +data Cxt = Cxt + { var_counter :: Int + , tvar_counter :: Int + } + +-- | Rename monad. State holds the number of renamed names. +newtype Rn a = Rn {runRn :: StateT Cxt (ExceptT String Identity) a} + deriving (Functor, Applicative, Monad, MonadState Cxt, MonadError String) + +-- | Maps old to new name +type Names = Map LIdent LIdent + +renameExp :: Names -> Exp -> Rn (Names, Exp) +renameExp old_names = \case + EVar n -> pure (coerce old_names, EVar . fromMaybe n $ Map.lookup n old_names) + EInj n -> pure (old_names, EInj n) + ELit lit -> pure (old_names, ELit lit) + EApp e1 e2 -> do + (env1, e1') <- renameExp old_names e1 + (env2, e2') <- renameExp old_names e2 + pure (Map.union env1 env2, EApp e1' e2') + EAdd e1 e2 -> do + (env1, e1') <- renameExp old_names e1 + (env2, e2') <- renameExp old_names e2 + pure (Map.union env1 env2, EAdd e1' e2') + + -- TODO fix shadowing + ELet bind e -> do + (new_names, bind') <- renameBind old_names bind + (new_names', e') <- renameExp new_names e + pure (new_names', ELet bind' e') + EAbs par e -> do + (new_names, par') <- newName old_names (coerce par) + (new_names', e') <- renameExp new_names e + pure (new_names', EAbs (coerce par') e') + EAnn e t -> do + (new_names, e') <- renameExp old_names e + t' <- renameTVars t + pure (new_names, EAnn e' t') + ECase e injs -> do + (new_names, e') <- renameExp old_names e + (new_names', injs') <- renameBranches new_names injs + pure (new_names', ECase e' injs') + +renameBranches :: Names -> [Branch] -> Rn (Names, [Branch]) +renameBranches ns xs = do + (new_names, xs') <- unzip <$> mapM (renameBranch ns) xs + if null new_names then return (mempty, xs') else return (head new_names, xs') + +renameBranch :: Names -> Branch -> Rn (Names, Branch) +renameBranch ns (Branch init e) = do + (new_names, init') <- renamePattern ns init + (new_names', e') <- renameExp new_names e + return (new_names', Branch init' e') + +renamePattern :: Names -> Pattern -> Rn (Names, Pattern) +renamePattern ns i = case i of + PInj cs ps -> do + (ns_new, ps) <- renamePatterns ns ps + return (ns_new, PInj cs ps) + rest -> return (ns, rest) + +renamePatterns :: Names -> [Pattern] -> Rn (Names, [Pattern]) +renamePatterns ns xs = do + (new_names, xs') <- unzip <$> mapM (renamePattern ns) xs + if null new_names then return (mempty, xs') else return (head new_names, xs') + +renameTVars :: Type -> Rn Type +renameTVars typ = case typ of + TAll tvar t -> do + tvar' <- nextNameTVar tvar + t' <- renameTVars $ substitute tvar tvar' t + pure $ TAll tvar' t' + TFun t1 t2 -> liftA2 TFun (renameTVars t1) (renameTVars t2) + _ -> pure typ + +substitute :: + TVar -> -- α + TVar -> -- α_n + Type -> -- A + Type -- [α_n/α]A +substitute tvar1 tvar2 typ = case typ of + TLit _ -> typ + TVar tvar' + | tvar' == tvar1 -> TVar tvar2 + | otherwise -> typ + TFun t1 t2 -> on TFun substitute' t1 t2 + TAll tvar t -> TAll tvar $ substitute' t + TData name typs -> TData name $ map substitute' typs + _ -> error "Impossible" + where + substitute' = substitute tvar1 tvar2 + +-- | Create a new name and add it to name environment. +newName :: Names -> LIdent -> Rn (Names, LIdent) +newName env old_name = do + new_name <- makeName old_name + pure (Map.insert old_name new_name env, new_name) + +-- | Create multiple names and add them to the name environment +newNames :: Names -> [LIdent] -> Rn (Names, [LIdent]) +newNames = mapAccumM newName + +-- | Annotate name with number and increment the number @prefix ⇒ prefix_number@. +makeName :: LIdent -> Rn LIdent +makeName (LIdent prefix) = do + i <- gets var_counter + let name = LIdent $ prefix ++ "_" ++ show i + modify $ \cxt -> cxt{var_counter = succ cxt.var_counter} + pure name + +nextNameTVar :: TVar -> Rn TVar +nextNameTVar (MkTVar (LIdent s)) = do + i <- gets tvar_counter + let tvar = MkTVar $ coerce $ s ++ "_" ++ show i + modify $ \cxt -> cxt{tvar_counter = succ cxt.tvar_counter} + pure tvar diff --git a/src/TypeChecker/RemoveTEVar.hs b/src/TypeChecker/RemoveTEVar.hs new file mode 100644 index 0000000..b83a134 --- /dev/null +++ b/src/TypeChecker/RemoveTEVar.hs @@ -0,0 +1,73 @@ +{-# LANGUAGE LambdaCase #-} + +module TypeChecker.RemoveTEVar where + +import Control.Applicative (Applicative (liftA2), liftA3) +import Control.Arrow (Arrow (second)) +import Control.Monad.Error (MonadError (throwError)) +import Data.Coerce (coerce) +import Data.Function (on) +import Data.Tuple.Extra (secondM) +import Grammar.Abs +import Grammar.ErrM (Err) +import qualified TypeChecker.TypeCheckerIr as T + +class RemoveTEVar a b where + rmTEVar :: a -> Err b + +instance RemoveTEVar (T.Program' Type) (T.Program' T.Type) where + rmTEVar (T.Program defs) = T.Program <$> rmTEVar defs + +instance RemoveTEVar (T.Def' Type) (T.Def' T.Type) where + rmTEVar = \case + T.DBind bind -> T.DBind <$> rmTEVar bind + T.DData dat -> T.DData <$> rmTEVar dat + +instance RemoveTEVar (T.Bind' Type) (T.Bind' T.Type) where + rmTEVar (T.Bind id vars rhs) = liftA3 T.Bind (rmTEVar id) (rmTEVar vars) (rmTEVar rhs) + +instance RemoveTEVar (T.Exp' Type) (T.Exp' T.Type) where + rmTEVar exp = case exp of + T.EVar name -> pure $ T.EVar name + T.EInj name -> pure $ T.EInj name + T.ELit lit -> pure $ T.ELit lit + T.ELet bind e -> liftA2 T.ELet (rmTEVar bind) (rmTEVar e) + T.EApp e1 e2 -> liftA2 T.EApp (rmTEVar e1) (rmTEVar e2) + T.EAdd e1 e2 -> liftA2 T.EApp (rmTEVar e1) (rmTEVar e2) + T.EAbs name e -> T.EAbs name <$> rmTEVar e + T.ECase e branches -> liftA2 T.ECase (rmTEVar e) (rmTEVar branches) + +instance RemoveTEVar (T.Branch' Type) (T.Branch' T.Type) where + rmTEVar (T.Branch (patt, t_patt) e) = liftA2 T.Branch (liftA2 (,) (rmTEVar patt) (rmTEVar t_patt)) (rmTEVar e) + +instance RemoveTEVar (T.Pattern' Type) (T.Pattern' T.Type) where + rmTEVar = \case + T.PVar (name, t) -> T.PVar . (name,) <$> rmTEVar t + T.PLit (lit, t) -> T.PLit . (lit,) <$> rmTEVar t + T.PCatch -> pure T.PCatch + T.PEnum name -> pure $ T.PEnum name + T.PInj name ps -> T.PInj name <$> rmTEVar ps + +instance RemoveTEVar (T.Data' Type) (T.Data' T.Type) where + rmTEVar (T.Data typ injs) = liftA2 T.Data (rmTEVar typ) (rmTEVar injs) + +instance RemoveTEVar (T.Inj' Type) (T.Inj' T.Type) where + rmTEVar (T.Inj name typ) = T.Inj name <$> rmTEVar typ + +instance RemoveTEVar (T.Id' Type) (T.Id' T.Type) where + rmTEVar = secondM rmTEVar + +instance RemoveTEVar (T.ExpT' Type) (T.ExpT' T.Type) where + rmTEVar (exp, typ) = liftA2 (,) (rmTEVar exp) (rmTEVar typ) + +instance RemoveTEVar a b => RemoveTEVar [a] [b] where + rmTEVar = mapM rmTEVar + +instance RemoveTEVar Type T.Type where + rmTEVar = \case + TLit lit -> pure $ T.TLit (coerce lit) + TVar tvar -> pure $ T.TVar tvar + TData name typs -> T.TData (coerce name) <$> rmTEVar typs + TFun t1 t2 -> liftA2 T.TFun (rmTEVar t1) (rmTEVar t2) + TAll tvar t -> T.TAll tvar <$> rmTEVar t + TEVar _ -> throwError "NewType TEVar!" diff --git a/src/TypeChecker/TypeCheckerBidir.hs b/src/TypeChecker/TypeCheckerBidir.hs new file mode 100644 index 0000000..7cb0081 --- /dev/null +++ b/src/TypeChecker/TypeCheckerBidir.hs @@ -0,0 +1,858 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# OPTIONS_GHC -Wno-incomplete-patterns #-} + +module TypeChecker.TypeCheckerBidir (typecheck, getVars) where + +import Auxiliary (maybeToRightM, snoc) +import Control.Applicative (Alternative, Applicative (liftA2), + (<|>)) +import Control.Monad.Except (ExceptT, MonadError (throwError), + runExceptT, unless, zipWithM, + zipWithM_) +import Control.Monad.State (MonadState (get, put), State, + evalState, gets, modify) +import Data.Coerce (coerce) +import Data.Function (on) +import Data.List (intercalate) +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Maybe (fromMaybe, isNothing) +import Data.Sequence (Seq (..)) +import qualified Data.Sequence as S +import Data.Tuple.Extra (second, secondM) +import Debug.Trace (trace) +import Grammar.Abs +import Grammar.ErrM +import Grammar.Print (printTree) +import Prelude hiding (exp, id) +import qualified TypeChecker.TypeCheckerIr as T + +-- Implementation is derived from the paper (Dunfield and Krishnaswami 2013) +-- https://doi.org/10.1145/2500365.2500582 + +data EnvElem = EnvVar LIdent Type -- ^ Term variable typing. x : A + | EnvTVar TVar -- ^ Universal type variable. α + | EnvTEVar TEVar -- ^ Existential unsolved type variable. ά + | EnvTEVarSolved TEVar Type -- ^ Existential solved type variable. ά = τ + | EnvMark TEVar -- ^ Scoping Marker. ▶ ά + deriving (Eq, Show) + +type Env = Seq EnvElem + +-- | Ordered context +-- Γ ::= ・| Γ, α | Γ, ά | Γ, ▶ ά | Γ, x:A +data Cxt = Cxt + { env :: Env -- ^ Local scope context Γ + , sig :: Map LIdent Type -- ^ Top-level signatures x : A + , binds :: Map LIdent Exp -- ^ Top-level binds x : e + , next_tevar :: Int -- ^ Counter to distinguish ά + , data_injs :: Map UIdent Type -- ^ Data injections (constructors) K + } deriving (Show, Eq) + +newtype Tc a = Tc { runTc :: ExceptT String (State Cxt) a } + deriving (Functor, Applicative, Monad, Alternative, MonadState Cxt, MonadError String) + +typecheck :: Program -> Err (T.Program' Type) +typecheck (Program defs) = do + datatypes <- mapM typecheckDataType [ d | DData d <- defs ] + + + let initCxt = Cxt + { env = mempty + , sig = Map.fromList [ (name, t) + | DSig' name t <- defs + ] + , binds = Map.fromList [ (name, foldr EAbs rhs vars) + | DBind' name vars rhs <- defs + ] + , next_tevar = 0 + , data_injs = Map.fromList [ (name, typ) + | Data _ injs <- datatypes + , Inj name typ <- injs + ] + } + + binds' <- evalState (runExceptT (runTc $ mapM typecheckBind binds)) initCxt; + pure . T.Program $ map T.DData (coerceData datatypes) ++ map T.DBind binds' + where + binds = [ b | DBind b <- defs ] + coerceData = map (\(Data t injs) -> T.Data t $ map + (\(Inj name typ) -> T.Inj (coerce name) typ) injs) + + +typecheckBind :: Bind -> Tc (T.Bind' Type) +typecheckBind (Bind name vars rhs) = do + bind' <- lookupSig name >>= \case + -- TODO These Judgment aren't accurate + -- (f:A → B) ∈ Γ + -- Γ,(xs:A) ⊢ e ↑ Β ⊣ Δ + --------------------------- + -- Γ ⊢ f xs = e ↓ Α → B ⊣ Δ + Just t -> do + (rhs', _) <- check (foldr EAbs rhs vars) t + pure (T.Bind (coerce name, t) (coerce vars') (rhs', t)) + where + vars' = zip vars $ getVars t + + -- Γ ⊢ (λxs. e) ↓ A → B ⊣ Δ + -- ------------------------------ + -- Γ ⊢ f xs = e ↓ [Γ]A → [Γ]B ⊣ Δ + Nothing -> do + (e, t) <- infer $ foldr EAbs rhs vars + t' <- applyEnv t + e' <- applyEnvExp e + let rhs' = skipLambdas (length vars) e' + vars' = zip vars $ getVars t' + pure (T.Bind (coerce name, t') (coerce vars') (rhs', t')) + env <- gets env + unless (isComplete env) err + putEnv Empty + pure bind' + where + err = throwError $ unlines + [ "Type inference failed: " ++ printTree (Bind name vars rhs) + , "Did you forget to add type annotation to a polymorphic function?" + ] + +typecheckDataType :: Data -> Err Data +typecheckDataType (Data typ injs) = do + (name, tvars) <- go [] typ + injs' <- mapM (\i -> typecheckInj i name tvars) injs + pure (Data typ injs') + where + go tvars = \case + TAll tvar t -> go (tvar:tvars) t + TData name typs + | Right tvars' <- mapM toTVar typs + , all (`elem` tvars) tvars' + -> pure (name, tvars') + _ -> throwError $ unwords ["Bad data type definition: ", ppT typ] + +typecheckInj :: Inj -> UIdent -> [TVar] -> Err Inj +typecheckInj (Inj inj_name inj_typ) name tvars + | not $ boundTVars tvars inj_typ + = throwError "Unbound type variables" + | TData name' typs <- getReturn inj_typ + , name' == name + , Right tvars' <- mapM toTVar typs + , tvars' == tvars + = pure (Inj inj_name $ foldr TAll inj_typ tvars) + | otherwise + = throwError $ unwords + ["Bad type constructor: ", show name + , "\nExpected: ", ppT . TData name $ map TVar tvars + , "\nActual: ", ppT $ getReturn inj_typ + ] + where + boundTVars :: [TVar] -> Type -> Bool + boundTVars tvars' = \case + TAll tvar t -> boundTVars (tvar:tvars') t + TFun t1 t2 -> on (&&) (boundTVars tvars') t1 t2 + TVar tvar -> elem tvar tvars' + TData _ typs -> all (boundTVars tvars) typs + TLit _ -> True + TEVar _ -> error "TEVar in data type declaration" + +--------------------------------------------------------------------------- +-- * Subtyping rules +--------------------------------------------------------------------------- + +-- | Γ ⊢ A <: B ⊣ Δ +-- Under input context Γ, type A is a subtype of B, with output context ∆ +subtype :: Type -> Type -> Tc () +subtype t1 t2 = case (t1, t2) of + + (TLit lit1, TLit lit2) | lit1 == lit2 -> pure () + + -- -------------------- <:Var + -- Γ[α] ⊢ α <: α ⊣ Γ[α] + (TVar tvar1, TVar tvar2) | tvar1 == tvar2 -> pure () + + -- -------------------- <:Exvar + -- Γ[ά] ⊢ ά <: ά ⊣ Γ[ά] + (TEVar tevar1, TEVar tevar2) | tevar1 == tevar2 -> pure () + + -- Γ ⊢ B₁ <: A₁ ⊣ Θ Θ ⊢ [Θ]A₂ <: [Θ]B₂ ⊣ Δ + -- ----------------------------------------- <:→ + -- Γ ⊢ A₁ → A₂ <: B₁ → B₂ ⊣ Δ + (TFun a1 a2, TFun b1 b2) -> do + subtype b1 a1 + a2' <- applyEnv a2 + b2' <- applyEnv b2 + subtype a2' b2' + + -- Γ, α ⊢ A <: B ⊣ Δ,α,Θ + -- --------------------- <:∀R + -- Γ ⊢ A <: ∀α. B ⊣ Δ + (a, TAll tvar b) -> do + let env_tvar = EnvTVar tvar + insertEnv env_tvar + subtype a b + dropTrailing env_tvar + + -- Γ,▶ ά,ά ⊢ [ά/α]A <: B ⊣ Δ,▶ ά,Θ + -- ------------------------------- <:∀L + -- Γ ⊢ ∀α.A <: B ⊣ Δ + (TAll tvar a, b) -> do + tevar <- fresh + let env_marker = EnvMark tevar + env_tevar = EnvTEVar tevar + insertEnv env_marker + insertEnv env_tevar + let a' = substitute tvar tevar a + subtype a' b + dropTrailing env_marker + + -- ά ∉ FV(A) Γ[ά] ⊢ ά :=< A ⊣ Δ + -- ------------------------------ <:instantiateL + -- Γ[ά] ⊢ ά <: A ⊣ Δ + (TEVar tevar, typ) | notElem tevar $ frees typ -> instantiateL tevar typ + + -- ά ∉ FV(A) Γ[ά] ⊢ A =:< ά ⊣ Δ + -- ------------------------------ <:instantiateR + -- Γ[ά] ⊢ A <: ά ⊣ Δ + (typ, TEVar tevar) | notElem tevar $ frees typ -> instantiateR typ tevar + + (TData name1 typs1, TData name2 typs2) + + -- D₁ = D₂ + -- ---------------- + -- Γ ⊢ D₁ () <: D₂ () + | name1 == name2 + , [] <- typs1 + , [] <- typs2 + -> pure () + + -- Γ ⊢ ά₁ <: έ₁ ⊣ Θ₁ + -- ... + -- D₁ = D₂ Θₙ₋₁ ⊢ [Θₙ₋₁]άₙ <: [Θₙ₋₁]έₙ ⊣ Δ + -- ------------------------------------------- + -- Γ ⊢ D (ά₁ ‥ άₙ) <: D (έ₁ ‥ έₙ) ⊣ Δ + | name1 == name2 + , t1:t1s <- typs1 + , t2:t2s <- typs2 + -> do + subtype t1 t2 + zipWithM_ go t1s t2s + where + go t1' t2' = do + t1'' <- applyEnv t1' + t2'' <- applyEnv t2' + subtype t1'' t2'' + + _ -> throwError $ unwords ["Types", ppT t1, "and", ppT t2, "doesn't match!"] + +--------------------------------------------------------------------------- +-- * Instantiation rules +--------------------------------------------------------------------------- + +-- | Γ ⊢ ά :=< A ⊣ Δ +-- Under input context Γ, instantiate ά such that ά <: A, with output context ∆ +instantiateL :: TEVar -> Type -> Tc () +instantiateL tevar typ = gets env >>= go + where + go env + + -- Γ ⊢ τ + -- ----------------------------- InstLSolve + -- Γ,ά,Γ' ⊢ ά :=< τ ⊣ Γ,(ά=τ),Γ' + | isMono typ + , (env_l, env_r) <- splitOn (EnvTEVar tevar) env + , Right _ <- wellFormed env_l typ + = putEnv $ (env_l :|> EnvTEVarSolved tevar typ) <> env_r + + | TEVar tevar' <- typ = instReach tevar tevar' + + -- Γ[ά₂ά₁,(ά=ά₁→ά₂)] ⊢ A₁ =:< ά₁ ⊣ Θ Θ ⊢ ά₂ :=< [Θ]A₂ ⊣ Δ + -- ------------------------------------------------------- InstLArr + -- Γ[ά] ⊢ ά :=< A₁ → A₂ ⊣ Δ + | TFun t1 t2 <- typ = do + tevar1 <- fresh + tevar2 <- fresh + insertEnv $ EnvTEVar tevar2 + insertEnv $ EnvTEVar tevar1 + insertEnv $ EnvTEVarSolved tevar (on TFun TEVar tevar1 tevar2) + instantiateR t1 tevar1 + instantiateL tevar2 =<< applyEnv t2 + + -- Γ[ά],ε ⊢ ά :=< E ⊣ Δ,ε,Δ' + -- ------------------------- InstLAIIR + -- Γ[ά] ⊢ ά :=< ∀ε.Ε ⊣ Δ + | TAll tvar t <- typ = do + instantiateL tevar t + let (env_l, _) = splitOn (EnvTVar tvar) env + putEnv env_l + + | otherwise = error $ "Trying to instantiateL: " ++ ppT (TEVar tevar) + ++ " <: " ++ ppT typ + +-- | Γ ⊢ A =:< ά ⊣ Δ +-- Under input context Γ, instantiate ά such that A <: ά, with output context ∆ +instantiateR :: Type -> TEVar -> Tc () +instantiateR typ tevar = gets env >>= go + where + go env + + -- Γ ⊢ τ + -- ----------------------------- InstRSolve + -- Γ,ά,Γ' ⊢ τ =:< ά ⊣ Γ,(ά=τ),Γ' + | isMono typ + , (env_l, env_r) <- splitOn (EnvTEVar tevar) env + , Right _ <- wellFormed env_l typ + = putEnv $ (env_l :|> EnvTEVarSolved tevar typ) <> env_r + + | TEVar tevar' <- typ = instReach tevar tevar' + + -- Γ[ά₂ά₁,(ά=ά₁→ά₂)] ⊢ A₁ :=< ά₁ ⊣ Θ Θ ⊢ ά₂ =:< [Θ]A₂ ⊣ Δ + -- ------------------------------------------------------- InstRArr + -- Γ[ά] ⊢ ά =:< A₁ → A₂ ⊣ Δ + | TFun t1 t2 <- typ = do + tevar1 <- fresh + tevar2 <- fresh + insertEnv $ EnvTEVar tevar2 + insertEnv $ EnvTEVar tevar1 + insertEnv $ EnvTEVarSolved tevar (on TFun TEVar tevar1 tevar2) + instantiateL tevar1 t1 + t2' <- applyEnv t2 + instantiateR t2' tevar2 + + -- Γ[ά],▶έ,ε ⊢ [έ/ε]E =:< ά ⊣ Δ,▶έ,Δ' + -- ---------------------------------- InstRAIIL + -- Γ[ά] ⊢ ∀ε.Ε =:< ά ⊣ Δ + | TAll tvar t <- typ = do + tevar' <- fresh + insertEnv $ EnvMark tevar' + insertEnv $ EnvTVar tvar + let t' = substitute tvar tevar' t + instantiateR t' tevar + let (env_l, _) = splitOn (EnvTVar tvar) env + putEnv env_l + + + | otherwise = error $ "Trying to instantiateR: " ++ ppT typ ++ " <: " + ++ ppT (TEVar tevar) + + +-- ----------------------------- InstLReach +-- Γ[ά][έ] ⊢ ά :=< έ ⊣ Γ[ά][έ=ά] +-- +-- ----------------------------- InstRReach +-- Γ[ά][έ] ⊢ έ =:< ά ⊣ Γ[ά][έ=ά] +instReach :: TEVar -> TEVar -> Tc () +instReach tevar tevar' = do + (env_l, env_r) <- gets (splitOn (EnvTEVar tevar') . env) + let env_solved = EnvTEVarSolved tevar' $ TEVar tevar + putEnv $ (env_l :|> env_solved) <> env_r + +--------------------------------------------------------------------------- +-- * Typing rules +--------------------------------------------------------------------------- + +-- | Γ ⊢ e ↑ A ⊣ Δ +-- Under input context Γ, e checks against input type A, with output context ∆ +check :: Exp -> Type -> Tc (T.ExpT' Type) +check exp typ + + -- Γ,α ⊢ e ↑ A ⊣ Δ,α,Θ + -- ------------------- ∀I + -- Γ ⊢ e ↑ ∀α.A ⊣ Δ + | TAll tvar t <- typ = do + let env_tvar = EnvTVar tvar + insertEnv env_tvar + exp' <- check exp t + (env_l, _) <- gets (splitOn env_tvar . env) + putEnv env_l + pure exp' + + -- Γ,(x:A) ⊢ e ↑ B ⊢ Δ,(x:A),Θ + -- --------------------------- →I + -- Γ ⊢ λx.e ↑ A → B ⊣ Δ + | EAbs name e <- exp + , TFun t1 t2 <- typ = do + let env_id = EnvVar name t1 + insertEnv env_id + e' <- check e t2 + (env_l, _) <- gets (splitOn env_id . env) + putEnv env_l + pure (T.EAbs (coerce name) e', typ) + + -- Θ ⊢ Π ∷ [Θ]A ↑ [Θ]C ⊣ Δ + -- Γ ⊢ e ↓ A ⊣ Θ Δ ⊢ Π covers [Δ]A TODO + -- --------------------------------------- + -- Γ ⊢ case e of Π ↑ C ⊣ Δ + | ECase scrut branches <- exp = do + (scrut', t_scrut) <- infer scrut + t_scrut' <- applyEnv t_scrut + typ' <- applyEnv typ + branches' <- mapM (\b -> checkBranch b t_scrut' typ') branches + pure (T.ECase (scrut', t_scrut') branches', typ') + + | otherwise = subsumption + where + -- Γ,α ⊢ e ↓ A ⊣ Θ Θ ⊢ [Θ]A <: [Θ]B ⊣ Δ + -- -------------------------------------- Sub + -- Γ ⊢ e ↑ B ⊣ Δ + subsumption = do + (exp', t) <- infer exp + exp'' <- applyEnvExp exp' + t' <- applyEnv t + typ' <- applyEnv typ + subtype t' typ' + pure (exp'', t') + +-- | Γ ⊢ e ↓ A ⊣ Δ +-- Under input context Γ, e infers output type A, with output context ∆ +infer :: Exp -> Tc (T.ExpT' Type) +infer = \case + + ELit lit -> pure (T.ELit lit, inferLit lit) + + -- (x : A) ∈ Γ + -- ------------- Var + -- Γ ⊢ x ↓ A ⊣ Γ + EVar name -> do + t <- liftA2 (<|>) (lookupEnv name) (lookupSig name) >>= \case + Just t -> pure t + Nothing -> do + e <- maybeToRightM + ("Unbound variable " ++ show name) + =<< lookupBind name + snd <$> infer e + pure (T.EVar (coerce name), t) + + EInj name -> do + t <- maybeToRightM ("Unknown constructor: " ++ show name) =<< lookupInj name + pure (T.EInj $ coerce name, t) + + -- Γ ⊢ A Γ ⊢ e ↑ A ⊣ Δ + -- --------------------- Anno + -- Γ ⊢ (e : A) ↓ A ⊣ Δ + EAnn e t -> do + _ <- gets $ (`wellFormed` t) . env + (e', _) <- check e t + pure (e', t) + + -- Γ ⊢ e₁ ↓ A ⊣ Θ Γ ⊢ [Θ]A • ⇓ C ⊣ Δ + -- ----------------------------------- →E + -- Γ ⊢ e₁ e₂ ↓ C ⊣ Δ + EApp e1 e2 -> do + (e1', t) <- infer e1 + t' <- applyEnv t + e1'' <- applyEnvExp e1' + (e2', t'') <- apply t' e2 + pure (T.EApp (e1'', t) e2', t'') + + -- Γ,ά,έ,(x:ά) ⊢ e ↑ έ ⊣ Δ,(x:ά),Θ + -- ------------------------------- →I + -- Γ ⊢ λx.e ↓ ά → έ ⊣ Δ + EAbs name e -> do + tevar1 <- fresh + tevar2 <- fresh + insertEnv $ EnvTEVar tevar1 + insertEnv $ EnvTEVar tevar2 + let env_id = EnvVar name (TEVar tevar1) + insertEnv env_id + e' <- check e $ TEVar tevar2 + dropTrailing env_id + let t_exp = on TFun TEVar tevar1 tevar2 + pure (T.EAbs (coerce name) e', t_exp) + + + -- Γ ⊢ e ↓ A ⊣ Θ Θ,(x:A) ⊢ e' ↑ C ⊣ Δ,(x:A),Θ + -- -------------------------------------------- LetI + -- Γ ⊢ let x=e in e' ↑ C ⊣ Δ + ELet (Bind name [] rhs) e -> do -- TODO vars + (rhs', t_rhs) <- infer rhs + let env_id = EnvVar name t_rhs + insertEnv env_id + (e', t) <- infer e + (env_l, _) <- gets (splitOn env_id . env) + putEnv env_l + pure (T.ELet (T.Bind (coerce name, t_rhs) [] (rhs', t_rhs)) (e',t), t) + + -- Γ ⊢ e₁ ↑ Int Γ ⊢ e₁ ↑ Int + -- --------------------------- +I + -- Γ ⊢ e₁ + e₂ ↓ Int ⊣ Δ + EAdd e1 e2 -> do + cxt <- get + let t = TLit "Int" + e1' <- check e1 t + put cxt + e2' <- check e2 t + pure (T.EAdd e1' e2', t) + +-- | Γ ⊢ A • e ⇓ C ⊣ Δ +-- Under input context Γ , applying a function of type A to e infers type C, with output context ∆ +-- Instantiate existential type variables until there is an arrow type. +apply :: Type -> Exp -> Tc (T.ExpT' Type, Type) +apply typ exp = case typ of + + -- Γ,ά ⊢ [ά/α]A • e ⇓ C ⊣ Δ + -- ------------------------ ∀App + -- Γ ⊢ ∀α.A • e ⇓ C ⊣ Δ + TAll tvar t -> do + tevar <- fresh + insertEnv $ EnvTEVar tevar + let t' = substitute tvar tevar t + apply t' exp + + -- Γ[ά₂,ά₁,(ά=ά₁→ά₂)] ⊢ e ↑ ά₁ ⊣ Δ + -- ------------------------------- άApp + -- Γ[ά] ⊢ ά • e ⇓ ά₂ ⊣ Δ + TEVar tevar -> do + tevar1 <- fresh + tevar2 <- fresh + let env_tevar1 = EnvTEVar tevar1 + env_tevar2 = EnvTEVar tevar2 + t_fun = on TFun TEVar tevar1 tevar2 + env_tevar_solved = EnvTEVarSolved tevar t_fun + (env_l, env_r) <- gets (splitOn (EnvTEVar tevar) . env) + putEnv $ + (env_l :|> env_tevar2 :|> env_tevar1 :|> env_tevar_solved) <> env_r + expT' <- check exp $ TEVar tevar1 + pure (expT', TEVar tevar2) + + -- Γ ⊢ e ↑ A ⊣ Δ + -- --------------------- →App + -- Γ ⊢ A → C • e ⇓ C ⊣ Δ + TFun t1 t2 -> do + expt' <- check exp t1 + pure (expt', t2) + + _ -> throwError ("Cannot apply type " ++ show typ ++ " with expression " ++ show exp) + +--------------------------------------------------------------------------- +-- * Pattern matching +--------------------------------------------------------------------------- + +-- | Γ ⊢ p ⇒ e ∷ A ↑ C +-- Under context Γ, check branch p ⇒ e of type A and bodies of type C +checkBranch :: Branch -> Type -> Type -> Tc (T.Branch' Type) +checkBranch (Branch patt exp) t_patt t_exp = do + env_marker <- EnvMark <$> fresh + insertEnv env_marker + patt' <- checkPattern patt t_patt + t_exp' <- applyEnv t_exp + (exp, t_exp) <- check exp t_exp' + (env_l, _) <- gets (splitOn env_marker . env) + putEnv env_l + pure (T.Branch patt' (exp, t_exp)) + +checkPattern :: Pattern -> Type -> Tc (T.Pattern' Type, Type) +checkPattern patt t_patt = case patt of + PVar x -> do + insertEnv $ EnvVar x t_patt + pure (T.PVar (coerce x, dummy), dummy) -- TODO + PCatch -> pure (T.PCatch, dummy) -- TODO + PLit lit | inferLit lit == t_patt -> let + t = inferLit lit + in + pure (T.PLit (lit, t), t) + | otherwise -> throwError "Literal in pattern have wrong type" + + PEnum name -> do + t <- maybeToRightM ("Unknown constructor " ++ show name) + =<< lookupInj name + subtype t t_patt + pure (T.PEnum (coerce name), dummy) -- TODO + + PInj name ps -> do + t <- maybeToRightM ("Unknown constructor " ++ show name) + =<< lookupInj name + let (t_ps, t_return) = partitionTypeWithForall t + unless (length ps == length t_ps) $ + throwError "Wrong number of variables" + subtype t_return t_patt + ps' <- zipWithM (\p t -> checkPattern p =<< applyEnv t) ps t_ps + let ps'' = map fst ps' -- TODO + pure (T.PInj (coerce name) ps'', dummy) + +--------------------------------------------------------------------------- +-- * Auxiliary +--------------------------------------------------------------------------- + +frees :: Type -> [TEVar] +frees = \case + TLit _ -> [] + TVar _ -> [] + TEVar tevar -> [tevar] + TFun t1 t2 -> on (++) frees t1 t2 + TAll _ t -> frees t + TData _ typs -> concatMap frees typs + +-- | [ά/α]A +substitute :: TVar -- α + -> TEVar -- ά + -> Type -- A + -> Type -- [ά/α]A +substitute tvar tevar typ = case typ of + TLit _ -> typ + TVar tvar' | tvar' == tvar -> TEVar tevar + | otherwise -> typ + TEVar _ -> typ + TFun t1 t2 -> on TFun substitute' t1 t2 + TAll tvar' t -> TAll tvar' (substitute' t) + TData name typs -> TData name $ map substitute' typs + where + substitute' = substitute tvar tevar + +-- | Γ,x,Γ' → (Γ, Γ') +splitOn :: EnvElem -> Env -> (Env, Env) +splitOn x env = second (S.drop 1) $ S.breakl (==x) env + +-- | Drop frontmost elements until and including element @x@. +dropTrailing :: EnvElem -> Tc () +dropTrailing x = modifyEnv $ S.takeWhileL (/= x) + +applyEnvExp :: T.Exp' Type -> Tc (T.Exp' Type) +applyEnvExp exp = case exp of + T.ELet (T.Bind id vars rhs) exp -> do + id <- applyEnvId id + vars' <- mapM applyEnvId vars + rhs' <- applyEnvExpT rhs + exp' <- applyEnvExpT exp + pure $ T.ELet (T.Bind id vars' rhs') exp' + T.EApp e1 e2 -> liftA2 T.EApp (applyEnvExpT e1) (applyEnvExpT e2) + T.EAdd e1 e2 -> liftA2 T.EAdd (applyEnvExpT e1) (applyEnvExpT e2) + T.EAbs name e -> T.EAbs name <$> applyEnvExpT e + T.ECase e branches -> liftA2 T.ECase (applyEnvExpT e) + (mapM applyEnvBranch branches) + _ -> pure exp + where + applyEnvExpT (e, t) = liftA2 (,) (applyEnvExp e) (applyEnv t) + applyEnvId = secondM applyEnv + applyEnvBranch (T.Branch (p, t) e) = do + pt <- liftA2 (,) (applyEnvPattern p) (applyEnv t) + e' <- applyEnvExpT e + pure $ T.Branch pt e' + applyEnvPattern = \case + T.PVar id -> T.PVar <$> applyEnvId id + T.PLit (lit, t) -> T.PLit . (lit, ) <$> applyEnv t + T.PInj name ps -> T.PInj name <$> mapM applyEnvPattern ps + p -> pure p + +applyEnv :: Type -> Tc Type +applyEnv t = gets $ (`applyEnv'` t) . env + +-- | [Γ]A. Applies context to type until fully applied. +applyEnv' :: Env -> Type -> Type +applyEnv' cxt typ | typ == typ' = typ' + | otherwise = applyEnv' cxt typ' + where + typ' = case typ of + TLit _ -> typ + TData name typs -> TData name $ map (applyEnv' cxt) typs + -- [Γ]α = α + TVar _ -> typ + -- [Γ[ά=τ]]ά = [Γ[ά=τ]]τ + -- [Γ[ά]]ά = [Γ[ά]]ά + TEVar tevar -> fromMaybe typ $ findSolved tevar cxt + -- [Γ](A → B) = [Γ]A → [Γ]B + TFun t1 t2 -> on TFun (applyEnv' cxt) t1 t2 + -- [Γ](∀α. A) = (∀α. [Γ]A) + TAll tvar t -> TAll tvar $ applyEnv' cxt t + +findSolved :: TEVar -> Env -> Maybe Type +findSolved _ Empty = Nothing +findSolved tevar (xs :|> x) = case x of + EnvTEVarSolved tevar' t | tevar == tevar' -> Just t + _ -> findSolved tevar xs + +-- | Γ ⊢ A +-- Under context Γ, type A is well-formed +wellFormed :: Env -> Type -> Err () +wellFormed env = \case + TLit _ -> pure () + + -- -------- UvarWF + -- Γ[α] ⊢ α + TVar tvar -> unless (EnvTVar tvar `elem` env) $ + throwError ("Unbound type variable: " ++ show tvar) + -- Γ ⊢ A Γ ⊢ B + -- ------------- ArrowWF + -- Γ ⊢ A → B + TFun t1 t2 -> do { wellFormed env t1; wellFormed env t2 } + + -- Γ,α ⊢ A + -- -------- ForallWF + -- Γ ⊢ ∀α.A + TAll tvar t -> wellFormed (env :|> EnvTVar tvar) t + + TEVar tevar + -- ---------- EvarWF + -- Γ[ά] ⊢ ά + | EnvTEVar tevar `elem` env -> pure () + + -- ---------- SolvedEvarWF + -- Γ[ά=τ] ⊢ ά + | Just _ <- findSolved tevar env -> pure () + | otherwise -> throwError ("Can't find type: " ++ show tevar) + + TData _ typs -> mapM_ (wellFormed env) typs + +isMono :: Type -> Bool +isMono = \case + TAll{} -> False + TFun t1 t2 -> on (&&) isMono t1 t2 + TData _ typs -> all isMono typs + TVar _ -> True + TEVar _ -> True + TLit _ -> True + +inferLit :: Lit -> Type +inferLit = \case + LInt _ -> TLit "Int" + LChar _ -> TLit "Char" + +fresh :: Tc TEVar +fresh = do + tevar <- gets (MkTEVar . LIdent . ("a#" ++) . show . next_tevar) + modify $ \cxt -> cxt { next_tevar = succ cxt.next_tevar } + pure tevar + +getVars :: Type -> [Type] +getVars = fst . partitionType + +getReturn :: Type -> Type +getReturn = snd . partitionType + +-- | Partion type into variable types and return type. +-- +-- ∀a.∀b. a → (∀c. c → c) → b +-- ([a, ∀c. c → c], b) +-- +-- Unsure if foralls should be added to the return type or not. +partitionType :: Type -> ([Type], Type) +partitionType = go [] . skipForalls' + where + + go acc t = case t of + TFun t1 t2 -> go (snoc t1 acc) t2 + _ -> (acc, t) + +skipForalls' :: Type -> Type +skipForalls' = snd . skipForalls + +skipForalls :: Type -> ([Type -> Type], Type) +skipForalls = go [] + where + go acc typ = case typ of + TAll tvar t -> go (snoc (TAll tvar) acc) t + _ -> (acc, typ) + +partitionTypeWithForall :: Type -> ([Type], Type) +partitionTypeWithForall typ = (t_vars', t_return') + where + t_vars' = map (\t -> foldr applyForall t foralls) t_vars + t_return' = foldr applyForall t_return foralls + + applyForall fa t | usesTVar tvar t = fa t + | otherwise = t + where TAll tvar _ = fa t + + (t_vars, t_return) = go [] typ' + (foralls, typ') = skipForalls typ + + + go acc t = case t of + TFun t1 t2 -> go (snoc t1 acc) t2 + _ -> (acc, t) + +usesTVar :: TVar -> Type -> Bool +usesTVar tvar = \case + TLit _ -> False + TVar tvar' | tvar' == tvar -> True + | otherwise -> False + TFun t1 t2 -> on (||) usesTVar' t1 t2 + TAll tvar' t | tvar' == tvar -> error "Redeclaration of TVar" + | otherwise -> usesTVar' t + TData _ typs -> any usesTVar' typs + _ -> error "Impossible" + where + usesTVar' = usesTVar tvar + +skipLambdas :: Int -> T.Exp' Type -> T.Exp' Type +skipLambdas i exp + | i == 0 = exp + | T.EAbs _ (e, _) <- exp = skipLambdas (i-1) e + | otherwise = error "Number of expected lambdas doesn't match expression" + +isComplete :: Env -> Bool +isComplete = isNothing . S.findIndexL unSolvedTEVar + where + unSolvedTEVar = \case + EnvTEVar _ -> True + _ -> False + +toTVar :: Type -> Err TVar +toTVar = \case + TVar tvar -> pure tvar + _ -> throwError "Not a type variable" + +insertEnv :: EnvElem -> Tc () +insertEnv x = modifyEnv (:|> x) + +lookupBind :: LIdent -> Tc (Maybe Exp) +lookupBind x = gets (Map.lookup x . binds) + +lookupSig :: LIdent -> Tc (Maybe Type) +lookupSig x = gets (Map.lookup x . sig) + +lookupEnv :: LIdent -> Tc (Maybe Type) +lookupEnv x = gets (findId . env) + where + findId Empty = Nothing + findId (ys :|> y) = case y of + EnvVar x' t | x==x' -> Just t + _ -> findId ys + +lookupInj :: UIdent -> Tc (Maybe Type) +lookupInj x = gets (Map.lookup x . data_injs) + +putEnv :: Env -> Tc () +putEnv = modifyEnv . const + +modifyEnv :: (Env -> Env) -> Tc () +modifyEnv f = + modify $ \cxt -> {- trace (ppEnv (f cxt.env)) -} cxt { env = f cxt.env } + +pattern DBind' name vars exp = DBind (Bind name vars exp) +pattern DSig' name typ = DSig (Sig name typ) + +dummy = TLit "Int" + +--------------------------------------------------------------------------- +-- * Debug +--------------------------------------------------------------------------- + +traceEnv s = do + env <- gets env + trace (s ++ " " ++ show env) pure () + +traceD s x = trace (s ++ " " ++ show x) pure () + +traceT s x = trace (s ++ " " ++ ppT x) pure () + +traceTs s xs = trace (s ++ " [ " ++ intercalate ", " (map ppT xs) ++ " ]") pure () + +ppT = \case + TLit (UIdent s) -> s + TVar (MkTVar (LIdent s)) -> "α_" ++ s + TFun t1 t2 -> ppT t1 ++ "→" ++ ppT t2 + TAll (MkTVar (LIdent s)) t -> "forall " ++ s ++ ". " ++ ppT t + TEVar (MkTEVar (LIdent s)) -> "ά_" ++ s + TData (UIdent name) typs -> name ++ " (" ++ unwords (map ppT typs) + ++ " )" +ppEnvElem = \case + EnvVar (LIdent s) t -> s ++ ":" ++ ppT t + EnvTVar (MkTVar (LIdent s)) -> "α_" ++ s + EnvTEVar (MkTEVar (LIdent s)) -> "ά_" ++ s + EnvTEVarSolved (MkTEVar (LIdent s)) t -> "ά_" ++ s ++ "=" ++ ppT t + EnvMark (MkTEVar (LIdent s)) -> "▶" ++ "ά_" ++ s + +ppEnv = \case + Empty -> "·" + (xs :|> x) -> ppEnv xs ++ " (" ++ ppEnvElem x ++ ")" diff --git a/src/TypeChecker/TypeCheckerHm.hs b/src/TypeChecker/TypeCheckerHm.hs index ba07616..adcf033 100644 --- a/src/TypeChecker/TypeCheckerHm.hs +++ b/src/TypeChecker/TypeCheckerHm.hs @@ -1,36 +1,31 @@ -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} -- | A module for type checking and inference using algorithm W, Hindley-Milner module TypeChecker.TypeChecker where -import Auxiliary -import Control.Monad.Except -import Control.Monad.Identity (runIdentity) -import Control.Monad.Reader -import Control.Monad.State -import Data.Bifunctor (second) -import Data.Coerce (coerce) -import Data.Foldable (traverse_) -import Data.Function (on) -import Data.List (foldl') -import Data.List.Extra (unsnoc) -import Data.Map (Map) -import Data.Map qualified as M -import Data.Maybe (fromJust) -import Data.Set (Set) -import Data.Set qualified as S -import Debug.Trace (trace) -import Grammar.Abs -import Grammar.Print (printTree) -import TypeChecker.TypeCheckerIr ( - Ctx (..), - Env (..), - Error, - Infer, - Subst, - ) -import TypeChecker.TypeCheckerIr qualified as T +import Auxiliary +import Control.Monad.Except +import Control.Monad.Identity (runIdentity) +import Control.Monad.Reader +import Control.Monad.State +import Data.Bifunctor (second) +import Data.Coerce (coerce) +import Data.Foldable (traverse_) +import Data.Function (on) +import Data.List (foldl') +import Data.List.Extra (unsnoc) +import Data.Map (Map) +import qualified Data.Map as M +import Data.Maybe (fromJust) +import Data.Set (Set) +import qualified Data.Set as S +import Debug.Trace (trace) +import Grammar.Abs +import Grammar.Print (printTree) +import qualified TypeChecker.TypeCheckerIr as T +import TypeChecker.TypeCheckerIr (Ctx (..), Env (..), Error, Infer, + Subst) initCtx = Ctx mempty initEnv = Env 0 'a' mempty mempty mempty @@ -78,7 +73,7 @@ checkData d = do retType :: Type -> Type retType (TFun _ t2) = retType t2 -retType a = a +retType a = a checkPrg :: Program -> Infer T.Program checkPrg (Program bs) = do @@ -105,7 +100,7 @@ preRun (x : xs) = case x of s <- gets sigs case M.lookup (coerce n) s of Nothing -> insertSig (coerce n) Nothing >> preRun xs - Just _ -> preRun xs + Just _ -> preRun xs DData d@(Data t _) -> collect (collectTypeVars t) >> checkData d >> preRun xs checkDef :: [Def] -> Infer [T.Def] @@ -152,9 +147,9 @@ typeEq _ _ = False skolem :: T.Type -> T.Type skolem (T.TVar (T.MkTVar a)) = T.TLit a -skolem (T.TAll x t) = T.TAll x (skolem t) -skolem (T.TFun t1 t2) = (T.TFun `on` skolem) t1 t2 -skolem t = t +skolem (T.TAll x t) = T.TAll x (skolem t) +skolem (T.TFun t1 t2) = (T.TFun `on` skolem) t1 t2 +skolem t = t isMoreSpecificOrEq :: T.Type -> T.Type -> Bool isMoreSpecificOrEq t1 (T.TAll _ t2) = isMoreSpecificOrEq t1 t2 @@ -169,8 +164,8 @@ isMoreSpecificOrEq a b = a == b isPoly :: Type -> Bool isPoly (TAll _ _) = True -isPoly (TVar _) = True -isPoly _ = False +isPoly (TVar _) = True +isPoly _ = False inferExp :: Exp -> Infer T.ExpT inferExp e = do @@ -183,7 +178,7 @@ class CollectTVars a where instance CollectTVars Exp where collectTypeVars (EAnn e t) = collectTypeVars t `S.union` collectTypeVars e - collectTypeVars _ = S.empty + collectTypeVars _ = S.empty instance CollectTVars Type where collectTypeVars (TVar (MkTVar i)) = S.singleton (coerce i) @@ -200,15 +195,15 @@ class NewType a b where instance NewType Type T.Type where toNew = \case - TLit i -> T.TLit $ coerce i - TVar v -> T.TVar $ toNew v + TLit i -> T.TLit $ coerce i + TVar v -> T.TVar $ toNew v TFun t1 t2 -> (T.TFun `on` toNew) t1 t2 - TAll b t -> T.TAll (toNew b) (toNew t) + TAll b t -> T.TAll (toNew b) (toNew t) TData i ts -> T.TData (coerce i) (map toNew ts) - TEVar _ -> error "Should not exist after typechecker" + TEVar _ -> error "Should not exist after typechecker" instance NewType Lit T.Lit where - toNew (LInt i) = T.LInt i + toNew (LInt i) = T.LInt i toNew (LChar i) = T.LChar i instance NewType Data T.Data where @@ -422,12 +417,12 @@ generalize :: Map T.Ident T.Type -> T.Type -> T.Type generalize env t = go (S.toList $ free t S.\\ free env) (removeForalls t) where go :: [T.Ident] -> T.Type -> T.Type - go [] t = t + go [] t = t go (x : xs) t = T.TAll (T.MkTVar x) (go xs t) removeForalls :: T.Type -> T.Type - removeForalls (T.TAll _ t) = removeForalls t + removeForalls (T.TAll _ t) = removeForalls t removeForalls (T.TFun t1 t2) = T.TFun (removeForalls t1) (removeForalls t2) - removeForalls t = t + removeForalls t = t {- | Instantiate a polymorphic type. The free type variables are substituted with fresh ones. @@ -477,10 +472,10 @@ instance SubstType T.Type where T.TLit a -> T.TLit a T.TVar (T.MkTVar a) -> case M.lookup a sub of Nothing -> T.TVar (T.MkTVar $ coerce a) - Just t -> t + Just t -> t T.TAll (T.MkTVar i) t -> case M.lookup i sub of Nothing -> T.TAll (T.MkTVar i) (apply sub t) - Just _ -> apply sub t + Just _ -> apply sub t T.TFun a b -> T.TFun (apply sub a) (apply sub b) T.TData name a -> T.TData name (map (apply sub) a) instance FreeVars (Map T.Ident T.Type) where @@ -513,10 +508,10 @@ instance SubstType T.Pattern where apply :: Subst -> T.Pattern -> T.Pattern apply s = \case T.PVar (iden, t) -> T.PVar (iden, apply s t) - T.PLit (lit, t) -> T.PLit (lit, apply s t) - T.PInj i ps -> T.PInj i $ apply s ps - T.PCatch -> T.PCatch - T.PEnum i -> T.PEnum i + T.PLit (lit, t) -> T.PLit (lit, apply s t) + T.PInj i ps -> T.PInj i $ apply s ps + T.PCatch -> T.PCatch + T.PEnum i -> T.PEnum i instance SubstType a => SubstType [a] where apply s = map (apply s) @@ -555,7 +550,7 @@ fresh = do next :: Char -> Char next 'z' = 'a' -next a = succ a +next a = succ a -- | Run the monadic action with an additional binding withBinding :: (Monad m, MonadReader Ctx m) => T.Ident -> T.Type -> m a -> m a @@ -608,10 +603,10 @@ inferBranch (Branch pat expr) = do withPattern :: T.Pattern -> Infer a -> Infer a withPattern p ma = case p of T.PVar (x, t) -> withBinding x t ma - T.PInj _ ps -> foldl' (flip withPattern) ma ps - T.PLit _ -> ma - T.PCatch -> ma - T.PEnum _ -> ma + T.PInj _ ps -> foldl' (flip withPattern) ma ps + T.PLit _ -> ma + T.PCatch -> ma + T.PEnum _ -> ma inferPattern :: Pattern -> Infer (T.Pattern, T.Type) inferPattern = \case @@ -659,14 +654,14 @@ inferPattern = \case flattenType :: T.Type -> [T.Type] flattenType (T.TFun a b) = flattenType a <> flattenType b -flattenType a = [a] +flattenType a = [a] typeLength :: T.Type -> Int typeLength (T.TFun a b) = typeLength a + typeLength b -typeLength _ = 1 +typeLength _ = 1 litType :: Lit -> T.Type -litType (LInt _) = int +litType (LInt _) = int litType (LChar _) = char int = T.TLit "Int" @@ -681,8 +676,8 @@ partitionType = go [] go acc 0 t = (acc, t) go acc i t = case t of TAll tvar t' -> second (TAll tvar) $ go acc i t' - TFun t1 t2 -> go (acc <> [t1]) (i - 1) t2 - _ -> error "Number of parameters and type doesn't match" + TFun t1 t2 -> go (acc <> [t1]) (i - 1) t2 + _ -> error "Number of parameters and type doesn't match" exprErr :: Infer a -> Exp -> Infer a exprErr ma exp = @@ -695,3 +690,4 @@ unzip4 = (as ++ [a], bs ++ [b], cs ++ [c], ds ++ [d]) ) ([], [], [], []) + diff --git a/src/TypeChecker/TypeCheckerIr.hs b/src/TypeChecker/TypeCheckerIr.hs index 74dc649..d56c14c 100644 --- a/src/TypeChecker/TypeCheckerIr.hs +++ b/src/TypeChecker/TypeCheckerIr.hs @@ -1,245 +1,135 @@ -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE PatternSynonyms #-} -module TypeChecker.TypeCheckerIr ( - module TypeChecker.TypeCheckerIr, -) where -import Control.Monad.Except -import Control.Monad.Reader -import Control.Monad.State -import Data.Char (isDigit) -import Data.Functor.Identity (Identity) -import Data.Map (Map) -import Data.Set (Set) -import Data.String qualified -import Grammar.Print -import Prelude -import Prelude qualified as C (Eq, Ord, Read, Show) +module TypeChecker.TypeCheckerIr + ( module Grammar.Abs + , module TypeChecker.TypeCheckerIr + ) where -newtype Ctx = Ctx {vars :: Map Ident Type} - deriving (Show) +import Data.String (IsString) +import Grammar.Abs (Character (..), Lit (..), TVar (..)) +import Grammar.Print +import Prelude +import qualified Prelude as C (Eq, Ord, Read, Show) -data Env = Env - { count :: Int - , nextChar :: Char - , sigs :: Map Ident (Maybe Type) - , constructors :: Map Ident Type - , takenTypeVars :: Set Ident - } - deriving (Show) +newtype Program' t = Program [Def' t] + deriving (C.Eq, C.Ord, C.Show, C.Read) -type Error = String -type Subst = Map Ident Type - -type Infer = StateT Env (ReaderT Ctx (ExceptT Error Identity)) - -newtype Program = Program [Def] - deriving (C.Eq, C.Ord, C.Show, C.Read) - -data Data = Data Ident [Constructor] - deriving (Show, Eq, Ord, Read) - -data Constructor = Constructor Ident Type - deriving (Show, Eq, Ord, Read) - -newtype TVar = MkTVar Ident - deriving (Show, Eq, Ord, Read) +data Def' t = DBind (Bind' t) + | DData (Data' t) + deriving (C.Eq, C.Ord, C.Show, C.Read) data Type = TLit Ident | TVar TVar + | TData Ident [Type] | TFun Type Type | TAll TVar Type - | TData Ident [Type] - deriving (Show, Eq, Ord, Read) + deriving (C.Eq, C.Ord, C.Show, C.Read) -data Exp - = EId Ident - | ELit Lit - | ELet Bind ExpT - | EApp ExpT ExpT - | EAdd ExpT ExpT - | EAbs Ident ExpT - | ECase ExpT [Branch] - deriving (C.Eq, C.Ord, C.Read, C.Show) +data Data' t = Data t [Inj' t] + deriving (C.Eq, C.Ord, C.Show, C.Read) -type ExpT = (Exp, Type) - -data Branch = Branch (Pattern, Type) ExpT - deriving (C.Eq, C.Ord, C.Read, C.Show) - -data Pattern = PVar Id | PLit (Lit, Type) | PInj Ident [Pattern] | PCatch | PEnum Ident - deriving (C.Eq, C.Ord, C.Show, C.Read) - -data Def = DBind Bind | DData Data - deriving (C.Eq, C.Ord, C.Read, C.Show) - -type Id = (Ident, Type) +data Inj' t = Inj Ident t + deriving (C.Eq, C.Ord, C.Show, C.Read) newtype Ident = Ident String - deriving (C.Eq, C.Ord, C.Show, C.Read, Data.String.IsString) + deriving (C.Eq, C.Ord, C.Show, C.Read, IsString) -data Lit = LInt Integer | LChar Char - deriving (Show, Eq, Ord, Read) +data Pattern' t + = PVar (Id' t) -- TODO should be Ident + | PLit (Lit, t) -- TODO should be Lit + | PCatch + | PEnum Ident + | PInj Ident [Pattern' t] -- TODO should be (Pattern' t, t) + deriving (C.Eq, C.Ord, C.Show, C.Read) -data Bind = Bind Id [Id] ExpT +data Exp' t + = EVar Ident + | EInj Ident + | ELit Lit + | ELet (Bind' t) (ExpT' t) + | EApp (ExpT' t) (ExpT' t) + | EAdd (ExpT' t) (ExpT' t) + | EAbs Ident (ExpT' t) + | ECase (ExpT' t) [Branch' t] + deriving (C.Eq, C.Ord, C.Show, C.Read) + +type Id' t = (Ident, t) +type ExpT' t = (Exp' t, t) + +data Bind' t = Bind (Id' t) [Id' t] (ExpT' t) deriving (C.Eq, C.Ord, C.Show, C.Read) +data Branch' t = Branch (Pattern' t, t) (ExpT' t) + deriving (C.Eq, C.Ord, C.Show, C.Read) + instance Print Ident where - prt _ (Ident str) = doc . showString $ str + prt i (Ident s) = prt i s -instance Print [Def] where - prt _ [] = concatD [] - prt _ (x : xs) = concatD [prt 0 x, doc (showString "\n\n"), prt 0 xs] - -instance Print Data where - prt i = \case - Data type_ constructors -> prPrec i 0 (concatD [doc (showString "data"), prt 0 type_, doc (showString "where"), doc (showString "{"), prt 0 constructors, doc (showString "}")]) - -instance Print Constructor where - prt i = \case - Constructor uident type_ -> prPrec i 0 (concatD [prt 0 uident, doc (showString ":"), prt 0 type_]) - -instance Print [Constructor] where - prt _ [] = concatD [] - prt _ [x] = concatD [prt 0 x] - prt _ (x : xs) = concatD [prt 0 x, prt 0 xs] - -instance Print Def where - prt i (DBind bind) = prt i bind - prt i (DData d) = prt i d - -instance Print Program where +instance Print t => Print (Program' t) where prt i (Program sc) = prPrec i 0 $ prt 0 sc -instance Print Bind where - prt i (Bind (name, t) args rhs) = - prPrec i 0 $ - concatD - [ prt 0 name - , doc $ showString ":" - , prt 0 t - , doc $ showString "\n" - , prt 0 name - , prtIdPs 0 args - , doc $ showString "=" - , prt 0 rhs - ] +instance Print t => Print (Bind' t) where + prt i (Bind sig@(name, _) parms rhs) = prPrec i 0 $ concatD + [ prtSig sig + , prt 0 name + , 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 ";"), doc (showString "\n"), prt 0 xs] +prtSig :: Print t => Id' t -> Doc +prtSig (name, t) = concatD [ prt 0 name + , doc $ showString ":" + , prt 0 t + , doc $ showString ";" + ] -prtIdPs :: Int -> [Id] -> Doc -prtIdPs i = prPrec i 0 . concatD . map (prtIdP i) +instance Print t => Print (ExpT' t) where + prt i (e, t) = concatD [ doc $ showString "(" + , prt i e + , doc $ showString "," + , prt i t + , doc $ showString ")" + ] -prtId :: Int -> Id -> Doc -prtId i (name, t) = - prPrec i 0 $ - concatD - [ doc $ showString "(" - , prt 0 name - , doc $ showString ":" - , prt 0 t - , doc $ showString ")" - ] +instance Print t => Print [Bind' t] where + prt _ [] = concatD [] + prt _ [x] = concatD [prt 0 x] + prt _ (x:xs) = concatD [prt 0 x, doc (showString ";"), prt 0 xs] -prtIdP :: Int -> Id -> Doc -prtIdP i (name, t) = - prPrec i 0 $ - concatD - [ doc $ showString "(" - , prt 0 name - , doc $ showString ":" - , prt 0 t - , doc $ showString ")" - ] +prtIdPs :: Print t => Int -> [Id' t] -> Doc +prtIdPs i = prPrec i 0 . concatD . map (prt i) -instance Print Exp where - prt i = \case - EId n -> prPrec i 3 $ concatD [prt 0 n] - ELit lit -> prPrec i 3 $ concatD [prt 0 lit] - ELet bs e -> - prPrec i 3 $ - concatD - [ doc $ showString "let" - , prt 0 bs - , doc $ showString "in" - , prt 0 e - ] - EApp e1 e2 -> - prPrec i 2 $ - concatD - [ prt 2 e1 - , prt 3 e2 - ] - EAdd e1 e2 -> - prPrec i 1 $ - concatD - [ doc $ showString "@" - , prt 1 e1 - , doc $ showString "+" - , prt 2 e2 - ] - EAbs n e -> - prPrec i 0 $ - concatD - [ doc $ showString "λ" - , prt 0 n - , doc $ showString "." - , prt 0 e - ] - ECase exp injs -> - prPrec - i - 0 - ( concatD - [ doc (showString "case") - , prt 0 exp - , doc (showString "of") - , doc (showString "{") - , prt 0 injs - , doc (showString "}") - , doc (showString ":") - ] - ) +instance Print t => Print (Id' t) where + prt i (name, t) = concatD [ doc $ showString "(" + , prt i name + , doc $ showString "," + , prt i t + , doc $ showString ")" + ] -instance Print ExpT where - prt i (e, t) = concatD [doc $ showString "(", prt i e, doc (showString ":"), prt i t, doc $ showString ")"] - -instance Print Branch where - prt i = \case - Branch (init, t) exp -> prPrec i 0 (concatD [prt 0 init, doc (showString ":"), prt 0 t, doc (showString "=>"), prt 0 exp]) - -instance Print Pattern where - prt i = \case - PVar lident -> prPrec i 0 (concatD [prtId 0 lident]) - PLit (lit, typ) -> prPrec i 0 (concatD [doc $ showString "(", prt 0 lit, doc $ showString ",", prt 0 typ, doc $ showString ")"]) - PInj uident patterns -> prPrec i 0 (concatD [prt 0 uident, prt 0 patterns]) - PCatch -> prPrec i 0 (concatD [doc (showString "_")]) - PEnum p -> prt i p - -instance Print [Branch] where - prt _ [] = concatD [] - prt _ [x] = concatD [prt 0 x] - prt _ (x : xs) = concatD [prt 0 x, doc (showString ";"), prt 0 xs] - -instance Print TVar where - prt i (MkTVar id) = prt i id - -instance Print Type where - prt i = \case - TLit uident -> prPrec i 2 (concatD [prt 0 uident]) - TVar tvar@(MkTVar (Ident iden)) -> - if all isDigit iden - then prPrec i 2 (concatD [prt 0 $ TVar (MkTVar (Ident ("a" <> iden)))]) - else prPrec i 2 (concatD [prt 0 tvar]) - TAll tvar type_ -> prPrec i 1 (concatD [doc (showString "forall"), prt 0 tvar, doc (showString "."), prt 0 type_]) - TData ident types -> prPrec i 1 (concatD [prt 0 ident, prt 0 types]) - TFun type_1 type_2 -> prPrec i 0 (concatD [prt 1 type_1, doc (showString "->"), prt 0 type_2]) - -instance Print Lit where - prt i = \case - LInt n -> prPrec i 0 (concatD [prt 0 n]) - LChar c -> prPrec i 0 (concatD [prt 0 c]) +instance Print t => Print (Exp' t) where + prt i = \case + EVar name -> prPrec i 3 $ prt 0 name + EInj name -> prPrec i 3 $ prt 0 name + ELit lit -> prPrec i 3 $ prt 0 lit + ELet b e -> prPrec i 3 $ concatD + [ doc $ showString "let" + , prt 0 b + , doc $ showString "in" + , prt 0 e + ] + EApp e1 e2 -> prPrec i 2 $ concatD + [ prt 2 e1 + , prt 3 e2 + ] + EAdd e1 e2 -> prPrec i 1 $ concatD + [ prt 1 e1 + , doc $ showString "+" + , prt 2 e2 + ] + EAbs v e -> prPrec i 0 $ concatD + [ doc $ showString "\\" diff --git a/tests/TestTypeCheckerBidir.hs b/tests/TestTypeCheckerBidir.hs new file mode 100644 index 0000000..3a20ca6 --- /dev/null +++ b/tests/TestTypeCheckerBidir.hs @@ -0,0 +1,232 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# HLINT ignore "Use camelCase" #-} +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE PatternSynonyms #-} + +module TestTypeCheckerBidir (testTypeCheckerBidir) where + +import Test.Hspec + +import Control.Monad ((<=<)) +import Grammar.ErrM (Err, pattern Bad, pattern Ok) +import Grammar.Par (myLexer, pProgram) +import Renamer.Renamer (rename) +import TypeChecker.RemoveTEVar (RemoveTEVar (rmTEVar)) +import TypeChecker.TypeCheckerBidir (typecheck) +import qualified TypeChecker.TypeCheckerIr as T + + +testTypeCheckerBidir = describe "Bidirectional type checker test" $ do + tc_id + tc_double + tc_add_lam + tc_const + tc_simple_rank2 + tc_rank2 + tc_identity + tc_pair + tc_tree + tc_mono_case + tc_pol_case + +tc_id = specify "Basic identity function polymorphism" $ run + [ "id : forall a. a -> a;" + , "id x = x;" + , "main = id 4;" + ] `shouldSatisfy` ok + +tc_double = specify "Addition inference" $ run + ["double x = x + x;"] `shouldSatisfy` ok + + +tc_add_lam = specify "Addition lambda inference" $ run + ["four = (\\x. x + x) 2;"] `shouldSatisfy` ok + + +tc_const = specify "Basic polymorphism with multiple type variables" $ run + [ "const : forall a. forall b. a -> b -> a;" + , "const x y = x;" + , "main = const 'a' 65;" + ] `shouldSatisfy` ok + +tc_simple_rank2 = specify "Simple rank two polymorphism" $ run + [ "id : forall a. a -> a;" + , "id x = x;" + + , "f : forall a. a -> (forall b. b -> b) -> a;" + , "f x g = g x;" + + , "main = f 4 id;" + ] `shouldSatisfy` ok + +tc_rank2 = specify "Rank two polymorphism is ok" $ run + [ "const : forall a. forall b. a -> b -> a;" + , "const x y = x;" + + , "rank2 : forall a. forall b. a -> (forall c. c -> Int) -> b -> Int;" + , "rank2 x f y = f x + f y;" + + , "main = rank2 3 (\\x. const 5 x : forall a. a -> Int) 'h';" + ] `shouldSatisfy` ok + +tc_identity = describe "(∀b. b → b) should only accept the identity function" $ do + specify "identityᵢₙₜ is rejected" $ run (fs ++ id_int) `shouldNotSatisfy` ok + specify "identity is accepted" $ run (fs ++ id) `shouldSatisfy` ok + where + fs = + [ "f : forall a. a -> (forall b. b -> b) -> a;" + , "f x g = g x;" + + , "id : forall a. a -> a;" + , "id x = x;" + + , "id_int : Int -> Int;" + , "id_int x = x;" + ] + id = + [ "main : Int;" + , "main = f 4 id;" + ] + id_int = + [ "main : Int;" + , "main = f 4 id_int;" + ] + +tc_pair = describe "Pair. Type variables in Pair a b typechecked" $ do + specify "Wrong arguments are rejected" $ run (fs ++ wrong) `shouldNotSatisfy` ok + specify "Correct arguments are accepted" $ run (fs ++ correct) `shouldSatisfy` ok + where + fs = + [ "data forall a. forall b. Pair (a b) where {" + , " Pair : a -> b -> Pair (a b)" + , "};" + + , "main : Pair (Int Char);" + ] + wrong = ["main = Pair 'a' 65;"] + correct = ["main = Pair 65 'a';"] + +tc_tree = describe "Tree. Recursive data type" $ do + specify "Wrong tree is rejected" $ run (fs ++ wrong) `shouldNotSatisfy` ok + specify "Correct tree is accepted" $ run (fs ++ correct) `shouldSatisfy` ok + where + fs = + [ "data forall a. Tree (a) where {" + , " Node : a -> Tree (a) -> Tree (a) -> Tree (a)" + , " Leaf : a -> Tree (a)" + , "};" + ] + wrong = ["tree = Node 1 (Node 2 (Node 4) (Leaf 5)) (Leaf 3);"] + correct = ["tree = Node 1 (Node 2 (Leaf 4) (Leaf 5)) (Leaf 3);"] + +tc_mono_case = describe "Monomorphic pattern matching" $ do + specify "First wrong case expression rejected" + $ run wrong1 `shouldNotSatisfy` ok + specify "Second wrong case expression rejected" + $ run wrong2 `shouldNotSatisfy` ok + specify "Third wrong case expression rejected" + $ run wrong3 `shouldNotSatisfy` ok + specify "First correct case expression accepted" + $ run correct1 `shouldSatisfy` ok + specify "Second correct case expression accepted" + $ run correct2 `shouldSatisfy` ok + + where + wrong1 = + [ "simple : Int -> Int;" + , "simple c = case c of {" + , " 'F' => 0;" + , " 'T' => 1;" + , "};" + ] + wrong2 = + [ "simple : Char -> Int;" + , "simple c = case c of {" + , " 'F' => 0;" + , " 1 => 1;" + , "};" + ] + wrong3 = + [ "simple : Char -> Int;" + , "simple c = case c of {" + , " 'F' => 0;" + , " 'T' => '1';" + , "};" + ] + correct1 = + [ "simple : Char -> Int;" + , "simple c = case c of {" + , " 'F' => 0;" + , " 'T' => 1;" + , "};" + ] + correct2 = + [ "simple : Char -> Int;" + , "simple c = case c of {" + , " 'F' => 0;" + , " _ => 1;" + , "};" + ] + +tc_pol_case = describe "Polymophic pattern matching" $ do + specify "First wrong case expression rejected" + $ run (fs ++ wrong1) `shouldNotSatisfy` ok + specify "Second wrong case expression rejected" + $ run (fs ++ wrong2) `shouldNotSatisfy` ok + specify "Third wrong case expression rejected" + $ run (fs ++ wrong3) `shouldNotSatisfy` ok + specify "First correct case expression accepted" + $ run (fs ++ correct1) `shouldSatisfy` ok + specify "Second correct case expression accepted" + $ run (fs ++ correct2) `shouldSatisfy` ok + where + fs = + [ "data forall a. List (a) where {" + , " Nil : List (a)" + , " Cons : a -> List (a) -> List (a)" + , "};" + ] + wrong1 = + [ "length : forall c. List (c) -> Int;" + , "length = \\list. case list of {" + , " Nil => 0;" + , " Cons 6 xs => 1 + length xs;" + , "};" + ] + wrong2 = + [ "length : forall c. List (c) -> Int;" + , "length = \\list. case list of {" + , " Cons => 0;" + , " Cons x xs => 1 + length xs;" + , "};" + ] + wrong3 = + [ "length : forall c. List (c) -> Int;" + , "length = \\list. case list of {" + , " 0 => 0;" + , " Cons x xs => 1 + length xs;" + , "};" + ] + correct1 = + [ "length : forall c. List (c) -> Int;" + , "length = \\list. case list of {" + , " Nil => 0;" + , " Cons x xs => 1 + length xs;" + , " Cons x (Cons y Nil) => 2;" + , "};" + ] + correct2 = + [ "length : forall c. List (c) -> Int;" + , "length = \\list. case list of {" + , " Nil => 0;" + , " non_empty => 1;" + , "};" + ] + +run :: [String] -> Err T.Program +run = rmTEVar <=< typecheck <=< pProgram . myLexer . unlines + +ok = \case + Ok _ -> True + Bad _ -> False diff --git a/tests/TestTypeCheckerHm.hs b/tests/TestTypeCheckerHm.hs new file mode 100644 index 0000000..b666701 --- /dev/null +++ b/tests/TestTypeCheckerHm.hs @@ -0,0 +1,113 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE QualifiedDo #-} + +module TestTypeCheckerHm (testTypeCheckerHm) where + +import Control.Monad ((<=<)) +import qualified DoStrings as D +import Grammar.Par (myLexer, pProgram) +import Prelude (Bool (..), Either (..), IO, fmap, + not, ($), (.)) +import Test.Hspec + +-- import Test.QuickCheck +import TypeChecker.TypeCheckerHm (typecheck) + + + +testTypeCheckerHm = describe "Hillner Milner type checker test" $ do + ok1 + ok2 + bad1 + bad2 + -- bad3 + + +ok1 = + specify "Basic polymorphism with multiple type variables" $ + run + ( D.do + const + "main = const 'a' 65 ;" + ) + `shouldSatisfy` ok +ok2 = + specify "Head with a correct signature is accepted" $ + run + ( D.do + list + headSig + head + ) + `shouldSatisfy` ok + +bad1 = + specify "Infinite type unification should not succeed" $ + run + ( D.do + "main = \\x. x x ;" + ) + `shouldSatisfy` bad + +bad2 = + specify "Pattern matching using different types should not succeed" $ + run + ( D.do + list + "bad xs = case xs of {" + " 1 => 0 ;" + " Nil => 0 ;" + "};" + ) + `shouldSatisfy` bad + +bad3 = + specify "Using a concrete function on a skolem variable should not succeed" $ + run + ( D.do + bool + _not + "f : a -> Bool () ;" + " f x = not x ;" + ) + `shouldSatisfy` bad + +run = typecheck <=< pProgram . myLexer + +ok (Right _) = True +ok (Left _) = False + +bad = not . ok + +-- FUNCTIONS + +const = D.do + "const : a -> b -> a ;" + "const x y = x ;" +list = D.do + "data List (a) where" + " {" + " Nil : List (a)" + " Cons : a -> List (a) -> List (a)" + " };" + +headSig = D.do + "head : List (a) -> a ;" +head = D.do + "head xs = " + " case xs of {" + " Cons x xs => x ;" + " };" + +bool = D.do + "data Bool () where {" + " True : Bool ()" + " False : Bool ()" + "};" + +_not = D.do + "not : Bool () -> Bool () ;" + "not x = case x of {" + " True => False ;" + " False => True ;" + "};" diff --git a/tests/TestTypeChekerHm.hs/DoStrings.hs b/tests/TestTypeChekerHm.hs/DoStrings.hs index 9c1ec16..dabf5d6 100644 --- a/tests/TestTypeChekerHm.hs/DoStrings.hs +++ b/tests/TestTypeChekerHm.hs/DoStrings.hs @@ -1,6 +1,6 @@ module DoStrings where -import Prelude hiding ((>>), (>>=)) +import Prelude hiding ((>>), (>>=)) (>>) :: String -> String -> String (>>) str1 str2 = str1 ++ "\n" ++ str2 diff --git a/tests/Tests.hs b/tests/Tests.hs new file mode 100644 index 0000000..7bcb0af --- /dev/null +++ b/tests/Tests.hs @@ -0,0 +1,10 @@ + +module Main where + +import Test.Hspec +import TestTypeCheckerBidir (testTypeCheckerBidir) +import TestTypeCheckerHm (testTypeCheckerHm) + +main = hspec $ do + testTypeCheckerBidir + testTypeCheckerHm From 45527abd50e67daaee560e0de725b54917f46e85 Mon Sep 17 00:00:00 2001 From: Martin Fredin Date: Mon, 27 Mar 2023 16:10:02 +0200 Subject: [PATCH 174/372] Fix module name --- src/TypeChecker/TypeCheckerHm.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/TypeChecker/TypeCheckerHm.hs b/src/TypeChecker/TypeCheckerHm.hs index adcf033..a24a0b7 100644 --- a/src/TypeChecker/TypeCheckerHm.hs +++ b/src/TypeChecker/TypeCheckerHm.hs @@ -2,7 +2,7 @@ {-# LANGUAGE OverloadedStrings #-} -- | A module for type checking and inference using algorithm W, Hindley-Milner -module TypeChecker.TypeChecker where +module TypeChecker.TypeCheckerHm where import Auxiliary import Control.Monad.Except From aab75a10f255b189072ad38618af5b1afaae3e28 Mon Sep 17 00:00:00 2001 From: sebastianselander Date: Mon, 27 Mar 2023 16:10:13 +0200 Subject: [PATCH 175/372] fixed justfile --- Justfile | 10 ++++++---- 1 file changed, 6 insertions(+), 4 deletions(-) diff --git a/Justfile b/Justfile index a880195..74e2e5d 100644 --- a/Justfile +++ b/Justfile @@ -13,9 +13,11 @@ clean: test: cabal test -# compile a specific file -run FILE: - cabal run language {{FILE}} - debug FILE: cabal run language -- -d {{FILE}} + +hm FILE: + cabal run language -- -t hm {{FILE}} + +bi FILE: + cabal run language -- -t bi {{FILE}} From 623c6d1e589799070e9966c36cf4356a1f53d201 Mon Sep 17 00:00:00 2001 From: Samuel Hammersberg Date: Mon, 27 Mar 2023 16:11:33 +0200 Subject: [PATCH 176/372] Fixed language.cabal. --- language.cabal | 1 - 1 file changed, 1 deletion(-) diff --git a/language.cabal b/language.cabal index 61724ee..348d0c5 100644 --- a/language.cabal +++ b/language.cabal @@ -32,7 +32,6 @@ executable language Grammar.ErrM Auxiliary Renamer.Renamer - TypeChecker.TypeChecker TypeChecker.TypeCheckerHm TypeChecker.TypeCheckerBidir TypeChecker.TypeCheckerIr From b7be75aa1e135c9c7537cdb910a550ec29c31417 Mon Sep 17 00:00:00 2001 From: Martin Fredin Date: Mon, 27 Mar 2023 16:14:14 +0200 Subject: [PATCH 177/372] Fix TypeCheckerIr --- src/TypeChecker/TypeCheckerIr.hs | 74 ++++++++++++++++++++++++++++++++ 1 file changed, 74 insertions(+) diff --git a/src/TypeChecker/TypeCheckerIr.hs b/src/TypeChecker/TypeCheckerIr.hs index d56c14c..1157938 100644 --- a/src/TypeChecker/TypeCheckerIr.hs +++ b/src/TypeChecker/TypeCheckerIr.hs @@ -133,3 +133,77 @@ instance Print t => Print (Exp' t) where ] EAbs v e -> prPrec i 0 $ concatD [ doc $ showString "\\" + , prt 0 v + , doc $ showString "." + , prt 0 e + ] + + ECase e branches -> prPrec i 0 $ concatD + [ doc $ showString "case" + , prt 0 e + , doc $ showString "of" + , doc $ showString "{" + , prt 0 branches + , doc $ showString "}" + ] + + +instance Print t => Print (Branch' t) where + prt i (Branch (pattern_, t) exp) = prPrec i 0 (concatD [doc (showString "("), prt 0 pattern_, doc (showString " : "), prt 0 t, doc (showString ")"), doc (showString "=>"), prt 0 exp]) + +instance Print t => Print [Branch' t] where + prt _ [] = concatD [] + prt _ [x] = concatD [prt 0 x] + prt _ (x:xs) = concatD [prt 0 x, doc (showString ";"), prt 0 xs] + +instance Print t => Print (Def' t) where + prt i = \case + DBind bind -> prPrec i 0 (concatD [prt 0 bind]) + DData data_ -> prPrec i 0 (concatD [prt 0 data_]) + +instance Print t => Print (Data' t) where + prt i = \case + Data type_ injs -> prPrec i 0 (concatD [doc (showString "data"), prt 0 type_, doc (showString "where"), doc (showString "{"), prt 0 injs, doc (showString "}")]) + +instance Print t => Print (Inj' t) where + prt i = \case + Inj uident type_ -> prPrec i 0 (concatD [prt 0 uident, doc (showString ":"), prt 0 type_]) + +instance Print t => Print (Pattern' t) where + prt i = \case + PVar name -> prPrec i 1 (concatD [prt 0 name]) + PLit (lit, _) -> prPrec i 1 (concatD [prt 0 lit]) + PCatch -> prPrec i 1 (concatD [doc (showString "_")]) + PEnum name -> prPrec i 1 (concatD [prt 0 name]) + PInj uident patterns -> prPrec i 0 (concatD [prt 0 uident, prt 1 patterns]) + +instance Print t => Print [Def' t] where + prt _ [] = concatD [] + prt _ [x] = concatD [prt 0 x] + prt _ (x:xs) = concatD [prt 0 x, doc (showString ";"), prt 0 xs] + +instance Print [Type] where + prt _ [] = concatD [] + prt _ (x:xs) = concatD [prt 0 x, doc (showString " "), prt 0 xs] + +instance Print Type where + prt i = \case + TLit uident -> prPrec i 1 (concatD [prt 0 uident]) + TVar tvar -> prPrec i 1 (concatD [prt 0 tvar]) + TData uident types -> prPrec i 1 (concatD [prt 0 uident, doc (showString "("), prt 0 types, doc (showString ")")]) + TFun type_1 type_2 -> prPrec i 0 (concatD [prt 1 type_1, doc (showString "->"), prt 0 type_2]) + TAll tvar type_ -> prPrec i 0 (concatD [doc (showString "forall"), prt 0 tvar, doc (showString "."), prt 0 type_]) + +type Program = Program' Type +type Def = Def' Type +type Data = Data' Type +type Bind = Bind' Type +type Branch = Branch' Type +type Pattern = Pattern' Type +type Inj = Inj' Type +type Exp = Exp' Type +type ExpT = ExpT' Type +type Id = Id' Type +pattern DBind' id vars expt = DBind (Bind id vars expt) +pattern DData' typ injs = DData (Data typ injs) + From 22783cf817d6dbb77648388fca5a274a1f216ea2 Mon Sep 17 00:00:00 2001 From: sebastianselander Date: Mon, 27 Mar 2023 16:14:40 +0200 Subject: [PATCH 178/372] Removed custom Character in favor of BNFC Char --- Grammar.cf | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/Grammar.cf b/Grammar.cf index 09d0f2e..55763f4 100644 --- a/Grammar.cf +++ b/Grammar.cf @@ -58,7 +58,7 @@ ECase. Exp ::= "case" Exp "of" "{" [Branch] "}"; ------------------------------------------------------------------------------- LInt. Lit ::= Integer; -LChar. Lit ::= Character; +LChar. Lit ::= Char; ------------------------------------------------------------------------------- -- * PATTERN MATCHING @@ -88,7 +88,6 @@ coercions Pattern 1; coercions Exp 4; coercions Type 1 ; -token Character '\''(char)'\'' ; token UIdent (upper (letter | digit | '_')*) ; token LIdent (lower (letter | digit | '_')*) ; From db2f8cd197bbb860f2f0c1604e904ad611ac9218 Mon Sep 17 00:00:00 2001 From: Martin Fredin Date: Mon, 27 Mar 2023 16:21:01 +0200 Subject: [PATCH 179/372] Fix Codegen --- src/Codegen/Codegen.hs | 113 +++++++++++++---------------------------- 1 file changed, 35 insertions(+), 78 deletions(-) diff --git a/src/Codegen/Codegen.hs b/src/Codegen/Codegen.hs index 5e7e37d..d2ad9ee 100644 --- a/src/Codegen/Codegen.hs +++ b/src/Codegen/Codegen.hs @@ -17,7 +17,6 @@ import Data.Tuple.Extra (dupe, first, second) import Debug.Trace (trace) import qualified Grammar.Abs as GA import Grammar.ErrM (Err) -import Monomorphizer.MonomorphizerIr (Ident (..)) import Monomorphizer.MonomorphizerIr as MIR -- | The record used as the code generator state @@ -58,13 +57,8 @@ getVarCount :: CompilerState Integer getVarCount = gets variableCount -- | Increases the variable count and returns it from the CodeGenerator state -<<<<<<< HEAD getNewVar :: CompilerState GA.Ident getNewVar = GA.Ident . show <$> (increaseVarCount >> getVarCount) -======= -getNewVar :: CompilerState Ident -getNewVar = (Ident . show) <$> (increaseVarCount >> getVarCount) ->>>>>>> da28c6d (Add bidirectional type checker, lambda lifter.) -- | Increses the label count and returns a label from the CodeGenerator state getNewLabel :: CompilerState Integer @@ -82,25 +76,10 @@ getFunctions bs = Map.fromList $ go bs go (MIR.DBind (MIR.Bind id args _) : xs) = (id, FunctionInfo{numArgs = length args, arguments = args}) : go xs -<<<<<<< HEAD go (_ : xs) = go xs -======= - go (MIR.DData (MIR.Data n cons) : xs) = - do map - ( \(Inj id xs) -> - ( (coerce id, MIR.TLit (extractTypeName n)) - , FunctionInfo - { numArgs = undefined -- TODO - , arguments = createArgs (snd <$> undefined) -- TODO - } - ) - ) - cons - <> go xs ->>>>>>> da28c6d (Add bidirectional type checker, lambda lifter.) createArgs :: [MIR.Type] -> [Id] -createArgs xs = fst $ foldl (\(acc, l) t -> (acc ++ [(Ident ("arg_" <> show l), t)], l + 1)) ([], 0) xs +createArgs xs = fst $ foldl (\(acc, l) t -> (acc ++ [(GA.Ident ("arg_" <> show l), t)], l + 1)) ([], 0) xs {- | Produces a map of functions infos from a list of binds, which contains useful data for code generation. @@ -110,7 +89,6 @@ getConstructors bs = Map.fromList $ go bs where go [] = [] go (MIR.DData (MIR.Data t cons) : xs) = -<<<<<<< HEAD fst ( foldl ( \(acc, i) (Constructor id xs) -> @@ -118,17 +96,6 @@ getConstructors bs = Map.fromList $ go bs , ConstructorInfo { numArgsCI = length (init . flattenType $ xs) , argumentsCI = createArgs (init . flattenType $ xs) -======= - do - let (Ident n) = extractTypeName t - fst - ( foldl - ( \(acc, i) (Inj (Ident id) xs) -> - ( ( (Ident (n <> "_" <> id), MIR.TLit (coerce n)) - , ConstructorInfo - { numArgsCI = undefined -- TODO - , argumentsCI = createArgs (snd <$> undefined) -- TODO ->>>>>>> da28c6d (Add bidirectional type checker, lambda lifter.) , numCI = i , returnTypeCI = t --last . flattenType $ xs } @@ -166,30 +133,30 @@ test :: Integer -> Program test v = Program [ DataType - (Ident "Craig") - [ Constructor (Ident "Bob") [MIR.Type (Ident "_Int")] - , Constructor (Ident "Betty") [MIR.Type (Ident "_Int")] + (GA.Ident "Craig") + [ Constructor (GA.Ident "Bob") [MIR.Type (GA.Ident "_Int")] + , Constructor (GA.Ident "Betty") [MIR.Type (GA.Ident "_Int")] ] , DataType - (Ident "Alice") - [ Constructor (Ident "Eve") [MIR.Type (Ident "_Int")] -- , - -- (Ident "Alice", [TInt, TInt]) + (GA.Ident "Alice") + [ Constructor (GA.Ident "Eve") [MIR.Type (GA.Ident "_Int")] -- , + -- (GA.Ident "Alice", [TInt, TInt]) ] - , Bind (Ident "fibonacci", MIR.Type (Ident "_Int")) [(Ident "x", MIR.Type (Ident "_Int"))] (EVar ("x", MIR.Type (Ident "Craig")), MIR.Type (Ident "Craig")) - , Bind (Ident "main", MIR.Type (Ident "_Int")) [] - -- (EApp (MIR.Type (Ident "Craig")) (EVar (Ident "Craig_Bob", MIR.Type (Ident "Craig")), MIR.Type (Ident "Craig")) (ELit (LInt v), MIR.Type (Ident "_Int")), MIR.Type (Ident "Craig"))-- (EInt 92) + , Bind (GA.Ident "fibonacci", MIR.Type (GA.Ident "_Int")) [(GA.Ident "x", MIR.Type (GA.Ident "_Int"))] (EId ("x", MIR.Type (GA.Ident "Craig")), MIR.Type (GA.Ident "Craig")) + , Bind (GA.Ident "main", MIR.Type (GA.Ident "_Int")) [] + -- (EApp (MIR.Type (GA.Ident "Craig")) (EId (GA.Ident "Craig_Bob", MIR.Type (GA.Ident "Craig")), MIR.Type (GA.Ident "Craig")) (ELit (LInt v), MIR.Type (GA.Ident "_Int")), MIR.Type (GA.Ident "Craig"))-- (EInt 92) $ eCaseInt - (EApp (MIR.TLit (Ident "Craig")) (EVar (Ident "Craig_Bob", MIR.TLit (Ident "Craig")), MIR.TLit (Ident "Craig")) (ELit (LInt v), MIR.Type (Ident "_Int")), MIR.Type (Ident "Craig")) - [ injectionCons "Craig_Bob" "Craig" [CIdent (Ident "x")] (EVar (Ident "x", MIR.Type (Ident "_Int")), MIR.Type (Ident "_Int")) + (EApp (MIR.TLit (GA.Ident "Craig")) (EId (GA.Ident "Craig_Bob", MIR.TLit (GA.Ident "Craig")), MIR.TLit (GA.Ident "Craig")) (ELit (LInt v), MIR.Type (GA.Ident "_Int")), MIR.Type (GA.Ident "Craig")) + [ injectionCons "Craig_Bob" "Craig" [CIdent (GA.Ident "x")] (EId (GA.Ident "x", MIR.Type (GA.Ident "_Int")), MIR.Type (GA.Ident "_Int")) , injectionCons "Craig_Betty" "Craig" [CLit (LInt 5)] (int 2) - , Injection (CIdent (Ident "z")) (int 3) + , Injection (CIdent (GA.Ident "z")) (int 3) , -- , injectionInt 5 (int 6) injectionCatchAll (int 10) ] ] where - injectionCons x y xs = Injection (CCons (Ident x, MIR.Type (Ident y)) xs) + injectionCons x y xs = Injection (CCons (GA.Ident x, MIR.Type (GA.Ident y)) xs) injectionInt x = Injection (CLit (LInt x)) injectionCatchAll = Injection CatchAll eCaseInt x xs = (ECase (MIR.TLit (MIR.Ident "_Int")) x xs, MIR.TLit (MIR.Ident "_Int")) @@ -239,7 +206,7 @@ compileScs [] = do emit $ SetVariable ptr' (Bitcast (Ref t') (VIdent top Ptr) (Ref $ CustomType id)) enumerateOneM_ - ( \i (Ident arg_n, arg_t) -> do + ( \i (GA.Ident arg_n, arg_t) -> do let arg_t' = type2LlvmType arg_t emit $ Comment (toIr arg_t' <> " " <> arg_n <> " " <> show i) elemPtr <- getNewVar @@ -255,7 +222,7 @@ compileScs [] = do I32 (VInteger i) ) - emit $ Store arg_t' (VIdent (Ident arg_n) arg_t') Ptr elemPtr + emit $ Store arg_t' (VIdent (GA.Ident arg_n) arg_t') Ptr elemPtr ) (argumentsCI ci) @@ -288,13 +255,8 @@ compileScs (MIR.DData (MIR.Data typ ts) : xs) = do let biggestVariant = 7 + maximum (sum . (\(Constructor _ fi) -> typeByteSize <$> variantTypes fi) <$> ts) emit $ LIR.Type (Ident outer_id) [I8, Array biggestVariant I8] mapM_ -<<<<<<< HEAD ( \(Constructor inner_id fi) -> do emit $ LIR.Type inner_id (I8 : variantTypes fi) -======= - ( \(Inj (Ident inner_id) fi) -> do - emit $ LIR.Type (Ident $ outer_id <> "_" <> inner_id) (I8 : map type2LlvmType (snd <$> undefined)) -- TODO ->>>>>>> da28c6d (Add bidirectional type checker, lambda lifter.) ) ts compileScs xs @@ -320,17 +282,17 @@ mainContent var = -- " %4 = load i72, ptr %3\n" <> -- " call i32 (ptr, ...) @printf(ptr noundef @.str, i72 noundef %4)\n" "call i32 (ptr, ...) @printf(ptr noundef @.str, i64 noundef " <> toIr var <> ")\n" - , -- , SetVariable (Ident "p") (Icmp LLEq I64 (VInteger 2) (VInteger 2)) - -- , BrCond (VIdent (Ident "p")) (Ident "b_1") (Ident "b_2") - -- , Label (Ident "b_1") + , -- , SetVariable (GA.Ident "p") (Icmp LLEq I64 (VInteger 2) (VInteger 2)) + -- , BrCond (VIdent (GA.Ident "p")) (GA.Ident "b_1") (GA.Ident "b_2") + -- , Label (GA.Ident "b_1") -- , UnsafeRaw -- "call i32 (ptr, ...) @printf(ptr noundef @.str, i64 noundef 1)\n" - -- , Br (Ident "end") - -- , Label (Ident "b_2") + -- , Br (GA.Ident "end") + -- , Label (GA.Ident "b_2") -- , UnsafeRaw -- "call i32 (ptr, ...) @printf(ptr noundef @.str, i64 noundef 2)\n" - -- , Br (Ident "end") - -- , Label (Ident "end") + -- , Br (GA.Ident "end") + -- , Label (GA.Ident "end") Ret I64 (VInteger 0) ] @@ -348,7 +310,7 @@ compileExp :: ExpT -> CompilerState () compileExp (MIR.ELit lit,t) = emitLit lit compileExp (MIR.EAdd e1 e2,t) = emitAdd t e1 e2 -- compileExp (ESub t e1 e2) = emitSub t e1 e2 -compileExp (MIR.EVar name,t) = emitIdent name +compileExp (MIR.EId name,t) = emitIdent name compileExp (MIR.EApp e1 e2,t) = emitApp t e1 e2 -- compileExp (EAbs t ti e) = emitAbs t ti e compileExp (MIR.ELet binds e,t) = undefined -- emitLet binds (fst e) @@ -366,7 +328,7 @@ emitECased t e cases = do let rt = type2LlvmType (snd e) vs <- exprToValue e lbl <- getNewLabel - let label = Ident $ "escape_" <> show lbl + let label = GA.Ident $ "escape_" <> show lbl stackPtr <- getNewVar emit $ SetVariable stackPtr (Alloca ty) mapM_ (emitCases rt ty label stackPtr vs) cs @@ -379,13 +341,13 @@ emitECased t e cases = do res <- getNewVar emit $ SetVariable res (Load ty Ptr stackPtr) where - emitCases :: LLVMType -> LLVMType -> Ident -> Ident -> LLVMValue -> Branch -> CompilerState () + emitCases :: LLVMType -> LLVMType -> GA.Ident -> GA.Ident -> LLVMValue -> Branch -> CompilerState () emitCases rt ty label stackPtr vs (Branch (MIR.PInj consId cs, t) exp) = do cons <- gets constructors let r = fromJust $ Map.lookup consId cons - lbl_failPos <- (\x -> Ident $ "failed_" <> show x) <$> getNewLabel - lbl_succPos <- (\x -> Ident $ "success_" <> show x) <$> getNewLabel + lbl_failPos <- (\x -> GA.Ident $ "failed_" <> show x) <$> getNewLabel + lbl_succPos <- (\x -> GA.Ident $ "success_" <> show x) <$> getNewLabel consVal <- getNewVar emit $ SetVariable consVal (ExtractValue rt vs 0) @@ -435,8 +397,8 @@ emitECased t e cases = do (MIR.LInt i, _) -> VInteger i (MIR.LChar i, _) -> VChar i ns <- getNewVar - lbl_failPos <- (\x -> Ident $ "failed_" <> show x) <$> getNewLabel - lbl_succPos <- (\x -> Ident $ "success_" <> show x) <$> getNewLabel + lbl_failPos <- (\x -> GA.Ident $ "failed_" <> show x) <$> getNewLabel + lbl_succPos <- (\x -> GA.Ident $ "success_" <> show x) <$> getNewLabel emit $ SetVariable ns (Icmp LLEq ty vs i') emit $ BrCond (VIdent ns ty) lbl_succPos lbl_failPos emit $ Label lbl_succPos @@ -482,13 +444,8 @@ emitApp rt e1 e2 = appEmitter e1 e2 [] appEmitter e1 e2 stack = do let newStack = e2 : stack case e1 of -<<<<<<< HEAD (MIR.EApp e1' e2', _) -> appEmitter e1' e2' newStack (MIR.EId name, t) -> do -======= - (MIR.EApp e1' e2', t) -> appEmitter e1' e2' newStack - (MIR.EVar name, t) -> do ->>>>>>> da28c6d (Add bidirectional type checker, lambda lifter.) args <- traverse exprToValue newStack vs <- getNewVar funcs <- gets functions @@ -505,7 +462,7 @@ emitApp rt e1 e2 = appEmitter e1 e2 [] emit $ SetVariable vs call x -> error $ "The unspeakable happened: " <> show x -emitIdent :: Ident -> CompilerState () +emitIdent :: GA.Ident -> CompilerState () emitIdent id = do -- !!this should never happen!! emit $ Comment "This should not have happened!" @@ -520,14 +477,14 @@ emitLit i = do (MIR.LChar i'') -> (VChar i'', I8) varCount <- getNewVar emit $ Comment "This should not have happened!" - emit $ SetVariable (Ident (show varCount)) (Add t i' (VInteger 0)) + emit $ SetVariable (GA.Ident (show varCount)) (Add t i' (VInteger 0)) emitAdd :: MIR.Type -> ExpT -> ExpT -> CompilerState () emitAdd t e1 e2 = do v1 <- exprToValue e1 v2 <- exprToValue e2 v <- getNewVar - emit $ SetVariable (Ident $ show v) (Add (type2LlvmType t) v1 v2) + emit $ SetVariable (GA.Ident $ show v) (Add (type2LlvmType t) v1 v2) emitSub :: MIR.Type -> ExpT -> ExpT -> CompilerState () emitSub t e1 e2 = do @@ -541,7 +498,7 @@ exprToValue = \case (MIR.ELit i, t) -> pure $ case i of (MIR.LInt i) -> VInteger i (MIR.LChar i) -> VChar i - (MIR.EVar name, t) -> do + (MIR.EId name, t) -> do funcs <- gets functions case Map.lookup (name, t) funcs of Just fi -> do @@ -558,7 +515,7 @@ exprToValue = \case e -> do compileExp e v <- getVarCount - pure $ VIdent (Ident $ show v) (getType e) + pure $ VIdent (GA.Ident $ show v) (getType e) type2LlvmType :: MIR.Type -> LLVMType type2LlvmType (MIR.TLit id@(Ident name)) = case name of From 72f4f260783d8bc802646ece547676d701a6e3e3 Mon Sep 17 00:00:00 2001 From: Samuel Hammersberg Date: Mon, 27 Mar 2023 16:31:30 +0200 Subject: [PATCH 180/372] Fixed the dependency on the Grammar Ident. --- src/Codegen/Codegen.hs | 124 ++++++++++++++------------- src/Monomorphizer/MonomorphizerIr.hs | 18 ++-- 2 files changed, 73 insertions(+), 69 deletions(-) diff --git a/src/Codegen/Codegen.hs b/src/Codegen/Codegen.hs index d2ad9ee..f7c4185 100644 --- a/src/Codegen/Codegen.hs +++ b/src/Codegen/Codegen.hs @@ -18,12 +18,13 @@ import Debug.Trace (trace) import qualified Grammar.Abs as GA import Grammar.ErrM (Err) import Monomorphizer.MonomorphizerIr as MIR +import qualified TypeChecker.TypeCheckerIr as TIR -- | The record used as the code generator state data CodeGenerator = CodeGenerator { instructions :: [LLVMIr] , functions :: Map MIR.Id FunctionInfo - , constructors :: Map GA.Ident ConstructorInfo + , constructors :: Map TIR.Ident ConstructorInfo , variableCount :: Integer , labelCount :: Integer } @@ -50,15 +51,15 @@ emit l = modify $ \t -> t{instructions = Auxiliary.snoc l $ instructions t} -- | Increases the variable counter in the CodeGenerator state increaseVarCount :: CompilerState () -increaseVarCount = modify $ \t -> t{variableCount = variableCount t + 1} +increaseVarCount = (emit $ Comment "increase") >> (modify $ \t -> t{variableCount = variableCount t + 1}) -- | Returns the variable count from the CodeGenerator state getVarCount :: CompilerState Integer getVarCount = gets variableCount -- | Increases the variable count and returns it from the CodeGenerator state -getNewVar :: CompilerState GA.Ident -getNewVar = GA.Ident . show <$> (increaseVarCount >> getVarCount) +getNewVar :: CompilerState TIR.Ident +getNewVar = TIR.Ident . show <$> (increaseVarCount >> getVarCount) -- | Increses the label count and returns a label from the CodeGenerator state getNewLabel :: CompilerState Integer @@ -79,19 +80,19 @@ getFunctions bs = Map.fromList $ go bs go (_ : xs) = go xs createArgs :: [MIR.Type] -> [Id] -createArgs xs = fst $ foldl (\(acc, l) t -> (acc ++ [(GA.Ident ("arg_" <> show l), t)], l + 1)) ([], 0) xs +createArgs xs = fst $ foldl (\(acc, l) t -> (acc ++ [(TIR.Ident ("arg_" <> show l), t)], l + 1)) ([], 0) xs {- | Produces a map of functions infos from a list of binds, which contains useful data for code generation. -} -getConstructors :: [MIR.Def] -> Map GA.Ident ConstructorInfo +getConstructors :: [MIR.Def] -> Map TIR.Ident ConstructorInfo getConstructors bs = Map.fromList $ go bs where go [] = [] go (MIR.DData (MIR.Data t cons) : xs) = fst ( foldl - ( \(acc, i) (Constructor id xs) -> + ( \(acc, i) (Inj id xs) -> ( ( id , ConstructorInfo { numArgsCI = length (init . flattenType $ xs) @@ -133,30 +134,30 @@ test :: Integer -> Program test v = Program [ DataType - (GA.Ident "Craig") - [ Constructor (GA.Ident "Bob") [MIR.Type (GA.Ident "_Int")] - , Constructor (GA.Ident "Betty") [MIR.Type (GA.Ident "_Int")] + (TIR.Ident "Craig") + [ Constructor (TIR.Ident "Bob") [MIR.Type (TIR.Ident "_Int")] + , Constructor (TIR.Ident "Betty") [MIR.Type (TIR.Ident "_Int")] ] , DataType - (GA.Ident "Alice") - [ Constructor (GA.Ident "Eve") [MIR.Type (GA.Ident "_Int")] -- , - -- (GA.Ident "Alice", [TInt, TInt]) + (TIR.Ident "Alice") + [ Constructor (TIR.Ident "Eve") [MIR.Type (TIR.Ident "_Int")] -- , + -- (TIR.Ident "Alice", [TInt, TInt]) ] - , Bind (GA.Ident "fibonacci", MIR.Type (GA.Ident "_Int")) [(GA.Ident "x", MIR.Type (GA.Ident "_Int"))] (EId ("x", MIR.Type (GA.Ident "Craig")), MIR.Type (GA.Ident "Craig")) - , Bind (GA.Ident "main", MIR.Type (GA.Ident "_Int")) [] - -- (EApp (MIR.Type (GA.Ident "Craig")) (EId (GA.Ident "Craig_Bob", MIR.Type (GA.Ident "Craig")), MIR.Type (GA.Ident "Craig")) (ELit (LInt v), MIR.Type (GA.Ident "_Int")), MIR.Type (GA.Ident "Craig"))-- (EInt 92) + , Bind (TIR.Ident "fibonacci", MIR.Type (TIR.Ident "_Int")) [(TIR.Ident "x", MIR.Type (TIR.Ident "_Int"))] (EId ("x", MIR.Type (TIR.Ident "Craig")), MIR.Type (TIR.Ident "Craig")) + , Bind (TIR.Ident "main", MIR.Type (TIR.Ident "_Int")) [] + -- (EApp (MIR.Type (TIR.Ident "Craig")) (EId (TIR.Ident "Craig_Bob", MIR.Type (TIR.Ident "Craig")), MIR.Type (TIR.Ident "Craig")) (ELit (LInt v), MIR.Type (TIR.Ident "_Int")), MIR.Type (TIR.Ident "Craig"))-- (EInt 92) $ eCaseInt - (EApp (MIR.TLit (GA.Ident "Craig")) (EId (GA.Ident "Craig_Bob", MIR.TLit (GA.Ident "Craig")), MIR.TLit (GA.Ident "Craig")) (ELit (LInt v), MIR.Type (GA.Ident "_Int")), MIR.Type (GA.Ident "Craig")) - [ injectionCons "Craig_Bob" "Craig" [CIdent (GA.Ident "x")] (EId (GA.Ident "x", MIR.Type (GA.Ident "_Int")), MIR.Type (GA.Ident "_Int")) + (EApp (MIR.TLit (TIR.Ident "Craig")) (EId (TIR.Ident "Craig_Bob", MIR.TLit (TIR.Ident "Craig")), MIR.TLit (TIR.Ident "Craig")) (ELit (LInt v), MIR.Type (TIR.Ident "_Int")), MIR.Type (TIR.Ident "Craig")) + [ injectionCons "Craig_Bob" "Craig" [CIdent (TIR.Ident "x")] (EId (TIR.Ident "x", MIR.Type (TIR.Ident "_Int")), MIR.Type (TIR.Ident "_Int")) , injectionCons "Craig_Betty" "Craig" [CLit (LInt 5)] (int 2) - , Injection (CIdent (GA.Ident "z")) (int 3) + , Injection (CIdent (TIR.Ident "z")) (int 3) , -- , injectionInt 5 (int 6) injectionCatchAll (int 10) ] ] where - injectionCons x y xs = Injection (CCons (GA.Ident x, MIR.Type (GA.Ident y)) xs) + injectionCons x y xs = Injection (CCons (TIR.Ident x, MIR.Type (TIR.Ident y)) xs) injectionInt x = Injection (CLit (LInt x)) injectionCatchAll = Injection CatchAll eCaseInt x xs = (ECase (MIR.TLit (MIR.Ident "_Int")) x xs, MIR.TLit (MIR.Ident "_Int")) @@ -206,7 +207,7 @@ compileScs [] = do emit $ SetVariable ptr' (Bitcast (Ref t') (VIdent top Ptr) (Ref $ CustomType id)) enumerateOneM_ - ( \i (GA.Ident arg_n, arg_t) -> do + ( \i (TIR.Ident arg_n, arg_t) -> do let arg_t' = type2LlvmType arg_t emit $ Comment (toIr arg_t' <> " " <> arg_n <> " " <> show i) elemPtr <- getNewVar @@ -222,7 +223,7 @@ compileScs [] = do I32 (VInteger i) ) - emit $ Store arg_t' (VIdent (GA.Ident arg_n) arg_t') Ptr elemPtr + emit $ Store arg_t' (VIdent (TIR.Ident arg_n) arg_t') Ptr elemPtr ) (argumentsCI ci) @@ -250,12 +251,12 @@ compileScs (MIR.DBind (MIR.Bind (name, _t) args exp) : xs) = do modify $ \s -> s{variableCount = 0} compileScs xs compileScs (MIR.DData (MIR.Data typ ts) : xs) = do - let (Ident outer_id) = extractTypeName typ + let (TIR.Ident outer_id) = extractTypeName typ let variantTypes fi = init $ map type2LlvmType (flattenType fi) - let biggestVariant = 7 + maximum (sum . (\(Constructor _ fi) -> typeByteSize <$> variantTypes fi) <$> ts) - emit $ LIR.Type (Ident outer_id) [I8, Array biggestVariant I8] + let biggestVariant = 7 + maximum (sum . (\(Inj _ fi) -> typeByteSize <$> variantTypes fi) <$> ts) + emit $ LIR.Type (TIR.Ident outer_id) [I8, Array biggestVariant I8] mapM_ - ( \(Constructor inner_id fi) -> do + ( \(Inj inner_id fi) -> do emit $ LIR.Type inner_id (I8 : variantTypes fi) ) ts @@ -282,17 +283,17 @@ mainContent var = -- " %4 = load i72, ptr %3\n" <> -- " call i32 (ptr, ...) @printf(ptr noundef @.str, i72 noundef %4)\n" "call i32 (ptr, ...) @printf(ptr noundef @.str, i64 noundef " <> toIr var <> ")\n" - , -- , SetVariable (GA.Ident "p") (Icmp LLEq I64 (VInteger 2) (VInteger 2)) - -- , BrCond (VIdent (GA.Ident "p")) (GA.Ident "b_1") (GA.Ident "b_2") - -- , Label (GA.Ident "b_1") + , -- , SetVariable (TIR.Ident "p") (Icmp LLEq I64 (VInteger 2) (VInteger 2)) + -- , BrCond (VIdent (TIR.Ident "p")) (TIR.Ident "b_1") (TIR.Ident "b_2") + -- , Label (TIR.Ident "b_1") -- , UnsafeRaw -- "call i32 (ptr, ...) @printf(ptr noundef @.str, i64 noundef 1)\n" - -- , Br (GA.Ident "end") - -- , Label (GA.Ident "b_2") + -- , Br (TIR.Ident "end") + -- , Label (TIR.Ident "b_2") -- , UnsafeRaw -- "call i32 (ptr, ...) @printf(ptr noundef @.str, i64 noundef 2)\n" - -- , Br (GA.Ident "end") - -- , Label (GA.Ident "end") + -- , Br (TIR.Ident "end") + -- , Label (TIR.Ident "end") Ret I64 (VInteger 0) ] @@ -301,16 +302,16 @@ defaultStart = [ UnsafeRaw "target triple = \"x86_64-pc-linux-gnu\"\n" , UnsafeRaw "target datalayout = \"e-m:o-i64:64-f80:128-n8:16:32:64-S128\"\n" , UnsafeRaw "@.str = private unnamed_addr constant [3 x i8] c\"%i\n\", align 1\n" - , UnsafeRaw "@.non_exhaustive_patterns = private unnamed_addr constant [41 x i8] c\"Non-exhaustive patterns in case at %i:%i\n\"" + , UnsafeRaw "@.non_exhaustive_patterns = private unnamed_addr constant [41 x i8] c\"Non-exhaustive patterns in case at %i:%i\n\"\n" , UnsafeRaw "declare i32 @printf(ptr noalias nocapture, ...)\n" - , UnsafeRaw "declare i32 @exit(i32)\n" + , UnsafeRaw "declare i32 @exit(i32 noundef)\n" ] compileExp :: ExpT -> CompilerState () compileExp (MIR.ELit lit,t) = emitLit lit compileExp (MIR.EAdd e1 e2,t) = emitAdd t e1 e2 -- compileExp (ESub t e1 e2) = emitSub t e1 e2 -compileExp (MIR.EId name,t) = emitIdent name +compileExp (MIR.EVar name, t) = emitIdent name compileExp (MIR.EApp e1 e2,t) = emitApp t e1 e2 -- compileExp (EAbs t ti e) = emitAbs t ti e compileExp (MIR.ELet binds e,t) = undefined -- emitLet binds (fst e) @@ -328,26 +329,28 @@ emitECased t e cases = do let rt = type2LlvmType (snd e) vs <- exprToValue e lbl <- getNewLabel - let label = GA.Ident $ "escape_" <> show lbl + let label = TIR.Ident $ "escape_" <> show lbl stackPtr <- getNewVar emit $ SetVariable stackPtr (Alloca ty) mapM_ (emitCases rt ty label stackPtr vs) cs + crashLbl <- TIR.Ident . ("crash_" <>) . show <$> getNewLabel + emit $ Label crashLbl emit . UnsafeRaw $ "call i32 (ptr, ...) @printf(ptr noundef @.non_exhaustive_patterns, i64 noundef 6, i64 noundef 6)\n" - emit . UnsafeRaw $ "call i32 @exit(i32 1)\n" - emit . UnsafeRaw $ "unreachable\n" - increaseVarCount >> increaseVarCount >> increaseVarCount + emit . UnsafeRaw $ "call i32 @exit(i32 noundef 1)\n" + mapM_ (const increaseVarCount) [0..1] emit $ Br label emit $ Label label res <- getNewVar emit $ SetVariable res (Load ty Ptr stackPtr) where - emitCases :: LLVMType -> LLVMType -> GA.Ident -> GA.Ident -> LLVMValue -> Branch -> CompilerState () + emitCases :: LLVMType -> LLVMType -> TIR.Ident -> TIR.Ident -> LLVMValue -> Branch -> CompilerState () emitCases rt ty label stackPtr vs (Branch (MIR.PInj consId cs, t) exp) = do + emit $ Comment "Inj" cons <- gets constructors let r = fromJust $ Map.lookup consId cons - lbl_failPos <- (\x -> GA.Ident $ "failed_" <> show x) <$> getNewLabel - lbl_succPos <- (\x -> GA.Ident $ "success_" <> show x) <$> getNewLabel + lbl_failPos <- (\x -> TIR.Ident $ "failed_" <> show x) <$> getNewLabel + lbl_succPos <- (\x -> TIR.Ident $ "success_" <> show x) <$> getNewLabel consVal <- getNewVar emit $ SetVariable consVal (ExtractValue rt vs 0) @@ -362,7 +365,6 @@ emitECased t e cases = do emit $ SetVariable castPtr (Alloca rt) emit $ Store rt vs Ptr castPtr emit $ SetVariable casted (Load (CustomType (coerce consId)) Ptr castPtr) - val <- exprToValue exp enumerateOneM_ (\i c -> do @@ -393,12 +395,13 @@ emitECased t e cases = do emit $ Br label emit $ Label lbl_failPos emitCases rt ty label stackPtr vs (Branch (MIR.PLit i, _) exp) = do + emit $ Comment "Plit" let i' = case i of (MIR.LInt i, _) -> VInteger i (MIR.LChar i, _) -> VChar i ns <- getNewVar - lbl_failPos <- (\x -> GA.Ident $ "failed_" <> show x) <$> getNewLabel - lbl_succPos <- (\x -> GA.Ident $ "success_" <> show x) <$> getNewLabel + lbl_failPos <- (\x -> TIR.Ident $ "failed_" <> show x) <$> getNewLabel + lbl_succPos <- (\x -> TIR.Ident $ "success_" <> show x) <$> getNewLabel emit $ SetVariable ns (Icmp LLEq ty vs i') emit $ BrCond (VIdent ns ty) lbl_succPos lbl_failPos emit $ Label lbl_succPos @@ -407,20 +410,22 @@ emitECased t e cases = do emit $ Br label emit $ Label lbl_failPos emitCases rt ty label stackPtr vs (Branch (MIR.PVar (id,_), _) exp) = do + emit $ Comment "Pvar" -- //TODO this is pretty disgusting and would heavily benefit from a rewrite valPtr <- getNewVar emit $ SetVariable valPtr (Alloca rt) emit $ Store rt vs Ptr valPtr emit $ SetVariable id (Load rt Ptr valPtr) - increaseVarCount - val <- exprToValue exp + val <- exprToValue exp emit $ Store ty val Ptr stackPtr emit $ Br label emitCases rt ty label stackPtr vs (Branch (MIR.PEnum id, _) exp) = do + emit $ Comment "Penum" val <- exprToValue exp emit $ Store ty val Ptr stackPtr emit $ Br label emitCases _ ty label stackPtr _ (Branch (MIR.PCatch, _) exp) = do + emit $ Comment "Pcatch" val <- exprToValue exp emit $ Store ty val Ptr stackPtr emit $ Br label @@ -445,7 +450,7 @@ emitApp rt e1 e2 = appEmitter e1 e2 [] let newStack = e2 : stack case e1 of (MIR.EApp e1' e2', _) -> appEmitter e1' e2' newStack - (MIR.EId name, t) -> do + (MIR.EVar name, t) -> do args <- traverse exprToValue newStack vs <- getNewVar funcs <- gets functions @@ -462,7 +467,7 @@ emitApp rt e1 e2 = appEmitter e1 e2 [] emit $ SetVariable vs call x -> error $ "The unspeakable happened: " <> show x -emitIdent :: GA.Ident -> CompilerState () +emitIdent :: TIR.Ident -> CompilerState () emitIdent id = do -- !!this should never happen!! emit $ Comment "This should not have happened!" @@ -477,14 +482,14 @@ emitLit i = do (MIR.LChar i'') -> (VChar i'', I8) varCount <- getNewVar emit $ Comment "This should not have happened!" - emit $ SetVariable (GA.Ident (show varCount)) (Add t i' (VInteger 0)) + emit $ SetVariable varCount (Add t i' (VInteger 0)) emitAdd :: MIR.Type -> ExpT -> ExpT -> CompilerState () emitAdd t e1 e2 = do v1 <- exprToValue e1 v2 <- exprToValue e2 v <- getNewVar - emit $ SetVariable (GA.Ident $ show v) (Add (type2LlvmType t) v1 v2) + emit $ SetVariable v (Add (type2LlvmType t) v1 v2) emitSub :: MIR.Type -> ExpT -> ExpT -> CompilerState () emitSub t e1 e2 = do @@ -498,7 +503,7 @@ exprToValue = \case (MIR.ELit i, t) -> pure $ case i of (MIR.LInt i) -> VInteger i (MIR.LChar i) -> VChar i - (MIR.EId name, t) -> do + (MIR.EVar name, t) -> do funcs <- gets functions case Map.lookup (name, t) funcs of Just fi -> do @@ -515,10 +520,10 @@ exprToValue = \case e -> do compileExp e v <- getVarCount - pure $ VIdent (GA.Ident $ show v) (getType e) + pure $ VIdent (TIR.Ident $ show v) (getType e) type2LlvmType :: MIR.Type -> LLVMType -type2LlvmType (MIR.TLit id@(Ident name)) = case name of +type2LlvmType (MIR.TLit id@(TIR.Ident name)) = case name of "Int" -> I64 _ -> CustomType id type2LlvmType (MIR.TFun t xs) = do @@ -532,11 +537,11 @@ type2LlvmType (MIR.TFun t xs) = do getType :: ExpT -> LLVMType getType (_, t) = type2LlvmType t -extractTypeName :: MIR.Type -> Ident +extractTypeName :: MIR.Type -> TIR.Ident extractTypeName (MIR.TLit id) = id -extractTypeName (MIR.TFun t xs) = let (Ident i) = extractTypeName t - (Ident is) = extractTypeName xs - in Ident $ i <> "_$_" <> is +extractTypeName (MIR.TFun t xs) = let (TIR.Ident i) = extractTypeName t + (TIR.Ident is) = extractTypeName xs + in TIR.Ident $ i <> "_$_" <> is valueGetType :: LLVMValue -> LLVMType valueGetType (VInteger _) = I64 @@ -558,4 +563,3 @@ typeByteSize (CustomType _) = 8 enumerateOneM_ :: Monad m => (Integer -> a -> m b) -> [a] -> m () enumerateOneM_ f = foldM_ (\i a -> f i a >> pure (i + 1)) 1 - diff --git a/src/Monomorphizer/MonomorphizerIr.hs b/src/Monomorphizer/MonomorphizerIr.hs index c80ad65..383e9fc 100644 --- a/src/Monomorphizer/MonomorphizerIr.hs +++ b/src/Monomorphizer/MonomorphizerIr.hs @@ -1,9 +1,9 @@ module Monomorphizer.MonomorphizerIr (module Monomorphizer.MonomorphizerIr, module GA) where -import Grammar.Abs (Ident (..)) -import qualified Grammar.Abs as GA (Ident (..)) +import qualified Grammar.Abs as GA (Ident (..)) +import qualified TypeChecker.TypeCheckerIr as TIR (Ident (..)) -type Id = (Ident, Type) +type Id = (TIR.Ident, Type) newtype Program = Program [Def] deriving (Show, Ord, Eq) @@ -18,7 +18,7 @@ data Bind = Bind Id [Id] ExpT deriving (Show, Ord, Eq) data Exp - = EVar Ident + = EVar TIR.Ident | ELit Lit | ELet Bind ExpT | EApp ExpT ExpT @@ -26,8 +26,8 @@ data Exp | ECase ExpT [Branch] deriving (Show, Ord, Eq) -data Pattern = PVar Id | PLit (Lit, Type) | PInj Ident [Pattern] - | PCatch | PEnum Ident +data Pattern = PVar Id | PLit (Lit, Type) | PInj TIR.Ident [Pattern] + | PCatch | PEnum TIR.Ident deriving (Eq, Ord, Show) data Branch = Branch (Pattern, Type) ExpT @@ -35,15 +35,15 @@ data Branch = Branch (Pattern, Type) ExpT type ExpT = (Exp, Type) -data Inj = Inj Ident Type +data Inj = Inj TIR.Ident Type deriving (Show, Ord, Eq) data Lit = LInt Integer - | LChar Character + | LChar Char deriving (Show, Ord, Eq) -data Type = TLit Ident | TFun Type Type +data Type = TLit TIR.Ident | TFun Type Type deriving (Show, Ord, Eq) flattenType :: Type -> [Type] From 750503063a8800ab0714e30a73df2db4599e80cb Mon Sep 17 00:00:00 2001 From: Samuel Hammersberg Date: Mon, 27 Mar 2023 16:31:47 +0200 Subject: [PATCH 181/372] Fixed the dependency on the Grammar Ident. --- src/TypeChecker/TypeCheckerIr.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/TypeChecker/TypeCheckerIr.hs b/src/TypeChecker/TypeCheckerIr.hs index 1157938..05949c9 100644 --- a/src/TypeChecker/TypeCheckerIr.hs +++ b/src/TypeChecker/TypeCheckerIr.hs @@ -8,7 +8,7 @@ module TypeChecker.TypeCheckerIr ) where import Data.String (IsString) -import Grammar.Abs (Character (..), Lit (..), TVar (..)) +import Grammar.Abs (Lit (..), TVar (..)) import Grammar.Print import Prelude import qualified Prelude as C (Eq, Ord, Read, Show) From 847ec37117147154c0bad98f0710a0ad8c7a08a3 Mon Sep 17 00:00:00 2001 From: Samuel Hammersberg Date: Mon, 27 Mar 2023 16:32:48 +0200 Subject: [PATCH 182/372] Fixed the dependency on the Grammar Ident. --- src/Monomorphizer/Monomorphizer.hs | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/src/Monomorphizer/Monomorphizer.hs b/src/Monomorphizer/Monomorphizer.hs index 5440bab..8d3808c 100644 --- a/src/Monomorphizer/Monomorphizer.hs +++ b/src/Monomorphizer/Monomorphizer.hs @@ -26,11 +26,11 @@ monoBind (T.Bind name args (e, t)) = M.Bind (monoId name) (map monoId args) (mon --monoData (T.Data (Ident id) cs) = M.Data (M.TLit (M.Ident id)) (map monoConstructor cs) monoConstructor :: T.Inj -> M.Inj -monoConstructor (T.Inj (Ident i) t) = M.Inj (M.Ident i) (monoType t) +monoConstructor (T.Inj (Ident i) t) = M.Inj (T.Ident i) (monoType t) monoExpr :: T.Exp -> M.Exp monoExpr = \case - T.EVar (Ident i) -> M.EVar (M.Ident i) + T.EVar (Ident i) -> M.EVar (T.Ident i) T.ELit lit -> M.ELit $ monoLit lit T.ELet bind expt -> M.ELet (monoBind bind) (monoexpt expt) T.EApp expt1 expt2 -> M.EApp (monoexpt expt1) (monoexpt expt2) @@ -48,9 +48,9 @@ monoAbsType (T.TData _ _) = error "NOT INDEXED TYPES" monoType :: T.Type -> M.Type monoType (T.TAll _ t) = monoType t monoType (T.TVar (T.MkTVar i)) = M.TLit "Int" -monoType (T.TLit (Ident i)) = M.TLit (M.Ident i) +monoType (T.TLit (Ident i)) = M.TLit (T.Ident i) monoType (T.TFun t1 t2) = M.TFun (monoType t1) (monoType t2) -monoType (T.TData (Ident n) t) = M.TLit (M.Ident (n ++ concatMap show t)) +monoType (T.TData (Ident n) t) = M.TLit (T.Ident (n ++ concatMap show t)) monoexpt :: T.ExpT -> M.ExpT monoexpt (e, t) = (monoExpr e, monoType t) @@ -73,5 +73,5 @@ monoPattern (T.PVar (id, t)) = M.PVar (id, monoType t) monoPattern (T.PLit (lit, t)) = M.PLit (monoLit lit, monoType t) monoPattern (T.PInj id ps) = M.PInj (coerce id) (map monoPattern ps) -- DO NOT DO THIS FOR REAL THOUGH -monoPattern (T.PEnum (Ident i)) = M.PInj (M.Ident i) [] +monoPattern (T.PEnum (Ident i)) = M.PInj (T.Ident i) [] monoPattern T.PCatch = M.PCatch From 6e54378327cbf6aa8c5b3d6cd53d1ba0c8b555a1 Mon Sep 17 00:00:00 2001 From: sebastianselander Date: Mon, 27 Mar 2023 16:48:23 +0200 Subject: [PATCH 183/372] Fixed errors in tc hm --- src/Codegen/LlvmIr.hs | 60 ++--- src/Monomorphizer/MonomorphizerIr.hs | 15 +- src/TypeChecker/TypeCheckerHm.hs | 361 +++++++++++++-------------- src/TypeChecker/TypeCheckerIr.hs | 255 ++++++++++--------- 4 files changed, 346 insertions(+), 345 deletions(-) diff --git a/src/Codegen/LlvmIr.hs b/src/Codegen/LlvmIr.hs index 0baf35a..59850b6 100644 --- a/src/Codegen/LlvmIr.hs +++ b/src/Codegen/LlvmIr.hs @@ -8,19 +8,18 @@ module Codegen.LlvmIr ( LLVMComp (..), Visibility (..), CallingConvention (..), - ToIr(..) + ToIr (..), ) where -import Data.List (intercalate) -import Grammar.Abs (Character) -import TypeChecker.TypeCheckerIr (Ident (..)) +import Data.List (intercalate) +import TypeChecker.TypeCheckerIr (Ident (..)) -data CallingConvention = TailCC | FastCC | CCC | ColdCC deriving Show +data CallingConvention = TailCC | FastCC | CCC | ColdCC deriving (Show) instance ToIr CallingConvention where toIr :: CallingConvention -> String toIr TailCC = "tailcc" toIr FastCC = "fastcc" - toIr CCC = "ccc" + toIr CCC = "ccc" toIr ColdCC = "coldcc" -- | A datatype which represents some basic LLVM types @@ -34,7 +33,7 @@ data LLVMType | Function LLVMType [LLVMType] | Array Integer LLVMType | CustomType Ident - deriving Show + deriving (Show) class ToIr a where toIr :: a -> String @@ -63,12 +62,12 @@ data LLVMComp | LLSge | LLSlt | LLSle - deriving Show + deriving (Show) instance ToIr LLVMComp where toIr :: LLVMComp -> String toIr = \case - LLEq -> "eq" - LLNe -> "ne" + LLEq -> "eq" + LLNe -> "ne" LLUgt -> "ugt" LLUge -> "uge" LLUlt -> "ult" @@ -78,30 +77,31 @@ instance ToIr LLVMComp where LLSlt -> "slt" LLSle -> "sle" -data Visibility = Local | Global deriving Show +data Visibility = Local | Global deriving (Show) instance ToIr Visibility where toIr :: Visibility -> String - toIr Local = "%" + toIr Local = "%" toIr Global = "@" --- | Represents a LLVM "value", as in an integer, a register variable, --- or a string contstant +{- | Represents a LLVM "value", as in an integer, a register variable, +or a string contstant +-} data LLVMValue = VInteger Integer - | VChar Character + | VChar Char | VIdent Ident LLVMType | VConstant String | VFunction Ident Visibility LLVMType - deriving Show + deriving (Show) instance ToIr LLVMValue where toIr :: LLVMValue -> String toIr v = case v of - VInteger i -> show i - VChar i -> show i - VIdent (Ident n) _ -> "%" <> n + VInteger i -> show i + VChar i -> show i + VIdent (Ident n) _ -> "%" <> n VFunction (Ident n) vis _ -> toIr vis <> n - VConstant s -> "c" <> show s + VConstant s -> "c" <> show s type Params = [(Ident, LLVMType)] type Args = [(LLVMType, LLVMValue)] @@ -114,8 +114,8 @@ data LLVMIr | Declare LLVMType Ident Params | SetVariable Ident LLVMIr | Variable Ident - -- extractvalue , {, }* - | ExtractValue LLVMType LLVMValue Integer + | -- extractvalue , {, }* + ExtractValue LLVMType LLVMValue Integer | GetElementPtr LLVMType LLVMType LLVMValue LLVMType LLVMValue LLVMType LLVMValue | GetElementPtrInbounds LLVMType LLVMType LLVMValue LLVMType LLVMValue LLVMType LLVMValue | Add LLVMType LLVMValue LLVMValue @@ -136,7 +136,7 @@ data LLVMIr | Comment String | UnsafeRaw String -- This should generally be avoided, and proper -- instructions should be used in its place - deriving Show + deriving (Show) -- | Converts a list of LLVMIr instructions to a string llvmIrToString :: [LLVMIr] -> String @@ -146,14 +146,15 @@ llvmIrToString = go 0 go _ [] = mempty go i (x : xs) = do let (i', n) = case x of - Define{} -> (i + 1, 0) + Define{} -> (i + 1, 0) DefineEnd -> (i - 1, 0) - _ -> (i, i) + _ -> (i, i) insToString n x <> go i' xs - {- | Converts a LLVM inststruction to a String, allowing for printing etc. - The integer represents the indentation - -} - {- FOURMOLU_DISABLE -} + +-- \| Converts a LLVM inststruction to a String, allowing for printing etc. +-- The integer represents the indentation +-- +{- FOURMOLU_DISABLE -} insToString :: Int -> LLVMIr -> String insToString i l = replicate i '\t' <> case l of @@ -261,4 +262,3 @@ llvmIrToString = go 0 lblPfx :: String lblPfx = "lbl_" - diff --git a/src/Monomorphizer/MonomorphizerIr.hs b/src/Monomorphizer/MonomorphizerIr.hs index 383e9fc..66888c0 100644 --- a/src/Monomorphizer/MonomorphizerIr.hs +++ b/src/Monomorphizer/MonomorphizerIr.hs @@ -1,7 +1,6 @@ -module Monomorphizer.MonomorphizerIr (module Monomorphizer.MonomorphizerIr, module GA) where +module Monomorphizer.MonomorphizerIr (module Monomorphizer.MonomorphizerIr) where -import qualified Grammar.Abs as GA (Ident (..)) -import qualified TypeChecker.TypeCheckerIr as TIR (Ident (..)) +import TypeChecker.TypeCheckerIr qualified as TIR (Ident (..)) type Id = (TIR.Ident, Type) @@ -26,8 +25,12 @@ data Exp | ECase ExpT [Branch] deriving (Show, Ord, Eq) -data Pattern = PVar Id | PLit (Lit, Type) | PInj TIR.Ident [Pattern] - | PCatch | PEnum TIR.Ident +data Pattern + = PVar Id + | PLit (Lit, Type) + | PInj TIR.Ident [Pattern] + | PCatch + | PEnum TIR.Ident deriving (Eq, Ord, Show) data Branch = Branch (Pattern, Type) ExpT @@ -48,4 +51,4 @@ data Type = TLit TIR.Ident | TFun Type Type flattenType :: Type -> [Type] flattenType (TFun t1 t2) = t1 : flattenType t2 -flattenType x = [x] +flattenType x = [x] diff --git a/src/TypeChecker/TypeCheckerHm.hs b/src/TypeChecker/TypeCheckerHm.hs index a24a0b7..1254a87 100644 --- a/src/TypeChecker/TypeCheckerHm.hs +++ b/src/TypeChecker/TypeCheckerHm.hs @@ -1,31 +1,29 @@ -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} -- | A module for type checking and inference using algorithm W, Hindley-Milner module TypeChecker.TypeCheckerHm where -import Auxiliary -import Control.Monad.Except -import Control.Monad.Identity (runIdentity) -import Control.Monad.Reader -import Control.Monad.State -import Data.Bifunctor (second) -import Data.Coerce (coerce) -import Data.Foldable (traverse_) -import Data.Function (on) -import Data.List (foldl') -import Data.List.Extra (unsnoc) -import Data.Map (Map) -import qualified Data.Map as M -import Data.Maybe (fromJust) -import Data.Set (Set) -import qualified Data.Set as S -import Debug.Trace (trace) -import Grammar.Abs -import Grammar.Print (printTree) -import qualified TypeChecker.TypeCheckerIr as T -import TypeChecker.TypeCheckerIr (Ctx (..), Env (..), Error, Infer, - Subst) +import Auxiliary +import Control.Monad.Except +import Control.Monad.Identity (Identity, runIdentity) +import Control.Monad.Reader +import Control.Monad.State +import Data.Bifunctor (second) +import Data.Coerce (coerce) +import Data.Foldable (traverse_) +import Data.Function (on) +import Data.List (foldl') +import Data.List.Extra (unsnoc) +import Data.Map (Map) +import Data.Map qualified as M +import Data.Maybe (fromJust) +import Data.Set (Set) +import Data.Set qualified as S +import Data.String +import Grammar.Abs +import Grammar.Print (printTree) +import TypeChecker.TypeCheckerIr qualified as T initCtx = Ctx mempty initEnv = Env 0 'a' mempty mempty mempty @@ -39,7 +37,7 @@ run = runC initEnv initCtx runC :: Env -> Ctx -> Infer a -> Either Error a runC e c = runIdentity . runExceptT . flip runReaderT c . flip evalStateT e -typecheck :: Program -> Either Error T.Program +typecheck :: Program -> Either Error (T.Program' Type) typecheck = run . checkPrg checkData :: Data -> Infer () @@ -50,9 +48,9 @@ checkData d = do (all isPoly ts) (throwError $ unwords ["Data type incorrectly declared"]) traverse_ - ( \(Constructor name' t') -> + ( \(Inj name' t') -> if typ == retType t' - then insertConstr (coerce name') (toNew t') + then insertConstr (coerce name') (t') else throwError $ unwords @@ -73,9 +71,9 @@ checkData d = do retType :: Type -> Type retType (TFun _ t2) = retType t2 -retType a = a +retType a = a -checkPrg :: Program -> Infer T.Program +checkPrg :: Program -> Infer (T.Program' Type) checkPrg (Program bs) = do preRun bs bs' <- checkDef bs @@ -94,25 +92,27 @@ preRun (x : xs) = case x of <> printTree n <> "'" ) - insertSig (coerce n) (Just $ toNew t) >> preRun xs + insertSig (coerce n) (Just $ t) >> preRun xs DBind (Bind n _ e) -> do collect (collectTypeVars e) s <- gets sigs case M.lookup (coerce n) s of Nothing -> insertSig (coerce n) Nothing >> preRun xs - Just _ -> preRun xs + Just _ -> preRun xs DData d@(Data t _) -> collect (collectTypeVars t) >> checkData d >> preRun xs -checkDef :: [Def] -> Infer [T.Def] +checkDef :: [Def] -> Infer [T.Def' Type] checkDef [] = return [] checkDef (x : xs) = case x of (DBind b) -> do b' <- checkBind b fmap (T.DBind b' :) (checkDef xs) - (DData d) -> fmap (T.DData (toNew d) :) (checkDef xs) + (DData d) -> fmap ((T.DData (coerceData d)) :) (checkDef xs) (DSig _) -> checkDef xs + where + coerceData (Data t injs) = T.Data t $ map (\(Inj name typ) -> T.Inj (coerce name) typ) injs -checkBind :: Bind -> Infer T.Bind +checkBind :: Bind -> Infer (T.Bind' Type) checkBind (Bind name args e) = do let lambda = makeLambda e (reverse (coerce args)) e@(_, args_t) <- inferExp lambda @@ -133,41 +133,41 @@ checkBind (Bind name args e) = do insertSig (coerce name) (Just args_t) return (T.Bind (coerce name, args_t) [] e) -typeEq :: T.Type -> T.Type -> Bool -typeEq (T.TFun l r) (T.TFun l' r') = typeEq l l' && typeEq r r' -typeEq (T.TLit a) (T.TLit b) = a == b -typeEq (T.TData name a) (T.TData name' b) = +typeEq :: Type -> Type -> Bool +typeEq (TFun l r) (TFun l' r') = typeEq l l' && typeEq r r' +typeEq (TLit a) (TLit b) = a == b +typeEq (TData name a) (TData name' b) = length a == length b && name == name' && and (zipWith typeEq a b) -typeEq (T.TAll _ t1) t2 = t1 `typeEq` t2 -typeEq t1 (T.TAll _ t2) = t1 `typeEq` t2 -typeEq (T.TVar _) (T.TVar _) = True +typeEq (TAll _ t1) t2 = t1 `typeEq` t2 +typeEq t1 (TAll _ t2) = t1 `typeEq` t2 +typeEq (TVar _) (TVar _) = True typeEq _ _ = False -skolem :: T.Type -> T.Type -skolem (T.TVar (T.MkTVar a)) = T.TLit a -skolem (T.TAll x t) = T.TAll x (skolem t) -skolem (T.TFun t1 t2) = (T.TFun `on` skolem) t1 t2 -skolem t = t +skolem :: Type -> Type +skolem (TVar (T.MkTVar a)) = TLit (coerce a) +skolem (TAll x t) = TAll x (skolem t) +skolem (TFun t1 t2) = (TFun `on` skolem) t1 t2 +skolem t = t -isMoreSpecificOrEq :: T.Type -> T.Type -> Bool -isMoreSpecificOrEq t1 (T.TAll _ t2) = isMoreSpecificOrEq t1 t2 -isMoreSpecificOrEq (T.TFun a b) (T.TFun c d) = +isMoreSpecificOrEq :: Type -> Type -> Bool +isMoreSpecificOrEq t1 (TAll _ t2) = isMoreSpecificOrEq t1 t2 +isMoreSpecificOrEq (TFun a b) (TFun c d) = isMoreSpecificOrEq a c && isMoreSpecificOrEq b d -isMoreSpecificOrEq (T.TData n1 ts1) (T.TData n2 ts2) = +isMoreSpecificOrEq (TData n1 ts1) (TData n2 ts2) = n1 == n2 && length ts1 == length ts2 && and (zipWith isMoreSpecificOrEq ts1 ts2) -isMoreSpecificOrEq _ (T.TVar _) = True +isMoreSpecificOrEq _ (TVar _) = True isMoreSpecificOrEq a b = a == b isPoly :: Type -> Bool isPoly (TAll _ _) = True -isPoly (TVar _) = True -isPoly _ = False +isPoly (TVar _) = True +isPoly _ = False -inferExp :: Exp -> Infer T.ExpT +inferExp :: Exp -> Infer (T.ExpT' Type) inferExp e = do (s, (e', t)) <- algoW e let subbed = apply s t @@ -178,7 +178,7 @@ class CollectTVars a where instance CollectTVars Exp where collectTypeVars (EAnn e t) = collectTypeVars t `S.union` collectTypeVars e - collectTypeVars _ = S.empty + collectTypeVars _ = S.empty instance CollectTVars Type where collectTypeVars (TVar (MkTVar i)) = S.singleton (coerce i) @@ -190,43 +190,12 @@ instance CollectTVars Type where collect :: Set T.Ident -> Infer () collect s = modify (\st -> st{takenTypeVars = s `S.union` takenTypeVars st}) -class NewType a b where - toNew :: a -> b - -instance NewType Type T.Type where - toNew = \case - TLit i -> T.TLit $ coerce i - TVar v -> T.TVar $ toNew v - TFun t1 t2 -> (T.TFun `on` toNew) t1 t2 - TAll b t -> T.TAll (toNew b) (toNew t) - TData i ts -> T.TData (coerce i) (map toNew ts) - TEVar _ -> error "Should not exist after typechecker" - -instance NewType Lit T.Lit where - toNew (LInt i) = T.LInt i - toNew (LChar i) = T.LChar i - -instance NewType Data T.Data where - toNew (Data t xs) = T.Data (name $ retType t) (toNew xs) - where - name (TData n _) = coerce n - name _ = error "Bug: Data types should not be able to be typed over non type variables" - -instance NewType Constructor T.Constructor where - toNew (Constructor name xs) = T.Constructor (coerce name) (toNew xs) - -instance NewType TVar T.TVar where - toNew (MkTVar i) = T.MkTVar $ coerce i - -instance NewType a b => NewType [a] [b] where - toNew = map toNew - -algoW :: Exp -> Infer (Subst, T.ExpT) +algoW :: Exp -> Infer (Subst, (T.ExpT' Type)) algoW = \case err@(EAnn e t) -> do (s1, (e', t')) <- exprErr (algoW e) err unless - (toNew t `isMoreSpecificOrEq` t') + (t `isMoreSpecificOrEq` t') ( throwError $ unwords [ "Annotated type:" @@ -236,34 +205,34 @@ algoW = \case ] ) applySt s1 $ do - s2 <- exprErr (unify (toNew t) t') err + s2 <- exprErr (unify (t) t') err let comp = s2 `compose` s1 - return (comp, apply comp (e', toNew t)) + return (comp, apply comp (e', t)) -- \| ------------------ -- \| Γ ⊢ i : Int, ∅ - ELit lit -> return (nullSubst, (T.ELit $ toNew lit, litType lit)) + ELit lit -> return (nullSubst, (T.ELit $ lit, litType lit)) -- \| x : σ ∈ Γ   τ = inst(σ) -- \| ---------------------- -- \| Γ ⊢ x : τ, ∅ EVar i -> do var <- asks vars case M.lookup (coerce i) var of - Just t -> inst t >>= \x -> return (nullSubst, (T.EId $ coerce i, x)) + Just t -> inst t >>= \x -> return (nullSubst, (T.EVar $ coerce i, x)) Nothing -> do sig <- gets sigs case M.lookup (coerce i) sig of - Just (Just t) -> return (nullSubst, (T.EId $ coerce i, t)) + Just (Just t) -> return (nullSubst, (T.EVar $ coerce i, t)) Just Nothing -> do fr <- fresh insertSig (coerce i) (Just fr) - return (nullSubst, (T.EId $ coerce i, fr)) + return (nullSubst, (T.EVar $ coerce i, fr)) Nothing -> throwError $ "Unbound variable: " <> printTree i EInj i -> do constr <- gets constructors case M.lookup (coerce i) constr of - Just t -> return (nullSubst, (T.EId $ coerce i, t)) + Just t -> return (nullSubst, (T.EVar $ coerce i, t)) Nothing -> throwError $ "Constructor: '" @@ -280,7 +249,7 @@ algoW = \case ( withBinding (coerce name) fr $ do (s1, (e', t')) <- exprErr (algoW e) err let varType = apply s1 fr - let newArr = T.TFun varType t' + let newArr = TFun varType t' return (s1, apply s1 (T.EAbs (coerce name) (e', t'), newArr)) ) err @@ -314,7 +283,7 @@ algoW = \case (s0, (e0', t0)) <- algoW e0 applySt s0 $ do (s1, (e1', t1)) <- algoW e1 - s2 <- exprErr (unify (apply s1 t0) (T.TFun t1 fr)) err + s2 <- exprErr (unify (apply s1 t0) (TFun t1 fr)) err let t = apply s2 fr let comp = s2 `compose` s1 `compose` s0 return (comp, apply comp (T.EApp (e0', t0) (e1', t1), t)) @@ -346,33 +315,33 @@ makeLambda :: Exp -> [T.Ident] -> Exp makeLambda = foldl (flip (EAbs . coerce)) -- | Unify two types producing a new substitution -unify :: T.Type -> T.Type -> Infer Subst +unify :: Type -> Type -> Infer Subst unify t0 t1 = do case (t0, t1) of - (T.TFun a b, T.TFun c d) -> do + (TFun a b, TFun c d) -> do s1 <- unify a c s2 <- unify (apply s1 b) (apply s1 d) return $ s1 `compose` s2 ----------- TODO: BE CAREFUL!!!! THIS IS PROBABLY WRONG!!! ----------- - (T.TVar (T.MkTVar a), t@(T.TData _ _)) -> return $ M.singleton a t - (t@(T.TData _ _), T.TVar (T.MkTVar b)) -> return $ M.singleton b t + (TVar (T.MkTVar a), t@(TData _ _)) -> return $ M.singleton (coerce a) t + (t@(TData _ _), TVar (T.MkTVar b)) -> return $ M.singleton (coerce b) t ------------------------------------------------------------------- - (T.TVar (T.MkTVar a), t) -> occurs a t - (t, T.TVar (T.MkTVar b)) -> occurs b t - (T.TAll _ t, b) -> unify t b - (a, T.TAll _ t) -> unify a t - (T.TLit a, T.TLit b) -> + (TVar (T.MkTVar a), t) -> occurs (coerce a) t + (t, TVar (T.MkTVar b)) -> occurs (coerce b) t + (TAll _ t, b) -> unify t b + (a, TAll _ t) -> unify a t + (TLit a, TLit b) -> if a == b then return M.empty else throwError . unwords $ [ "Can not unify" - , "'" <> printTree (T.TLit a) <> "'" + , "'" <> printTree (TLit a) <> "'" , "with" - , "'" <> printTree (T.TLit b) <> "'" + , "'" <> printTree (TLit b) <> "'" ] - (T.TData name t, T.TData name' t') -> + (TData name t, TData name' t') -> if name == name' && length t == length t' then do xs <- zipWithM unify t t' @@ -380,7 +349,7 @@ unify t0 t1 = do else throwError $ unwords - [ "T.Type constructor:" + [ "Type constructor:" , printTree name , "(" <> printTree t <> ")" , "does not match with:" @@ -398,42 +367,42 @@ unify t0 t1 = do I.E. { a = a -> b } is an unsolvable constraint since there is no substitution where these are equal -} -occurs :: T.Ident -> T.Type -> Infer Subst -occurs i t@(T.TVar _) = return (M.singleton i t) +occurs :: T.Ident -> Type -> Infer Subst +occurs i t@(TVar _) = return (M.singleton i t) occurs i t = if S.member i (free t) then throwError $ unwords [ "Occurs check failed, can't unify" - , printTree (T.TVar $ T.MkTVar i) + , printTree (TVar $ T.MkTVar (coerce i)) , "with" , printTree t ] else return $ M.singleton i t -- | Generalize a type over all free variables in the substitution set -generalize :: Map T.Ident T.Type -> T.Type -> T.Type +generalize :: Map T.Ident Type -> Type -> Type generalize env t = go (S.toList $ free t S.\\ free env) (removeForalls t) where - go :: [T.Ident] -> T.Type -> T.Type - go [] t = t - go (x : xs) t = T.TAll (T.MkTVar x) (go xs t) - removeForalls :: T.Type -> T.Type - removeForalls (T.TAll _ t) = removeForalls t - removeForalls (T.TFun t1 t2) = T.TFun (removeForalls t1) (removeForalls t2) - removeForalls t = t + go :: [T.Ident] -> Type -> Type + go [] t = t + go (x : xs) t = TAll (T.MkTVar (coerce x)) (go xs t) + removeForalls :: Type -> Type + removeForalls (TAll _ t) = removeForalls t + removeForalls (TFun t1 t2) = TFun (removeForalls t1) (removeForalls t2) + removeForalls t = t {- | Instantiate a polymorphic type. The free type variables are substituted with fresh ones. -} -inst :: T.Type -> Infer T.Type +inst :: Type -> Infer Type inst = \case - T.TAll (T.MkTVar bound) t -> do + TAll (T.MkTVar bound) t -> do fr <- fresh - let s = M.singleton bound fr + let s = M.singleton (coerce bound) fr apply s <$> inst t - T.TFun t1 t2 -> T.TFun <$> inst t1 <*> inst t2 + TFun t1 t2 -> TFun <$> inst t1 <*> inst t2 rest -> return rest -- | Compose two substitution sets @@ -455,41 +424,40 @@ class FreeVars t where -- | Get all free variables from t free :: t -> Set T.Ident -instance FreeVars T.Type where - free :: T.Type -> Set T.Ident - free (T.TVar (T.MkTVar a)) = S.singleton a - free (T.TAll (T.MkTVar bound) t) = S.singleton bound `S.intersection` free t - free (T.TLit _) = mempty - free (T.TFun a b) = free a `S.union` free b +instance FreeVars Type where + free :: Type -> Set T.Ident + free (TVar (T.MkTVar a)) = S.singleton (coerce a) + free (TAll (T.MkTVar bound) t) = S.singleton (coerce bound) `S.intersection` free t + free (TLit _) = mempty + free (TFun a b) = free a `S.union` free b -- \| Not guaranteed to be correct - free (T.TData _ a) = + free (TData _ a) = foldl' (\acc x -> free x `S.union` acc) S.empty a -instance SubstType T.Type where - apply :: Subst -> T.Type -> T.Type +instance SubstType Type where + apply :: Subst -> Type -> Type apply sub t = do case t of - T.TLit a -> T.TLit a - T.TVar (T.MkTVar a) -> case M.lookup a sub of - Nothing -> T.TVar (T.MkTVar $ coerce a) - Just t -> t - T.TAll (T.MkTVar i) t -> case M.lookup i sub of - Nothing -> T.TAll (T.MkTVar i) (apply sub t) - Just _ -> apply sub t - T.TFun a b -> T.TFun (apply sub a) (apply sub b) - T.TData name a -> T.TData name (map (apply sub) a) -instance FreeVars (Map T.Ident T.Type) where - free :: Map T.Ident T.Type -> Set T.Ident + TLit a -> TLit a + TVar (T.MkTVar a) -> case M.lookup (coerce a) sub of + Nothing -> TVar (T.MkTVar $ coerce a) + Just t -> t + TAll (T.MkTVar i) t -> case M.lookup (coerce i) sub of + Nothing -> TAll (T.MkTVar i) (apply sub t) + Just _ -> apply sub t + TFun a b -> TFun (apply sub a) (apply sub b) + TData name a -> TData name (map (apply sub) a) +instance FreeVars (Map T.Ident Type) where + free :: Map T.Ident Type -> Set T.Ident free m = foldl' S.union S.empty (map free $ M.elems m) -instance SubstType (Map T.Ident T.Type) where - apply :: Subst -> Map T.Ident T.Type -> Map T.Ident T.Type +instance SubstType (Map T.Ident Type) where + apply :: Subst -> Map T.Ident Type -> Map T.Ident Type apply s = M.map (apply s) -instance SubstType T.Exp where - apply :: Subst -> T.Exp -> T.Exp +instance SubstType (T.Exp' Type) where apply s = \case - T.EId i -> T.EId i + T.EVar i -> T.EVar i T.ELit lit -> T.ELit lit T.ELet (T.Bind (ident, t1) args e1) e2 -> T.ELet @@ -499,19 +467,18 @@ instance SubstType T.Exp where T.EAdd e1 e2 -> T.EAdd (apply s e1) (apply s e2) T.EAbs ident e -> T.EAbs ident (apply s e) T.ECase e brnch -> T.ECase (apply s e) (apply s brnch) + T.EInj{} -> error "implement" -instance SubstType T.Branch where - apply :: Subst -> T.Branch -> T.Branch +instance SubstType (T.Branch' Type) where apply s (T.Branch (i, t) e) = T.Branch (apply s i, apply s t) (apply s e) -instance SubstType T.Pattern where - apply :: Subst -> T.Pattern -> T.Pattern +instance SubstType (T.Pattern' Type) where apply s = \case T.PVar (iden, t) -> T.PVar (iden, apply s t) - T.PLit (lit, t) -> T.PLit (lit, apply s t) - T.PInj i ps -> T.PInj i $ apply s ps - T.PCatch -> T.PCatch - T.PEnum i -> T.PEnum i + T.PLit (lit, t) -> T.PLit (lit, apply s t) + T.PInj i ps -> T.PInj i $ apply s ps + T.PCatch -> T.PCatch + T.PEnum i -> T.PEnum i instance SubstType a => SubstType [a] where apply s = map (apply s) @@ -519,7 +486,7 @@ instance SubstType a => SubstType [a] where instance (SubstType a, SubstType b) => SubstType (a, b) where apply s (a, b) = (apply s a, apply s b) -instance SubstType T.Id where +instance SubstType (T.Id' Type) where apply s (name, t) = (name, apply s t) -- | Apply substitutions to the environment. @@ -531,7 +498,7 @@ nullSubst :: Subst nullSubst = M.empty -- | Generate a new fresh variable and increment the state counter -fresh :: Infer T.Type +fresh :: Infer Type fresh = do c <- gets nextChar n <- gets count @@ -545,34 +512,34 @@ fresh = do fresh else if n == 0 - then return . T.TVar . T.MkTVar . T.Ident $ [c] - else return . T.TVar . T.MkTVar . T.Ident $ [c] ++ show n + then return . TVar . T.MkTVar $ LIdent [c] + else return . TVar . T.MkTVar . LIdent $ [c] ++ show n next :: Char -> Char next 'z' = 'a' -next a = succ a +next a = succ a -- | Run the monadic action with an additional binding -withBinding :: (Monad m, MonadReader Ctx m) => T.Ident -> T.Type -> m a -> m a +withBinding :: (Monad m, MonadReader Ctx m) => T.Ident -> Type -> m a -> m a withBinding i p = local (\st -> st{vars = M.insert i p (vars st)}) -- | Run the monadic action with several additional bindings -withBindings :: (Monad m, MonadReader Ctx m) => [(T.Ident, T.Type)] -> m a -> m a +withBindings :: (Monad m, MonadReader Ctx m) => [(T.Ident, Type)] -> m a -> m a withBindings xs = local (\st -> st{vars = foldl' (flip (uncurry M.insert)) (vars st) xs}) -- | Insert a function signature into the environment -insertSig :: T.Ident -> Maybe T.Type -> Infer () +insertSig :: T.Ident -> Maybe Type -> Infer () insertSig i t = modify (\st -> st{sigs = M.insert i t (sigs st)}) -- | Insert a constructor with its data type -insertConstr :: T.Ident -> T.Type -> Infer () +insertConstr :: T.Ident -> Type -> Infer () insertConstr i t = modify (\st -> st{constructors = M.insert i t (constructors st)}) -------- PATTERN MATCHING --------- -checkCase :: T.Type -> [Branch] -> Infer (Subst, [T.Branch], T.Type) +checkCase :: Type -> [Branch] -> Infer (Subst, [T.Branch' Type], Type) checkCase _ [] = throwError "Atleast one case required" checkCase expT brnchs = do (subs, injTs, injs, returns) <- unzip4 <$> mapM inferBranch brnchs @@ -594,23 +561,23 @@ checkCase expT brnchs = do let comp = sub2 `compose` sub1 `compose` sub0 return (comp, apply comp injs, apply comp returns_type) -inferBranch :: Branch -> Infer (Subst, T.Type, T.Branch, T.Type) +inferBranch :: Branch -> Infer (Subst, Type, T.Branch' Type, Type) inferBranch (Branch pat expr) = do newPat@(pat, branchT) <- inferPattern pat (sub, newExp@(_, exprT)) <- withPattern pat (algoW expr) return (sub, apply sub branchT, T.Branch (apply sub newPat) (apply sub newExp), apply sub exprT) -withPattern :: T.Pattern -> Infer a -> Infer a +withPattern :: T.Pattern' Type -> Infer a -> Infer a withPattern p ma = case p of T.PVar (x, t) -> withBinding x t ma - T.PInj _ ps -> foldl' (flip withPattern) ma ps - T.PLit _ -> ma - T.PCatch -> ma - T.PEnum _ -> ma + T.PInj _ ps -> foldl' (flip withPattern) ma ps + T.PLit _ -> ma + T.PCatch -> ma + T.PEnum _ -> ma -inferPattern :: Pattern -> Infer (T.Pattern, T.Type) +inferPattern :: Pattern -> Infer (T.Pattern' Type, Type) inferPattern = \case - PLit lit -> let lt = litType lit in return (T.PLit (toNew lit, lt), lt) + PLit lit -> let lt = litType lit in return (T.PLit (lit, lt), lt) PInj constr patterns -> do t <- gets (M.lookup (coerce constr) . constructors) t <- maybeToRightM ("Constructor: " <> printTree constr <> " does not exist") t @@ -644,28 +611,28 @@ inferPattern = \case ++ show (typeLength t - 1) ++ " arguments but has been given 0" ) - let (T.TData _data _ts) = t -- nasty nasty + let (TData _data _ts) = t -- nasty nasty frs <- mapM (const fresh) _ts - return (T.PEnum $ coerce p, T.TData _data frs) + return (T.PEnum $ coerce p, TData _data frs) PVar x -> do fr <- fresh let pvar = T.PVar (coerce x, fr) return (pvar, fr) -flattenType :: T.Type -> [T.Type] -flattenType (T.TFun a b) = flattenType a <> flattenType b -flattenType a = [a] +flattenType :: Type -> [Type] +flattenType (TFun a b) = flattenType a <> flattenType b +flattenType a = [a] -typeLength :: T.Type -> Int -typeLength (T.TFun a b) = typeLength a + typeLength b -typeLength _ = 1 +typeLength :: Type -> Int +typeLength (TFun a b) = typeLength a + typeLength b +typeLength _ = 1 -litType :: Lit -> T.Type -litType (LInt _) = int +litType :: Lit -> Type +litType (LInt _) = int litType (LChar _) = char -int = T.TLit "Int" -char = T.TLit "Char" +int = TLit "Int" +char = TLit "Char" partitionType :: Int -> -- Number of parameters to apply @@ -676,8 +643,8 @@ partitionType = go [] go acc 0 t = (acc, t) go acc i t = case t of TAll tvar t' -> second (TAll tvar) $ go acc i t' - TFun t1 t2 -> go (acc <> [t1]) (i - 1) t2 - _ -> error "Number of parameters and type doesn't match" + TFun t1 t2 -> go (acc <> [t1]) (i - 1) t2 + _ -> error "Number of parameters and type doesn't match" exprErr :: Infer a -> Exp -> Infer a exprErr ma exp = @@ -691,3 +658,19 @@ unzip4 = ) ([], [], [], []) +newtype Ctx = Ctx {vars :: Map T.Ident Type} + deriving (Show) + +data Env = Env + { count :: Int + , nextChar :: Char + , sigs :: Map T.Ident (Maybe Type) + , constructors :: Map T.Ident Type + , takenTypeVars :: Set T.Ident + } + deriving (Show) + +type Error = String +type Subst = Map T.Ident Type + +type Infer = StateT Env (ReaderT Ctx (ExceptT Error Identity)) diff --git a/src/TypeChecker/TypeCheckerIr.hs b/src/TypeChecker/TypeCheckerIr.hs index 05949c9..46d1127 100644 --- a/src/TypeChecker/TypeCheckerIr.hs +++ b/src/TypeChecker/TypeCheckerIr.hs @@ -1,24 +1,24 @@ -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE PatternSynonyms #-} +module TypeChecker.TypeCheckerIr ( + module Grammar.Abs, + module TypeChecker.TypeCheckerIr, +) where -module TypeChecker.TypeCheckerIr - ( module Grammar.Abs - , module TypeChecker.TypeCheckerIr - ) where - -import Data.String (IsString) -import Grammar.Abs (Lit (..), TVar (..)) -import Grammar.Print -import Prelude -import qualified Prelude as C (Eq, Ord, Read, Show) +import Data.String (IsString) +import Grammar.Abs (Lit (..), TVar (..)) +import Grammar.Print +import Prelude +import Prelude qualified as C (Eq, Ord, Read, Show) newtype Program' t = Program [Def' t] - deriving (C.Eq, C.Ord, C.Show, C.Read) + deriving (C.Eq, C.Ord, C.Show, C.Read) -data Def' t = DBind (Bind' t) - | DData (Data' t) - deriving (C.Eq, C.Ord, C.Show, C.Read) +data Def' t + = DBind (Bind' t) + | DData (Data' t) + deriving (C.Eq, C.Ord, C.Show, C.Read) data Type = TLit Ident @@ -26,24 +26,24 @@ data Type | TData Ident [Type] | TFun Type Type | TAll TVar Type - deriving (C.Eq, C.Ord, C.Show, C.Read) + deriving (C.Eq, C.Ord, C.Show, C.Read) data Data' t = Data t [Inj' t] - deriving (C.Eq, C.Ord, C.Show, C.Read) + deriving (C.Eq, C.Ord, C.Show, C.Read) data Inj' t = Inj Ident t - deriving (C.Eq, C.Ord, C.Show, C.Read) + deriving (C.Eq, C.Ord, C.Show, C.Read) newtype Ident = Ident String - deriving (C.Eq, C.Ord, C.Show, C.Read, IsString) + deriving (C.Eq, C.Ord, C.Show, C.Read, IsString) data Pattern' t - = PVar (Id' t) -- TODO should be Ident - | PLit (Lit, t) -- TODO should be Lit + = PVar (Id' t) -- TODO should be Ident + | PLit (Lit, t) -- TODO should be Lit | PCatch | PEnum Ident | PInj Ident [Pattern' t] -- TODO should be (Pattern' t, t) - deriving (C.Eq, C.Ord, C.Show, C.Read) + deriving (C.Eq, C.Ord, C.Show, C.Read) data Exp' t = EVar Ident @@ -52,18 +52,18 @@ data Exp' t | ELet (Bind' t) (ExpT' t) | EApp (ExpT' t) (ExpT' t) | EAdd (ExpT' t) (ExpT' t) - | EAbs Ident (ExpT' t) + | EAbs Ident (ExpT' t) | ECase (ExpT' t) [Branch' t] - deriving (C.Eq, C.Ord, C.Show, C.Read) + deriving (C.Eq, C.Ord, C.Show, C.Read) -type Id' t = (Ident, t) +type Id' t = (Ident, t) type ExpT' t = (Exp' t, t) data Bind' t = Bind (Id' t) [Id' t] (ExpT' t) deriving (C.Eq, C.Ord, C.Show, C.Read) data Branch' t = Branch (Pattern' t, t) (ExpT' t) - deriving (C.Eq, C.Ord, C.Show, C.Read) + deriving (C.Eq, C.Ord, C.Show, C.Read) instance Print Ident where prt i (Ident s) = prt i s @@ -72,127 +72,143 @@ instance Print t => Print (Program' t) where prt i (Program sc) = prPrec i 0 $ prt 0 sc instance Print t => Print (Bind' t) where - prt i (Bind sig@(name, _) parms rhs) = prPrec i 0 $ concatD - [ prtSig sig - , prt 0 name - , prtIdPs 0 parms - , doc $ showString "=" - , prt 0 rhs - ] + prt i (Bind sig@(name, _) parms rhs) = + prPrec i 0 $ + concatD + [ prtSig sig + , prt 0 name + , prtIdPs 0 parms + , doc $ showString "=" + , prt 0 rhs + ] prtSig :: Print t => Id' t -> Doc -prtSig (name, t) = concatD [ prt 0 name - , doc $ showString ":" - , prt 0 t - , doc $ showString ";" - ] +prtSig (name, t) = + concatD + [ prt 0 name + , doc $ showString ":" + , prt 0 t + , doc $ showString ";" + ] instance Print t => Print (ExpT' t) where - prt i (e, t) = concatD [ doc $ showString "(" - , prt i e - , doc $ showString "," - , prt i t - , doc $ showString ")" - ] + prt i (e, t) = + concatD + [ doc $ showString "(" + , prt i e + , doc $ showString "," + , prt i t + , doc $ showString ")" + ] instance Print t => Print [Bind' t] where - prt _ [] = concatD [] - prt _ [x] = concatD [prt 0 x] - prt _ (x:xs) = concatD [prt 0 x, doc (showString ";"), prt 0 xs] + prt _ [] = concatD [] + prt _ [x] = concatD [prt 0 x] + prt _ (x : xs) = concatD [prt 0 x, doc (showString ";"), prt 0 xs] prtIdPs :: Print t => Int -> [Id' t] -> Doc prtIdPs i = prPrec i 0 . concatD . map (prt i) instance Print t => Print (Id' t) where - prt i (name, t) = concatD [ doc $ showString "(" - , prt i name - , doc $ showString "," - , prt i t - , doc $ showString ")" - ] + prt i (name, t) = + concatD + [ doc $ showString "(" + , prt i name + , doc $ showString "," + , prt i t + , doc $ showString ")" + ] instance Print t => Print (Exp' t) where - prt i = \case - EVar name -> prPrec i 3 $ prt 0 name - EInj name -> prPrec i 3 $ prt 0 name - ELit lit -> prPrec i 3 $ prt 0 lit - ELet b e -> prPrec i 3 $ concatD - [ doc $ showString "let" - , prt 0 b - , doc $ showString "in" - , prt 0 e - ] - EApp e1 e2 -> prPrec i 2 $ concatD - [ prt 2 e1 - , prt 3 e2 - ] - EAdd e1 e2 -> prPrec i 1 $ concatD - [ prt 1 e1 - , doc $ showString "+" - , prt 2 e2 - ] - EAbs v e -> prPrec i 0 $ concatD - [ doc $ showString "\\" - , prt 0 v - , doc $ showString "." - , prt 0 e - ] - - ECase e branches -> prPrec i 0 $ concatD - [ doc $ showString "case" - , prt 0 e - , doc $ showString "of" - , doc $ showString "{" - , prt 0 branches - , doc $ showString "}" - ] - + prt i = \case + EVar name -> prPrec i 3 $ prt 0 name + EInj name -> prPrec i 3 $ prt 0 name + ELit lit -> prPrec i 3 $ prt 0 lit + ELet b e -> + prPrec i 3 $ + concatD + [ doc $ showString "let" + , prt 0 b + , doc $ showString "in" + , prt 0 e + ] + EApp e1 e2 -> + prPrec i 2 $ + concatD + [ prt 2 e1 + , prt 3 e2 + ] + EAdd e1 e2 -> + prPrec i 1 $ + concatD + [ prt 1 e1 + , doc $ showString "+" + , prt 2 e2 + ] + EAbs v e -> + prPrec i 0 $ + concatD + [ doc $ showString "\\" + , prt 0 v + , doc $ showString "." + , prt 0 e + ] + ECase e branches -> + prPrec i 0 $ + concatD + [ doc $ showString "case" + , prt 0 e + , doc $ showString "of" + , doc $ showString "{" + , prt 0 branches + , doc $ showString "}" + ] instance Print t => Print (Branch' t) where - prt i (Branch (pattern_, t) exp) = prPrec i 0 (concatD [doc (showString "("), prt 0 pattern_, doc (showString " : "), prt 0 t, doc (showString ")"), doc (showString "=>"), prt 0 exp]) + prt i (Branch (pattern_, t) exp) = prPrec i 0 (concatD [doc (showString "("), prt 0 pattern_, doc (showString " : "), prt 0 t, doc (showString ")"), doc (showString "=>"), prt 0 exp]) instance Print t => Print [Branch' t] where - prt _ [] = concatD [] - prt _ [x] = concatD [prt 0 x] - prt _ (x:xs) = concatD [prt 0 x, doc (showString ";"), prt 0 xs] + prt _ [] = concatD [] + prt _ [x] = concatD [prt 0 x] + prt _ (x : xs) = concatD [prt 0 x, doc (showString ";"), prt 0 xs] instance Print t => Print (Def' t) where - prt i = \case - DBind bind -> prPrec i 0 (concatD [prt 0 bind]) - DData data_ -> prPrec i 0 (concatD [prt 0 data_]) + prt i = \case + DBind bind -> prPrec i 0 (concatD [prt 0 bind]) + DData data_ -> prPrec i 0 (concatD [prt 0 data_]) instance Print t => Print (Data' t) where - prt i = \case - Data type_ injs -> prPrec i 0 (concatD [doc (showString "data"), prt 0 type_, doc (showString "where"), doc (showString "{"), prt 0 injs, doc (showString "}")]) + prt i = \case + Data type_ injs -> prPrec i 0 (concatD [doc (showString "data"), prt 0 type_, doc (showString "where"), doc (showString "{"), prt 0 injs, doc (showString "}")]) instance Print t => Print (Inj' t) where - prt i = \case - Inj uident type_ -> prPrec i 0 (concatD [prt 0 uident, doc (showString ":"), prt 0 type_]) + prt i = \case + Inj uident type_ -> prPrec i 0 (concatD [prt 0 uident, doc (showString ":"), prt 0 type_]) instance Print t => Print (Pattern' t) where - prt i = \case - PVar name -> prPrec i 1 (concatD [prt 0 name]) - PLit (lit, _) -> prPrec i 1 (concatD [prt 0 lit]) - PCatch -> prPrec i 1 (concatD [doc (showString "_")]) - PEnum name -> prPrec i 1 (concatD [prt 0 name]) - PInj uident patterns -> prPrec i 0 (concatD [prt 0 uident, prt 1 patterns]) + prt i = \case + PVar name -> prPrec i 1 (concatD [prt 0 name]) + PLit (lit, _) -> prPrec i 1 (concatD [prt 0 lit]) + PCatch -> prPrec i 1 (concatD [doc (showString "_")]) + PEnum name -> prPrec i 1 (concatD [prt 0 name]) + PInj uident patterns -> prPrec i 0 (concatD [prt 0 uident, prt 1 patterns]) instance Print t => Print [Def' t] where - prt _ [] = concatD [] - prt _ [x] = concatD [prt 0 x] - prt _ (x:xs) = concatD [prt 0 x, doc (showString ";"), prt 0 xs] + prt _ [] = concatD [] + prt _ [x] = concatD [prt 0 x] + prt _ (x : xs) = concatD [prt 0 x, doc (showString ";"), prt 0 xs] instance Print [Type] where - prt _ [] = concatD [] - prt _ (x:xs) = concatD [prt 0 x, doc (showString " "), prt 0 xs] + prt _ [] = concatD [] + prt _ (x : xs) = concatD [prt 0 x, doc (showString " "), prt 0 xs] instance Print Type where - prt i = \case - TLit uident -> prPrec i 1 (concatD [prt 0 uident]) - TVar tvar -> prPrec i 1 (concatD [prt 0 tvar]) - TData uident types -> prPrec i 1 (concatD [prt 0 uident, doc (showString "("), prt 0 types, doc (showString ")")]) - TFun type_1 type_2 -> prPrec i 0 (concatD [prt 1 type_1, doc (showString "->"), prt 0 type_2]) - TAll tvar type_ -> prPrec i 0 (concatD [doc (showString "forall"), prt 0 tvar, doc (showString "."), prt 0 type_]) + prt i = \case + TLit uident -> prPrec i 1 (concatD [prt 0 uident]) + TVar tvar -> prPrec i 1 (concatD [prt 0 tvar]) + TData uident types -> prPrec i 1 (concatD [prt 0 uident, doc (showString "("), prt 0 types, doc (showString ")")]) + TFun type_1 type_2 -> prPrec i 0 (concatD [prt 1 type_1, doc (showString "->"), prt 0 type_2]) + TAll tvar type_ -> prPrec i 0 (concatD [doc (showString "forall"), prt 0 tvar, doc (showString "."), prt 0 type_]) type Program = Program' Type type Def = Def' Type @@ -201,9 +217,8 @@ type Bind = Bind' Type type Branch = Branch' Type type Pattern = Pattern' Type type Inj = Inj' Type -type Exp = Exp' Type +type Exp = Exp' Type type ExpT = ExpT' Type -type Id = Id' Type +type Id = Id' Type pattern DBind' id vars expt = DBind (Bind id vars expt) -pattern DData' typ injs = DData (Data typ injs) - +pattern DData' typ injs = DData (Data typ injs) From d5ce73beaeb53bf04cfe1ff78a3ba4c8f338e871 Mon Sep 17 00:00:00 2001 From: sebastianselander Date: Mon, 27 Mar 2023 16:52:22 +0200 Subject: [PATCH 184/372] hm is compatible --- src/Main.hs | 124 ++++++++++++++++++--------------- src/TypeChecker/TypeChecker.hs | 18 +++++ tests/DoStrings.hs | 4 ++ tests/TestTypeCheckerHm.hs | 29 ++++---- 4 files changed, 106 insertions(+), 69 deletions(-) create mode 100644 src/TypeChecker/TypeChecker.hs create mode 100644 tests/DoStrings.hs diff --git a/src/Main.hs b/src/Main.hs index 210916d..19ef68c 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -2,87 +2,97 @@ module Main where -import Control.Monad (when) -import Data.Bool (bool) -import Data.List.Extra (isSuffixOf) -import Data.Maybe (fromJust, isNothing) -import GHC.IO.Handle.Text (hPutStrLn) -import System.Console.GetOpt (ArgDescr (NoArg, ReqArg), - ArgOrder (RequireOrder), - OptDescr (Option), getOpt, - usageInfo) -import System.Directory (createDirectory, doesPathExist, - getDirectoryContents, - removeDirectoryRecursive, - setCurrentDirectory) -import System.Environment (getArgs) -import System.Exit (ExitCode (ExitFailure), - exitFailure, exitSuccess, - exitWith) -import System.IO (stderr) +import Control.Monad (when) +import Data.Bool (bool) +import Data.List.Extra (isSuffixOf) +import Data.Maybe (fromJust, isNothing) +import GHC.IO.Handle.Text (hPutStrLn) +import System.Console.GetOpt ( + ArgDescr (NoArg, ReqArg), + ArgOrder (RequireOrder), + OptDescr (Option), + getOpt, + usageInfo, + ) +import System.Directory ( + createDirectory, + doesPathExist, + getDirectoryContents, + removeDirectoryRecursive, + setCurrentDirectory, + ) +import System.Environment (getArgs) +import System.Exit ( + ExitCode (ExitFailure), + exitFailure, + exitSuccess, + exitWith, + ) +import System.IO (stderr) - -import Codegen.Codegen (generateCode) -import Compiler (compile) -import Grammar.ErrM (Err) -import Grammar.Par (myLexer, pProgram) -import Grammar.Print (printTree) -import LambdaLifter (lambdaLift) -import Monomorphizer.Monomorphizer (monomorphize) -import Renamer.Renamer (rename) -import System.Process (spawnCommand, waitForProcess) -import TypeChecker.TypeChecker (TypeChecker (Bi, Hm), typecheck) +import Codegen.Codegen (generateCode) +import Compiler (compile) +import Grammar.ErrM (Err) +import Grammar.Par (myLexer, pProgram) +import Grammar.Print (printTree) +import LambdaLifter (lambdaLift) +import Monomorphizer.Monomorphizer (monomorphize) +import Renamer.Renamer (rename) +import System.Process (spawnCommand, waitForProcess) +import TypeChecker.TypeChecker (TypeChecker (Bi, Hm), typecheck) main :: IO () main = getArgs >>= parseArgs >>= uncurry main' parseArgs :: [String] -> IO (Options, String) parseArgs argv = case getOpt RequireOrder flags argv of - (os, f:_, []) - | opts.help || isNothing opts.typechecker -> do - hPutStrLn stderr (usageInfo header flags) - exitSuccess - | otherwise -> pure (opts, f) - where - opts = foldr ($) initOpts os - (_, _, errs) -> do - hPutStrLn stderr (concat errs ++ usageInfo header flags) - exitWith (ExitFailure 1) + (os, f : _, []) + | opts.help || isNothing opts.typechecker -> do + hPutStrLn stderr (usageInfo header flags) + exitSuccess + | otherwise -> pure (opts, f) + where + opts = foldr ($) initOpts os + (_, _, errs) -> do + hPutStrLn stderr (concat errs ++ usageInfo header flags) + exitWith (ExitFailure 1) where header = "Usage: language [--help] [-d|--debug] [-t|type-checker bi/hm] FILE \n" flags :: [OptDescr (Options -> Options)] flags = - [ Option ['d'] ["debug"] (NoArg enableDebug) "Print debug messages." + [ Option ['d'] ["debug"] (NoArg enableDebug) "Print debug messages." , Option ['t'] ["type-checker"] (ReqArg chooseTypechecker "bi/hm") "Choose type checker. Possible options are bi and hm" - , Option [] ["help"] (NoArg enableHelp) "Print this help message" + , Option [] ["help"] (NoArg enableHelp) "Print this help message" ] initOpts :: Options -initOpts = Options { help = False - , debug = False - , typechecker = Nothing - } +initOpts = + Options + { help = False + , debug = False + , typechecker = Nothing + } enableHelp :: Options -> Options -enableHelp opts = opts { help = True } +enableHelp opts = opts{help = True} enableDebug :: Options -> Options -enableDebug opts = opts { debug = True } +enableDebug opts = opts{debug = True} chooseTypechecker :: String -> Options -> Options -chooseTypechecker s options = options { typechecker = tc } +chooseTypechecker s options = options{typechecker = tc} where tc = case s of - "hm" -> pure Hm - "bi" -> pure Bi - _ -> Nothing + "hm" -> pure Hm + "bi" -> pure Bi + _ -> Nothing data Options = Options - { help :: Bool - , debug :: Bool - , typechecker :: Maybe TypeChecker - } + { help :: Bool + , debug :: Bool + , typechecker :: Maybe TypeChecker + } main' :: Options -> String -> IO () main' opts s = do @@ -110,12 +120,12 @@ main' opts s = do -- printToErr "\n -- Compiler --" generatedCode <- fromCompilerErr $ generateCode (monomorphize typechecked) - --putStrLn generatedCode + -- putStrLn generatedCode check <- doesPathExist "output" when check (removeDirectoryRecursive "output") createDirectory "output" - when debug $ do + when opts.debug $ do _ <- writeFile "output/llvm.ll" generatedCode debugDotViz diff --git a/src/TypeChecker/TypeChecker.hs b/src/TypeChecker/TypeChecker.hs new file mode 100644 index 0000000..6c95a09 --- /dev/null +++ b/src/TypeChecker/TypeChecker.hs @@ -0,0 +1,18 @@ +module TypeChecker.TypeChecker (typecheck, TypeChecker (..)) where + +import Control.Monad ((<=<)) +import Grammar.Abs +import Grammar.ErrM (Err) +import TypeChecker.RemoveTEVar (RemoveTEVar (rmTEVar)) +import TypeChecker.TypeCheckerBidir qualified as Bi +import TypeChecker.TypeCheckerHm qualified as Hm +import TypeChecker.TypeCheckerIr qualified as T + +data TypeChecker = Bi | Hm + +typecheck :: TypeChecker -> Program -> Err T.Program +typecheck tc = rmTEVar <=< f + where + f = case tc of + Bi -> Bi.typecheck + Hm -> Hm.typecheck diff --git a/tests/DoStrings.hs b/tests/DoStrings.hs new file mode 100644 index 0000000..73580f8 --- /dev/null +++ b/tests/DoStrings.hs @@ -0,0 +1,4 @@ +module DoStrings where + +(>>) str1 str2 = str1 ++ "\n" ++ str2 +(>>=) str1 f = f str1 diff --git a/tests/TestTypeCheckerHm.hs b/tests/TestTypeCheckerHm.hs index b666701..ae298c8 100644 --- a/tests/TestTypeCheckerHm.hs +++ b/tests/TestTypeCheckerHm.hs @@ -1,27 +1,32 @@ +{-# LANGUAGE QualifiedDo #-} {-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE QualifiedDo #-} module TestTypeCheckerHm (testTypeCheckerHm) where -import Control.Monad ((<=<)) -import qualified DoStrings as D -import Grammar.Par (myLexer, pProgram) -import Prelude (Bool (..), Either (..), IO, fmap, - not, ($), (.)) -import Test.Hspec +import Control.Monad ((<=<)) +import DoStrings qualified as D +import Grammar.Par (myLexer, pProgram) +import Test.Hspec +import Prelude ( + Bool (..), + Either (..), + IO, + fmap, + not, + ($), + (.), + ) -- import Test.QuickCheck -import TypeChecker.TypeCheckerHm (typecheck) - - +import TypeChecker.TypeCheckerHm (typecheck) testTypeCheckerHm = describe "Hillner Milner type checker test" $ do ok1 ok2 bad1 bad2 - -- bad3 +-- bad3 ok1 = specify "Basic polymorphism with multiple type variables" $ @@ -75,7 +80,7 @@ bad3 = run = typecheck <=< pProgram . myLexer ok (Right _) = True -ok (Left _) = False +ok (Left _) = False bad = not . ok From 2adc3dceeea5421b7590e29108ebc84481229df8 Mon Sep 17 00:00:00 2001 From: sebastianselander Date: Mon, 27 Mar 2023 16:53:29 +0200 Subject: [PATCH 185/372] added old tests --- tests/TestTypeCheckerHm.hs | 249 +++++++++++++++++++++++++++---------- 1 file changed, 181 insertions(+), 68 deletions(-) diff --git a/tests/TestTypeCheckerHm.hs b/tests/TestTypeCheckerHm.hs index ae298c8..b5d14c6 100644 --- a/tests/TestTypeCheckerHm.hs +++ b/tests/TestTypeCheckerHm.hs @@ -1,81 +1,180 @@ {-# LANGUAGE QualifiedDo #-} {-# LANGUAGE NoImplicitPrelude #-} -module TestTypeCheckerHm (testTypeCheckerHm) where +module Main where import Control.Monad ((<=<)) import DoStrings qualified as D import Grammar.Par (myLexer, pProgram) import Test.Hspec -import Prelude ( - Bool (..), - Either (..), - IO, - fmap, - not, - ($), - (.), - ) +import Prelude (Bool (..), Either (..), IO, mapM_, not, ($), (.)) -- import Test.QuickCheck -import TypeChecker.TypeCheckerHm (typecheck) +import TypeChecker.TypeChecker (typecheck) -testTypeCheckerHm = describe "Hillner Milner type checker test" $ do - ok1 - ok2 - bad1 - bad2 +main :: IO () +main = do + mapM_ hspec goods + mapM_ hspec bads + mapM_ hspec bes --- bad3 +goods = + [ testSatisfy + "Basic polymorphism with multiple type variables" + ( D.do + _const + "main = const 'a' 65 ;" + ) + ok + , testSatisfy + "Head with a correct signature is accepted" + ( D.do + _List + _headSig + _head + ) + ok + , testSatisfy + "Most simple inference possible" + ( D.do + _id + ) + ok + , testSatisfy + "Pattern matching on a nested list" + ( D.do + _List + "main : List (List (a)) -> Int ;" + "main xs = case xs of {" + " Cons Nil _ => 1 ;" + " _ => 0 ;" + "};" + ) + ok + ] -ok1 = - specify "Basic polymorphism with multiple type variables" $ - run - ( D.do - const - "main = const 'a' 65 ;" - ) - `shouldSatisfy` ok -ok2 = - specify "Head with a correct signature is accepted" $ - run - ( D.do - list - headSig - head - ) - `shouldSatisfy` ok +bads = + [ testSatisfy + "Infinite type unification should not succeed" + ( D.do + "main = \\x. x x ;" + ) + bad + , testSatisfy + "Pattern matching using different types should not succeed" + ( D.do + _List + "bad xs = case xs of {" + " 1 => 0 ;" + " Nil => 0 ;" + "};" + ) + bad + , testSatisfy + "Using a concrete function (data type) on a skolem variable should not succeed" + ( D.do + _Bool + _not + "f : a -> Bool () ;" + "f x = not x ;" + ) + bad + , testSatisfy + "Using a concrete function (primitive type) on a skolem variable should not succeed" + ( D.do + "plusOne : Int -> Int ;" + "plusOne x = x + 1 ;" + "f : a -> Int ;" + "f x = plusOne x ;" + ) + bad + , testSatisfy + "A function without signature used in an incompatible context should not succeed" + ( D.do + "main = _id 1 2 ;" + "_id x = x ;" + ) + bad + , testSatisfy + "Pattern matching on literal and _List should not succeed" + ( D.do + _List + "length : List (c) -> Int;" + "length _List = case _List of {" + " 0 => 0;" + " Cons x xs => 1 + length xs;" + "};" + ) + bad + , testSatisfy + "List of function Int -> Int functions should not be usable on Char" + ( D.do + _List + "main : List (Int -> Int) -> Int ;" + "main xs = case xs of {" + " Cons f _ => f 'a' ;" + " Nil => 0 ;" + " };" + ) + bad + , testSatisfy + "id with incorrect signature" + ( D.do + "id : a -> b;" + "id x = x;" + ) + bad + , testSatisfy + "incorrect type signature on id lambda" + ( D.do + "id = ((\\x. x) : a -> b);" + ) + bad + ] -bad1 = - specify "Infinite type unification should not succeed" $ - run - ( D.do - "main = \\x. x x ;" - ) - `shouldSatisfy` bad +bes = + [ testBe + "A basic arithmetic function should be able to be inferred" + ( D.do + "plusOne x = x + 1 ;" + "main x = plusOne x ;" + ) + ( D.do + "plusOne : Int -> Int ;" + "plusOne x = x + 1 ;" + "main : Int -> Int ;" + "main x = plusOne x ;" + ) + , testBe + "A basic arithmetic function should be able to be inferred" + ( D.do + "plusOne x = x + 1 ;" + ) + ( D.do + "plusOne : Int -> Int ;" + "plusOne x = x + 1 ;" + ) + , testBe + "List of function Int -> Int functions should be inferred corretly" + ( D.do + _List + "main xs = case xs of {" + " Cons f _ => f 1 ;" + " Nil => 0 ;" + " };" + ) + ( D.do + _List + "main : List (Int -> Int) -> Int ;" + "main xs = case xs of {" + " Cons f _ => f 1 ;" + " Nil => 0 ;" + " };" + ) + ] -bad2 = - specify "Pattern matching using different types should not succeed" $ - run - ( D.do - list - "bad xs = case xs of {" - " 1 => 0 ;" - " Nil => 0 ;" - "};" - ) - `shouldSatisfy` bad - -bad3 = - specify "Using a concrete function on a skolem variable should not succeed" $ - run - ( D.do - bool - _not - "f : a -> Bool () ;" - " f x = not x ;" - ) - `shouldSatisfy` bad +testSatisfy desc test satisfaction = specify desc $ run test `shouldSatisfy` satisfaction +testBe desc test shouldbe = specify desc $ run test `shouldBe` run shouldbe run = typecheck <=< pProgram . myLexer @@ -86,25 +185,26 @@ bad = not . ok -- FUNCTIONS -const = D.do +_const = D.do "const : a -> b -> a ;" "const x y = x ;" -list = D.do +_List = D.do "data List (a) where" " {" " Nil : List (a)" " Cons : a -> List (a) -> List (a)" " };" -headSig = D.do +_headSig = D.do "head : List (a) -> a ;" -head = D.do + +_head = D.do "head xs = " " case xs of {" " Cons x xs => x ;" " };" -bool = D.do +_Bool = D.do "data Bool () where {" " True : Bool ()" " False : Bool ()" @@ -116,3 +216,16 @@ _not = D.do " True => False ;" " False => True ;" "};" +_id = "id x = x ;" + +_Maybe = D.do + "data Maybe (a) where {" + " Nothing : Maybe (a)" + " Just : a -> Maybe (a)" + " };" + +_fmap = D.do + "fmap f ma = case ma of {" + " Nothing => Nothing ;" + " Just a => Just (f a) ;" + "};" From 506d8733d98a4f8078274298028013b7b000a8aa Mon Sep 17 00:00:00 2001 From: sebastianselander Date: Mon, 27 Mar 2023 16:54:10 +0200 Subject: [PATCH 186/372] added old tests, still broken --- tests/TestTypeCheckerHm.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests/TestTypeCheckerHm.hs b/tests/TestTypeCheckerHm.hs index b5d14c6..ce72c63 100644 --- a/tests/TestTypeCheckerHm.hs +++ b/tests/TestTypeCheckerHm.hs @@ -1,7 +1,7 @@ {-# LANGUAGE QualifiedDo #-} {-# LANGUAGE NoImplicitPrelude #-} -module Main where +module TestTypeCheckerHm where import Control.Monad ((<=<)) import DoStrings qualified as D From 4a6c72fce01ee88b1c18dd8d866e2fc7a31df205 Mon Sep 17 00:00:00 2001 From: Rakarake Date: Mon, 27 Mar 2023 20:11:49 +0200 Subject: [PATCH 187/372] Removed codegen to compile, type seem to work for newly added example --- language.cabal | 8 ++++---- sample-programs/mono.crf | 5 +++++ src/Main.hs | 28 ++++++++++++++++------------ src/Monomorphizer/Monomorphizer.hs | 18 ++++++++---------- 4 files changed, 33 insertions(+), 26 deletions(-) create mode 100644 sample-programs/mono.crf 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" From ad2bd645d9b2b699cf5c1e07b88f1654c771f589 Mon Sep 17 00:00:00 2001 From: sebastian Date: Mon, 27 Mar 2023 20:33:11 +0200 Subject: [PATCH 188/372] tests are running now --- tests/TestTypeCheckerBidir.hs | 183 ++++++++++++++++++---------------- tests/TestTypeCheckerHm.hs | 13 ++- 2 files changed, 101 insertions(+), 95 deletions(-) diff --git a/tests/TestTypeCheckerBidir.hs b/tests/TestTypeCheckerBidir.hs index 3a20ca6..1aaaf62 100644 --- a/tests/TestTypeCheckerBidir.hs +++ b/tests/TestTypeCheckerBidir.hs @@ -1,86 +1,95 @@ +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} {-# HLINT ignore "Use camelCase" #-} {-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE PatternSynonyms #-} module TestTypeCheckerBidir (testTypeCheckerBidir) where -import Test.Hspec - -import Control.Monad ((<=<)) -import Grammar.ErrM (Err, pattern Bad, pattern Ok) -import Grammar.Par (myLexer, pProgram) -import Renamer.Renamer (rename) -import TypeChecker.RemoveTEVar (RemoveTEVar (rmTEVar)) -import TypeChecker.TypeCheckerBidir (typecheck) -import qualified TypeChecker.TypeCheckerIr as T +import Test.Hspec +import Control.Monad ((<=<)) +import Grammar.ErrM (Err, pattern Bad, pattern Ok) +import Grammar.Par (myLexer, pProgram) +import Renamer.Renamer (rename) +import TypeChecker.RemoveTEVar (RemoveTEVar (rmTEVar)) +import TypeChecker.TypeCheckerBidir (typecheck) +import TypeChecker.TypeCheckerIr qualified as T testTypeCheckerBidir = describe "Bidirectional type checker test" $ do - tc_id - tc_double - tc_add_lam - tc_const - tc_simple_rank2 - tc_rank2 - tc_identity - tc_pair - tc_tree - tc_mono_case - tc_pol_case + tc_id + tc_double + tc_add_lam + tc_const + tc_simple_rank2 + tc_rank2 + tc_identity + tc_pair + tc_tree + tc_mono_case + tc_pol_case -tc_id = specify "Basic identity function polymorphism" $ run - [ "id : forall a. a -> a;" - , "id x = x;" - , "main = id 4;" - ] `shouldSatisfy` ok +tc_id = + specify "Basic identity function polymorphism" $ + run + [ "id : forall a. a -> a;" + , "id x = x;" + , "main = id 4;" + ] + `shouldSatisfy` ok -tc_double = specify "Addition inference" $ run - ["double x = x + x;"] `shouldSatisfy` ok +tc_double = + specify "Addition inference" $ + run + ["double x = x + x;"] + `shouldSatisfy` ok +tc_add_lam = + specify "Addition lambda inference" $ + run + ["four = (\\x. x + x) 2;"] + `shouldSatisfy` ok -tc_add_lam = specify "Addition lambda inference" $ run - ["four = (\\x. x + x) 2;"] `shouldSatisfy` ok +tc_const = + specify "Basic polymorphism with multiple type variables" $ + run + [ "const : forall a. forall b. a -> b -> a;" + , "const x y = x;" + , "main = const 'a' 65;" + ] + `shouldSatisfy` ok +tc_simple_rank2 = + specify "Simple rank two polymorphism" $ + run + [ "id : forall a. a -> a;" + , "id x = x;" + , "f : forall a. a -> (forall b. b -> b) -> a;" + , "f x g = g x;" + , "main = f 4 id;" + ] + `shouldSatisfy` ok -tc_const = specify "Basic polymorphism with multiple type variables" $ run - [ "const : forall a. forall b. a -> b -> a;" - , "const x y = x;" - , "main = const 'a' 65;" - ] `shouldSatisfy` ok - -tc_simple_rank2 = specify "Simple rank two polymorphism" $ run - [ "id : forall a. a -> a;" - , "id x = x;" - - , "f : forall a. a -> (forall b. b -> b) -> a;" - , "f x g = g x;" - - , "main = f 4 id;" - ] `shouldSatisfy` ok - -tc_rank2 = specify "Rank two polymorphism is ok" $ run - [ "const : forall a. forall b. a -> b -> a;" - , "const x y = x;" - - , "rank2 : forall a. forall b. a -> (forall c. c -> Int) -> b -> Int;" - , "rank2 x f y = f x + f y;" - - , "main = rank2 3 (\\x. const 5 x : forall a. a -> Int) 'h';" - ] `shouldSatisfy` ok +tc_rank2 = + specify "Rank two polymorphism is ok" $ + run + [ "const : forall a. forall b. a -> b -> a;" + , "const x y = x;" + , "rank2 : forall a. forall b. a -> (forall c. c -> Int) -> b -> Int;" + , "rank2 x f y = f x + f y;" + , "main = rank2 3 (\\x. const 5 x : forall a. a -> Int) 'h';" + ] + `shouldSatisfy` ok tc_identity = describe "(∀b. b → b) should only accept the identity function" $ do - specify "identityᵢₙₜ is rejected" $ run (fs ++ id_int) `shouldNotSatisfy` ok - specify "identity is accepted" $ run (fs ++ id) `shouldSatisfy` ok + specify "identityᵢₙₜ is rejected" $ run (fs ++ id_int) `shouldNotSatisfy` ok + specify "identity is accepted" $ run (fs ++ id) `shouldSatisfy` ok where fs = [ "f : forall a. a -> (forall b. b -> b) -> a;" , "f x g = g x;" - , "id : forall a. a -> a;" , "id x = x;" - , "id_int : Int -> Int;" , "id_int x = x;" ] @@ -101,37 +110,35 @@ tc_pair = describe "Pair. Type variables in Pair a b typechecked" $ do [ "data forall a. forall b. Pair (a b) where {" , " Pair : a -> b -> Pair (a b)" , "};" - , "main : Pair (Int Char);" ] - wrong = ["main = Pair 'a' 65;"] + wrong = ["main = Pair 'a' 65;"] correct = ["main = Pair 65 'a';"] tc_tree = describe "Tree. Recursive data type" $ do specify "Wrong tree is rejected" $ run (fs ++ wrong) `shouldNotSatisfy` ok specify "Correct tree is accepted" $ run (fs ++ correct) `shouldSatisfy` ok where - fs = + fs = [ "data forall a. Tree (a) where {" , " Node : a -> Tree (a) -> Tree (a) -> Tree (a)" , " Leaf : a -> Tree (a)" , "};" ] - wrong = ["tree = Node 1 (Node 2 (Node 4) (Leaf 5)) (Leaf 3);"] + wrong = ["tree = Node 1 (Node 2 (Node 4) (Leaf 5)) (Leaf 3);"] correct = ["tree = Node 1 (Node 2 (Leaf 4) (Leaf 5)) (Leaf 3);"] tc_mono_case = describe "Monomorphic pattern matching" $ do - specify "First wrong case expression rejected" - $ run wrong1 `shouldNotSatisfy` ok - specify "Second wrong case expression rejected" - $ run wrong2 `shouldNotSatisfy` ok - specify "Third wrong case expression rejected" - $ run wrong3 `shouldNotSatisfy` ok - specify "First correct case expression accepted" - $ run correct1 `shouldSatisfy` ok - specify "Second correct case expression accepted" - $ run correct2 `shouldSatisfy` ok - + specify "First wrong case expression rejected" $ + run wrong1 `shouldNotSatisfy` ok + specify "Second wrong case expression rejected" $ + run wrong2 `shouldNotSatisfy` ok + specify "Third wrong case expression rejected" $ + run wrong3 `shouldNotSatisfy` ok + specify "First correct case expression accepted" $ + run correct1 `shouldSatisfy` ok + specify "Second correct case expression accepted" $ + run correct2 `shouldSatisfy` ok where wrong1 = [ "simple : Int -> Int;" @@ -170,16 +177,16 @@ tc_mono_case = describe "Monomorphic pattern matching" $ do ] tc_pol_case = describe "Polymophic pattern matching" $ do - specify "First wrong case expression rejected" - $ run (fs ++ wrong1) `shouldNotSatisfy` ok - specify "Second wrong case expression rejected" - $ run (fs ++ wrong2) `shouldNotSatisfy` ok - specify "Third wrong case expression rejected" - $ run (fs ++ wrong3) `shouldNotSatisfy` ok - specify "First correct case expression accepted" - $ run (fs ++ correct1) `shouldSatisfy` ok - specify "Second correct case expression accepted" - $ run (fs ++ correct2) `shouldSatisfy` ok + specify "First wrong case expression rejected" $ + run (fs ++ wrong1) `shouldNotSatisfy` ok + specify "Second wrong case expression rejected" $ + run (fs ++ wrong2) `shouldNotSatisfy` ok + specify "Third wrong case expression rejected" $ + run (fs ++ wrong3) `shouldNotSatisfy` ok + specify "First correct case expression accepted" $ + run (fs ++ correct1) `shouldSatisfy` ok + specify "Second correct case expression accepted" $ + run (fs ++ correct2) `shouldSatisfy` ok where fs = [ "data forall a. List (a) where {" @@ -225,8 +232,8 @@ tc_pol_case = describe "Polymophic pattern matching" $ do ] run :: [String] -> Err T.Program -run = rmTEVar <=< typecheck <=< pProgram . myLexer . unlines +run = rmTEVar <=< typecheck <=< pProgram . myLexer . unlines ok = \case - Ok _ -> True - Bad _ -> False + Ok _ -> True + Bad _ -> False diff --git a/tests/TestTypeCheckerHm.hs b/tests/TestTypeCheckerHm.hs index ce72c63..f3d8dd6 100644 --- a/tests/TestTypeCheckerHm.hs +++ b/tests/TestTypeCheckerHm.hs @@ -7,16 +7,15 @@ import Control.Monad ((<=<)) import DoStrings qualified as D import Grammar.Par (myLexer, pProgram) import Test.Hspec -import Prelude (Bool (..), Either (..), IO, mapM_, not, ($), (.)) +import Prelude (Bool (..), Either (..), IO, foldl1, mapM_, not, ($), (.), (>>)) -- import Test.QuickCheck -import TypeChecker.TypeChecker (typecheck) +import TypeChecker.TypeCheckerHm (typecheck) -main :: IO () -main = do - mapM_ hspec goods - mapM_ hspec bads - mapM_ hspec bes +testTypeCheckerHm = describe "Hindley-Milner type checker test" $ do + foldl1 (>>) goods + foldl1 (>>) bads + foldl1 (>>) bes goods = [ testSatisfy From a38e96a83bd7acd18706090bc71a4040ff3a5758 Mon Sep 17 00:00:00 2001 From: Martin Fredin Date: Mon, 27 Mar 2023 20:51:00 +0200 Subject: [PATCH 189/372] Fix Ident print instance --- src/TypeChecker/TypeCheckerIr.hs | 30 +++++++++++++++--------------- tests/TestTypeCheckerHm.hs | 17 +++++++++-------- 2 files changed, 24 insertions(+), 23 deletions(-) diff --git a/src/TypeChecker/TypeCheckerIr.hs b/src/TypeChecker/TypeCheckerIr.hs index 46d1127..f8216c5 100644 --- a/src/TypeChecker/TypeCheckerIr.hs +++ b/src/TypeChecker/TypeCheckerIr.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE PatternSynonyms #-} module TypeChecker.TypeCheckerIr ( @@ -6,11 +6,11 @@ module TypeChecker.TypeCheckerIr ( module TypeChecker.TypeCheckerIr, ) where -import Data.String (IsString) -import Grammar.Abs (Lit (..), TVar (..)) -import Grammar.Print -import Prelude -import Prelude qualified as C (Eq, Ord, Read, Show) +import Data.String (IsString) +import Grammar.Abs (Lit (..), TVar (..)) +import Grammar.Print +import Prelude +import qualified Prelude as C (Eq, Ord, Read, Show) newtype Program' t = Program [Def' t] deriving (C.Eq, C.Ord, C.Show, C.Read) @@ -66,7 +66,7 @@ data Branch' t = Branch (Pattern' t, t) (ExpT' t) deriving (C.Eq, C.Ord, C.Show, C.Read) instance Print Ident where - prt i (Ident s) = prt i s + prt _ (Ident s) = doc $ showString s instance Print t => Print (Program' t) where prt i (Program sc) = prPrec i 0 $ prt 0 sc @@ -102,8 +102,8 @@ instance Print t => Print (ExpT' t) where ] instance Print t => Print [Bind' t] where - prt _ [] = concatD [] - prt _ [x] = concatD [prt 0 x] + prt _ [] = concatD [] + prt _ [x] = concatD [prt 0 x] prt _ (x : xs) = concatD [prt 0 x, doc (showString ";"), prt 0 xs] prtIdPs :: Print t => Int -> [Id' t] -> Doc @@ -168,13 +168,13 @@ instance Print t => Print (Branch' t) where prt i (Branch (pattern_, t) exp) = prPrec i 0 (concatD [doc (showString "("), prt 0 pattern_, doc (showString " : "), prt 0 t, doc (showString ")"), doc (showString "=>"), prt 0 exp]) instance Print t => Print [Branch' t] where - prt _ [] = concatD [] - prt _ [x] = concatD [prt 0 x] + prt _ [] = concatD [] + prt _ [x] = concatD [prt 0 x] prt _ (x : xs) = concatD [prt 0 x, doc (showString ";"), prt 0 xs] instance Print t => Print (Def' t) where prt i = \case - DBind bind -> prPrec i 0 (concatD [prt 0 bind]) + DBind bind -> prPrec i 0 (concatD [prt 0 bind]) DData data_ -> prPrec i 0 (concatD [prt 0 data_]) instance Print t => Print (Data' t) where @@ -194,12 +194,12 @@ instance Print t => Print (Pattern' t) where PInj uident patterns -> prPrec i 0 (concatD [prt 0 uident, prt 1 patterns]) instance Print t => Print [Def' t] where - prt _ [] = concatD [] - prt _ [x] = concatD [prt 0 x] + prt _ [] = concatD [] + prt _ [x] = concatD [prt 0 x] prt _ (x : xs) = concatD [prt 0 x, doc (showString ";"), prt 0 xs] instance Print [Type] where - prt _ [] = concatD [] + prt _ [] = concatD [] prt _ (x : xs) = concatD [prt 0 x, doc (showString " "), prt 0 xs] instance Print Type where diff --git a/tests/TestTypeCheckerHm.hs b/tests/TestTypeCheckerHm.hs index f3d8dd6..0a8e76f 100644 --- a/tests/TestTypeCheckerHm.hs +++ b/tests/TestTypeCheckerHm.hs @@ -1,16 +1,17 @@ -{-# LANGUAGE QualifiedDo #-} {-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE QualifiedDo #-} module TestTypeCheckerHm where -import Control.Monad ((<=<)) -import DoStrings qualified as D -import Grammar.Par (myLexer, pProgram) -import Test.Hspec -import Prelude (Bool (..), Either (..), IO, foldl1, mapM_, not, ($), (.), (>>)) +import Control.Monad ((<=<)) +import qualified DoStrings as D +import Grammar.Par (myLexer, pProgram) +import Prelude (Bool (..), Either (..), IO, foldl1, + mapM_, not, ($), (.), (>>)) +import Test.Hspec -- import Test.QuickCheck -import TypeChecker.TypeCheckerHm (typecheck) +import TypeChecker.TypeCheckerHm (typecheck) testTypeCheckerHm = describe "Hindley-Milner type checker test" $ do foldl1 (>>) goods @@ -178,7 +179,7 @@ testBe desc test shouldbe = specify desc $ run test `shouldBe` run shouldbe run = typecheck <=< pProgram . myLexer ok (Right _) = True -ok (Left _) = False +ok (Left _) = False bad = not . ok From e1633ea147d5d03945714f9a4d7cec9b0f2413db Mon Sep 17 00:00:00 2001 From: sebastian Date: Mon, 27 Mar 2023 21:16:48 +0200 Subject: [PATCH 190/372] small fixed and added qualifiedDo --- src/Auxiliary.hs | 25 +++-- src/TypeChecker/TypeCheckerHm.hs | 163 ++++++++++++++++++------------- 2 files changed, 108 insertions(+), 80 deletions(-) diff --git a/src/Auxiliary.hs b/src/Auxiliary.hs index d27ac24..fb0b8cb 100644 --- a/src/Auxiliary.hs +++ b/src/Auxiliary.hs @@ -1,9 +1,15 @@ {-# LANGUAGE LambdaCase #-} + module Auxiliary (module Auxiliary) where -import Control.Monad.Error.Class (liftEither) -import Control.Monad.Except (MonadError) -import Data.Either.Combinators (maybeToRight) -import TypeChecker.TypeCheckerIr (Type (TFun)) + +import Control.Monad.Error.Class (liftEither) +import Control.Monad.Except (MonadError) +import Data.Either.Combinators (maybeToRight) +import TypeChecker.TypeCheckerIr (Type (TFun)) +import Prelude hiding ((>>), (>>=)) + +(>>) a b = a ++ " " ++ b +(>>=) a f = f a snoc :: a -> [a] -> [a] snoc x xs = xs ++ [x] @@ -15,9 +21,8 @@ mapAccumM :: Monad m => (s -> a -> m (s, b)) -> s -> [a] -> m (s, [b]) mapAccumM f = go where go acc = \case - [] -> pure (acc, []) - x:xs -> do - (acc', x') <- f acc x - (acc'', xs') <- go acc' xs - pure (acc'', x':xs') - + [] -> pure (acc, []) + x : xs -> do + (acc', x') <- f acc x + (acc'', xs') <- go acc' xs + pure (acc'', x' : xs') diff --git a/src/TypeChecker/TypeCheckerHm.hs b/src/TypeChecker/TypeCheckerHm.hs index 1254a87..e7dff50 100644 --- a/src/TypeChecker/TypeCheckerHm.hs +++ b/src/TypeChecker/TypeCheckerHm.hs @@ -1,10 +1,12 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QualifiedDo #-} -- | A module for type checking and inference using algorithm W, Hindley-Milner module TypeChecker.TypeCheckerHm where -import Auxiliary +import Auxiliary (maybeToRightM) +import Auxiliary qualified as Aux import Control.Monad.Except import Control.Monad.Identity (Identity, runIdentity) import Control.Monad.Reader @@ -28,14 +30,16 @@ import TypeChecker.TypeCheckerIr qualified as T initCtx = Ctx mempty initEnv = Env 0 'a' mempty mempty mempty -runPretty :: Exp -> Either Error String -runPretty = fmap (printTree . fst) . run . inferExp - run :: Infer a -> Either Error a run = runC initEnv initCtx runC :: Env -> Ctx -> Infer a -> Either Error a -runC e c = runIdentity . runExceptT . flip runReaderT c . flip evalStateT e +runC e c = + runIdentity + . runExceptT + . flip runReaderT c + . flip evalStateT e + . runInfer typecheck :: Program -> Either Error (T.Program' Type) typecheck = run . checkPrg @@ -49,15 +53,15 @@ checkData d = do (throwError $ unwords ["Data type incorrectly declared"]) traverse_ ( \(Inj name' t') -> - if typ == retType t' - then insertConstr (coerce name') (t') + if typ == returnType t' + then insertConstr (coerce name') t' else throwError $ unwords [ "return type of constructor:" , printTree name' , "with type:" - , printTree (retType t') + , printTree (returnType t') , "does not match data: " , printTree typ ] @@ -69,9 +73,9 @@ checkData d = do <> printTree d <> "'" -retType :: Type -> Type -retType (TFun _ t2) = retType t2 -retType a = a +returnType :: Type -> Type +returnType (TFun _ t2) = returnType t2 +returnType a = a checkPrg :: Program -> Infer (T.Program' Type) checkPrg (Program bs) = do @@ -92,7 +96,7 @@ preRun (x : xs) = case x of <> printTree n <> "'" ) - insertSig (coerce n) (Just $ t) >> preRun xs + insertSig (coerce n) (Just t) >> preRun xs DBind (Bind n _ e) -> do collect (collectTypeVars e) s <- gets sigs @@ -107,10 +111,11 @@ checkDef (x : xs) = case x of (DBind b) -> do b' <- checkBind b fmap (T.DBind b' :) (checkDef xs) - (DData d) -> fmap ((T.DData (coerceData d)) :) (checkDef xs) + (DData d) -> fmap (T.DData (coerceData d) :) (checkDef xs) (DSig _) -> checkDef xs where - coerceData (Data t injs) = T.Data t $ map (\(Inj name typ) -> T.Inj (coerce name) typ) injs + coerceData (Data t injs) = + T.Data t $ map (\(Inj name typ) -> T.Inj (coerce name) typ) injs checkBind :: Bind -> Infer (T.Bind' Type) checkBind (Bind name args e) = do @@ -145,11 +150,11 @@ typeEq t1 (TAll _ t2) = t1 `typeEq` t2 typeEq (TVar _) (TVar _) = True typeEq _ _ = False -skolem :: Type -> Type -skolem (TVar (T.MkTVar a)) = TLit (coerce a) -skolem (TAll x t) = TAll x (skolem t) -skolem (TFun t1 t2) = (TFun `on` skolem) t1 t2 -skolem t = t +skolemize :: Type -> Type +skolemize (TVar (MkTVar a)) = TEVar (MkTEVar $ coerce a) +skolemize (TAll x t) = TAll x (skolemize t) +skolemize (TFun t1 t2) = (TFun `on` skolemize) t1 t2 +skolemize t = t isMoreSpecificOrEq :: Type -> Type -> Bool isMoreSpecificOrEq t1 (TAll _ t2) = isMoreSpecificOrEq t1 t2 @@ -204,10 +209,9 @@ algoW = \case , printTree t' ] ) - applySt s1 $ do - s2 <- exprErr (unify (t) t') err - let comp = s2 `compose` s1 - return (comp, apply comp (e', t)) + s2 <- exprErr (unify (t) t') err + let comp = s2 `compose` s1 + return (comp, apply comp (e', t)) -- \| ------------------ -- \| Γ ⊢ i : Int, ∅ @@ -262,16 +266,14 @@ algoW = \case err@(EAdd e0 e1) -> do (s1, (e0', t0)) <- algoW e0 - applySt s1 $ do - (s2, (e1', t1)) <- algoW e1 - -- applySt s2 $ do - s3 <- exprErr (unify (apply s2 t0) int) err - s4 <- exprErr (unify (apply s3 t1) int) err - let comp = s4 `compose` s3 `compose` s2 `compose` s1 - return - ( comp - , apply comp (T.EAdd (e0', t0) (e1', t1), int) - ) + (s2, (e1', t1)) <- algoW e1 + s3 <- exprErr (unify (apply s2 t0) int) err + s4 <- exprErr (unify (apply s3 t1) int) err + let comp = s4 `compose` s3 `compose` s2 `compose` s1 + return + ( comp + , apply comp (T.EAdd (e0', t0) (e1', t1), int) + ) -- \| Γ ⊢ e₀ : τ₀, S₀ S₀Γ ⊢ e₁ : τ₁, S1 -- \| τ' = newvar S₂ = mgu(S₁τ₀, τ₁ → τ') @@ -281,12 +283,11 @@ algoW = \case err@(EApp e0 e1) -> do fr <- fresh (s0, (e0', t0)) <- algoW e0 - applySt s0 $ do - (s1, (e1', t1)) <- algoW e1 - s2 <- exprErr (unify (apply s1 t0) (TFun t1 fr)) err - let t = apply s2 fr - let comp = s2 `compose` s1 `compose` s0 - return (comp, apply comp (T.EApp (e0', t0) (e1', t1), t)) + (s1, (e1', t1)) <- algoW e1 + s2 <- exprErr (unify (apply s1 t0) (TFun t1 fr)) err + let t = apply s2 fr + let comp = s2 `compose` s1 `compose` s0 + return (comp, apply comp (T.EApp (e0', t0) (e1', t1), t)) -- \| Γ ⊢ e₀ : τ, S₀ S₀Γ, x : S̅₀Γ̅(τ) ⊢ e₁ : τ', S₁ -- \| ---------------------------------------------- @@ -346,22 +347,45 @@ unify t0 t1 = do then do xs <- zipWithM unify t t' return $ foldr compose nullSubst xs + else throwError $ + Aux.do + "Type constructor:" + printTree name + "(" + printTree t + ")" + "does not match with:" + printTree name' + "(" + printTree t' + ")" + + -- [ "Type constructor:" + -- , printTree name + -- , "(" <> printTree t <> ")" + -- , "does not match with:" + -- , printTree name' + -- , "(" <> printTree t' <> ")" + -- ] + (TEVar a, TEVar b) -> + if a == b + then return M.empty else - throwError $ - unwords - [ "Type constructor:" - , printTree name - , "(" <> printTree t <> ")" - , "does not match with:" - , printTree name' - , "(" <> printTree t' <> ")" - ] + throwError + . unwords + $ [ "Can not unify" + , "'" <> printTree (TEVar a) <> "'" + , "with" + , "'" <> printTree (TEVar b) <> "'" + ] (a, b) -> do - throwError . unwords $ - [ "'" <> printTree a <> "'" - , "can't be unified with" - , "'" <> printTree b <> "'" - ] + throwError + . unwords + $ [ "Can not unify" + , "'" <> printTree a <> "'" + , "with" + , "'" <> printTree b <> "'" + ] {- | Check if a type is contained in another type. I.E. { a = a -> b } is an unsolvable constraint since there is no substitution @@ -415,7 +439,7 @@ composeAll = foldl' compose nullSubst -- TODO: Split this class into two separate classes, one for free variables -- and one for applying substitutions --- | A class representing free variables functions +-- | A class for substitutions class SubstType t where -- | Apply a substitution to t apply :: Subst -> t -> t @@ -430,9 +454,10 @@ instance FreeVars Type where free (TAll (T.MkTVar bound) t) = S.singleton (coerce bound) `S.intersection` free t free (TLit _) = mempty free (TFun a b) = free a `S.union` free b - -- \| Not guaranteed to be correct - free (TData _ a) = - foldl' (\acc x -> free x `S.union` acc) S.empty a + free (TData _ a) = free a + +instance FreeVars a => FreeVars [a] where + free = let f acc x = acc `S.union` free x in foldl' f S.empty instance SubstType Type where apply :: Subst -> Type -> Type @@ -447,13 +472,14 @@ instance SubstType Type where Just _ -> apply sub t TFun a b -> TFun (apply sub a) (apply sub b) TData name a -> TData name (map (apply sub) a) + instance FreeVars (Map T.Ident Type) where free :: Map T.Ident Type -> Set T.Ident - free m = foldl' S.union S.empty (map free $ M.elems m) + free = free . M.elems instance SubstType (Map T.Ident Type) where apply :: Subst -> Map T.Ident Type -> Map T.Ident Type - apply s = M.map (apply s) + apply = M.map . apply instance SubstType (T.Exp' Type) where apply s = \case @@ -467,7 +493,7 @@ instance SubstType (T.Exp' Type) where T.EAdd e1 e2 -> T.EAdd (apply s e1) (apply s e2) T.EAbs ident e -> T.EAbs ident (apply s e) T.ECase e brnch -> T.ECase (apply s e) (apply s brnch) - T.EInj{} -> error "implement" + T.EInj i -> T.EInj i instance SubstType (T.Branch' Type) where apply s (T.Branch (i, t) e) = T.Branch (apply s i, apply s t) (apply s e) @@ -489,10 +515,6 @@ instance (SubstType a, SubstType b) => SubstType (a, b) where instance SubstType (T.Id' Type) where apply s (name, t) = (name, apply s t) --- | Apply substitutions to the environment. -applySt :: Subst -> Infer a -> Infer a -applySt s = local (\st -> st{vars = apply s (vars st)}) - -- | Represents the empty substition set nullSubst :: Subst nullSubst = M.empty @@ -513,11 +535,11 @@ fresh = do else if n == 0 then return . TVar . T.MkTVar $ LIdent [c] - else return . TVar . T.MkTVar . LIdent $ [c] ++ show n - -next :: Char -> Char -next 'z' = 'a' -next a = succ a + else return . TVar . T.MkTVar . LIdent $ c : show n + where + next :: Char -> Char + next 'z' = 'a' + next a = succ a -- | Run the monadic action with an additional binding withBinding :: (Monad m, MonadReader Ctx m) => T.Ident -> Type -> m a -> m a @@ -673,4 +695,5 @@ data Env = Env type Error = String type Subst = Map T.Ident Type -type Infer = StateT Env (ReaderT Ctx (ExceptT Error Identity)) +newtype Infer a = Infer {runInfer :: StateT Env (ReaderT Ctx (ExceptT Error Identity)) a} + deriving (Functor, Applicative, Monad, MonadReader Ctx, MonadError Error, MonadState Env) From 4b24755b9324fd6bed5b22ce300c66bc72ab15e1 Mon Sep 17 00:00:00 2001 From: sebastian Date: Mon, 27 Mar 2023 22:38:39 +0200 Subject: [PATCH 191/372] cleaned up implementations and added check for duplicate constructors --- src/TypeChecker/TypeCheckerHm.hs | 233 ++++++++++++++++--------------- 1 file changed, 123 insertions(+), 110 deletions(-) diff --git a/src/TypeChecker/TypeCheckerHm.hs b/src/TypeChecker/TypeCheckerHm.hs index e7dff50..026810f 100644 --- a/src/TypeChecker/TypeCheckerHm.hs +++ b/src/TypeChecker/TypeCheckerHm.hs @@ -13,7 +13,6 @@ import Control.Monad.Reader import Control.Monad.State import Data.Bifunctor (second) import Data.Coerce (coerce) -import Data.Foldable (traverse_) import Data.Function (on) import Data.List (foldl') import Data.List.Extra (unsnoc) @@ -22,7 +21,6 @@ import Data.Map qualified as M import Data.Maybe (fromJust) import Data.Set (Set) import Data.Set qualified as S -import Data.String import Grammar.Abs import Grammar.Print (printTree) import TypeChecker.TypeCheckerIr qualified as T @@ -45,33 +43,61 @@ typecheck :: Program -> Either Error (T.Program' Type) typecheck = run . checkPrg checkData :: Data -> Infer () -checkData d = do - case d of - (Data typ@(TData _ ts) constrs) -> do - unless - (all isPoly ts) - (throwError $ unwords ["Data type incorrectly declared"]) - traverse_ - ( \(Inj name' t') -> - if typ == returnType t' - then insertConstr (coerce name') t' - else - throwError $ - unwords - [ "return type of constructor:" - , printTree name' - , "with type:" - , printTree (returnType t') - , "does not match data: " - , printTree typ - ] - ) - constrs - _ -> - throwError $ - "incorrectly declared data type '" - <> printTree d - <> "'" +checkData (Data typ injs) = do + (name, tvars) <- go typ + mapM_ (\i -> typecheckInj i name tvars) injs + where + go = \case + TData name typs + | Right tvars' <- mapM toTVar typs -> + pure (name, tvars') + TAll _ _ -> throwError "Explicit foralls not allowed, for now" + _ -> throwError $ unwords ["Bad data type definition: ", printTree typ] + +typecheckInj :: Inj -> UIdent -> [TVar] -> Infer () +typecheckInj (Inj c inj_typ) name tvars + | Right False <- boundTVars tvars inj_typ = + throwError "Unbound type variables" + | TData name' typs <- returnType inj_typ + , Right tvars' <- mapM toTVar typs + , name' == name + , tvars' == tvars = do + exist <- existInj (coerce c) + case exist of + Just t -> throwError $ Aux.do + "Constructor" + quote $ coerce name + "with type" + quote $ printTree t + "already exist" + Nothing -> insertInj (coerce c) inj_typ + | otherwise = + throwError $ + unwords + [ "Bad type constructor: " + , show name + , "\nExpected: " + , printTree . TData name $ map TVar tvars + , "\nActual: " + , printTree $ returnType inj_typ + ] + where + boundTVars :: [TVar] -> Type -> Either Error Bool + boundTVars tvars' = \case + TAll{} -> throwError "Explicit foralls not allowed, for now" + TFun t1 t2 -> do + t1' <- boundTVars tvars t1 + t2' <- boundTVars tvars t2 + return $ t1' && t2' + TVar tvar -> return $ tvar `elem` tvars' + TData _ typs -> and <$> mapM (boundTVars tvars) typs + TLit _ -> return True + TEVar _ -> error "TEVar in data type declaration" + +toTVar :: Type -> Either String TVar +toTVar = \case + TVar tvar -> pure tvar + _ -> throwError "Not a type variable" returnType :: Type -> Type returnType (TFun _ t2) = returnType t2 @@ -91,10 +117,9 @@ preRun (x : xs) = case x of gets (M.member (coerce n) . sigs) >>= flip when - ( throwError $ - "Duplicate signatures for function '" - <> printTree n - <> "'" + ( throwError $ Aux.do + "Duplicate signatures for function" + quote $ printTree n ) insertSig (coerce n) (Just t) >> preRun xs DBind (Bind n _ e) -> do @@ -126,12 +151,11 @@ checkBind (Bind name args e) = do Just (Just t') -> do unless (args_t `typeEq` t') - ( throwError $ - "Inferred type '" - ++ printTree args_t - ++ " does not match specified type '" - ++ printTree t' - ++ "'" + ( throwError $ Aux.do + "Inferred type" + quote $ printTree args_t + "does not match specified type" + quote $ printTree t' ) return $ T.Bind (coerce name, t') [] e _ -> do @@ -195,7 +219,7 @@ instance CollectTVars Type where collect :: Set T.Ident -> Infer () collect s = modify (\st -> st{takenTypeVars = s `S.union` takenTypeVars st}) -algoW :: Exp -> Infer (Subst, (T.ExpT' Type)) +algoW :: Exp -> Infer (Subst, T.ExpT' Type) algoW = \case err@(EAnn e t) -> do (s1, (e', t')) <- exprErr (algoW e) err @@ -209,14 +233,14 @@ algoW = \case , printTree t' ] ) - s2 <- exprErr (unify (t) t') err + s2 <- exprErr (unify t t') err let comp = s2 `compose` s1 return (comp, apply comp (e', t)) -- \| ------------------ -- \| Γ ⊢ i : Int, ∅ - ELit lit -> return (nullSubst, (T.ELit $ lit, litType lit)) + ELit lit -> return (nullSubst, (T.ELit lit, litType lit)) -- \| x : σ ∈ Γ   τ = inst(σ) -- \| ---------------------- -- \| Γ ⊢ x : τ, ∅ @@ -234,7 +258,7 @@ algoW = \case return (nullSubst, (T.EVar $ coerce i, fr)) Nothing -> throwError $ "Unbound variable: " <> printTree i EInj i -> do - constr <- gets constructors + constr <- gets injections case M.lookup (coerce i) constr of Just t -> return (nullSubst, (T.EVar $ coerce i, t)) Nothing -> @@ -334,14 +358,12 @@ unify t0 t1 = do (TLit a, TLit b) -> if a == b then return M.empty - else - throwError - . unwords - $ [ "Can not unify" - , "'" <> printTree (TLit a) <> "'" - , "with" - , "'" <> printTree (TLit b) <> "'" - ] + else throwError $ + Aux.do + "Can not unify" + quote $ printTree (TLit a) + "with" + quote $ printTree (TLit b) (TData name t, TData name' t') -> if name == name' && length t == length t' then do @@ -351,41 +373,26 @@ unify t0 t1 = do Aux.do "Type constructor:" printTree name - "(" - printTree t - ")" + quote $ printTree t "does not match with:" printTree name' - "(" - printTree t' - ")" - - -- [ "Type constructor:" - -- , printTree name - -- , "(" <> printTree t <> ")" - -- , "does not match with:" - -- , printTree name' - -- , "(" <> printTree t' <> ")" - -- ] + quote $ printTree t' (TEVar a, TEVar b) -> if a == b then return M.empty - else - throwError - . unwords - $ [ "Can not unify" - , "'" <> printTree (TEVar a) <> "'" - , "with" - , "'" <> printTree (TEVar b) <> "'" - ] + else throwError $ + Aux.do + "Can not unify" + quote $ printTree (TEVar a) + "with" + quote $ printTree (TEVar b) (a, b) -> do - throwError - . unwords - $ [ "Can not unify" - , "'" <> printTree a <> "'" - , "with" - , "'" <> printTree b <> "'" - ] + throwError $ + Aux.do + "Can not unify" + quote $ printTree a + "with" + quote $ printTree b {- | Check if a type is contained in another type. I.E. { a = a -> b } is an unsolvable constraint since there is no substitution @@ -395,14 +402,12 @@ occurs :: T.Ident -> Type -> Infer Subst occurs i t@(TVar _) = return (M.singleton i t) occurs i t = if S.member i (free t) - then - throwError $ - unwords - [ "Occurs check failed, can't unify" - , printTree (TVar $ T.MkTVar (coerce i)) - , "with" - , printTree t - ] + then throwError $ + Aux.do + "Occurs check failed, can't unify" + quote $ printTree (TVar $ T.MkTVar (coerce i)) + "with" + quote $ printTree t else return $ M.singleton i t -- | Generalize a type over all free variables in the substitution set @@ -455,6 +460,7 @@ instance FreeVars Type where free (TLit _) = mempty free (TFun a b) = free a `S.union` free b free (TData _ a) = free a + free (TEVar _) = S.empty instance FreeVars a => FreeVars [a] where free = let f acc x = acc `S.union` free x in foldl' f S.empty @@ -471,7 +477,10 @@ instance SubstType Type where Nothing -> TAll (T.MkTVar i) (apply sub t) Just _ -> apply sub t TFun a b -> TFun (apply sub a) (apply sub b) - TData name a -> TData name (map (apply sub) a) + TData name a -> TData name (apply sub a) + TEVar (MkTEVar a) -> case M.lookup (coerce a) sub of + Nothing -> TEVar (MkTEVar a) + Just t -> t instance FreeVars (Map T.Ident Type) where free :: Map T.Ident Type -> Set T.Ident @@ -555,9 +564,12 @@ insertSig :: T.Ident -> Maybe Type -> Infer () insertSig i t = modify (\st -> st{sigs = M.insert i t (sigs st)}) -- | Insert a constructor with its data type -insertConstr :: T.Ident -> Type -> Infer () -insertConstr i t = - modify (\st -> st{constructors = M.insert i t (constructors st)}) +insertInj :: T.Ident -> Type -> Infer () +insertInj i t = + modify (\st -> st{injections = M.insert i t (injections st)}) + +existInj :: T.Ident -> Infer (Maybe Type) +existInj n = gets (M.lookup n . injections) -------- PATTERN MATCHING --------- @@ -601,37 +613,35 @@ inferPattern :: Pattern -> Infer (T.Pattern' Type, Type) inferPattern = \case PLit lit -> let lt = litType lit in return (T.PLit (lit, lt), lt) PInj constr patterns -> do - t <- gets (M.lookup (coerce constr) . constructors) + t <- gets (M.lookup (coerce constr) . injections) t <- maybeToRightM ("Constructor: " <> printTree constr <> " does not exist") t let numArgs = typeLength t - 1 let (vs, ret) = fromJust (unsnoc $ flattenType t) patterns <- mapM inferPattern patterns unless (length patterns == numArgs) - ( throwError $ - "The constructor '" - ++ printTree constr - ++ "'" - ++ " should have " - ++ show numArgs - ++ " arguments but has been given " - ++ show (length patterns) + ( throwError $ Aux.do + "The constructor" + quote $ printTree constr + " should have " + show numArgs + " arguments but has been given " + show (length patterns) ) sub <- composeAll <$> zipWithM unify vs (map snd patterns) return (T.PInj (coerce constr) (apply sub (map fst patterns)), apply sub ret) PCatch -> (T.PCatch,) <$> fresh PEnum p -> do - t <- gets (M.lookup (coerce p) . constructors) + t <- gets (M.lookup (coerce p) . injections) t <- maybeToRightM ("Constructor: " <> printTree p <> " does not exist") t unless (typeLength t == 1) - ( throwError $ - "The constructor '" - ++ printTree p - ++ "'" - ++ " should have " - ++ show (typeLength t - 1) - ++ " arguments but has been given 0" + ( throwError $ Aux.do + "The constructor" + quote $ printTree p + " should have " + show (typeLength t - 1) + " arguments but has been given 0" ) let (TData _data _ts) = t -- nasty nasty frs <- mapM (const fresh) _ts @@ -687,7 +697,7 @@ data Env = Env { count :: Int , nextChar :: Char , sigs :: Map T.Ident (Maybe Type) - , constructors :: Map T.Ident Type + , injections :: Map T.Ident Type , takenTypeVars :: Set T.Ident } deriving (Show) @@ -697,3 +707,6 @@ type Subst = Map T.Ident Type newtype Infer a = Infer {runInfer :: StateT Env (ReaderT Ctx (ExceptT Error Identity)) a} deriving (Functor, Applicative, Monad, MonadReader Ctx, MonadError Error, MonadState Env) + +quote :: String -> String +quote s = "'" ++ s ++ "'" From 0d2fe862e064e2cf428089aadab7ad0f2fd4995a Mon Sep 17 00:00:00 2001 From: sebastian Date: Mon, 27 Mar 2023 23:05:40 +0200 Subject: [PATCH 192/372] fixed bug and additional test --- src/TypeChecker/TypeCheckerHm.hs | 43 ++++++++++++++++++-------------- tests/TestTypeCheckerHm.hs | 38 ++++++++++++++++++++-------- 2 files changed, 52 insertions(+), 29 deletions(-) diff --git a/src/TypeChecker/TypeCheckerHm.hs b/src/TypeChecker/TypeCheckerHm.hs index 026810f..92af317 100644 --- a/src/TypeChecker/TypeCheckerHm.hs +++ b/src/TypeChecker/TypeCheckerHm.hs @@ -113,7 +113,7 @@ preRun :: [Def] -> Infer () preRun [] = return () preRun (x : xs) = case x of DSig (Sig n t) -> do - collect (collectTypeVars t) + collect (collectTVars t) gets (M.member (coerce n) . sigs) >>= flip when @@ -123,20 +123,23 @@ preRun (x : xs) = case x of ) insertSig (coerce n) (Just t) >> preRun xs DBind (Bind n _ e) -> do - collect (collectTypeVars e) + collect (collectTVars e) s <- gets sigs case M.lookup (coerce n) s of Nothing -> insertSig (coerce n) Nothing >> preRun xs Just _ -> preRun xs - DData d@(Data t _) -> collect (collectTypeVars t) >> checkData d >> preRun xs + DData d@(Data t _) -> collect (collectTVars t) >> checkData d >> preRun xs checkDef :: [Def] -> Infer [T.Def' Type] checkDef [] = return [] checkDef (x : xs) = case x of (DBind b) -> do b' <- checkBind b - fmap (T.DBind b' :) (checkDef xs) - (DData d) -> fmap (T.DData (coerceData d) :) (checkDef xs) + xs' <- checkDef xs + return $ T.DBind b' : xs' + (DData d) -> do + xs' <- checkDef xs + return $ T.DData (coerceData d) : xs' (DSig _) -> checkDef xs where coerceData (Data t injs) = @@ -145,22 +148,24 @@ checkDef (x : xs) = case x of checkBind :: Bind -> Infer (T.Bind' Type) checkBind (Bind name args e) = do let lambda = makeLambda e (reverse (coerce args)) - e@(_, args_t) <- inferExp lambda + (e, lambda_t) <- inferExp lambda s <- gets sigs case M.lookup (coerce name) s of Just (Just t') -> do + sub1 <- unify lambda_t t' + sub2 <- unify t' lambda_t unless - (args_t `typeEq` t') + (apply sub1 lambda_t == t' && lambda_t == apply sub2 t') ( throwError $ Aux.do "Inferred type" - quote $ printTree args_t + quote $ printTree lambda_t "does not match specified type" quote $ printTree t' ) - return $ T.Bind (coerce name, t') [] e + return $ T.Bind (coerce name, t') [] (e, lambda_t) _ -> do - insertSig (coerce name) (Just args_t) - return (T.Bind (coerce name, args_t) [] e) + insertSig (coerce name) (Just lambda_t) + return (T.Bind (coerce name, lambda_t) [] (e, lambda_t)) typeEq :: Type -> Type -> Bool typeEq (TFun l r) (TFun l' r') = typeEq l l' && typeEq r r' @@ -203,18 +208,18 @@ inferExp e = do return $ second (const subbed) (e', t) class CollectTVars a where - collectTypeVars :: a -> Set T.Ident + collectTVars :: a -> Set T.Ident instance CollectTVars Exp where - collectTypeVars (EAnn e t) = collectTypeVars t `S.union` collectTypeVars e - collectTypeVars _ = S.empty + collectTVars (EAnn e t) = collectTVars t `S.union` collectTVars e + collectTVars _ = S.empty instance CollectTVars Type where - collectTypeVars (TVar (MkTVar i)) = S.singleton (coerce i) - collectTypeVars (TAll _ t) = collectTypeVars t - collectTypeVars (TFun t1 t2) = (S.union `on` collectTypeVars) t1 t2 - collectTypeVars (TData _ ts) = foldl' (\acc x -> acc `S.union` collectTypeVars x) S.empty ts - collectTypeVars _ = S.empty + collectTVars (TVar (MkTVar i)) = S.singleton (coerce i) + collectTVars (TAll _ t) = collectTVars t + collectTVars (TFun t1 t2) = (S.union `on` collectTVars) t1 t2 + collectTVars (TData _ ts) = foldl' (\acc x -> acc `S.union` collectTVars x) S.empty ts + collectTVars _ = S.empty collect :: Set T.Ident -> Infer () collect s = modify (\st -> st{takenTypeVars = s `S.union` takenTypeVars st}) diff --git a/tests/TestTypeCheckerHm.hs b/tests/TestTypeCheckerHm.hs index 0a8e76f..e326bd5 100644 --- a/tests/TestTypeCheckerHm.hs +++ b/tests/TestTypeCheckerHm.hs @@ -1,17 +1,28 @@ +{-# LANGUAGE QualifiedDo #-} {-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE QualifiedDo #-} module TestTypeCheckerHm where -import Control.Monad ((<=<)) -import qualified DoStrings as D -import Grammar.Par (myLexer, pProgram) -import Prelude (Bool (..), Either (..), IO, foldl1, - mapM_, not, ($), (.), (>>)) -import Test.Hspec +import Control.Monad ((<=<)) +import DoStrings qualified as D +import Grammar.Par (myLexer, pProgram) +import Grammar.Print (printTree) +import Test.Hspec +import Prelude ( + Bool (..), + Either (..), + IO, + fmap, + foldl1, + mapM_, + not, + ($), + (.), + (>>), + ) -- import Test.QuickCheck -import TypeChecker.TypeCheckerHm (typecheck) +import TypeChecker.TypeCheckerHm (typecheck) testTypeCheckerHm = describe "Hindley-Milner type checker test" $ do foldl1 (>>) goods @@ -124,6 +135,13 @@ bads = "id x = x;" ) bad + , testSatisfy + "incorrect signature on const" + ( D.do + "const : a -> b -> b;" + "const x y = x" + ) + bad , testSatisfy "incorrect type signature on id lambda" ( D.do @@ -176,10 +194,10 @@ bes = testSatisfy desc test satisfaction = specify desc $ run test `shouldSatisfy` satisfaction testBe desc test shouldbe = specify desc $ run test `shouldBe` run shouldbe -run = typecheck <=< pProgram . myLexer +run = fmap printTree . typecheck <=< pProgram . myLexer ok (Right _) = True -ok (Left _) = False +ok (Left _) = False bad = not . ok From 4d3d90c6a382c4d5ce6794adcfea40f4f024fee6 Mon Sep 17 00:00:00 2001 From: Samuel Hammersberg Date: Tue, 28 Mar 2023 09:48:27 +0200 Subject: [PATCH 193/372] Added some debug options to the just file. --- Justfile | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/Justfile b/Justfile index 74e2e5d..01c262e 100644 --- a/Justfile +++ b/Justfile @@ -21,3 +21,9 @@ hm FILE: bi FILE: cabal run language -- -t bi {{FILE}} + +hmd FILE: + cabal run language -- -d -t hm {{FILE}} + +bid FILE: + cabal run language -- -d -t bi {{FILE}} \ No newline at end of file From 437c193ea8070139e9e23cb869f27cc7d4c8a124 Mon Sep 17 00:00:00 2001 From: sebastianselander Date: Tue, 28 Mar 2023 10:07:30 +0200 Subject: [PATCH 194/372] fixed EAnn --- src/TypeChecker/TypeCheckerHm.hs | 4 +++- tests/TestTypeCheckerHm.hs | 2 -- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/src/TypeChecker/TypeCheckerHm.hs b/src/TypeChecker/TypeCheckerHm.hs index 92af317..1d40a5c 100644 --- a/src/TypeChecker/TypeCheckerHm.hs +++ b/src/TypeChecker/TypeCheckerHm.hs @@ -228,8 +228,10 @@ algoW :: Exp -> Infer (Subst, T.ExpT' Type) algoW = \case err@(EAnn e t) -> do (s1, (e', t')) <- exprErr (algoW e) err + sub1 <- unify t t' + sub2 <- unify t' t unless - (t `isMoreSpecificOrEq` t') + (apply sub1 t == t' && apply sub2 t' == t) ( throwError $ unwords [ "Annotated type:" diff --git a/tests/TestTypeCheckerHm.hs b/tests/TestTypeCheckerHm.hs index e326bd5..5f600ed 100644 --- a/tests/TestTypeCheckerHm.hs +++ b/tests/TestTypeCheckerHm.hs @@ -11,10 +11,8 @@ import Test.Hspec import Prelude ( Bool (..), Either (..), - IO, fmap, foldl1, - mapM_, not, ($), (.), From 54f7d54bf91125fa52dabed56a9d38b53bc501d6 Mon Sep 17 00:00:00 2001 From: sebastianselander Date: Tue, 28 Mar 2023 10:10:26 +0200 Subject: [PATCH 195/372] fixed EAdd conversion bug in RemoveTEVars --- src/TypeChecker/RemoveTEVar.hs | 54 ++++++++++++++++------------------ 1 file changed, 26 insertions(+), 28 deletions(-) diff --git a/src/TypeChecker/RemoveTEVar.hs b/src/TypeChecker/RemoveTEVar.hs index b83a134..43a87f7 100644 --- a/src/TypeChecker/RemoveTEVar.hs +++ b/src/TypeChecker/RemoveTEVar.hs @@ -2,15 +2,13 @@ module TypeChecker.RemoveTEVar where -import Control.Applicative (Applicative (liftA2), liftA3) -import Control.Arrow (Arrow (second)) -import Control.Monad.Error (MonadError (throwError)) -import Data.Coerce (coerce) -import Data.Function (on) -import Data.Tuple.Extra (secondM) -import Grammar.Abs -import Grammar.ErrM (Err) -import qualified TypeChecker.TypeCheckerIr as T +import Control.Applicative (Applicative (liftA2), liftA3) +import Control.Monad.Except (MonadError (throwError)) +import Data.Coerce (coerce) +import Data.Tuple.Extra (secondM) +import Grammar.Abs +import Grammar.ErrM (Err) +import TypeChecker.TypeCheckerIr qualified as T class RemoveTEVar a b where rmTEVar :: a -> Err b @@ -20,22 +18,22 @@ instance RemoveTEVar (T.Program' Type) (T.Program' T.Type) where instance RemoveTEVar (T.Def' Type) (T.Def' T.Type) where rmTEVar = \case - T.DBind bind -> T.DBind <$> rmTEVar bind - T.DData dat -> T.DData <$> rmTEVar dat + T.DBind bind -> T.DBind <$> rmTEVar bind + T.DData dat -> T.DData <$> rmTEVar dat instance RemoveTEVar (T.Bind' Type) (T.Bind' T.Type) where rmTEVar (T.Bind id vars rhs) = liftA3 T.Bind (rmTEVar id) (rmTEVar vars) (rmTEVar rhs) instance RemoveTEVar (T.Exp' Type) (T.Exp' T.Type) where rmTEVar exp = case exp of - T.EVar name -> pure $ T.EVar name - T.EInj name -> pure $ T.EInj name - T.ELit lit -> pure $ T.ELit lit - T.ELet bind e -> liftA2 T.ELet (rmTEVar bind) (rmTEVar e) - T.EApp e1 e2 -> liftA2 T.EApp (rmTEVar e1) (rmTEVar e2) - T.EAdd e1 e2 -> liftA2 T.EApp (rmTEVar e1) (rmTEVar e2) - T.EAbs name e -> T.EAbs name <$> rmTEVar e - T.ECase e branches -> liftA2 T.ECase (rmTEVar e) (rmTEVar branches) + T.EVar name -> pure $ T.EVar name + T.EInj name -> pure $ T.EInj name + T.ELit lit -> pure $ T.ELit lit + T.ELet bind e -> liftA2 T.ELet (rmTEVar bind) (rmTEVar e) + T.EApp e1 e2 -> liftA2 T.EApp (rmTEVar e1) (rmTEVar e2) + T.EAdd e1 e2 -> liftA2 T.EAdd (rmTEVar e1) (rmTEVar e2) + T.EAbs name e -> T.EAbs name <$> rmTEVar e + T.ECase e branches -> liftA2 T.ECase (rmTEVar e) (rmTEVar branches) instance RemoveTEVar (T.Branch' Type) (T.Branch' T.Type) where rmTEVar (T.Branch (patt, t_patt) e) = liftA2 T.Branch (liftA2 (,) (rmTEVar patt) (rmTEVar t_patt)) (rmTEVar e) @@ -43,10 +41,10 @@ instance RemoveTEVar (T.Branch' Type) (T.Branch' T.Type) where instance RemoveTEVar (T.Pattern' Type) (T.Pattern' T.Type) where rmTEVar = \case T.PVar (name, t) -> T.PVar . (name,) <$> rmTEVar t - T.PLit (lit, t) -> T.PLit . (lit,) <$> rmTEVar t - T.PCatch -> pure T.PCatch - T.PEnum name -> pure $ T.PEnum name - T.PInj name ps -> T.PInj name <$> rmTEVar ps + T.PLit (lit, t) -> T.PLit . (lit,) <$> rmTEVar t + T.PCatch -> pure T.PCatch + T.PEnum name -> pure $ T.PEnum name + T.PInj name ps -> T.PInj name <$> rmTEVar ps instance RemoveTEVar (T.Data' Type) (T.Data' T.Type) where rmTEVar (T.Data typ injs) = liftA2 T.Data (rmTEVar typ) (rmTEVar injs) @@ -65,9 +63,9 @@ instance RemoveTEVar a b => RemoveTEVar [a] [b] where instance RemoveTEVar Type T.Type where rmTEVar = \case - TLit lit -> pure $ T.TLit (coerce lit) - TVar tvar -> pure $ T.TVar tvar + TLit lit -> pure $ T.TLit (coerce lit) + TVar tvar -> pure $ T.TVar tvar TData name typs -> T.TData (coerce name) <$> rmTEVar typs - TFun t1 t2 -> liftA2 T.TFun (rmTEVar t1) (rmTEVar t2) - TAll tvar t -> T.TAll tvar <$> rmTEVar t - TEVar _ -> throwError "NewType TEVar!" + TFun t1 t2 -> liftA2 T.TFun (rmTEVar t1) (rmTEVar t2) + TAll tvar t -> T.TAll tvar <$> rmTEVar t + TEVar _ -> throwError "NewType TEVar!" From 1558c98d10854b537244ee6e1bdd3b2dc2bb9ff7 Mon Sep 17 00:00:00 2001 From: sebastianselander Date: Tue, 28 Mar 2023 10:46:04 +0200 Subject: [PATCH 196/372] improved the idea of error messages, still not very clean --- src/TypeChecker/TypeCheckerHm.hs | 121 ++++++++++++++++++++----------- 1 file changed, 77 insertions(+), 44 deletions(-) diff --git a/src/TypeChecker/TypeCheckerHm.hs b/src/TypeChecker/TypeCheckerHm.hs index 1d40a5c..1fc0ee4 100644 --- a/src/TypeChecker/TypeCheckerHm.hs +++ b/src/TypeChecker/TypeCheckerHm.hs @@ -1,4 +1,5 @@ {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QualifiedDo #-} @@ -39,32 +40,36 @@ runC e c = . flip evalStateT e . runInfer -typecheck :: Program -> Either Error (T.Program' Type) -typecheck = run . checkPrg +typecheck :: Program -> Either String (T.Program' Type) +typecheck = onLeft msg . run . checkPrg + where + onLeft :: (Error -> String) -> Either Error a -> Either String a + onLeft f (Left x) = Left $ f x + onLeft _ (Right x) = Right x checkData :: Data -> Infer () -checkData (Data typ injs) = do +checkData err@(Data typ injs) = do (name, tvars) <- go typ - mapM_ (\i -> typecheckInj i name tvars) injs + dataErr (mapM_ (\i -> typecheckInj i name tvars) injs) err where go = \case TData name typs | Right tvars' <- mapM toTVar typs -> pure (name, tvars') - TAll _ _ -> throwError "Explicit foralls not allowed, for now" - _ -> throwError $ unwords ["Bad data type definition: ", printTree typ] + TAll _ _ -> uncatchableErr "Explicit foralls not allowed, for now" + _ -> uncatchableErr $ unwords ["Bad data type definition: ", printTree typ] typecheckInj :: Inj -> UIdent -> [TVar] -> Infer () typecheckInj (Inj c inj_typ) name tvars | Right False <- boundTVars tvars inj_typ = - throwError "Unbound type variables" + catchableErr "Unbound type variables" | TData name' typs <- returnType inj_typ , Right tvars' <- mapM toTVar typs , name' == name , tvars' == tvars = do exist <- existInj (coerce c) case exist of - Just t -> throwError $ Aux.do + Just t -> uncatchableErr $ Aux.do "Constructor" quote $ coerce name "with type" @@ -72,7 +77,7 @@ typecheckInj (Inj c inj_typ) name tvars "already exist" Nothing -> insertInj (coerce c) inj_typ | otherwise = - throwError $ + uncatchableErr $ unwords [ "Bad type constructor: " , show name @@ -84,7 +89,7 @@ typecheckInj (Inj c inj_typ) name tvars where boundTVars :: [TVar] -> Type -> Either Error Bool boundTVars tvars' = \case - TAll{} -> throwError "Explicit foralls not allowed, for now" + TAll{} -> uncatchableErr "Explicit foralls not allowed, for now" TFun t1 t2 -> do t1' <- boundTVars tvars t1 t2' <- boundTVars tvars t2 @@ -94,10 +99,10 @@ typecheckInj (Inj c inj_typ) name tvars TLit _ -> return True TEVar _ -> error "TEVar in data type declaration" -toTVar :: Type -> Either String TVar +toTVar :: Type -> Either Error TVar toTVar = \case TVar tvar -> pure tvar - _ -> throwError "Not a type variable" + _ -> uncatchableErr "Not a type variable" returnType :: Type -> Type returnType (TFun _ t2) = returnType t2 @@ -117,7 +122,7 @@ preRun (x : xs) = case x of gets (M.member (coerce n) . sigs) >>= flip when - ( throwError $ Aux.do + ( uncatchableErr $ Aux.do "Duplicate signatures for function" quote $ printTree n ) @@ -156,7 +161,7 @@ checkBind (Bind name args e) = do sub2 <- unify t' lambda_t unless (apply sub1 lambda_t == t' && lambda_t == apply sub2 t') - ( throwError $ Aux.do + ( uncatchableErr $ Aux.do "Inferred type" quote $ printTree lambda_t "does not match specified type" @@ -232,13 +237,11 @@ algoW = \case sub2 <- unify t' t unless (apply sub1 t == t' && apply sub2 t' == t) - ( throwError $ - unwords - [ "Annotated type:" - , printTree t - , "does not match inferred type:" - , printTree t' - ] + ( uncatchableErr $ Aux.do + "Annotated type" + quote $ printTree t + "does not match inferred type" + quote $ printTree t' ) s2 <- exprErr (unify t t') err let comp = s2 `compose` s1 @@ -263,16 +266,16 @@ algoW = \case fr <- fresh insertSig (coerce i) (Just fr) return (nullSubst, (T.EVar $ coerce i, fr)) - Nothing -> throwError $ "Unbound variable: " <> printTree i + Nothing -> uncatchableErr $ "Unbound variable: " <> printTree i EInj i -> do constr <- gets injections case M.lookup (coerce i) constr of Just t -> return (nullSubst, (T.EVar $ coerce i, t)) Nothing -> - throwError $ - "Constructor: '" - <> printTree i - <> "' is not defined" + uncatchableErr $ Aux.do + "Constructor:" + quote $ printTree i + "is not defined" -- \| τ = newvar Γ, x : τ ⊢ e : τ', S -- \| --------------------------------- @@ -365,7 +368,7 @@ unify t0 t1 = do (TLit a, TLit b) -> if a == b then return M.empty - else throwError $ + else catchableErr $ Aux.do "Can not unify" quote $ printTree (TLit a) @@ -376,7 +379,7 @@ unify t0 t1 = do then do xs <- zipWithM unify t t' return $ foldr compose nullSubst xs - else throwError $ + else catchableErr $ Aux.do "Type constructor:" printTree name @@ -387,14 +390,14 @@ unify t0 t1 = do (TEVar a, TEVar b) -> if a == b then return M.empty - else throwError $ + else catchableErr $ Aux.do "Can not unify" quote $ printTree (TEVar a) "with" quote $ printTree (TEVar b) (a, b) -> do - throwError $ + catchableErr $ Aux.do "Can not unify" quote $ printTree a @@ -409,12 +412,14 @@ occurs :: T.Ident -> Type -> Infer Subst occurs i t@(TVar _) = return (M.singleton i t) occurs i t = if S.member i (free t) - then throwError $ - Aux.do - "Occurs check failed, can't unify" - quote $ printTree (TVar $ T.MkTVar (coerce i)) - "with" - quote $ printTree t + then + catchableErr + ( Aux.do + "Occurs check failed, can't unify" + quote $ printTree (TVar $ T.MkTVar (coerce i)) + "with" + quote $ printTree t + ) else return $ M.singleton i t -- | Generalize a type over all free variables in the substitution set @@ -581,7 +586,7 @@ existInj n = gets (M.lookup n . injections) -------- PATTERN MATCHING --------- checkCase :: Type -> [Branch] -> Infer (Subst, [T.Branch' Type], Type) -checkCase _ [] = throwError "Atleast one case required" +checkCase _ [] = catchableErr "Atleast one case required" checkCase expT brnchs = do (subs, injTs, injs, returns) <- unzip4 <$> mapM inferBranch brnchs let sub0 = composeAll subs @@ -621,13 +626,23 @@ inferPattern = \case PLit lit -> let lt = litType lit in return (T.PLit (lit, lt), lt) PInj constr patterns -> do t <- gets (M.lookup (coerce constr) . injections) - t <- maybeToRightM ("Constructor: " <> printTree constr <> " does not exist") t + t <- + maybeToRightM + ( Error + ( Aux.do + "Constructor:" + quote $ printTree constr + "does not exist" + ) + True + ) + t let numArgs = typeLength t - 1 let (vs, ret) = fromJust (unsnoc $ flattenType t) patterns <- mapM inferPattern patterns unless (length patterns == numArgs) - ( throwError $ Aux.do + ( catchableErr $ Aux.do "The constructor" quote $ printTree constr " should have " @@ -640,10 +655,20 @@ inferPattern = \case PCatch -> (T.PCatch,) <$> fresh PEnum p -> do t <- gets (M.lookup (coerce p) . injections) - t <- maybeToRightM ("Constructor: " <> printTree p <> " does not exist") t + t <- + maybeToRightM + ( Error + ( Aux.do + "Constructor:" + quote $ printTree p + "does not exist" + ) + True + ) + t unless (typeLength t == 1) - ( throwError $ Aux.do + ( catchableErr $ Aux.do "The constructor" quote $ printTree p " should have " @@ -686,8 +711,10 @@ partitionType = go [] _ -> error "Number of parameters and type doesn't match" exprErr :: Infer a -> Exp -> Infer a -exprErr ma exp = - catchError ma (\x -> throwError $ x <> " in expression: \n" <> printTree exp) +exprErr ma exp = catchError ma (\x -> if x.catchable then throwError (x{msg = x.msg <> " in expression: \n" <> printTree exp, catchable = False}) else throwError x) + +dataErr :: Infer a -> Data -> Infer a +dataErr ma d = catchError ma (\x -> if x.catchable then throwError (x{msg = x.msg <> " in data: \n" <> printTree d}) else throwError (x{catchable = False})) unzip4 :: [(a, b, c, d)] -> ([a], [b], [c], [d]) unzip4 = @@ -709,11 +736,17 @@ data Env = Env } deriving (Show) -type Error = String +data Error = Error {msg :: String, catchable :: Bool} type Subst = Map T.Ident Type newtype Infer a = Infer {runInfer :: StateT Env (ReaderT Ctx (ExceptT Error Identity)) a} deriving (Functor, Applicative, Monad, MonadReader Ctx, MonadError Error, MonadState Env) +catchableErr :: MonadError Error m => String -> m a +catchableErr msg = throwError $ Error msg True + +uncatchableErr :: MonadError Error m => String -> m a +uncatchableErr msg = throwError $ Error msg False + quote :: String -> String quote s = "'" ++ s ++ "'" From 0639489d280ffbbdb644e683de24719d9e76e470 Mon Sep 17 00:00:00 2001 From: sebastianselander Date: Tue, 28 Mar 2023 10:50:05 +0200 Subject: [PATCH 197/372] restructured layout of code a bit --- src/TypeChecker/TypeCheckerHm.hs | 182 +++++++++++++++---------------- 1 file changed, 91 insertions(+), 91 deletions(-) diff --git a/src/TypeChecker/TypeCheckerHm.hs b/src/TypeChecker/TypeCheckerHm.hs index 1fc0ee4..9fe62a4 100644 --- a/src/TypeChecker/TypeCheckerHm.hs +++ b/src/TypeChecker/TypeCheckerHm.hs @@ -47,67 +47,6 @@ typecheck = onLeft msg . run . checkPrg onLeft f (Left x) = Left $ f x onLeft _ (Right x) = Right x -checkData :: Data -> Infer () -checkData err@(Data typ injs) = do - (name, tvars) <- go typ - dataErr (mapM_ (\i -> typecheckInj i name tvars) injs) err - where - go = \case - TData name typs - | Right tvars' <- mapM toTVar typs -> - pure (name, tvars') - TAll _ _ -> uncatchableErr "Explicit foralls not allowed, for now" - _ -> uncatchableErr $ unwords ["Bad data type definition: ", printTree typ] - -typecheckInj :: Inj -> UIdent -> [TVar] -> Infer () -typecheckInj (Inj c inj_typ) name tvars - | Right False <- boundTVars tvars inj_typ = - catchableErr "Unbound type variables" - | TData name' typs <- returnType inj_typ - , Right tvars' <- mapM toTVar typs - , name' == name - , tvars' == tvars = do - exist <- existInj (coerce c) - case exist of - Just t -> uncatchableErr $ Aux.do - "Constructor" - quote $ coerce name - "with type" - quote $ printTree t - "already exist" - Nothing -> insertInj (coerce c) inj_typ - | otherwise = - uncatchableErr $ - unwords - [ "Bad type constructor: " - , show name - , "\nExpected: " - , printTree . TData name $ map TVar tvars - , "\nActual: " - , printTree $ returnType inj_typ - ] - where - boundTVars :: [TVar] -> Type -> Either Error Bool - boundTVars tvars' = \case - TAll{} -> uncatchableErr "Explicit foralls not allowed, for now" - TFun t1 t2 -> do - t1' <- boundTVars tvars t1 - t2' <- boundTVars tvars t2 - return $ t1' && t2' - TVar tvar -> return $ tvar `elem` tvars' - TData _ typs -> and <$> mapM (boundTVars tvars) typs - TLit _ -> return True - TEVar _ -> error "TEVar in data type declaration" - -toTVar :: Type -> Either Error TVar -toTVar = \case - TVar tvar -> pure tvar - _ -> uncatchableErr "Not a type variable" - -returnType :: Type -> Type -returnType (TFun _ t2) = returnType t2 -returnType a = a - checkPrg :: Program -> Infer (T.Program' Type) checkPrg (Program bs) = do preRun bs @@ -172,39 +111,66 @@ checkBind (Bind name args e) = do insertSig (coerce name) (Just lambda_t) return (T.Bind (coerce name, lambda_t) [] (e, lambda_t)) -typeEq :: Type -> Type -> Bool -typeEq (TFun l r) (TFun l' r') = typeEq l l' && typeEq r r' -typeEq (TLit a) (TLit b) = a == b -typeEq (TData name a) (TData name' b) = - length a == length b - && name == name' - && and (zipWith typeEq a b) -typeEq (TAll _ t1) t2 = t1 `typeEq` t2 -typeEq t1 (TAll _ t2) = t1 `typeEq` t2 -typeEq (TVar _) (TVar _) = True -typeEq _ _ = False +checkData :: Data -> Infer () +checkData err@(Data typ injs) = do + (name, tvars) <- go typ + dataErr (mapM_ (\i -> checkInj i name tvars) injs) err + where + go = \case + TData name typs + | Right tvars' <- mapM toTVar typs -> + pure (name, tvars') + TAll _ _ -> uncatchableErr "Explicit foralls not allowed, for now" + _ -> uncatchableErr $ unwords ["Bad data type definition: ", printTree typ] -skolemize :: Type -> Type -skolemize (TVar (MkTVar a)) = TEVar (MkTEVar $ coerce a) -skolemize (TAll x t) = TAll x (skolemize t) -skolemize (TFun t1 t2) = (TFun `on` skolemize) t1 t2 -skolemize t = t +checkInj :: Inj -> UIdent -> [TVar] -> Infer () +checkInj (Inj c inj_typ) name tvars + | Right False <- boundTVars tvars inj_typ = + catchableErr "Unbound type variables" + | TData name' typs <- returnType inj_typ + , Right tvars' <- mapM toTVar typs + , name' == name + , tvars' == tvars = do + exist <- existInj (coerce c) + case exist of + Just t -> uncatchableErr $ Aux.do + "Constructor" + quote $ coerce name + "with type" + quote $ printTree t + "already exist" + Nothing -> insertInj (coerce c) inj_typ + | otherwise = + uncatchableErr $ + unwords + [ "Bad type constructor: " + , show name + , "\nExpected: " + , printTree . TData name $ map TVar tvars + , "\nActual: " + , printTree $ returnType inj_typ + ] + where + boundTVars :: [TVar] -> Type -> Either Error Bool + boundTVars tvars' = \case + TAll{} -> uncatchableErr "Explicit foralls not allowed, for now" + TFun t1 t2 -> do + t1' <- boundTVars tvars t1 + t2' <- boundTVars tvars t2 + return $ t1' && t2' + TVar tvar -> return $ tvar `elem` tvars' + TData _ typs -> and <$> mapM (boundTVars tvars) typs + TLit _ -> return True + TEVar _ -> error "TEVar in data type declaration" -isMoreSpecificOrEq :: Type -> Type -> Bool -isMoreSpecificOrEq t1 (TAll _ t2) = isMoreSpecificOrEq t1 t2 -isMoreSpecificOrEq (TFun a b) (TFun c d) = - isMoreSpecificOrEq a c && isMoreSpecificOrEq b d -isMoreSpecificOrEq (TData n1 ts1) (TData n2 ts2) = - n1 == n2 - && length ts1 == length ts2 - && and (zipWith isMoreSpecificOrEq ts1 ts2) -isMoreSpecificOrEq _ (TVar _) = True -isMoreSpecificOrEq a b = a == b +toTVar :: Type -> Either Error TVar +toTVar = \case + TVar tvar -> pure tvar + _ -> uncatchableErr "Not a type variable" -isPoly :: Type -> Bool -isPoly (TAll _ _) = True -isPoly (TVar _) = True -isPoly _ = False +returnType :: Type -> Type +returnType (TFun _ t2) = returnType t2 +returnType a = a inferExp :: Exp -> Infer (T.ExpT' Type) inferExp e = do @@ -724,6 +690,40 @@ unzip4 = ) ([], [], [], []) +-- typeEq :: Type -> Type -> Bool +-- typeEq (TFun l r) (TFun l' r') = typeEq l l' && typeEq r r' +-- typeEq (TLit a) (TLit b) = a == b +-- typeEq (TData name a) (TData name' b) = +-- length a == length b +-- && name == name' +-- && and (zipWith typeEq a b) +-- typeEq (TAll _ t1) t2 = t1 `typeEq` t2 +-- typeEq t1 (TAll _ t2) = t1 `typeEq` t2 +-- typeEq (TVar _) (TVar _) = True +-- typeEq _ _ = False + +-- skolemize :: Type -> Type +-- skolemize (TVar (MkTVar a)) = TEVar (MkTEVar $ coerce a) +-- skolemize (TAll x t) = TAll x (skolemize t) +-- skolemize (TFun t1 t2) = (TFun `on` skolemize) t1 t2 +-- skolemize t = t + +-- isMoreSpecificOrEq :: Type -> Type -> Bool +-- isMoreSpecificOrEq t1 (TAll _ t2) = isMoreSpecificOrEq t1 t2 +-- isMoreSpecificOrEq (TFun a b) (TFun c d) = +-- isMoreSpecificOrEq a c && isMoreSpecificOrEq b d +-- isMoreSpecificOrEq (TData n1 ts1) (TData n2 ts2) = +-- n1 == n2 +-- && length ts1 == length ts2 +-- && and (zipWith isMoreSpecificOrEq ts1 ts2) +-- isMoreSpecificOrEq _ (TVar _) = True +-- isMoreSpecificOrEq a b = a == b + +-- isPoly :: Type -> Bool +-- isPoly (TAll _ _) = True +-- isPoly (TVar _) = True +-- isPoly _ = False + newtype Ctx = Ctx {vars :: Map T.Ident Type} deriving (Show) From 58fe92affe75a25b8a19b5f29ad94fcf39ea7d14 Mon Sep 17 00:00:00 2001 From: sebastianselander Date: Tue, 28 Mar 2023 10:50:45 +0200 Subject: [PATCH 198/372] Revert "restructured layout of code a bit" This reverts commit 0639489d280ffbbdb644e683de24719d9e76e470. --- src/TypeChecker/TypeCheckerHm.hs | 182 +++++++++++++++---------------- 1 file changed, 91 insertions(+), 91 deletions(-) diff --git a/src/TypeChecker/TypeCheckerHm.hs b/src/TypeChecker/TypeCheckerHm.hs index 9fe62a4..1fc0ee4 100644 --- a/src/TypeChecker/TypeCheckerHm.hs +++ b/src/TypeChecker/TypeCheckerHm.hs @@ -47,6 +47,67 @@ typecheck = onLeft msg . run . checkPrg onLeft f (Left x) = Left $ f x onLeft _ (Right x) = Right x +checkData :: Data -> Infer () +checkData err@(Data typ injs) = do + (name, tvars) <- go typ + dataErr (mapM_ (\i -> typecheckInj i name tvars) injs) err + where + go = \case + TData name typs + | Right tvars' <- mapM toTVar typs -> + pure (name, tvars') + TAll _ _ -> uncatchableErr "Explicit foralls not allowed, for now" + _ -> uncatchableErr $ unwords ["Bad data type definition: ", printTree typ] + +typecheckInj :: Inj -> UIdent -> [TVar] -> Infer () +typecheckInj (Inj c inj_typ) name tvars + | Right False <- boundTVars tvars inj_typ = + catchableErr "Unbound type variables" + | TData name' typs <- returnType inj_typ + , Right tvars' <- mapM toTVar typs + , name' == name + , tvars' == tvars = do + exist <- existInj (coerce c) + case exist of + Just t -> uncatchableErr $ Aux.do + "Constructor" + quote $ coerce name + "with type" + quote $ printTree t + "already exist" + Nothing -> insertInj (coerce c) inj_typ + | otherwise = + uncatchableErr $ + unwords + [ "Bad type constructor: " + , show name + , "\nExpected: " + , printTree . TData name $ map TVar tvars + , "\nActual: " + , printTree $ returnType inj_typ + ] + where + boundTVars :: [TVar] -> Type -> Either Error Bool + boundTVars tvars' = \case + TAll{} -> uncatchableErr "Explicit foralls not allowed, for now" + TFun t1 t2 -> do + t1' <- boundTVars tvars t1 + t2' <- boundTVars tvars t2 + return $ t1' && t2' + TVar tvar -> return $ tvar `elem` tvars' + TData _ typs -> and <$> mapM (boundTVars tvars) typs + TLit _ -> return True + TEVar _ -> error "TEVar in data type declaration" + +toTVar :: Type -> Either Error TVar +toTVar = \case + TVar tvar -> pure tvar + _ -> uncatchableErr "Not a type variable" + +returnType :: Type -> Type +returnType (TFun _ t2) = returnType t2 +returnType a = a + checkPrg :: Program -> Infer (T.Program' Type) checkPrg (Program bs) = do preRun bs @@ -111,66 +172,39 @@ checkBind (Bind name args e) = do insertSig (coerce name) (Just lambda_t) return (T.Bind (coerce name, lambda_t) [] (e, lambda_t)) -checkData :: Data -> Infer () -checkData err@(Data typ injs) = do - (name, tvars) <- go typ - dataErr (mapM_ (\i -> checkInj i name tvars) injs) err - where - go = \case - TData name typs - | Right tvars' <- mapM toTVar typs -> - pure (name, tvars') - TAll _ _ -> uncatchableErr "Explicit foralls not allowed, for now" - _ -> uncatchableErr $ unwords ["Bad data type definition: ", printTree typ] +typeEq :: Type -> Type -> Bool +typeEq (TFun l r) (TFun l' r') = typeEq l l' && typeEq r r' +typeEq (TLit a) (TLit b) = a == b +typeEq (TData name a) (TData name' b) = + length a == length b + && name == name' + && and (zipWith typeEq a b) +typeEq (TAll _ t1) t2 = t1 `typeEq` t2 +typeEq t1 (TAll _ t2) = t1 `typeEq` t2 +typeEq (TVar _) (TVar _) = True +typeEq _ _ = False -checkInj :: Inj -> UIdent -> [TVar] -> Infer () -checkInj (Inj c inj_typ) name tvars - | Right False <- boundTVars tvars inj_typ = - catchableErr "Unbound type variables" - | TData name' typs <- returnType inj_typ - , Right tvars' <- mapM toTVar typs - , name' == name - , tvars' == tvars = do - exist <- existInj (coerce c) - case exist of - Just t -> uncatchableErr $ Aux.do - "Constructor" - quote $ coerce name - "with type" - quote $ printTree t - "already exist" - Nothing -> insertInj (coerce c) inj_typ - | otherwise = - uncatchableErr $ - unwords - [ "Bad type constructor: " - , show name - , "\nExpected: " - , printTree . TData name $ map TVar tvars - , "\nActual: " - , printTree $ returnType inj_typ - ] - where - boundTVars :: [TVar] -> Type -> Either Error Bool - boundTVars tvars' = \case - TAll{} -> uncatchableErr "Explicit foralls not allowed, for now" - TFun t1 t2 -> do - t1' <- boundTVars tvars t1 - t2' <- boundTVars tvars t2 - return $ t1' && t2' - TVar tvar -> return $ tvar `elem` tvars' - TData _ typs -> and <$> mapM (boundTVars tvars) typs - TLit _ -> return True - TEVar _ -> error "TEVar in data type declaration" +skolemize :: Type -> Type +skolemize (TVar (MkTVar a)) = TEVar (MkTEVar $ coerce a) +skolemize (TAll x t) = TAll x (skolemize t) +skolemize (TFun t1 t2) = (TFun `on` skolemize) t1 t2 +skolemize t = t -toTVar :: Type -> Either Error TVar -toTVar = \case - TVar tvar -> pure tvar - _ -> uncatchableErr "Not a type variable" +isMoreSpecificOrEq :: Type -> Type -> Bool +isMoreSpecificOrEq t1 (TAll _ t2) = isMoreSpecificOrEq t1 t2 +isMoreSpecificOrEq (TFun a b) (TFun c d) = + isMoreSpecificOrEq a c && isMoreSpecificOrEq b d +isMoreSpecificOrEq (TData n1 ts1) (TData n2 ts2) = + n1 == n2 + && length ts1 == length ts2 + && and (zipWith isMoreSpecificOrEq ts1 ts2) +isMoreSpecificOrEq _ (TVar _) = True +isMoreSpecificOrEq a b = a == b -returnType :: Type -> Type -returnType (TFun _ t2) = returnType t2 -returnType a = a +isPoly :: Type -> Bool +isPoly (TAll _ _) = True +isPoly (TVar _) = True +isPoly _ = False inferExp :: Exp -> Infer (T.ExpT' Type) inferExp e = do @@ -690,40 +724,6 @@ unzip4 = ) ([], [], [], []) --- typeEq :: Type -> Type -> Bool --- typeEq (TFun l r) (TFun l' r') = typeEq l l' && typeEq r r' --- typeEq (TLit a) (TLit b) = a == b --- typeEq (TData name a) (TData name' b) = --- length a == length b --- && name == name' --- && and (zipWith typeEq a b) --- typeEq (TAll _ t1) t2 = t1 `typeEq` t2 --- typeEq t1 (TAll _ t2) = t1 `typeEq` t2 --- typeEq (TVar _) (TVar _) = True --- typeEq _ _ = False - --- skolemize :: Type -> Type --- skolemize (TVar (MkTVar a)) = TEVar (MkTEVar $ coerce a) --- skolemize (TAll x t) = TAll x (skolemize t) --- skolemize (TFun t1 t2) = (TFun `on` skolemize) t1 t2 --- skolemize t = t - --- isMoreSpecificOrEq :: Type -> Type -> Bool --- isMoreSpecificOrEq t1 (TAll _ t2) = isMoreSpecificOrEq t1 t2 --- isMoreSpecificOrEq (TFun a b) (TFun c d) = --- isMoreSpecificOrEq a c && isMoreSpecificOrEq b d --- isMoreSpecificOrEq (TData n1 ts1) (TData n2 ts2) = --- n1 == n2 --- && length ts1 == length ts2 --- && and (zipWith isMoreSpecificOrEq ts1 ts2) --- isMoreSpecificOrEq _ (TVar _) = True --- isMoreSpecificOrEq a b = a == b - --- isPoly :: Type -> Bool --- isPoly (TAll _ _) = True --- isPoly (TVar _) = True --- isPoly _ = False - newtype Ctx = Ctx {vars :: Map T.Ident Type} deriving (Show) From 66e419efa6837b1689d7f3ace246638e3955323e Mon Sep 17 00:00:00 2001 From: Samuel Hammersberg Date: Tue, 28 Mar 2023 11:53:25 +0200 Subject: [PATCH 199/372] Fixed the unnamed temporary bugs. --- src/Codegen/Codegen.hs | 14 +++++++++++--- src/Monomorphizer/Monomorphizer.hs | 9 +++++---- 2 files changed, 16 insertions(+), 7 deletions(-) diff --git a/src/Codegen/Codegen.hs b/src/Codegen/Codegen.hs index f7c4185..f1db64f 100644 --- a/src/Codegen/Codegen.hs +++ b/src/Codegen/Codegen.hs @@ -51,7 +51,9 @@ emit l = modify $ \t -> t{instructions = Auxiliary.snoc l $ instructions t} -- | Increases the variable counter in the CodeGenerator state increaseVarCount :: CompilerState () -increaseVarCount = (emit $ Comment "increase") >> (modify $ \t -> t{variableCount = variableCount t + 1}) +increaseVarCount = do + gets variableCount >>= \s -> emit.Comment $ "increase: " <> show (s + 1) + modify $ \t -> t{variableCount = variableCount t + 1} -- | Returns the variable count from the CodeGenerator state getVarCount :: CompilerState Integer @@ -333,8 +335,8 @@ emitECased t e cases = do stackPtr <- getNewVar emit $ SetVariable stackPtr (Alloca ty) mapM_ (emitCases rt ty label stackPtr vs) cs - crashLbl <- TIR.Ident . ("crash_" <>) . show <$> getNewLabel - emit $ Label crashLbl + -- crashLbl <- TIR.Ident . ("crash_" <>) . show <$> getNewLabel + -- emit $ Label crashLbl emit . UnsafeRaw $ "call i32 (ptr, ...) @printf(ptr noundef @.non_exhaustive_patterns, i64 noundef 6, i64 noundef 6)\n" emit . UnsafeRaw $ "call i32 @exit(i32 noundef 1)\n" mapM_ (const increaseVarCount) [0..1] @@ -419,16 +421,22 @@ emitECased t e cases = do val <- exprToValue exp emit $ Store ty val Ptr stackPtr emit $ Br label + lbl_failPos <- (\x -> TIR.Ident $ "failed_" <> show x) <$> getNewLabel + emit $ Label lbl_failPos emitCases rt ty label stackPtr vs (Branch (MIR.PEnum id, _) exp) = do emit $ Comment "Penum" val <- exprToValue exp emit $ Store ty val Ptr stackPtr emit $ Br label + lbl_failPos <- (\x -> TIR.Ident $ "failed_" <> show x) <$> getNewLabel + emit $ Label lbl_failPos emitCases _ ty label stackPtr _ (Branch (MIR.PCatch, _) exp) = do emit $ Comment "Pcatch" val <- exprToValue exp emit $ Store ty val Ptr stackPtr emit $ Br label + lbl_failPos <- (\x -> TIR.Ident $ "failed_" <> show x) <$> getNewLabel + emit $ Label lbl_failPos --emitLet :: Bind -> Exp -> CompilerState () emitLet xs e = do diff --git a/src/Monomorphizer/Monomorphizer.hs b/src/Monomorphizer/Monomorphizer.hs index 8d3808c..01cc4a4 100644 --- a/src/Monomorphizer/Monomorphizer.hs +++ b/src/Monomorphizer/Monomorphizer.hs @@ -17,26 +17,27 @@ monoDefs = map monoDef monoDef :: T.Def -> M.Def monoDef (T.DBind bind) = M.DBind $ monoBind bind ---monoDef (T.DData d) = M.DData $ monoData d +monoDef (T.DData d) = M.DData $ monoData d monoBind :: T.Bind -> M.Bind monoBind (T.Bind name args (e, t)) = M.Bind (monoId name) (map monoId args) (monoExpr e, monoType t) ---monoData :: T.Data -> M.Data ---monoData (T.Data (Ident id) cs) = M.Data (M.TLit (M.Ident id)) (map monoConstructor cs) +monoData :: T.Data -> M.Data +monoData (T.Data id cs) = M.Data (monoType id) (map monoConstructor cs) monoConstructor :: T.Inj -> M.Inj monoConstructor (T.Inj (Ident i) t) = M.Inj (T.Ident i) (monoType t) monoExpr :: T.Exp -> M.Exp monoExpr = \case - T.EVar (Ident i) -> M.EVar (T.Ident i) + T.EVar i -> M.EVar i T.ELit lit -> M.ELit $ monoLit lit T.ELet bind expt -> M.ELet (monoBind bind) (monoexpt expt) T.EApp expt1 expt2 -> M.EApp (monoexpt expt1) (monoexpt expt2) T.EAdd expt1 expt2 -> M.EAdd (monoexpt expt1) (monoexpt expt2) T.EAbs _i _expt -> error "BUG" T.ECase expt injs -> M.ECase (monoexpt expt) (monoInjs injs) + T.EInj i -> M.EVar i monoAbsType :: T.Type -> M.Type monoAbsType (T.TLit u) = M.TLit (coerce u) From d7549d421c02292ff3b81e0573150c99c9c49afb Mon Sep 17 00:00:00 2001 From: Samuel Hammersberg Date: Tue, 28 Mar 2023 13:49:34 +0200 Subject: [PATCH 200/372] Fixed a missing dependency. --- language.cabal | 2 ++ 1 file changed, 2 insertions(+) diff --git a/language.cabal b/language.cabal index 348d0c5..255f75c 100644 --- a/language.cabal +++ b/language.cabal @@ -32,6 +32,7 @@ executable language Grammar.ErrM Auxiliary Renamer.Renamer + TypeChecker.TypeChecker TypeChecker.TypeCheckerHm TypeChecker.TypeCheckerBidir TypeChecker.TypeCheckerIr @@ -75,6 +76,7 @@ Test-suite language-testsuite Grammar.ErrM Auxiliary Renamer.Renamer + TypeChecker.TypeChecker TypeChecker.TypeCheckerHm TypeChecker.TypeCheckerBidir TypeChecker.RemoveTEVar From 2aff7a77438b0d219495b494951836bb46f033ec Mon Sep 17 00:00:00 2001 From: Samuel Hammersberg Date: Tue, 28 Mar 2023 13:50:19 +0200 Subject: [PATCH 201/372] Fixed argumentless constructors being treated as variables. --- src/Codegen/Codegen.hs | 12 ++++--- src/Main.hs | 75 +++++++++++++++++++----------------------- test_program.crf | 36 +++++++++----------- 3 files changed, 56 insertions(+), 67 deletions(-) diff --git a/src/Codegen/Codegen.hs b/src/Codegen/Codegen.hs index f1db64f..6dd9c2a 100644 --- a/src/Codegen/Codegen.hs +++ b/src/Codegen/Codegen.hs @@ -14,8 +14,6 @@ import Data.Map (Map) import qualified Data.Map as Map import Data.Maybe (fromJust, fromMaybe) import Data.Tuple.Extra (dupe, first, second) -import Debug.Trace (trace) -import qualified Grammar.Abs as GA import Grammar.ErrM (Err) import Monomorphizer.MonomorphizerIr as MIR import qualified TypeChecker.TypeCheckerIr as TIR @@ -376,7 +374,7 @@ emitECased t e cases = do emit $ SetVariable (fst x) (ExtractValue (CustomType (coerce consId)) (VIdent casted Ptr) i) PLit (l, t) -> undefined PInj id ps -> undefined - PCatch -> undefined + PCatch -> pure() PEnum id -> undefined --case c of -- CIdent x -> do @@ -513,7 +511,13 @@ exprToValue = \case (MIR.LChar i) -> VChar i (MIR.EVar name, t) -> do funcs <- gets functions - case Map.lookup (name, t) funcs of + cons <- gets constructors + let res = Map.lookup (name, t) funcs + <|> + (\c -> FunctionInfo { numArgs = numArgsCI c + , arguments = argumentsCI c} ) + <$> Map.lookup name cons + case res of Just fi -> do if numArgs fi == 0 then do diff --git a/src/Main.hs b/src/Main.hs index 19ef68c..99cd84b 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -2,44 +2,35 @@ module Main where -import Control.Monad (when) -import Data.Bool (bool) -import Data.List.Extra (isSuffixOf) -import Data.Maybe (fromJust, isNothing) -import GHC.IO.Handle.Text (hPutStrLn) -import System.Console.GetOpt ( - ArgDescr (NoArg, ReqArg), - ArgOrder (RequireOrder), - OptDescr (Option), - getOpt, - usageInfo, - ) -import System.Directory ( - createDirectory, - doesPathExist, - getDirectoryContents, - removeDirectoryRecursive, - setCurrentDirectory, - ) -import System.Environment (getArgs) -import System.Exit ( - ExitCode (ExitFailure), - exitFailure, - exitSuccess, - exitWith, - ) -import System.IO (stderr) +import Control.Monad (when) +import Data.Bool (bool) +import Data.List.Extra (isSuffixOf) +import Data.Maybe (fromJust, isNothing) +import GHC.IO.Handle.Text (hPutStrLn) +import System.Console.GetOpt (ArgDescr (NoArg, ReqArg), + ArgOrder (RequireOrder), + OptDescr (Option), getOpt, + usageInfo) +import System.Directory (createDirectory, doesPathExist, + getDirectoryContents, + removeDirectoryRecursive, + setCurrentDirectory) +import System.Environment (getArgs) +import System.Exit (ExitCode (ExitFailure), + exitFailure, exitSuccess, + exitWith) +import System.IO (stderr) -import Codegen.Codegen (generateCode) -import Compiler (compile) -import Grammar.ErrM (Err) -import Grammar.Par (myLexer, pProgram) -import Grammar.Print (printTree) -import LambdaLifter (lambdaLift) -import Monomorphizer.Monomorphizer (monomorphize) -import Renamer.Renamer (rename) -import System.Process (spawnCommand, waitForProcess) -import TypeChecker.TypeChecker (TypeChecker (Bi, Hm), typecheck) +import Codegen.Codegen (generateCode) +import Compiler (compile) +import Grammar.ErrM (Err) +import Grammar.Par (myLexer, pProgram) +import Grammar.Print (printTree) +import LambdaLifter (lambdaLift) +import Monomorphizer.Monomorphizer (monomorphize) +import Renamer.Renamer (rename) +import System.Process (spawnCommand, waitForProcess) +import TypeChecker.TypeChecker (TypeChecker (Bi, Hm), typecheck) main :: IO () main = getArgs >>= parseArgs >>= uncurry main' @@ -86,11 +77,11 @@ chooseTypechecker s options = options{typechecker = tc} tc = case s of "hm" -> pure Hm "bi" -> pure Bi - _ -> Nothing + _ -> Nothing data Options = Options - { help :: Bool - , debug :: Bool + { help :: Bool + , debug :: Bool , typechecker :: Maybe TypeChecker } @@ -111,8 +102,8 @@ main' opts s = do bool (printToErr $ printTree typechecked) (printToErr $ show typechecked) opts.debug printToErr "\n-- Lambda Lifter --" - let lifted = lambdaLift typechecked - printToErr $ printTree lifted + --let lifted = lambdaLift typechecked + --printToErr $ printTree lifted -- printToErr "\n-- Lambda Lifter --" -- let lifted = lambdaLift typechecked diff --git a/test_program.crf b/test_program.crf index 72593d2..4771d93 100644 --- a/test_program.crf +++ b/test_program.crf @@ -1,26 +1,20 @@ -data Maybe () where { - Nothing : Maybe () - Just : Int -> Maybe () +data List () where { + Nil : List () + Cons : Int -> List () -> List () }; --- fmap : (Int -> Int) -> Maybe () -> Maybe () ; --- fmap f ma = case ma of { --- Nothing => Nothing ; --- Just a => Just (f a) ; --- }; - -main = case (Just 10) of { - Just a => a ; - Nothing => 1 ; +main = case Nil of { + Nil => 0 ; + Cons a _ => a ; }; --- pure : Int -> Maybe () ; --- pure x = Just x ; --- --- return = pure; --- --- bind : Maybe () -> (Int -> Maybe ()) -> Maybe () ; --- bind ma f = case ma of { --- Nothing => Nothing ; --- Just a => f a ; +-- length : List () -> Int ; +-- length xs = case xs of { +-- Nil => 0; +-- Cons _ xs => 1 + length xs ; -- }; + +--sum xs = case xs of { +-- Nil => 0 ; +-- Cons a xs => a + main xs ; +--}; \ No newline at end of file From 85f31b129baf1d18d1c140d677af63498bd50314 Mon Sep 17 00:00:00 2001 From: Samuel Hammersberg Date: Tue, 28 Mar 2023 14:15:22 +0200 Subject: [PATCH 202/372] Yoinked over the garbage collector. --- src/Accurate_GC/Makefile | 5 + src/Accurate_GC/gc.cpp | 16 + src/Accurate_GC/gc_printer.cpp | 16 + src/Accurate_GC/sample.ll | 4 + src/Accurate_GC/shadow_stack.cpp | 63 +++ src/GC/Makefile | 66 ++++ src/GC/docs/benchmarking.md | 21 + src/GC/docs/lib/chunk.md | 26 ++ src/GC/docs/lib/event.md | 47 +++ src/GC/docs/lib/heap.md | 54 +++ src/GC/docs/lib/profiler.md | 30 ++ src/GC/docs/ref-guide.md | 83 ++++ src/GC/include/chunk.hpp | 25 ++ src/GC/include/event.hpp | 56 +++ src/GC/include/heap.hpp | 100 +++++ src/GC/include/profiler.hpp | 49 +++ src/GC/lib/event.cpp | 75 ++++ src/GC/lib/heap.cpp | 659 +++++++++++++++++++++++++++++++ src/GC/lib/profiler.cpp | 192 +++++++++ src/GC/tests/MarkSweep.cpp | 87 ++++ src/GC/tests/advance.cpp | 44 +++ src/GC/tests/alloc_free.cpp | 32 ++ src/GC/tests/events.cpp | 44 +++ src/GC/tests/extern_lib.cpp | 94 +++++ src/GC/tests/file.cpp | 68 ++++ src/GC/tests/game.cpp | 95 +++++ src/GC/tests/h_test.cpp | 106 +++++ src/GC/tests/linker.cpp | 30 ++ src/GC/tests/player.hpp | 51 +++ src/GC/tests/stack.cpp | 76 ++++ src/GC/tests/stack2.cpp | 51 +++ src/GC/tests/struct_test.cpp | 41 ++ src/GC/todo.md | 11 + 33 files changed, 2417 insertions(+) create mode 100644 src/Accurate_GC/Makefile create mode 100644 src/Accurate_GC/gc.cpp create mode 100644 src/Accurate_GC/gc_printer.cpp create mode 100644 src/Accurate_GC/sample.ll create mode 100644 src/Accurate_GC/shadow_stack.cpp create mode 100644 src/GC/Makefile create mode 100644 src/GC/docs/benchmarking.md create mode 100644 src/GC/docs/lib/chunk.md create mode 100644 src/GC/docs/lib/event.md create mode 100644 src/GC/docs/lib/heap.md create mode 100644 src/GC/docs/lib/profiler.md create mode 100644 src/GC/docs/ref-guide.md create mode 100644 src/GC/include/chunk.hpp create mode 100644 src/GC/include/event.hpp create mode 100644 src/GC/include/heap.hpp create mode 100644 src/GC/include/profiler.hpp create mode 100644 src/GC/lib/event.cpp create mode 100644 src/GC/lib/heap.cpp create mode 100644 src/GC/lib/profiler.cpp create mode 100644 src/GC/tests/MarkSweep.cpp create mode 100644 src/GC/tests/advance.cpp create mode 100644 src/GC/tests/alloc_free.cpp create mode 100644 src/GC/tests/events.cpp create mode 100644 src/GC/tests/extern_lib.cpp create mode 100644 src/GC/tests/file.cpp create mode 100644 src/GC/tests/game.cpp create mode 100644 src/GC/tests/h_test.cpp create mode 100644 src/GC/tests/linker.cpp create mode 100644 src/GC/tests/player.hpp create mode 100644 src/GC/tests/stack.cpp create mode 100644 src/GC/tests/stack2.cpp create mode 100644 src/GC/tests/struct_test.cpp create mode 100644 src/GC/todo.md diff --git a/src/Accurate_GC/Makefile b/src/Accurate_GC/Makefile new file mode 100644 index 0000000..347e2dc --- /dev/null +++ b/src/Accurate_GC/Makefile @@ -0,0 +1,5 @@ +LEVEL := ../.. +LIBRARYNAME = GC +LOADABLE_MODULE = 1 + +include $(LEVEL)/Makefile.common \ No newline at end of file diff --git a/src/Accurate_GC/gc.cpp b/src/Accurate_GC/gc.cpp new file mode 100644 index 0000000..ddf8bc0 --- /dev/null +++ b/src/Accurate_GC/gc.cpp @@ -0,0 +1,16 @@ +// TODO: include these properly +#include "llvm/CodeGen/GCStrategy.h" +#include "llvm/CodeGen/GCMetadata.h" +#include "llvm/Support/Compiler.h" + +using namespace llvm; + +namespace { + class LLVM_LIBRARY_VISIBILITY GC : public GCStrategy { + public: + GC() {} + }; + + GCRegistry::Add + X("gc", "The bespoken garbage collector."); +} \ No newline at end of file diff --git a/src/Accurate_GC/gc_printer.cpp b/src/Accurate_GC/gc_printer.cpp new file mode 100644 index 0000000..f392c4b --- /dev/null +++ b/src/Accurate_GC/gc_printer.cpp @@ -0,0 +1,16 @@ +#include "llvm/CodeGen/GCMetadataPrinter.h" +#include "llvm/Support/Compiler.h" + +using namespace llvm; + +namespace { + class LLVM_LIBRARY_VISIBILITY GCPrinter : public GCMetadataPrinter { + public: + virtual void beginAssembly(AsmPrinter &AP); + + virtual void finishAssembly(AsmPrinter &AP); + }; + + GCMetadataPrinterRegistry::Add + X("gc", "The bespoken garbage collector."); +} \ No newline at end of file diff --git a/src/Accurate_GC/sample.ll b/src/Accurate_GC/sample.ll new file mode 100644 index 0000000..d737d38 --- /dev/null +++ b/src/Accurate_GC/sample.ll @@ -0,0 +1,4 @@ +define void @f() gc "gc" { +entry: + ret void +} \ No newline at end of file diff --git a/src/Accurate_GC/shadow_stack.cpp b/src/Accurate_GC/shadow_stack.cpp new file mode 100644 index 0000000..2c75629 --- /dev/null +++ b/src/Accurate_GC/shadow_stack.cpp @@ -0,0 +1,63 @@ +/// The map for a single function's stack frame. One of these is +/// compiled as constant data into the executable for each function. +/// +/// Storage of metadata values is elided if the %metadata parameter to +/// @llvm.gcroot is null. +struct FrameMap { + int NumRoots; //< Number of roots in stack frame. (int32_t) + int NumMeta; //< Number of metadata entries. May be < NumRoots. + const void *Meta[0]; //< Metadata for each root. +}; + +/// A link in the dynamic shadow stack. One of these is embedded in +/// the stack frame of each function on the call stack. +struct StackEntry { + StackEntry *Next; //< Link to next stack entry (the caller's). + const FrameMap *Map; //< Pointer to constant FrameMap. + void *Roots[0]; //< Stack roots (in-place array). +}; + +/// The head of the singly-linked list of StackEntries. Functions push +/// and pop onto this in their prologue and epilogue. +/// +/// Since there is only a global list, this technique is not threadsafe. +StackEntry *llvm_gc_root_chain; + +/// Calls Visitor(root, meta) for each GC root on the stack. +/// root and meta are exactly the values passed to +/// @llvm.gcroot. +/// +/// Visitor could be a function to recursively mark live objects. Or it +/// might copy them to another heap or generation. +/// +/// @param Visitor A function to invoke for every GC root on the stack. +void visitGCRoots(void (*Visitor)(void **Root, const void *Meta)) { + for (StackEntry *R = llvm_gc_root_chain; R; R = R->Next) { + unsigned i = 0; + + // For roots [0, NumMeta), the metadata pointer is in the FrameMap. + for (unsigned e = R->Map->NumMeta; i != e; ++i) + Visitor(&R->Roots[i], R->Map->Meta[i]); + + // For roots [NumMeta, NumRoots), the metadata pointer is null. + for (unsigned e = R->Map->NumRoots; i != e; ++i) + Visitor(&R->Roots[i], nullptr); + } +} + + // To access the stack map +void traverseStackMap() { + for (auto I = GCFunctionMetadata::roots_begin(), E = GCFunctionMetadata::end(); I != E; ++I) { + GCFunctionInfo *FI = *I; + unsigned FrameSize = FI->getFrameSize(); + size_t RootCount = FI->roots_size(); + + for (GCFunctionInfo::roots_iterator RI = FI->roots_begin(), + RE = FI->roots_end(); + RI != RE; ++RI) { + int RootNum = RI->Num; + int RootStackOffset = RI->StackOffset; + Constant *RootMetadata = RI->Metadata; + } + } +} \ No newline at end of file diff --git a/src/GC/Makefile b/src/GC/Makefile new file mode 100644 index 0000000..add6d73 --- /dev/null +++ b/src/GC/Makefile @@ -0,0 +1,66 @@ +CC = clang++ +CWD = $(shell pwd) +LIB_INCL = -I$(CWD)/include +LIB_SO = -L$(CWD)/lib +LIB_LINK = $(CWD)/lib +CFLAGS = -Wall -Wextra -v -g -std=gnu++20 -stdlib=libc++ -I +VGFLAGS = --leak-check=full --show-leak-kinds=all +STDFLAGS = -std=gnu++20 -stdlib=libc++ +WFLAGS = -Wall -Wextra +DBGFLAGS = -g + +advance: + $(CC) $(WFLAGS) $(STDFLAGS) tests/advance.cpp -o tests/advance.out + +file: + $(CC) $(WFLAGS) $(STDFLAGS) tests/file.cpp -o tests/file.out + +heap: + $(CC) $(WFLAGS) $(STDFLAGS) $(LIB_INCL) lib/heap.cpp + +h_test: + rm -f tests/h_test.out +# $(CC) $(WFLAGS) $(STDFLAGS) $(LIB_INCL) tests/h_test.cpp lib/heap.cpp lib/profiler.cpp lib/event.cpp -o tests/h_test.out + $(CC) $(STDFLAGS) $(WFLAGS) $(LIB_INCL) -O3 -g -o tests/h_test.out tests/h_test.cpp lib/gcoll.a + +h_test_vg: h_test + valgrind $(VGFLAGS) tests/h_test.out + +h_test_dbg: h_test + lldb tests/h_test.out launch + +linker: + rm -f tests/linker.out + $(CC) $(WFLAGS) $(STDFLAGS) $(LIB_INCL) tests/linker.cpp lib/heap.cpp -o tests/linker.out + +linker_vg: linker + valgrind $(VGFLAGS) tests/linker.out + +game: + rm -f tests/game.out + $(CC) $(WFLAGS) $(STDFLAGS) $(LIB_INCL) tests/game.cpp lib/heap.cpp lib/profiler.cpp lib/event.cpp -o tests/game.out + +extern_lib: +# remove old files + rm -f lib/heap.o lib/libheap.so tests/extern_lib.out +# compile heap to object file + $(CC) $(STDFLAGS) -c -fPIC -o lib/heap.o lib/heap.cpp + + $(CC) $(STDFLAGS) -shared -o lib/libheap.so lib/heap.o + $(CC) $(STDFLAGS) $(WFLAGS) $(LIB_INCL) -v tests/extern_lib.cpp lib/heap.cpp -o tests/extern_lib.out + $(CC) $(STDFLAGS) $(LIB_INCL) $(LIB_SO) -v -Wall -o tests/extern_lib.out tests/extern_lib.cpp -lheap + LD_LIBRARY_PATH=$(LIB_LINK) tests/extern_lib.out + +static_lib: +# remove old files + rm -f lib/event.o lib/profiler.o lib/heap.o lib/gcoll.a tests/extern_lib.out +# compile object files + $(CC) $(STDFLAGS) $(WFLAGS) $(LIB_INCL) -O3 -g -c -o lib/event.o lib/event.cpp -fPIC + $(CC) $(STDFLAGS) $(WFLAGS) $(LIB_INCL) -O3 -g -c -o lib/profiler.o lib/profiler.cpp -fPIC + $(CC) $(STDFLAGS) $(WFLAGS) $(LIB_INCL) -O3 -g -c -o lib/heap.o lib/heap.cpp -fPIC +# create static library + ar r lib/gcoll.a lib/event.o lib/profiler.o lib/heap.o + +# create test program +static_lib_test: static_lib + $(CC) $(STDFLAGS) $(WFLAGS) $(LIB_INCL) -o tests/extern_lib.out tests/extern_lib.cpp lib/gcoll.a \ No newline at end of file diff --git a/src/GC/docs/benchmarking.md b/src/GC/docs/benchmarking.md new file mode 100644 index 0000000..c2b9279 --- /dev/null +++ b/src/GC/docs/benchmarking.md @@ -0,0 +1,21 @@ +# Benchmarking + +free_overlap(): + 9_000 nodes: + With indexing: + Execution time: 22624 ≈ 22ms ≈ 0s. + Without indexing: + Execution time: 24891 ≈ 24ms ≈ 0s. + + 90_000 nodes: + With indexing: + Execution time: 693642 ≈ 693ms ≈ 0s. + Without indexing: + Execution time: 712297 ≈ 712ms ≈ 0s. + +Linked list test: + 50_000 nodes: + With marking all: + Execution time: 13911478 ≈ 13911ms ≈ 13s. + Without marking: + Execution time: 234361 ≈ 234ms ≈ 0s. \ No newline at end of file diff --git a/src/GC/docs/lib/chunk.md b/src/GC/docs/lib/chunk.md new file mode 100644 index 0000000..97230f5 --- /dev/null +++ b/src/GC/docs/lib/chunk.md @@ -0,0 +1,26 @@ +# chunk.hpp + +A chunk struct object is the basic element of what can be +stored on the heap. When `Heap::alloc` is called a +chunk may be created to represent the space of memory +that was allocated on the heap by `alloc`. + +## Members +`bool m_marked`: A boolean flag to mark an object during mark/sweep. + +`uintptr_t *const m_start`: A constant pointer pointing to the start +address of the memory space that was allocated. + +`const size_t m_size`: The size of the memory space that was allocated. + +## Constructors +There are three constructors for a chunk. One regular constructor +and two copy constructors. + +`Chunk(size_t size, uintptr_t *start)`: Used for creating new chunks in +`Heap::alloc`. + +`Chunk(const Chunk *const c)`: A copy constructor used by the profiler +to store chunk data after the initial chunk is deleted. + +`Chunk(const Chunk &c)`: A secondary copy constructor used for debugging. \ No newline at end of file diff --git a/src/GC/docs/lib/event.md b/src/GC/docs/lib/event.md new file mode 100644 index 0000000..8884205 --- /dev/null +++ b/src/GC/docs/lib/event.md @@ -0,0 +1,47 @@ +# event.hpp & event.cpp + +An event class used by the profiler to track actions +on the heap. + +## Members +`const GCEventType m_type`: The type of event recorded. + +`const std::time_t m_timestamp`: The timestamp of the event, +initialized to the current time by `std::time(NULL)`. + +`const Chunk *m_chunk`: The chunk an event is related to. +For example, in `alloc` when a new chunk is created, a +new event is recorded with the type of `NewChunk` and +`m_chunk` then contains a copied version of that new chunk. +If an event is not related to a chunk this member is initialized +to a nullptr. + +`const size_t m_size`: In an `AllocStart` event, this member +stores the amount of bytes requested to `alloc`. Otherwise +this member is initialized to 0. + +## Constructors +`GCEvent(GCEventType type)`: Used for creating events that are +independent of a chunk and size (like `ProfilerDispose`). + +`GCEvent(GCEventType type, Chunk *chunk)`: Used for creating events +that are connected to a chunk (like `ChunkMarked`). + +`GCEvent(GCEventType type, size_t size)`: Used for creating events +that are related to a size (only `AllocStart`). + +## Destructors +`~GCEvent()`: Default destructor and also frees the member +`m_chunk` if it's not the `nullptr`. + +## Functions +`GCEventType get_type()`: Getter for the type of the event. + +`std::time_t get_time_stamp()`: Getter for the timestamp of +the event. + +`const Chunk *get_chunk()`: Getter for the Chunk the event +is related to. The chunk data is constant. + +`const char *type_to_string()`: Translates the type of the +event to a string. \ No newline at end of file diff --git a/src/GC/docs/lib/heap.md b/src/GC/docs/lib/heap.md new file mode 100644 index 0000000..a0c31ab --- /dev/null +++ b/src/GC/docs/lib/heap.md @@ -0,0 +1,54 @@ +# heap.hpp & heap.cpp + +## Members +`char *const m_heap`: This is the pointer to the simulated heap which +collection occurs on. It's a byte array with a constant pointer. + +`size_t m_size`: The size of bytes that has been allocated on the heap. + +`inline static Heap *m_instance`: The singleton instance of Heap. Before +the heap is initialized this is initialized to the null pointer. + +`uintptr_t *m_stack_top`: The address of the topmost stack frame which +serves as the stop for scanning the stack. Initialized as the null pointer +but assigned to the correct address in `Heap::init()`. + +`bool m_profiler_enable`: The state of the profiler, `true` if the +profiler is enabled, `false` otherwise. It is initialized as `false`. + +`std::vector m_allocated_chunks`: Contains pointers to all +chunks that are allocated on the heap and can be reachable (if +a collection has been triggered previously). + +`std::vector m_freed_chunks`: Contains pointer to +chunks that have been freed, used to try and recycle chunks. + +## Constructors +`Heap()`: Default constructor which guarantees to initialize +the `m_heap` pointer and the byte array. Declared private +in accordance with the singleton pattern. + +## Destructors +`~Heap()`: Frees the `m_heap` byte array. Declared private +in accordance with the singleton pattern. + +## Functions +`static void init()`: Initializes the heap singleton and the member +`m_instance`. Must be called before any calls to `alloc()`. + +`static void dispose()`: Disposes the heap singleton which frees +the heap. If the profiler is enabled the profiler is also disposed. + +`static void *alloc(size_t size)`: Tries to allocate `size` amount +of bytes on the heap. The allocation is C-style, meaning `alloc()` +returns a `void *` similar to `malloc` and the user should cast +this pointer to an appropriate type. If this function is called with +the argument of 0, it will return the null pointer. This function can throw +runtime errors on two occasions. One if there is not enough memory +on the heap after a collection is triggered, it will throw a runtime +error with the message "Out of memory". The other occasion is when +a collection is triggered and the heap has not been initialized +properly by calling `init()`. + +`static void set_profiler(bool mode)`: Enables or disables (`true` +or `false`) the profiler. \ No newline at end of file diff --git a/src/GC/docs/lib/profiler.md b/src/GC/docs/lib/profiler.md new file mode 100644 index 0000000..cd925d6 --- /dev/null +++ b/src/GC/docs/lib/profiler.md @@ -0,0 +1,30 @@ +# profiler.hpp & profiler.cpp + +## Members +`inline static Profiler *m_instance`: The pointer to the profiler +singleton instance. + +`std::vector m_events`: A vector of events recorded +by the profiler. The contents are always sorted by time. + +## Constructors +`Profiler()`: Default constructor, declared private because of +the singleton pattern. + +## Destructors +`~Profiler()`: Default destructor, declared private because of +the singleton pattern. This destructor also deletes any events +that were recorded by the profiler to free memory. + +## Functions +`static void record(GCEventType type)`: Records an event independent +of a size and a chunk (like `ProfilerDispose`). + +`static void record(GCEventType type, size_t size)`: Records an event independent +of a chunk but not a size (only `AllocStart`). + +`static void record(GCEventType type, Chunk *chunk)`: Records an event independent +of a size but not a chunk (like `NewChunk`). + +`static void dispose()`: Disposes the profiler by dumping a log file of all +events and deleting events to free memory. \ No newline at end of file diff --git a/src/GC/docs/ref-guide.md b/src/GC/docs/ref-guide.md new file mode 100644 index 0000000..7ee627e --- /dev/null +++ b/src/GC/docs/ref-guide.md @@ -0,0 +1,83 @@ +# GC library - reference guide + +The Heap class is the core of the library and contains all necessary +functions for using the library. This class exposes four public functions +which are `init`, `dispose`, `alloc`, and `set_profiler`. + +To use the library, simply include it as `#include "heap.hpp"` and link +it during compilation. Or you can compile it to a static library using +the target `make static_lib` which compiles everything to an .a file. +It can also be compiled to a shared library if necessary with the target +`make shared_lib` which produces an .so file. + +## Quick guide +1. If you want a profiler, call `Heap::set_profiler(true)`. Otherwise this can be skipped. +2. Call `Heap::init()` to initialize the heap before using `alloc` (**crucial**). +3. Use `Heap::alloc()` as you want. +4. At program exit, call `Heap::dispose()` to free up all the memory used. + +## Functions + +### Heap::init() +When using the library, the user has to, at the start of the program, +call the `void init()` function, which initiates the Heap singleton +and the class member `m_stack_top`. **It is crucial** that this +functions is called from the `main` function of the end program, +as `init` uses the intrinsic function `__builtin_frame_address` +to find the address of the **first** stack frame of the end program. +If the function **is not** called from the `main` function +of the end program, it is not guaranteed that the garbage collector +will collect all objects. + +The intrinsic function used is technically unsafe for this use, +but during testing it has only shown to segfault for values greater +than the one used in `init`. If you run into a segfault, please +contact the developers. + + +### Heap::set_profiler(bool mode) +This function is used to enable or disable the profiler connected +to the Heap. The profiler is primarily used for testing, but can +also be used in general to keep track of the programs history. + +This function takes a single boolean as an argument to represent +the state of the profiler. `true` means that the profiler is enabled +and `false` means that the profiler is disabled. This function +can theoretically be called at any time during program execution, +but it's probably a bad idea. It is recommended to call this function +before the call to `init` or at least at before the first call to +`alloc`. + +### Heap::alloc(size_t size) +The probably most important function in this library. This function +is called to request memory from the "heap". `alloc` takes a single +argument which is a `size_t` (unsigned long) to represent the amount +of bytes to allocate on the heap. The allocation is C-style, meaning +that alloc returns a `void` pointer similar to `malloc`, which +is then supposed to be cast by the user to a proper pointer. When +`alloc` is called and there is already not enough memory left on +the heap to accommodate the request, a collection is triggered +to free up memory for the allocation. Hence the user does not +need to make their own calls to `free` or manually free up memory. + +`alloc` can also return a null pointer, if the user requests to +allocate 0 bytes. This is not recommended. + +`alloc` can also throw runtime errors in two cases. The first one +is of there is not enough memory on the heap available after +a collection, which in case the allocation cannot complete. +The second case is during a collection, where the function +`collect` throws a runtime error if the heap is not already +initialized by a call to `init`. Calls to `alloc` can technically +take place without properly initializing the heap, but this is +not recommended. + +### Heap::dispose() +This function is used to dispose the heap at the program exit. +If the profiler is enabled, it is also disposed from a call +to `dispose`. When the profiler is disposed, a log file is +dumped containing the events on the heap. If the profiler +is disabled, nothing happens to the profiler during `dispose`. +After the profiler is disposed, the heap is deleted which +frees up all the memory used and deletes (hopefully) all +the remaining objects in memory. \ No newline at end of file diff --git a/src/GC/include/chunk.hpp b/src/GC/include/chunk.hpp new file mode 100644 index 0000000..595b50b --- /dev/null +++ b/src/GC/include/chunk.hpp @@ -0,0 +1,25 @@ +#pragma once + +#include +#include + +namespace GC +{ + /** + * The basic element of what can be stored on + * the heap. A chunk contains a start address + * on the actual heap, the size of memory that + * is allocated at that address and if the + * chunk is reachable (marked). + */ + struct Chunk + { + bool m_marked {false}; + uintptr_t *const m_start {nullptr}; + const size_t m_size {0}; + + Chunk(size_t size, uintptr_t *start) : m_start(start), m_size(size) {} + Chunk(const Chunk *const c) : m_marked(c->m_marked), m_start(c->m_start), m_size(c->m_size) {} + Chunk(const Chunk &c) : m_marked(c.m_marked), m_start(c.m_start), m_size(c.m_size) {} + }; +} \ No newline at end of file diff --git a/src/GC/include/event.hpp b/src/GC/include/event.hpp new file mode 100644 index 0000000..298ccab --- /dev/null +++ b/src/GC/include/event.hpp @@ -0,0 +1,56 @@ +#pragma once + +#include +#include +#include +#include + +#include "chunk.hpp" + +namespace GC +{ + /** + * Types of events that can occur on the heap. + */ + enum GCEventType + { + HeapInit, + AllocStart, + CollectStart, + MarkStart, + ChunkMarked, + ChunkSwept, + ChunkFreed, + NewChunk, + ReusedChunk, + ProfilerDispose + }; + + /** + * Stores metadeta about an event on the heap. + */ + class GCEvent + { + private: + const GCEventType m_type; + const std::time_t m_timestamp {std::time(NULL)}; + const Chunk *m_chunk {nullptr}; + const size_t m_size {0}; + + public: + GCEvent(GCEventType type) : m_type(type) {} + GCEvent(GCEventType type, Chunk *chunk) : m_type(type), m_chunk(chunk) {} + GCEvent(GCEventType type, size_t size) : m_type(type), m_size(size) {} + + ~GCEvent() { + if (m_chunk != nullptr) + delete m_chunk; + } + + GCEventType get_type(); + std::time_t get_time_stamp(); + const Chunk *get_chunk(); + size_t get_size(); + const char *type_to_string(); + }; +} \ No newline at end of file diff --git a/src/GC/include/heap.hpp b/src/GC/include/heap.hpp new file mode 100644 index 0000000..365a838 --- /dev/null +++ b/src/GC/include/heap.hpp @@ -0,0 +1,100 @@ +#pragma once + +#include +#include +#include +#include +#include + +#include "chunk.hpp" +#include "profiler.hpp" + +#define HEAP_SIZE 2097152 //65536 +#define FREE_THRESH (uint) 100000 +#define DEBUG + +namespace GC +{ + /** + * Flags for the collect overlead for conditional + * collection (mark/sweep/free/all). + */ + enum CollectOption { + MARK=0x1, + SWEEP=0x2, + MARK_SWEEP = 0x3, + FREE=0x4, + COLLECT_ALL=0x7 + }; + + /** + * The heap class to represent the heap for the + * garbage collection. The heap is a singleton + * instance and can be retrieved by Heap::the() + * inside the heap class. The heap is represented + * by a char array of size 65536 and can enable + * a profiler to track the actions on the heap. + */ + class Heap + { + private: + Heap() : m_heap(static_cast(malloc(HEAP_SIZE))) {} + + ~Heap() + { + std::free((char *)m_heap); + } + + char *const m_heap; + size_t m_size {0}; + // static Heap *m_instance {nullptr}; + uintptr_t *m_stack_top {nullptr}; + bool m_profiler_enable {false}; + + std::vector m_allocated_chunks; + std::vector m_freed_chunks; + + static bool profiler_enabled(); + // static Chunk *get_at(std::vector &list, size_t n); + void collect(); + void sweep(Heap &heap); + Chunk *try_recycle_chunks(size_t size); + void free(Heap &heap); + void free_overlap(Heap &heap); + void mark(uintptr_t *start, const uintptr_t *end, std::vector &worklist); + void print_line(Chunk *chunk); + void print_worklist(std::vector &list); + void mark_step(uintptr_t start, uintptr_t end, std::vector &worklist); + + // Temporary + Chunk *try_recycle_chunks_new(size_t size); + void free_overlap_new(Heap &heap); + + public: + /** + * These are the only five functions which are exposed + * as the API for LLVM. At the absolute start of the + * program the developer has to call init() to ensure + * that the address of the topmost stack frame is + * saved as the limit for scanning the stack in collect. + */ + + static Heap &the(); + static void init(); + static void dispose(); + static void *alloc(size_t size); + void set_profiler(bool mode); + + // Stop the compiler from generating copy-methods + Heap(Heap const&) = delete; + Heap& operator=(Heap const&) = delete; + +#ifdef DEBUG + void collect(CollectOption flags); // conditional collection + void check_init(); // print dummy things + void print_contents(); // print dummy things + void print_allocated_chunks(Heap *heap); // print the contents in m_allocated_chunks + void print_summary(); +#endif + }; +} \ No newline at end of file diff --git a/src/GC/include/profiler.hpp b/src/GC/include/profiler.hpp new file mode 100644 index 0000000..ccdf463 --- /dev/null +++ b/src/GC/include/profiler.hpp @@ -0,0 +1,49 @@ +#pragma once + +#include + +#include "chunk.hpp" +#include "event.hpp" + +namespace GC { + + class Profiler { + private: + Profiler() {} + ~Profiler() + { + for (GCEvent *c : m_events) + delete c; + } + + /** + * Returns the instance of the Profiler singleton. + * If m_instance is the nullptr and the profiler + * is not initialized yet, initialize it and return + * the pointer to it. Otherwise return the previously + * initialized pointer. + * + * @returns The pointer to the profiler singleton. + */ + static Profiler *the() + { + if (m_instance) + return m_instance; + m_instance = new Profiler(); + return m_instance; + } + + inline static Profiler *m_instance {nullptr}; + std::vector m_events; + + std::ofstream create_file_stream(); + std::string get_log_folder(); + static void dump_trace(); + + public: + static void record(GCEventType type); + static void record(GCEventType type, size_t size); + static void record(GCEventType type, Chunk *chunk); + static void dispose(); + }; +} \ No newline at end of file diff --git a/src/GC/lib/event.cpp b/src/GC/lib/event.cpp new file mode 100644 index 0000000..2815a77 --- /dev/null +++ b/src/GC/lib/event.cpp @@ -0,0 +1,75 @@ +#include +#include +#include + +#include "chunk.hpp" +#include "event.hpp" + +namespace GC +{ + /** + * @returns The type of the event + */ + GCEventType GCEvent::get_type() + { + return m_type; + } + + /** + * @returns The time the event happened in + * the form of time_t. + */ + std::time_t GCEvent::get_time_stamp() + { + return m_timestamp; + } + + /** + * If the event is related to a chunk, this + * function returns the chunk that it is + * related to. If the event is independent + * of a chunk, it returns the nullptr. + * + * @returns A chunk pointer or the nullptr. + */ + const Chunk *GCEvent::get_chunk() + { + return m_chunk; + } + + /** + * If the event is an AllocStart event, this + * returns the size of the alloc() request. + * otherwise this returns 0. + * + * @returns A number representing the number + * of bytes requested to alloc() + * or 0 if the event is not an + * AllocStart event. + */ + size_t GCEvent::get_size() + { + return m_size; + } + + /** + * @returns The string conversion of the event type. + */ + const char *GCEvent::type_to_string() + { + switch (m_type) + { + case HeapInit: return "HeapInit"; + case AllocStart: return "AllocStart"; + case CollectStart: return "CollectStart"; + case MarkStart: return "MarkStart"; + case ChunkMarked: return "ChunkMarked"; + case ChunkSwept: return "ChunkSwept"; + case ChunkFreed: return "ChunkFreed"; + case NewChunk: return "NewChunk"; + case ReusedChunk: return "ReusedChunk"; + case ProfilerDispose: return "ProfilerDispose"; + default: return "[Unknown]"; + } + } +} \ No newline at end of file diff --git a/src/GC/lib/heap.cpp b/src/GC/lib/heap.cpp new file mode 100644 index 0000000..579f421 --- /dev/null +++ b/src/GC/lib/heap.cpp @@ -0,0 +1,659 @@ +#include +#include +#include +#include +#include +#include +#include +#include +#include + +#include "heap.hpp" + +using std::cout, std::endl, std::vector, std::hex, std::dec; + +namespace GC +{ + /** + * This implementation of the() guarantees laziness + * on the instance and a correct destruction with + * the destructor. + * + * @returns The singleton object. + */ + Heap& Heap::the() + { + static Heap instance; + return instance; + } + + /** + * Initialises the heap singleton and saves the address + * of the calling function's stack frame as the stack_top. + * Presumeably this address points to the stack frame of + * the compiled LLVM executable after linking. + */ + void Heap::init() + { + Heap &heap = Heap::the(); + if (heap.profiler_enabled()) + Profiler::record(HeapInit); +// clang complains because arg for __b_f_a is not 0 which is "unsafe" +#pragma clang diagnostic ignored "-Wframe-address" + heap.m_stack_top = static_cast(__builtin_frame_address(1)); + } + + /** + * Disposes the heap and the profiler at program exit + * which also triggers a heap log file dumped if the + * profiler is enabled. + */ + void Heap::dispose() + { + Heap &heap = Heap::the(); + if (heap.profiler_enabled()) + Profiler::dispose(); + } + + /** + * Allocates a given amount of bytes on the heap. + * + * @param size The amount of bytes to be allocated. + * + * @return A pointer to the address where the memory + * has been allocated. This pointer is supposed + * to be casted to and object pointer. + */ + void *Heap::alloc(size_t size) + { + // Singleton + Heap &heap = Heap::the(); + bool profiler_enabled = heap.profiler_enabled(); + + if (profiler_enabled) + Profiler::record(AllocStart, size); + + if (size == 0) + { + cout << "Heap: Cannot alloc 0B. No bytes allocated." << endl; + return nullptr; + } + + if (heap.m_size + size > HEAP_SIZE) + { + heap.collect(); + // If memory is not enough after collect, crash with OOM error + throw std::runtime_error(std::string("Error: Heap out of memory")); + } + + // If a chunk was recycled, return the old chunk address + Chunk *reused_chunk = heap.try_recycle_chunks(size); + if (reused_chunk != nullptr) + { + if (profiler_enabled) + Profiler::record(ReusedChunk, reused_chunk); + return static_cast(reused_chunk->m_start); + } + + // If no free chunks was found (reused_chunk is a nullptr), + // then create a new chunk + auto new_chunk = new Chunk(size, (uintptr_t *)(heap.m_heap + heap.m_size)); + + heap.m_size += size; + heap.m_allocated_chunks.push_back(new_chunk); + + if (profiler_enabled) + Profiler::record(NewChunk, new_chunk); + + return new_chunk->m_start; + } + + /** + * Tries to recycle used and freed chunks that are + * already allocated objects by the OS but freed + * from our Heap. This reduces the amount of GC + * objects slightly which saves time from malloc'ing + * memory from the OS. + * + * @param size Amount of bytes needed for the object + * which is about to be allocated. + * + * @returns If a chunk is found and recycled, a + * pointer to the allocated memory for + * the object is returned. If not, a + * nullptr is returned to signify no + * chunks were found. + */ + Chunk *Heap::try_recycle_chunks(size_t size) + { + Heap &heap = Heap::the(); + // Check if there are any freed chunks large enough for current request + for (size_t i = 0; i < heap.m_freed_chunks.size(); i++) + { + //auto chunk = Heap::get_at(heap.m_freed_chunks, i); + auto chunk = heap.m_freed_chunks[i]; + auto iter = heap.m_freed_chunks.begin(); + advance(iter, i); + if (chunk->m_size > size) + { + // Split the chunk, use one part and add the remaining part to + // the list of freed chunks + size_t diff = chunk->m_size - size; + auto chunk_complement = new Chunk(diff, chunk->m_start + chunk->m_size); + + heap.m_freed_chunks.erase(iter); + heap.m_freed_chunks.push_back(chunk_complement); + heap.m_allocated_chunks.push_back(chunk); + + return chunk; + } + else if (chunk->m_size == size) + { + // Reuse the whole chunk + heap.m_freed_chunks.erase(iter); + heap.m_allocated_chunks.push_back(chunk); + return chunk; + } + } + // If no chunk was found, return nullptr + return nullptr; + } + + /** + * Advances an iterator and returns an element + * at position `n`. + * + * @param list The list to retrieve an element from. + * + * @param n The position to retrieve an element at. + * + * @returns The pointer to the chunk at position n in list. + */ + // Chunk *Heap::get_at(std::vector &list, size_t n) + // { + // auto iter = list.begin(); + // if (!n) + // return *iter; + // std::advance(iter, n); + // return *iter; + // } + + /** + * Returns a bool whether the profiler is enabled + * or not. + * + * @returns True or false if the profiler is enabled + * or disabled respectively. + */ + bool Heap::profiler_enabled() { + Heap &heap = Heap::the(); + return heap.m_profiler_enable; + } + + /** + * Collection phase of the garbage collector. When + * an allocation is requested and there is no space + * left on the heap, a collection is triggered. This + * function is private so that the user cannot trigger + * a collection unneccessarily. + */ + void Heap::collect() + { + Heap &heap = Heap::the(); + + if (heap.profiler_enabled()) + Profiler::record(CollectStart); + + // get current stack frame + auto stack_bottom = reinterpret_cast(__builtin_frame_address(0)); + + if (heap.m_stack_top == nullptr) + throw std::runtime_error(std::string("Error: Heap is not initialized, read the docs!")); + + uintptr_t *stack_top = heap.m_stack_top; + + auto work_list = heap.m_allocated_chunks; + mark(stack_bottom, stack_top, work_list); + + sweep(heap); + + free(heap); + } + + /** + * Iterates through the stack, if an element on the stack points to a chunk, + * called a root chunk, that chunk is marked (i.e. reachable). + * Then it recursively follows all chunks which are possibly reachable from + * the root chunk and mark those chunks. + * If a chunk is marked it is removed from the worklist, since it's no longer of + * concern for this method. + * + * Time complexity: 0(N^2 * log(N)) as upper bound. + * Where N is either the size of the worklist or the size of + * the stack frame, depending on which is the largest. + * + * @param start Pointer to the start of the stack frame. + * @param end Pointer to the end of the stack frame. + * @param worklist The currently allocated chunks, which haven't been marked. + */ + void Heap::mark(uintptr_t *start, const uintptr_t* const end, vector &worklist) + { + Heap &heap = Heap::the(); + bool profiler_enabled = heap.m_profiler_enable; + if (profiler_enabled) + Profiler::record(MarkStart); + + // To find adresses thats in the worklist + for (; start <= end; start++) + { + auto it = worklist.begin(); + auto stop = worklist.end(); + while (it != stop) + { + Chunk *chunk = *it; + auto c_start = reinterpret_cast(chunk->m_start); + auto c_size = reinterpret_cast(chunk->m_size); + auto c_end = reinterpret_cast(c_start + c_size); + + // Check if the stack pointer points to something within the chunk + if (c_start <= *start && *start < c_end) + { + if (!chunk->m_marked) + { + if (profiler_enabled) + Profiler::record(ChunkMarked, chunk); + chunk->m_marked = true; + it = worklist.erase(it); + + // Recursively call mark, to see if the reachable chunk further points to another chunk + mark((uintptr_t *)c_start, (uintptr_t *)c_end, worklist); + } + else + { + ++it; + } + } + else + { + ++it; + } + } + } + } + + + /** + * Sweeps the heap, unmarks the marked chunks for the next cycle, + * adds the unmarked nodes to the list of freed chunks; to be freed. + * + * Time complexity: O(N^2), where N is the number of allocated chunks. + * It is quadratic, in the worst case, + * since each call to erase() is linear. + * + * @param heap Pointer to the heap singleton instance. + */ + void Heap::sweep(Heap &heap) + { + auto iter = heap.m_allocated_chunks.begin(); + bool profiler_enabled = heap.m_profiler_enable; + // This cannot "iter != stop", results in seg fault, since the end gets updated, I think. + while (iter != heap.m_allocated_chunks.end()) + { + Chunk *chunk = *iter; + + // Unmark the marked chunks for the next iteration. + if (chunk->m_marked) + { + chunk->m_marked = false; + ++iter; + } + else + { + // Add the unmarked chunks to freed chunks and remove from + // the list of allocated chunks + if (profiler_enabled) + Profiler::record(ChunkSwept, chunk); + heap.m_freed_chunks.push_back(chunk); + iter = heap.m_allocated_chunks.erase(iter); + } + } + } + + /** + * Frees chunks that was moved to the list m_freed_chunks + * by the sweep phase. If there are more than a certain + * amount of free chunks, delete the free chunks to + * avoid cluttering. + * + * Time complexity: O(N^2), where N is the freed chunks. + * If free_overlap() is called, it runs in O(N^2), + * otherwise O(N). + * + * @param heap Heap singleton instance, only for avoiding + * redundant calls to the singleton get + */ + void Heap::free(Heap &heap) + { + if (heap.m_freed_chunks.size() > FREE_THRESH) + { + bool profiler_enabled = heap.profiler_enabled(); + while (heap.m_freed_chunks.size()) + { + auto chunk = heap.m_freed_chunks.back(); + heap.m_freed_chunks.pop_back(); + if (profiler_enabled) + Profiler::record(ChunkFreed, chunk); + delete chunk; + } + } + // if there are chunks but not more than FREE_THRESH + else if (heap.m_freed_chunks.size()) + { + // essentially, always check for overlap between + // chunks before finishing the allocation + free_overlap(heap); + } + } + + /** + * Checks for overlaps between freed chunks of memory + * and removes overlapping chunks while prioritizing + * the chunks at lower addresses. + * + * Time complexity: O(N^2), where N is the number of freed chunks. + * At each iteration get_at() is called, which is linear. + * + * @param heap Heap singleton instance, only for avoiding + * redundant calls to the singleton get + * + * @note Maybe this should be changed to prioritizing + * larger chunks. Should remove get_at() to indexing, + * since that's constant. + */ + void Heap::free_overlap(Heap &heap) // borde göra en record(ChunkFreed) på onödiga chunks + { + std::vector filtered; + size_t i = 0; + //auto prev = Heap::get_at(heap.m_freed_chunks, i++); + auto prev = heap.m_freed_chunks[i++]; + prev->m_marked = true; + filtered.push_back(prev); + cout << filtered.back()->m_start << endl; + for (; i < heap.m_freed_chunks.size(); i++) + { + prev = filtered.back(); + //auto next = Heap::get_at(heap.m_freed_chunks, i); + auto next = heap.m_freed_chunks[i]; + auto p_start = (uintptr_t)(prev->m_start); + auto p_size = (uintptr_t)(prev->m_size); + auto n_start = (uintptr_t)(next->m_start); + if (n_start >= (p_start + p_size)) + { + next->m_marked = true; + filtered.push_back(next); + } + } + heap.m_freed_chunks.swap(filtered); + + bool profiler_enabled = heap.m_profiler_enable; + // After swap m_freed_chunks contains still available chunks + // and filtered contains all the chunks, so delete unused chunks + for (Chunk *chunk : filtered) + { + // if chunk was filtered away, delete it + if (!chunk->m_marked) + { + if (profiler_enabled) + Profiler::record(ChunkFreed, chunk); + delete chunk; + } + else + { + chunk->m_marked = false; + } + } + } + +#ifdef DEBUG + /** + * Prints the result of Heap::init() and a dummy value + * for the current stack frame for reference. + */ + void Heap::check_init() + { + Heap &heap = Heap::the(); + cout << "Heap addr:\t" << &heap << "\n"; + cout << "GC m_stack_top:\t" << heap.m_stack_top << "\n"; + auto stack_bottom = reinterpret_cast(__builtin_frame_address(0)); + cout << "GC stack_bottom:\t" << stack_bottom << endl; + } + + /** + * Conditional collection, only to be used in debugging + * + * @param flags Bitmap of flags + */ + void Heap::collect(CollectOption flags) + { + set_profiler(true); + + Heap &heap = Heap::the(); + + if (heap.m_profiler_enable) + Profiler::record(CollectStart); + + cout << "DEBUG COLLECT\nFLAGS: "; + if (flags & MARK) + cout << "\n - MARK"; + if (flags & SWEEP) + cout << "\n - SWEEP"; + if (flags & FREE) + cout << "\n - FREE"; + cout << "\n"; + + // get the frame adress, whwere local variables and saved registers are located + auto stack_bottom = reinterpret_cast(__builtin_frame_address(0)); + cout << "Stack bottom in collect:\t" << stack_bottom << "\n"; + uintptr_t *stack_top = heap.m_stack_top; + + cout << "Stack end in collect:\t " << stack_top << endl; + auto work_list = heap.m_allocated_chunks; + + if (flags & MARK) + mark(stack_bottom, stack_top, work_list); + + if (flags & SWEEP) + sweep(heap); + + if (flags & FREE) + free(heap); + } + + // Mark child references from the root references + void mark_test(vector &worklist) + { + while (worklist.size() > 0) + { + Chunk *ref = worklist.back(); + worklist.pop_back(); + Chunk *child = (Chunk *)ref; // this is probably not correct + if (child != nullptr && !child->m_marked) + { + child->m_marked = true; + worklist.push_back(child); + mark_test(worklist); + } + } + } + + // Mark the root references and look for child references to them + void mark_from_roots(uintptr_t *start, const uintptr_t *end) + { + vector worklist; + for (; start > end; start--) + { + if (*start % 8 == 0) + { // all pointers must be aligned as double words + Chunk *ref = (Chunk *)*start; + if (ref != nullptr && !ref->m_marked) + { + ref->m_marked = true; + worklist.push_back(ref); + mark_test(worklist); + } + } + } + } + + // For testing purposes + void Heap::print_line(Chunk *chunk) + { + cout << "Marked: " << chunk->m_marked << "\nStart adr: " << chunk->m_start << "\nSize: " << chunk->m_size << " B\n" + << endl; + } + + void Heap::print_worklist(std::vector &list) + { + for (auto cp : list) + cout << "Chunk at:\t" << cp->m_start << "\nSize:\t\t" << cp->m_size << "\n"; + cout << endl; + } + + void Heap::print_contents() + { + Heap &heap = Heap::the(); + if (heap.m_allocated_chunks.size()) + { + cout << "\nALLOCATED CHUNKS #" << dec << heap.m_allocated_chunks.size() << endl; + for (auto chunk : heap.m_allocated_chunks) + print_line(chunk); + } + else + { + cout << "NO ALLOCATIONS\n" << endl; + } + if (heap.m_freed_chunks.size()) + { + cout << "\nFREED CHUNKS #" << dec << heap.m_freed_chunks.size() << endl; + for (auto fchunk : heap.m_freed_chunks) + print_line(fchunk); + } + else + { + cout << "NO FREED CHUNKS" << endl; + } + } + + void Heap::print_summary() + { + Heap &heap = Heap::the(); + if (heap.m_allocated_chunks.size()) + { + cout << "\nALLOCATED CHUNKS #" << dec << heap.m_allocated_chunks.size() << endl; + } + else + { + cout << "NO ALLOCATIONS\n" << endl; + } + if (heap.m_freed_chunks.size()) + { + cout << "\nFREED CHUNKS #" << dec << heap.m_freed_chunks.size() << endl; + } + else + { + cout << "NO FREED CHUNKS" << endl; + } + } + + void Heap::set_profiler(bool mode) + { + Heap &heap = Heap::the(); + heap.m_profiler_enable = mode; + } + + void Heap::print_allocated_chunks(Heap *heap) { + cout << "--- Allocated Chunks ---\n" << endl; + for (auto chunk : heap->m_allocated_chunks) { + print_line(chunk); + } + } + + Chunk *Heap::try_recycle_chunks_new(size_t size) + { + Heap &heap = Heap::the(); + // Check if there are any freed chunks large enough for current request + for (size_t i = 0; i < heap.m_freed_chunks.size(); i++) + { + auto chunk = heap.m_freed_chunks[i]; //Heap::get_at(heap.m_freed_chunks, i); + auto iter = heap.m_freed_chunks.begin(); + //advance(iter, i); + i++; + if (chunk->m_size > size) + { + // Split the chunk, use one part and add the remaining part to + // the list of freed chunks + size_t diff = chunk->m_size - size; + auto chunk_complement = new Chunk(diff, chunk->m_start + chunk->m_size); + + heap.m_freed_chunks.erase(iter); + heap.m_freed_chunks.push_back(chunk_complement); + heap.m_allocated_chunks.push_back(chunk); + + return chunk; + } + else if (chunk->m_size == size) + { + // Reuse the whole chunk + heap.m_freed_chunks.erase(iter); + heap.m_allocated_chunks.push_back(chunk); + return chunk; + } + } + // If no chunk was found, return nullptr + return nullptr; + } + + void Heap::free_overlap_new(Heap &heap) // borde göra en record(ChunkFreed) på onödiga chunks + { + std::vector filtered; + size_t i = 0; + auto prev = heap.m_freed_chunks[i++]; //Heap::get_at(heap.m_freed_chunks, i++); + prev->m_marked = true; + filtered.push_back(prev); + cout << filtered.back()->m_start << endl; + for (; i < heap.m_freed_chunks.size(); i++) + { + prev = filtered.back(); + auto next = heap.m_freed_chunks[i]; //Heap::get_at(heap.m_freed_chunks, i); + auto p_start = (uintptr_t)(prev->m_start); + auto p_size = (uintptr_t)(prev->m_size); + auto n_start = (uintptr_t)(next->m_start); + if (n_start >= (p_start + p_size)) + { + next->m_marked = true; + filtered.push_back(next); + } + } + heap.m_freed_chunks.swap(filtered); + + bool profiler_enabled = heap.m_profiler_enable; + // After swap m_freed_chunks contains still available chunks + // and filtered contains all the chunks, so delete unused chunks + for (Chunk *chunk : filtered) + { + // if chunk was filtered away, delete it + if (!chunk->m_marked) + { + if (profiler_enabled) + Profiler::record(ChunkFreed, chunk); + delete chunk; + } + else + { + chunk->m_marked = false; + } + } + } + +#endif +} \ No newline at end of file diff --git a/src/GC/lib/profiler.cpp b/src/GC/lib/profiler.cpp new file mode 100644 index 0000000..29abad4 --- /dev/null +++ b/src/GC/lib/profiler.cpp @@ -0,0 +1,192 @@ +#include +#include +#include +#include +#include +#include +#include +#include + +#include "chunk.hpp" +#include "event.hpp" +#include "profiler.hpp" + +// #define MAC_OS + +namespace GC +{ + /** + * Records an event independent of a chunk. + * + * @param type The type of event to record. + */ + void Profiler::record(GCEventType type) + { + auto event = new GCEvent(type); + auto profiler = Profiler::the(); + profiler->m_events.push_back(event); + } + + /** + * This overload is only used with an AllocStart + * event. + * + * @param type The type of event to record. + * + * @param size The size of requested to alloc(). + */ + void Profiler::record(GCEventType type, size_t size) + { + auto event = new GCEvent(type, size); + auto profiler = Profiler::the(); + profiler->m_events.push_back(event); + } + + /** + * Records an event related to a chunk. + * + * @param type The type of event to record. + * + * @param chunk The chunk the event is connected + * to. + */ + void Profiler::record(GCEventType type, Chunk *chunk) + { + // Create a copy of chunk to store in the profiler + // because in free() chunks are deleted and cannot + // be referenced by the profiler. These copied + // chunks are deleted by the profiler on dispose(). + auto chunk_copy = new Chunk(chunk); + auto event = new GCEvent(type, chunk_copy); + auto profiler = Profiler::the(); + profiler->m_events.push_back(event); + } + + /** + * Prints the history of the recorded events + * to a log file in the /tests/logs folder. + */ + void Profiler::dump_trace() + { + auto profiler = Profiler::the(); + auto start = profiler->m_events.begin(); + auto end = profiler->m_events.end(); + + // File output stream + std::ofstream fstr = profiler->create_file_stream(); + // Buffer for timestamp + char buffer[22]; + // Time variables + std::tm *btm; + std::time_t tt; + const Chunk *chunk; + + while (start != end) + { + auto event = *start++; + + tt = event->get_time_stamp(); + btm = std::localtime(&tt); + std::strftime(buffer, 22, "%a %T", btm); + + fstr << "--------------------------------\n" + << buffer + << "\nEvent:\t" << event->type_to_string(); + + + + chunk = event->get_chunk(); + + if (event->get_type() == AllocStart) + { + fstr << "\nSize: " << event->get_size(); + } + else if (chunk) + { + fstr << "\nChunk: " << chunk->m_start + << "\n Size: " << chunk->m_size + << "\n Mark: " << chunk->m_marked; + } + fstr << "\n"; + } + fstr << "--------------------------------" << std::endl; + } + + /** + * Deletes the profiler singleton and all + * the events recorded after recording + * the ProfilerDispose event and dumping + * the history to a log file. + */ + void Profiler::dispose() + { + Profiler::record(ProfilerDispose); + Profiler::dump_trace(); + auto profiler = Profiler::the(); + delete profiler; + } + + /** + * Creates a filestream for the future + * log file to print the history to in + * dump_trace(). + * + * @returns The output stream to the file. + */ + std::ofstream Profiler::create_file_stream() + { + // get current time + std::time_t tt = std::time(NULL); + std::tm *ptm = std::localtime(&tt); + + // format to string + char buffer[32]; + std::strftime(buffer, 32, "/log_%a_%H_%M_%S.txt", ptm); + std::string filename(buffer); + + // const std::string ABS_PATH = "/home/virre/dev/systemF/org/language/src/GC/"; + // // const std::string ABS_PATH = "/Users/valtermiari/Desktop/DV/Bachelors/code/language/src/GC"; + // std::string fullpath = ABS_PATH + filename; + + const std::string fullpath = get_log_folder() + filename; + + std::ofstream fstr(fullpath); + return fstr; + } + + /** + * This function retrieves the path to the folder + * of the executable to use for log files. + * + * @returns The path to the logs folder. + * + * @throws A runtime error if the call + * to readlink() fails. + */ + std::string Profiler::get_log_folder() + { +#ifndef MAC_OS + char buffer[1024]; + // chars read from path + ssize_t len = readlink("/proc/self/exe", buffer, sizeof(buffer)-1); + + // if readlink fails + if (len == -1) + { + throw std::runtime_error(std::string("Error: readlink failed on '/proc/self/exe/'")); + } + + buffer[len] = '\0'; + + // convert to string for string operators + auto path = std::string(buffer); + + // remove filename + size_t last_slash = path.find_last_of('/'); + std::string folder = path.substr(0, last_slash); +#else + auto folder = std::string("/Users/valtermiari/Desktop/DV/Bachelors/code/language/src/GC/tests"); +#endif + return folder + "/logs"; + } +} \ No newline at end of file diff --git a/src/GC/tests/MarkSweep.cpp b/src/GC/tests/MarkSweep.cpp new file mode 100644 index 0000000..ab219d2 --- /dev/null +++ b/src/GC/tests/MarkSweep.cpp @@ -0,0 +1,87 @@ +#include +#include +#define HEAP_SIZE 65536 // Arbitrary for now, 2^16 +using namespace std; + +/* A simple mark and sweep algorithm */ + +// Shouldn't be exposed. For now, it is +struct ObjectHeader { + size_t size = sizeof(this); + bool marked = false; + +}; + +struct Object : ObjectHeader { + char name; // should be something like id, but for testing sake its char + Object* child; + // Object(char name_) {} + Object(char name_, Object* child_) { + name = name_; + child = child_; + } +}; + +// Representing the heap as a simple struct for now +struct Heap { + Object heap_space[HEAP_SIZE]; +}; + +// For now it assumes that it is given root objects from the start, no root finding included +class MarkSweep { + public: + void mark(Object* obj) { + if (!markedBit(obj)) { + markBit(obj); + Object* ref = obj->child; + if (ref != nullptr) { + mark(ref); + } + } + } + + void sweep(vector worklist) { + for (Object* obj: worklist) { + if (!markedBit(obj) && obj != nullptr) { + delete obj; + } + } + } + + private: + bool markedBit(Object* obj) { + return obj->marked; + } + + void markBit(Object* obj) { + obj->marked = true; + } + +}; + +int main() { + Object* b = new Object('B', nullptr); + // b->name = 'B'; + // b->child = nullptr; + Object* c = new Object('C', b); + // c->name = 'C'; + // c->child = b; // c -> d + Object* d = new Object('D', nullptr); + // d->name = 'D'; + // d->child = nullptr; + + //Heap* heap = new Heap{*c, *b, *d}; + vector worklist = {c, b, d}; + MarkSweep* gc = new MarkSweep(); + + gc->mark(c); + cout << "Expected 1, got: " << b->marked << '\n'; + cout << "Expected 1, got: " << c->marked << '\n'; + cout << "Expected 0, got: " << d->marked << '\n'; + + gc->sweep(worklist); + cout << b->name << '\n'; + cout << c->name << '\n'; + cout << d->name << '\n'; // The object at d is now deleted (freed) + return 0; +} \ No newline at end of file diff --git a/src/GC/tests/advance.cpp b/src/GC/tests/advance.cpp new file mode 100644 index 0000000..92ce506 --- /dev/null +++ b/src/GC/tests/advance.cpp @@ -0,0 +1,44 @@ +#include +#include +#include +#include +#include +#include + +int main() { + using namespace std; + using TimeStamp = std::chrono::_V2::system_clock::time_point; + + list l; + char c = 'a'; + for (int i = 1; i <= 5; i++) { + l.push_back(c++); + } + + auto iter = l.begin(); + auto stop = l.end(); + + while (iter != stop) { + cout << *iter << " "; + + iter++; + } + cout << endl; + iter = l.begin(); + while (*iter != *stop) { + cout << *iter << " "; + iter++; + } + cout << endl; + + cout << "rebased" << endl; + cout << "iter: " << *iter << "\nstop: " << *stop << endl; + + TimeStamp ts = std::chrono::system_clock::now(); + std::time_t tt = std::chrono::system_clock::to_time_t(ts); + std::string tstr = std::ctime(&tt); + tstr.resize(tstr.size()-1); + std::cout << tstr << std::endl; + + return 0; +} \ No newline at end of file diff --git a/src/GC/tests/alloc_free.cpp b/src/GC/tests/alloc_free.cpp new file mode 100644 index 0000000..4a0f6f8 --- /dev/null +++ b/src/GC/tests/alloc_free.cpp @@ -0,0 +1,32 @@ +#include + +#include "heap.hpp" + +struct Obj { + int a; + int b; + int c; +}; + +int main() { + GC::Heap::init(); + Obj *obj; + + for (int i = 0; i < 4; i++) { + obj = static_cast(GC::Heap::alloc(sizeof(Obj))); + obj->a = i * i + 1; + obj->b = i * i + 2; + obj->c = i * i + 3; + } + + // heap->force_collect(); + auto heap = GC::Heap::debug_the(); + heap->collect(COLLECT_ALL); + + std::cout << obj->a << ", " << obj->b << ", " << obj->c << std::endl; + + //delete heap; + GC::Heap::dispose(); + + return 0; +} \ No newline at end of file diff --git a/src/GC/tests/events.cpp b/src/GC/tests/events.cpp new file mode 100644 index 0000000..e517092 --- /dev/null +++ b/src/GC/tests/events.cpp @@ -0,0 +1,44 @@ +#include +#include + +using namespace std; +// broken :( +// [event_source(native)] +class ESource { +public: + __event void TestEvent(int eValue); +}; + +// [event_receiver(native)] +class EReceiver { +public: + void Handler1(int eValue) { + cout << "Handler1 with: " << eValue << endl; + } + + void Handler2(int eValue) { + cout << "Handler2 with: " << eValue << endl; + } + + void hookEvent(ESource *eSource) { + __hook(&ESource::TestEvent, eSource, &EReceiver::Handler1); + __hook(&ESource::TestEvent, eSource, &EReceiver::Handler2); + } + + void unhookEvent(ESource *eSource) { + __unhook(&ESource::TestEvent, eSource, &EReceiver::Handler1); + __unhook(&ESource::TestEvent, eSource, &EReceiver::Handler2); + } +}; + +int main() { + + ESource src; + EReceiver rcv; + + rcv.hookEvent(&src); + __raise src.TestEvent(12); + rcv.unhookEvent(&src); + + return 0; +} \ No newline at end of file diff --git a/src/GC/tests/extern_lib.cpp b/src/GC/tests/extern_lib.cpp new file mode 100644 index 0000000..fa30051 --- /dev/null +++ b/src/GC/tests/extern_lib.cpp @@ -0,0 +1,94 @@ +#include +#include + +#include "heap.hpp" + +GC::Heap& singleton_test(); +void init_gc(GC::Heap& heap); +void frame_test(GC::Heap& heap); + +int main() { + std::cout << "in main" << std::endl; + GC::Heap &heap = singleton_test(); + + init_gc(heap); + frame_test(heap); + + heap.dispose(); + + return 0; +} + +/** + * This test is supposed to determine if the singleton pattern + * implementation is working correctly. This test passes if the + * first and second call prints the same memory address. + * + * Result: pass + * + * @return Pointer to the Heap singleton instance +*/ +GC::Heap& singleton_test() { + std::cout << "TESTING SINGLETON INSTANCES" << std::endl; + std::cout << "===========================" << std::endl; + std::cout << "Call 1:\t" << &GC::Heap::the() << std::endl; // First call which initializes the singleton instance + GC::Heap &heap = GC::Heap::the(); // Second call which should return the initialized instance + std::cout << "Call 2:\t" << &heap << std::endl; + std::cout << "===========================" << std::endl; + return heap; +} + + +/** + * This test calls Heap::init() which saves the stack-frame + * address from the calling function (this function). + * Heap::init() is supposed to be called at the absolute + * start of the program to save the address of the + * topmost stack frame. This test doesn't do anything + * but prepares for the next test(s). + * + * @param heap The Heap pointer to the singleton instance. + * +*/ +void init_gc(GC::Heap& heap){ + std::cout << "\n\n INITIALIZING THE HEAP" << std::endl; + std::cout << "===========================" << std::endl; + heap.init(); + heap.set_profiler(true); + std::cout << "===========================" << std::endl; +} + +/** + * This function tests the functionality of the intrinsic + * function `__builtin_frame_address` which returns the + * address of the corresponding level of stack frame. + * When given a param of 0, it returns the current stack frame. + * When given a param of 1, it returns the previous stack + * frame, and so on. + * + * This test passes on two conditions: + * 1) if the address of the current frame is smaller than + * the address of the previous frame (assumed). + * 2) if the previous frame has the same address as the one + * saved in the Heap instance after running Heap::init(). + * + * Result: pass + * + * @param heap The Heap instance +*/ +void frame_test(GC::Heap& heap) { + std::cout << "\n\n TESTING FRAME ADDRESSES" << std::endl; + std::cout << "===========================" << std::endl; + +#pragma clang diagnostic ignored "-Wframe-address" // clang++ directive to ignore warnings about __b_f_a + auto curr_frame = reinterpret_cast(__builtin_frame_address(0)); // addr of curr stack frame + std::cout << "Current stack frame:\t" << curr_frame << std::endl; +#pragma clang diagnostic ignored "-Wframe-address" + auto prev_frame = reinterpret_cast(__builtin_frame_address(1)); // addr of prev stack frame + std::cout << "Previous stack frame:\t" << prev_frame << std::endl; + + heap.check_init(); // prints the saved absolute top of the stack + // auto alloced = heap->alloc(sizeof(unsigned long)); + + std::cout << "===========================" << std::endl; +} \ No newline at end of file diff --git a/src/GC/tests/file.cpp b/src/GC/tests/file.cpp new file mode 100644 index 0000000..df9e441 --- /dev/null +++ b/src/GC/tests/file.cpp @@ -0,0 +1,68 @@ +#include +#include +#include +#include +#include +#include + +void time_string(char *buffer); +void print_log_file(const std::string TESTS_PATH); +void readlink_test(); + +int main() +{ + // char time_buffer[31]; + // time_string(time_buffer); + + // const std::string TESTS_PATH = "/home/virre/dev/systemF/org/language/src/GC/tests/"; + // print_log_file(TESTS_PATH); + + readlink_test(); + + return 0; +} + +void time_string(char *const buffer) +{ + std::time_t tt = std::time(NULL); + std::tm *ptm = std::localtime(&tt); + std::strftime(buffer, 31, "/logs/log_%a_%H_%M_%S.txt", ptm); + std::cout << buffer << std::endl; +} + +void print_log_file(const std::string TESTS_PATH) +{ + std::string path = TESTS_PATH + "/testlog.txt"; + + std::ofstream testF(path); + + testF << "hellow york"; + + testF.close(); +} + +void readlink_test() +{ + char buffer[1024]; + ssize_t len = readlink("/proc/self/exe", buffer, sizeof(buffer)-1); + if (len == -1) + { + std::cout << "readlink error" << std::endl; + return; + } + + buffer[len] = '\0'; + std::cout << "readlink:\n" << "'''" << buffer << "'''"; // << std::endl; + + auto path = std::string(buffer); + std::cout << path << "\nlen: " << path.size() << "\ncap:" << path.capacity(); + + size_t last_slash = path.find_last_of('/'); + std::string folder = path.substr(0, last_slash); + + std::cout << "\n" << folder; + + std::string log_path = folder + "/log_file_bla.txt"; + std::cout << "\n" << log_path << std::endl; + +} \ No newline at end of file diff --git a/src/GC/tests/game.cpp b/src/GC/tests/game.cpp new file mode 100644 index 0000000..e01ec8e --- /dev/null +++ b/src/GC/tests/game.cpp @@ -0,0 +1,95 @@ +#include + +#include "player.hpp" +#include "heap.hpp" + +#define X_LENGTH 1000 +#define Y_LENGTH 500 +#define MAX_PLAYERS 100 + +/* +* Description: +* This class is designed to test the Garbage Collector with a mock game, +* that consists of several live objects in the form of players, that in +* turn consists partially of Point objects. +* +* Goal: +* to find out if all the objects are allocated successfully +* and to see if they are reachable from the stack, i.e. they can get marked. +* +* Result: +* all objects gets allocated, but only Game object gets marked. +*/ + + +class Game { + +private: + + std::vector *players; + //std::vector *players; + Point *dimensions; + +public: + + Game() { + dimensions->x = X_LENGTH; + dimensions->y = Y_LENGTH; + } + + void init() { + players = static_cast*>(GC::Heap::alloc(sizeof(Player*) * MAX_PLAYERS)); + //players = static_cast*>(GC::Heap::alloc(sizeof(Player) * MAX_PLAYERS)); + dimensions = static_cast(GC::Heap::alloc(sizeof(Point))); + dimensions->x = X_LENGTH; + dimensions->y = Y_LENGTH; + } + + void add_player(Player *p) { + players->push_back(p); + } + + Player* create_player(string *s, Point *pos, Point *size, Point *dir) { + Player *p = static_cast(GC::Heap::alloc(sizeof(Player))); + /* + Cannot allocate by new, since it the allocates outside of "out" heap. That also lead so us having to + define an alternative constructor, that's actually a method. Since our "alloc" does not call the constructor + of the object + */ + p->init(s, pos, size, dir); + return p; + } + + void create_players(int nr) { + for (int i = 0; i < nr; i++) { + + std::string *str = static_cast(GC::Heap::alloc(sizeof(std::string))); + Point *pos = static_cast(GC::Heap::alloc(sizeof(Point))); + Point *size = static_cast(GC::Heap::alloc(sizeof(Point))); + Point *dir = static_cast(GC::Heap::alloc(sizeof(Point))); + + Player *p = create_player(str, pos, size, dir); + add_player(p); + } + } + +}; + +int main() { + GC::Heap::init(); + GC::Heap *gc = GC::Heap::debug_the(); + gc->check_init(); + + Game *game = static_cast(gc->alloc(sizeof(Game))); + game->init(); + game->create_players(2); + + std::cout << "Player size: " << sizeof(Player) << std::endl; + std::cout << "Game size: " << sizeof(Game) << std::endl; + std::cout << "Point size: " << sizeof(Point) << std::endl; + + gc->collect(GC::MARK); + gc->print_contents(); + + return 0; +} \ No newline at end of file diff --git a/src/GC/tests/h_test.cpp b/src/GC/tests/h_test.cpp new file mode 100644 index 0000000..c871721 --- /dev/null +++ b/src/GC/tests/h_test.cpp @@ -0,0 +1,106 @@ +#include +#include + +#include "heap.hpp" + +using std::cout, std::endl; + +struct Node { + int id; + Node *child; +}; + +Node *create_chain(int depth) { + cout << "entering create_chain"; + std::vector nodes; + if (depth > 0) { + Node *last_node = static_cast(GC::Heap::alloc(sizeof(Node))); + last_node->id = depth; + last_node->child = nullptr; + nodes.push_back(last_node); + for (size_t i = 0; i < depth; i++) { + Node *node = static_cast(GC::Heap::alloc(sizeof(Node))); + node->id = depth-i; + node->child = nodes[i]; + nodes.push_back(node); + } + cout << "\nexiting create_chain" << endl; + return nodes[depth]; + } + else + return 0; +} + +void create_array(size_t size) { + int *arr = static_cast(GC::Heap::alloc(sizeof(int) * size)); +} + +void detach_pointer(long **ptr) { + cout << "entering detach_pointer"; + long *dummy_ptr = nullptr; + *ptr = dummy_ptr; + cout << "\nexiting detach_pointer" << endl; +} + +Node *test_chain(int depth, bool detach) { + cout << "entering test_chain"; + auto stack_start = reinterpret_cast(__builtin_frame_address(0)); + + Node *node_chain = create_chain(depth); + if (detach) + node_chain->child = nullptr; + + cout << "\nexiting test_chain" << endl; + return node_chain; +} + +void test_some_types() { + cout << "entering test_some_types" << endl; + auto stack_start = reinterpret_cast(__builtin_frame_address(0)); + std::cout << "Stack start from test_some_types:\t" << stack_start << std::endl; + + long *l = static_cast(GC::Heap::alloc(sizeof(long))); + std::cout << "l points to:\t\t" << l << std::endl; + detach_pointer(&l); + std::cout << "l points to:\t\t" << l << std::endl; + + // Some more dummy values of different sizes, to test stack pointer alignment + int *i = static_cast(GC::Heap::alloc(sizeof(int))); + char *c = static_cast(GC::Heap::alloc(sizeof(int))); + short *s = static_cast(GC::Heap::alloc(sizeof(short))); + cout << "exiting test_some_types" << endl; +} + +int main() { + cout << "entering main" << endl; + using namespace std::literals; + + auto start = std::chrono::high_resolution_clock::now(); + //std::cout << "Value of start: " << start.time_since_epoch().count() << std::endl; + GC::Heap::init(); + GC::Heap &gc = GC::Heap::the(); + gc.set_profiler(true); + gc.check_init(); + auto stack_start = reinterpret_cast(__builtin_frame_address(0)); + + Node *root1 = static_cast(gc.alloc(sizeof(Node))); + Node *root2 = static_cast(gc.alloc(sizeof(Node))); + root1 = test_chain(58000, false); + root2 = test_chain(58000, false); + + + gc.collect(GC::COLLECT_ALL); + auto end = std::chrono::high_resolution_clock::now(); + //std::cout << "Value of end: " << end.time_since_epoch().count() << std::endl; + + gc.print_summary(); + gc.dispose(); + + std::cout + << "Execution time: " + << std::chrono::duration_cast(end - start).count() << " ≈ " + << (end - start) / 1ms << "ms ≈ " + << (end - start) / 1s << "s.\n"; + + return 0; +} \ No newline at end of file diff --git a/src/GC/tests/linker.cpp b/src/GC/tests/linker.cpp new file mode 100644 index 0000000..36717c5 --- /dev/null +++ b/src/GC/tests/linker.cpp @@ -0,0 +1,30 @@ +#include + +#include "heap.hpp" + +struct Obj { + int a; + int b; + int c; +}; + +int main() { + auto heap = GC::Heap::debug_the(); + + std::cout << "heap:\t" << heap << std::endl; + + auto obj = static_cast(GC::Heap::alloc(sizeof(Obj))); + + std::cout << "obj: \t" << obj << std::endl; + + obj->a = 3; + obj->b = 4; + obj->c = 5; + + std::cout << obj->a << ", " << obj->b << ", " << obj->c << std::endl; + + heap->print_contents(); + //delete heap; + + return 0; +} \ No newline at end of file diff --git a/src/GC/tests/player.hpp b/src/GC/tests/player.hpp new file mode 100644 index 0000000..8a8e30f --- /dev/null +++ b/src/GC/tests/player.hpp @@ -0,0 +1,51 @@ +#include + +using std::string; + +class Point { + +public: + + int x, y; + Point() {} + Point(int _x, int _y) : x(_x), y(_y) {} +}; + +class Player { + +private: + + string *name; + Point *position; + Point *size; + Point *direction; + +public: + + Player() {} + +/* Player(string n, Point pos, Point s, Point dir) + : name(n), position(pos.x, pos.y), size(s.x, s.y), direction(dir.x, dir.y) + {} */ + + void move() { + position->x += direction->x; + position->y += direction->y; + } + + void set_speed(int dx, int dy) { + direction->x = dx; + direction->y = dy; + } + + // This is probably neccessary to initialize an object with our GC + // Since allocation and construction cannot be done at the same time + void init(string *n, Point *pos, Point *s, Point *dir) { + name = n; + position = pos; + size = s; + direction = dir; + + } + +}; diff --git a/src/GC/tests/stack.cpp b/src/GC/tests/stack.cpp new file mode 100644 index 0000000..8f8382e --- /dev/null +++ b/src/GC/tests/stack.cpp @@ -0,0 +1,76 @@ +#include +#include +#include +#include + +/* + * Stack.cpp + * - Tests stack scanning and stack pointers + * + * Goal: Find the values of the following variables + * and their position on the stack + * - unsigned long a + * - unsigned long b + * - unsigned long global_1 + * - unsigned long global_2 + * + * Result: Passed +*/ + + + + +std::vector iv; + +void collect() { + std::cout << "in collect" << std::endl; + + uintptr_t *stack_start = reinterpret_cast(__builtin_frame_address(0)); + + // denna orsakar segfault om man ger __b_f_a ett värde större än 2 + // uintptr_t *stack_end = reinterpret_cast(__builtin_frame_address(100)); + + std::cout << "SP1:\t" << stack_start << "\nSP2:\t" << (stack_start - 1*sizeof(int)) << std::endl; + std::cout << "SP-:\t" << --stack_start << std::endl; + + const uintptr_t *stack_end = (stack_start + 30*sizeof(int)); + int vars_found = 0; + + while (stack_start < stack_end) { + + if (std::find(iv.begin(), iv.end(), stack_start) != iv.end()) { + vars_found++; + std::cout << "Found " << *(reinterpret_cast(stack_start)) << " at " << stack_start << std::endl; + } + + // std::cout << "SP address:\t\t" << stack_start << "\nSP value:\t\t" << *(reinterpret_cast(stack_start)) << std::endl; + + stack_start++; + } + + if (vars_found == 0) { + std::cout << "Found nothing" << std::endl; + } +} + +int add(unsigned long a, unsigned long b) { + iv.push_back(reinterpret_cast(&a)); + iv.push_back(reinterpret_cast(&b)); + std::cout << "'a':\t" << &a << "\n'b':\t" << &b << std::endl; + collect(); + return a + b; +} + +int main() { + + unsigned long global_1 = 16; + unsigned long global_2 = 32; + + iv.push_back(&global_1); + iv.push_back(&global_2); + + std::cout << "'g1':\t" << &global_1 << "\n'g2':\t" << &global_2 << std::endl; + + add(3,2); + return 0; +} \ No newline at end of file diff --git a/src/GC/tests/stack2.cpp b/src/GC/tests/stack2.cpp new file mode 100644 index 0000000..f1a78bc --- /dev/null +++ b/src/GC/tests/stack2.cpp @@ -0,0 +1,51 @@ +#include +#include + +void dummy1(); +void dummy2(); + +int main() { + + uintptr_t *prev1 = reinterpret_cast(__builtin_frame_address(0)); + uintptr_t *prev2 = static_cast(__builtin_frame_address(0)); + + std::cout << "reinterpret:\t" << prev1 << "\nstatic:\t\t" << prev2 << std::endl; + + std::cout << "Start:\t\t" << prev1 << std::endl; +#pragma clang diagnostic ignored "-Wframe-address" + uintptr_t *tmp = reinterpret_cast(__builtin_frame_address(1)); + std::cout << "Frame 1:\t" << tmp << "\t\tDiff:\t" << std::hex << "0x"<< tmp - prev1 << std::endl; + prev1 = tmp; + +#pragma clang diagnostic ignored "-Wframe-address" + tmp = reinterpret_cast(__builtin_frame_address(2)); + std::cout << "Frame 2:\t" << tmp << "\tDiff:\t" << std::hex << "0x" << tmp - prev1 << std::endl; + prev1 = tmp; + +// arg > 2 for __builtin_frame_address() results in segfault +// #pragma clang diagnostic ignored "-Wframe-address" +// tmp = reinterpret_cast(__builtin_frame_address(3)); +// std::cout << "Frame 3:\t" << tmp << "\tDiff:\t" << std::hex << "0x" << prev1 - tmp << std::endl; + + dummy1(); + + return 0; +} + +void dummy1() { + std::cout << "D1 SFrame:\t" << __builtin_frame_address(0); +#pragma clang diagnostic ignored "-Wframe-address" + std::cout << "\t\tPrev:\t" << __builtin_frame_address(1) << std::endl; + std::cout << "D1 RA:\t\t" << std::hex << __builtin_return_address(0) << std::endl; + dummy2(); +} + +void dummy2() { + std::cout << "Frame:\t\t" << __builtin_frame_address(0); +#pragma clang diagnostic ignored "-Wframe-address" + std::cout << "\t\tPrev:\t" << __builtin_frame_address(1) << std::endl; + void *ra = __builtin_return_address(0); + std::cout << "D2 RA:\t\t" << std::hex << ra << std::endl; + // gives same value as pure 'ra' + // std::cout << "D2 ERA:\t\t" << std::hex << __builtin_extract_return_addr(ra) << std::endl; +} \ No newline at end of file diff --git a/src/GC/tests/struct_test.cpp b/src/GC/tests/struct_test.cpp new file mode 100644 index 0000000..2b2b677 --- /dev/null +++ b/src/GC/tests/struct_test.cpp @@ -0,0 +1,41 @@ +#include + +#include "heap.hpp" + +using namespace std; + +struct Node { + int value; + Node *left; + Node *right; +}; + +int getValue(); +Node *createNode(); +void insert(); + +int main() { + GC::Heap::init(); + Node *node = static_cast(GC::Heap::alloc(sizeof(Node))); + + return 0; +} + +int getValue() { + cout << "Enter a value to insert: "; + int value; + cin >> value; + return value; +} + +Node *createNode() { + Node *node = static_cast(GC::Heap::alloc(sizeof(Node))); + node->value = getValue(); + return node; +} + +void insert(Node *root) { + Node *node = createNode(); + Node *curr = root; + while (curr) +} \ No newline at end of file diff --git a/src/GC/todo.md b/src/GC/todo.md new file mode 100644 index 0000000..83fcf2c --- /dev/null +++ b/src/GC/todo.md @@ -0,0 +1,11 @@ +# Garbage collection + +## Project +Deliver to samuel + +## GC TODO: +- PR till master + +## Tests TODO +- Write complex datastructures for tests with larger programs +- Testa `__builtin_frame_address` mer specifikt för att se om första stack framen skannas \ No newline at end of file From b1d3e31efd3f8d3e82e6d094fce529654c790005 Mon Sep 17 00:00:00 2001 From: sebastianselander Date: Tue, 28 Mar 2023 14:31:20 +0200 Subject: [PATCH 203/372] Fixed previously incorrect type equality check, commented code, add test --- src/TypeChecker/Bugs.md | 36 +- src/TypeChecker/TypeCheckerHm.hs | 585 ++++++++++++++++--------------- tests/TestTypeCheckerHm.hs | 25 ++ 3 files changed, 335 insertions(+), 311 deletions(-) diff --git a/src/TypeChecker/Bugs.md b/src/TypeChecker/Bugs.md index 8dad339..fb986a5 100644 --- a/src/TypeChecker/Bugs.md +++ b/src/TypeChecker/Bugs.md @@ -27,38 +27,12 @@ Program below should not type check main : a -> b ; main x = x; ``` +## Pattern match on functions + +Program below should not type check -## Bugged error message ```hs -data Maybe () where { - Nothing : Maybe - Just : Int -> Maybe - }; - -fmap : (Int -> Int) -> Maybe -> Maybe ; -fmap f ma = case ma of { - Nothing => Nothing ; - Just a => Just (f a) ; -}; - -pure : Int -> Maybe ; -pure x = Just x ; - -ap mf ma = case mf of { - Just f => case ma of { - Nothing => Nothing; - Just a => Just (f a); - }; - Nothing => Nothing; -}; - -return = pure; - -bind ma f = case ma of { - Nothing => Nothing ; - Just a => f a ; +main = case \x. x of { + _ => 0; }; ``` -``` -TYPECHECKER ERROR -Inferred type '("c" -> "Int") -> "Maybe" -> "Maybe" does not match specified type '("Int" -> "Int") -> "Maybe" -> "Maybe"' diff --git a/src/TypeChecker/TypeCheckerHm.hs b/src/TypeChecker/TypeCheckerHm.hs index 1fc0ee4..2edd1f2 100644 --- a/src/TypeChecker/TypeCheckerHm.hs +++ b/src/TypeChecker/TypeCheckerHm.hs @@ -12,7 +12,6 @@ import Control.Monad.Except import Control.Monad.Identity (Identity, runIdentity) import Control.Monad.Reader import Control.Monad.State -import Data.Bifunctor (second) import Data.Coerce (coerce) import Data.Function (on) import Data.List (foldl') @@ -30,16 +29,17 @@ initCtx = Ctx mempty initEnv = Env 0 'a' mempty mempty mempty run :: Infer a -> Either Error a -run = runC initEnv initCtx +run = run' initEnv initCtx -runC :: Env -> Ctx -> Infer a -> Either Error a -runC e c = +run' :: Env -> Ctx -> Infer a -> Either Error a +run' e c = runIdentity . runExceptT . flip runReaderT c . flip evalStateT e . runInfer +-- | Type check a program typecheck :: Program -> Either String (T.Program' Type) typecheck = onLeft msg . run . checkPrg where @@ -47,20 +47,87 @@ typecheck = onLeft msg . run . checkPrg onLeft f (Left x) = Left $ f x onLeft _ (Right x) = Right x +checkPrg :: Program -> Infer (T.Program' Type) +checkPrg (Program bs) = do + preRun bs + bs' <- checkDef bs + return $ T.Program bs' + +preRun :: [Def] -> Infer () +preRun [] = return () +preRun (x : xs) = case x of + DSig (Sig n t) -> do + collect (collectTVars t) + gets (M.member (coerce n) . sigs) + >>= flip + when + ( uncatchableErr $ Aux.do + "Duplicate signatures for function" + quote $ printTree n + ) + insertSig (coerce n) (Just t) >> preRun xs + DBind (Bind n _ e) -> do + collect (collectTVars e) + s <- gets sigs + case M.lookup (coerce n) s of + Nothing -> insertSig (coerce n) Nothing >> preRun xs + Just _ -> preRun xs + DData d@(Data t _) -> collect (collectTVars t) >> checkData d >> preRun xs + +checkDef :: [Def] -> Infer [T.Def' Type] +checkDef [] = return [] +checkDef (x : xs) = case x of + (DBind b) -> do + b' <- checkBind b + xs' <- checkDef xs + return $ T.DBind b' : xs' + (DData d) -> do + xs' <- checkDef xs + return $ T.DData (coerceData d) : xs' + (DSig _) -> checkDef xs + where + coerceData (Data t injs) = + T.Data t $ map (\(Inj name typ) -> T.Inj (coerce name) typ) injs + +checkBind :: Bind -> Infer (T.Bind' Type) +checkBind (Bind name args e) = do + let lambda = makeLambda e (reverse (coerce args)) + (sub0, (e, lambda_t)) <- inferExp lambda + s <- gets sigs + case M.lookup (coerce name) s of + Just (Just t') -> do + let fsig = apply sub0 t' + sub1 <- liftEither $ runIdentity $ runExceptT $ execStateT (typeEq fsig lambda_t) mempty + sub2 <- liftEither $ runIdentity $ runExceptT $ execStateT (typeEq lambda_t fsig) mempty + unless + (lambda_t == apply sub1 fsig && apply sub2 lambda_t == fsig) + ( uncatchableErr $ Aux.do + "Inferred type" + quote $ printTree lambda_t + "does not match specified type" + quote $ printTree t' + ) + return $ T.Bind (coerce name, lambda_t) [] (e, lambda_t) + _ -> do + insertSig (coerce name) (Just lambda_t) + return (T.Bind (coerce name, lambda_t) [] (e, lambda_t)) + checkData :: Data -> Infer () checkData err@(Data typ injs) = do (name, tvars) <- go typ - dataErr (mapM_ (\i -> typecheckInj i name tvars) injs) err + dataErr (mapM_ (\i -> checkInj i name tvars) injs) err where go = \case TData name typs | Right tvars' <- mapM toTVar typs -> pure (name, tvars') TAll _ _ -> uncatchableErr "Explicit foralls not allowed, for now" - _ -> uncatchableErr $ unwords ["Bad data type definition: ", printTree typ] + _ -> + uncatchableErr $ + unwords ["Bad data type definition: ", printTree typ] -typecheckInj :: Inj -> UIdent -> [TVar] -> Infer () -typecheckInj (Inj c inj_typ) name tvars +checkInj :: Inj -> UIdent -> [TVar] -> Infer () +checkInj (Inj c inj_typ) name tvars | Right False <- boundTVars tvars inj_typ = catchableErr "Unbound type variables" | TData name' typs <- returnType inj_typ @@ -108,109 +175,11 @@ returnType :: Type -> Type returnType (TFun _ t2) = returnType t2 returnType a = a -checkPrg :: Program -> Infer (T.Program' Type) -checkPrg (Program bs) = do - preRun bs - bs' <- checkDef bs - return $ T.Program bs' - -preRun :: [Def] -> Infer () -preRun [] = return () -preRun (x : xs) = case x of - DSig (Sig n t) -> do - collect (collectTVars t) - gets (M.member (coerce n) . sigs) - >>= flip - when - ( uncatchableErr $ Aux.do - "Duplicate signatures for function" - quote $ printTree n - ) - insertSig (coerce n) (Just t) >> preRun xs - DBind (Bind n _ e) -> do - collect (collectTVars e) - s <- gets sigs - case M.lookup (coerce n) s of - Nothing -> insertSig (coerce n) Nothing >> preRun xs - Just _ -> preRun xs - DData d@(Data t _) -> collect (collectTVars t) >> checkData d >> preRun xs - -checkDef :: [Def] -> Infer [T.Def' Type] -checkDef [] = return [] -checkDef (x : xs) = case x of - (DBind b) -> do - b' <- checkBind b - xs' <- checkDef xs - return $ T.DBind b' : xs' - (DData d) -> do - xs' <- checkDef xs - return $ T.DData (coerceData d) : xs' - (DSig _) -> checkDef xs - where - coerceData (Data t injs) = - T.Data t $ map (\(Inj name typ) -> T.Inj (coerce name) typ) injs - -checkBind :: Bind -> Infer (T.Bind' Type) -checkBind (Bind name args e) = do - let lambda = makeLambda e (reverse (coerce args)) - (e, lambda_t) <- inferExp lambda - s <- gets sigs - case M.lookup (coerce name) s of - Just (Just t') -> do - sub1 <- unify lambda_t t' - sub2 <- unify t' lambda_t - unless - (apply sub1 lambda_t == t' && lambda_t == apply sub2 t') - ( uncatchableErr $ Aux.do - "Inferred type" - quote $ printTree lambda_t - "does not match specified type" - quote $ printTree t' - ) - return $ T.Bind (coerce name, t') [] (e, lambda_t) - _ -> do - insertSig (coerce name) (Just lambda_t) - return (T.Bind (coerce name, lambda_t) [] (e, lambda_t)) - -typeEq :: Type -> Type -> Bool -typeEq (TFun l r) (TFun l' r') = typeEq l l' && typeEq r r' -typeEq (TLit a) (TLit b) = a == b -typeEq (TData name a) (TData name' b) = - length a == length b - && name == name' - && and (zipWith typeEq a b) -typeEq (TAll _ t1) t2 = t1 `typeEq` t2 -typeEq t1 (TAll _ t2) = t1 `typeEq` t2 -typeEq (TVar _) (TVar _) = True -typeEq _ _ = False - -skolemize :: Type -> Type -skolemize (TVar (MkTVar a)) = TEVar (MkTEVar $ coerce a) -skolemize (TAll x t) = TAll x (skolemize t) -skolemize (TFun t1 t2) = (TFun `on` skolemize) t1 t2 -skolemize t = t - -isMoreSpecificOrEq :: Type -> Type -> Bool -isMoreSpecificOrEq t1 (TAll _ t2) = isMoreSpecificOrEq t1 t2 -isMoreSpecificOrEq (TFun a b) (TFun c d) = - isMoreSpecificOrEq a c && isMoreSpecificOrEq b d -isMoreSpecificOrEq (TData n1 ts1) (TData n2 ts2) = - n1 == n2 - && length ts1 == length ts2 - && and (zipWith isMoreSpecificOrEq ts1 ts2) -isMoreSpecificOrEq _ (TVar _) = True -isMoreSpecificOrEq a b = a == b - -isPoly :: Type -> Bool -isPoly (TAll _ _) = True -isPoly (TVar _) = True -isPoly _ = False - -inferExp :: Exp -> Infer (T.ExpT' Type) +inferExp :: Exp -> Infer (Subst, T.ExpT' Type) inferExp e = do (s, (e', t)) <- algoW e let subbed = apply s t - return $ second (const subbed) (e', t) + return (s, (e', subbed)) class CollectTVars a where collectTVars :: a -> Set T.Ident @@ -223,7 +192,8 @@ instance CollectTVars Type where collectTVars (TVar (MkTVar i)) = S.singleton (coerce i) collectTVars (TAll _ t) = collectTVars t collectTVars (TFun t1 t2) = (S.union `on` collectTVars) t1 t2 - collectTVars (TData _ ts) = foldl' (\acc x -> acc `S.union` collectTVars x) S.empty ts + collectTVars (TData _ ts) = + foldl' (\acc x -> acc `S.union` collectTVars x) S.empty ts collectTVars _ = S.empty collect :: Set T.Ident -> Infer () @@ -232,7 +202,7 @@ collect s = modify (\st -> st{takenTypeVars = s `S.union` takenTypeVars st}) algoW :: Exp -> Infer (Subst, T.ExpT' Type) algoW = \case err@(EAnn e t) -> do - (s1, (e', t')) <- exprErr (algoW e) err + (sub0, (e', t')) <- exprErr (algoW e) err sub1 <- unify t t' sub2 <- unify t' t unless @@ -243,8 +213,7 @@ algoW = \case "does not match inferred type" quote $ printTree t' ) - s2 <- exprErr (unify t t') err - let comp = s2 `compose` s1 + let comp = sub2 `compose` sub1 `compose` sub0 return (comp, apply comp (e', t)) -- \| ------------------ @@ -257,7 +226,9 @@ algoW = \case EVar i -> do var <- asks vars case M.lookup (coerce i) var of - Just t -> inst t >>= \x -> return (nullSubst, (T.EVar $ coerce i, x)) + Just t -> + inst t >>= \x -> + return (nullSubst, (T.EVar $ coerce i, x)) Nothing -> do sig <- gets sigs case M.lookup (coerce i) sig of @@ -266,7 +237,10 @@ algoW = \case fr <- fresh insertSig (coerce i) (Just fr) return (nullSubst, (T.EVar $ coerce i, fr)) - Nothing -> uncatchableErr $ "Unbound variable: " <> printTree i + Nothing -> + uncatchableErr $ + "Unbound variable: " + <> printTree i EInj i -> do constr <- gets injections case M.lookup (coerce i) constr of @@ -283,14 +257,11 @@ algoW = \case err@(EAbs name e) -> do fr <- fresh - exprErr - ( withBinding (coerce name) fr $ do - (s1, (e', t')) <- exprErr (algoW e) err - let varType = apply s1 fr - let newArr = TFun varType t' - return (s1, apply s1 (T.EAbs (coerce name) (e', t'), newArr)) - ) - err + withBinding (coerce name) fr $ do + (s1, (e', t')) <- exprErr (algoW e) err + let varType = apply s1 fr + let newArr = TFun varType t' + return (s1, apply s1 (T.EAbs (coerce name) (e', t'), newArr)) -- \| Γ ⊢ e₀ : τ₀, S₀ S₀Γ ⊢ e₁ : τ₁, S₁ -- \| s₂ = mgu(s₁τ₀, Int) s₃ = mgu(s₂τ₁, Int) @@ -338,29 +309,120 @@ algoW = \case (s2, (e1', t2)) <- algoW e1 let comp = s2 `compose` s1 return (comp, apply comp (T.ELet bind' (e1', t2), t2)) - - -- \| TODO: Add judgement ECase caseExpr injs -> do (sub, (e', t)) <- algoW caseExpr (subst, injs, ret_t) <- checkCase t injs let comp = subst `compose` sub return (comp, apply comp (T.ECase (e', t) injs, ret_t)) -makeLambda :: Exp -> [T.Ident] -> Exp -makeLambda = foldl (flip (EAbs . coerce)) +checkCase :: Type -> [Branch] -> Infer (Subst, [T.Branch' Type], Type) +checkCase _ [] = catchableErr "Atleast one case required" +checkCase expT brnchs = do + (subs, branchTs, injs, returns) <- unzip4 <$> mapM inferBranch brnchs + let sub0 = composeAll subs + (sub1, _) <- + foldM + ( \(sub, acc) x -> + (\a -> (a `compose` sub, a `apply` acc)) <$> unify x acc + ) + (nullSubst, expT) + branchTs + (sub2, returns_type) <- + foldM + ( \(sub, acc) x -> + (\a -> (a `compose` sub, a `apply` acc)) <$> unify x acc + ) + (nullSubst, head returns) + (tail returns) + let comp = sub2 `compose` sub1 `compose` sub0 + return (comp, apply comp injs, apply comp returns_type) + +inferBranch :: Branch -> Infer (Subst, Type, T.Branch' Type, Type) +inferBranch (Branch pat expr) = do + newPat@(pat, branchT) <- inferPattern pat + (sub, newExp@(_, exprT)) <- withPattern pat (algoW expr) + return + ( sub + , apply sub branchT + , T.Branch (apply sub newPat) (apply sub newExp) + , apply sub exprT + ) + +inferPattern :: Pattern -> Infer (T.Pattern' Type, Type) +inferPattern = \case + PLit lit -> let lt = litType lit in return (T.PLit (lit, lt), lt) + PInj constr patterns -> do + t <- gets (M.lookup (coerce constr) . injections) + t <- + maybeToRightM + ( Error + ( Aux.do + "Constructor:" + quote $ printTree constr + "does not exist" + ) + True + ) + t + let numArgs = typeLength t - 1 + let (vs, ret) = fromJust (unsnoc $ flattenType t) + patterns <- mapM inferPattern patterns + unless + (length patterns == numArgs) + ( catchableErr $ Aux.do + "The constructor" + quote $ printTree constr + " should have " + show numArgs + " arguments but has been given " + show (length patterns) + ) + sub <- composeAll <$> zipWithM unify vs (map snd patterns) + return + ( T.PInj (coerce constr) (apply sub (map fst patterns)) + , apply sub ret + ) + PCatch -> (T.PCatch,) <$> fresh + PEnum p -> do + t <- gets (M.lookup (coerce p) . injections) + t <- + maybeToRightM + ( Error + ( Aux.do + "Constructor:" + quote $ printTree p + "does not exist" + ) + True + ) + t + unless + (typeLength t == 1) + ( catchableErr $ Aux.do + "The constructor" + quote $ printTree p + " should have " + show (typeLength t - 1) + " arguments but has been given 0" + ) + let (TData _data _ts) = t -- nasty nasty + frs <- mapM (const fresh) _ts + return (T.PEnum $ coerce p, TData _data frs) + PVar x -> do + fr <- fresh + let pvar = T.PVar (coerce x, fr) + return (pvar, fr) -- | Unify two types producing a new substitution unify :: Type -> Type -> Infer Subst -unify t0 t1 = do +unify t0 t1 = case (t0, t1) of (TFun a b, TFun c d) -> do s1 <- unify a c s2 <- unify (apply s1 b) (apply s1 d) return $ s1 `compose` s2 - ----------- TODO: BE CAREFUL!!!! THIS IS PROBABLY WRONG!!! ----------- (TVar (T.MkTVar a), t@(TData _ _)) -> return $ M.singleton (coerce a) t (t@(TData _ _), TVar (T.MkTVar b)) -> return $ M.singleton (coerce b) t - ------------------------------------------------------------------- (TVar (T.MkTVar a), t) -> occurs (coerce a) t (t, TVar (T.MkTVar b)) -> occurs (coerce b) t (TAll _ t, b) -> unify t b @@ -422,7 +484,12 @@ occurs i t = ) else return $ M.singleton i t --- | Generalize a type over all free variables in the substitution set +{- | Generalize a type over all free variables in the substitution set + Used for let bindings to allow expression that do not type check in + equivalent lambda expressions: + Type checks: let f = \x. x in (f True, f 'a') + Does not type check: (\f. (f True, f 'a')) (\x. x) +-} generalize :: Map T.Ident Type -> Type -> Type generalize env t = go (S.toList $ free t S.\\ free env) (removeForalls t) where @@ -446,15 +513,27 @@ inst = \case TFun t1 t2 -> TFun <$> inst t1 <*> inst t2 rest -> return rest --- | Compose two substitution sets -compose :: Subst -> Subst -> Subst -compose m1 m2 = M.map (apply m1) m2 `M.union` m1 - -composeAll :: [Subst] -> Subst -composeAll = foldl' compose nullSubst - --- TODO: Split this class into two separate classes, one for free variables --- and one for applying substitutions +-- | Generate a new fresh variable +fresh :: Infer Type +fresh = do + c <- gets nextChar + n <- gets count + taken <- gets takenTypeVars + if c == 'z' + then do + modify (\st -> st{count = succ (count st), nextChar = 'a'}) + else modify (\st -> st{nextChar = next (nextChar st)}) + if coerce [c] `S.member` taken + then do + fresh + else + if n == 0 + then return . TVar . T.MkTVar $ LIdent [c] + else return . TVar . T.MkTVar . LIdent $ c : show n + where + next :: Char -> Char + next 'z' = 'a' + next a = succ a -- | A class for substitutions class SubstType t where @@ -468,7 +547,8 @@ class FreeVars t where instance FreeVars Type where free :: Type -> Set T.Ident free (TVar (T.MkTVar a)) = S.singleton (coerce a) - free (TAll (T.MkTVar bound) t) = S.singleton (coerce bound) `S.intersection` free t + free (TAll (T.MkTVar bound) t) = + S.singleton (coerce bound) `S.intersection` free t free (TLit _) = mempty free (TFun a b) = free a `S.union` free b free (TData _ a) = free a @@ -540,27 +620,19 @@ instance SubstType (T.Id' Type) where nullSubst :: Subst nullSubst = M.empty --- | Generate a new fresh variable and increment the state counter -fresh :: Infer Type -fresh = do - c <- gets nextChar - n <- gets count - taken <- gets takenTypeVars - if c == 'z' - then do - modify (\st -> st{count = succ (count st), nextChar = 'a'}) - else modify (\st -> st{nextChar = next (nextChar st)}) - if coerce [c] `S.member` taken - then do - fresh - else - if n == 0 - then return . TVar . T.MkTVar $ LIdent [c] - else return . TVar . T.MkTVar . LIdent $ c : show n - where - next :: Char -> Char - next 'z' = 'a' - next a = succ a +-- | Compose two substitution sets +compose :: Subst -> Subst -> Subst +compose m1 m2 = M.map (apply m1) m2 `M.union` m1 + +-- | Compose a list of substitution sets into one +composeAll :: [Subst] -> Subst +composeAll = foldl' compose nullSubst + +{- | Convert a function with arguments to its pointfree version +> makeLambda (add x y = x + y) = add = \x. \y. x + y +-} +makeLambda :: Exp -> [T.Ident] -> Exp +makeLambda = foldl (flip (EAbs . coerce)) -- | Run the monadic action with an additional binding withBinding :: (Monad m, MonadReader Ctx m) => T.Ident -> Type -> m a -> m a @@ -571,49 +643,8 @@ withBindings :: (Monad m, MonadReader Ctx m) => [(T.Ident, Type)] -> m a -> m a withBindings xs = local (\st -> st{vars = foldl' (flip (uncurry M.insert)) (vars st) xs}) --- | Insert a function signature into the environment -insertSig :: T.Ident -> Maybe Type -> Infer () -insertSig i t = modify (\st -> st{sigs = M.insert i t (sigs st)}) - --- | Insert a constructor with its data type -insertInj :: T.Ident -> Type -> Infer () -insertInj i t = - modify (\st -> st{injections = M.insert i t (injections st)}) - -existInj :: T.Ident -> Infer (Maybe Type) -existInj n = gets (M.lookup n . injections) - --------- PATTERN MATCHING --------- - -checkCase :: Type -> [Branch] -> Infer (Subst, [T.Branch' Type], Type) -checkCase _ [] = catchableErr "Atleast one case required" -checkCase expT brnchs = do - (subs, injTs, injs, returns) <- unzip4 <$> mapM inferBranch brnchs - let sub0 = composeAll subs - (sub1, _) <- - foldM - ( \(sub, acc) x -> - (\a -> (a `compose` sub, a `apply` acc)) <$> unify x acc - ) - (nullSubst, expT) - injTs - (sub2, returns_type) <- - foldM - ( \(sub, acc) x -> - (\a -> (a `compose` sub, a `apply` acc)) <$> unify x acc - ) - (nullSubst, head returns) - (tail returns) - let comp = sub2 `compose` sub1 `compose` sub0 - return (comp, apply comp injs, apply comp returns_type) - -inferBranch :: Branch -> Infer (Subst, Type, T.Branch' Type, Type) -inferBranch (Branch pat expr) = do - newPat@(pat, branchT) <- inferPattern pat - (sub, newExp@(_, exprT)) <- withPattern pat (algoW expr) - return (sub, apply sub branchT, T.Branch (apply sub newPat) (apply sub newExp), apply sub exprT) - -withPattern :: T.Pattern' Type -> Infer a -> Infer a +-- | Run the monadic action with a pattern +withPattern :: (Monad m, MonadReader Ctx m) => T.Pattern' Type -> m a -> m a withPattern p ma = case p of T.PVar (x, t) -> withBinding x t ma T.PInj _ ps -> foldl' (flip withPattern) ma ps @@ -621,74 +652,27 @@ withPattern p ma = case p of T.PCatch -> ma T.PEnum _ -> ma -inferPattern :: Pattern -> Infer (T.Pattern' Type, Type) -inferPattern = \case - PLit lit -> let lt = litType lit in return (T.PLit (lit, lt), lt) - PInj constr patterns -> do - t <- gets (M.lookup (coerce constr) . injections) - t <- - maybeToRightM - ( Error - ( Aux.do - "Constructor:" - quote $ printTree constr - "does not exist" - ) - True - ) - t - let numArgs = typeLength t - 1 - let (vs, ret) = fromJust (unsnoc $ flattenType t) - patterns <- mapM inferPattern patterns - unless - (length patterns == numArgs) - ( catchableErr $ Aux.do - "The constructor" - quote $ printTree constr - " should have " - show numArgs - " arguments but has been given " - show (length patterns) - ) - sub <- composeAll <$> zipWithM unify vs (map snd patterns) - return (T.PInj (coerce constr) (apply sub (map fst patterns)), apply sub ret) - PCatch -> (T.PCatch,) <$> fresh - PEnum p -> do - t <- gets (M.lookup (coerce p) . injections) - t <- - maybeToRightM - ( Error - ( Aux.do - "Constructor:" - quote $ printTree p - "does not exist" - ) - True - ) - t - unless - (typeLength t == 1) - ( catchableErr $ Aux.do - "The constructor" - quote $ printTree p - " should have " - show (typeLength t - 1) - " arguments but has been given 0" - ) - let (TData _data _ts) = t -- nasty nasty - frs <- mapM (const fresh) _ts - return (T.PEnum $ coerce p, TData _data frs) - PVar x -> do - fr <- fresh - let pvar = T.PVar (coerce x, fr) - return (pvar, fr) +-- | Insert a function signature into the environment +insertSig :: T.Ident -> Maybe Type -> Infer () +insertSig i t = modify (\st -> st{sigs = M.insert i t (sigs st)}) + +-- | Insert a constructor into the start with its type +insertInj :: T.Ident -> Type -> Infer () +insertInj i t = + modify (\st -> st{injections = M.insert i t (injections st)}) + +{- | Check if an injection (constructor of data type) +with an equivalent name has been declared already +-} +existInj :: T.Ident -> Infer (Maybe Type) +existInj n = gets (M.lookup n . injections) flattenType :: Type -> [Type] flattenType (TFun a b) = flattenType a <> flattenType b flattenType a = [a] typeLength :: Type -> Int -typeLength (TFun a b) = typeLength a + typeLength b +typeLength (TFun _ b) = 1 + typeLength b typeLength _ = 1 litType :: Lit -> Type @@ -698,23 +682,63 @@ litType (LChar _) = char int = TLit "Int" char = TLit "Char" -partitionType :: - Int -> -- Number of parameters to apply - Type -> - ([Type], Type) -partitionType = go [] - where - go acc 0 t = (acc, t) - go acc i t = case t of - TAll tvar t' -> second (TAll tvar) $ go acc i t' - TFun t1 t2 -> go (acc <> [t1]) (i - 1) t2 - _ -> error "Number of parameters and type doesn't match" +typeEq :: Type -> Type -> StateT Subst (ExceptT Error Identity) () +typeEq (TVar (T.MkTVar a)) t@(TVar _) = do + st <- get + case M.lookup (coerce a) st of + Nothing -> put $ M.insert (coerce a) t st + Just t' -> unless (t == t') (catchableErr "TYPE MISMATCH") +typeEq (TFun l r) (TFun l' r') = typeEq l l' *> typeEq r r' +typeEq (TAll _ l) (TAll _ r) = typeEq l r +typeEq (TLit a) (TLit b) = unless (a == b) (catchableErr "TYPE MISMATCH") +typeEq (TData nameL tL) (TData nameR tR) = do + unless (nameL == nameR) (catchableErr "TYPE MISMATCH") + zipWithM_ typeEq tL tR +typeEq (TEVar _) (TEVar _) = catchableErr "TYPE MISMATCH" +typeEq _ _ = catchableErr "TYPE MISMATCH" -exprErr :: Infer a -> Exp -> Infer a -exprErr ma exp = catchError ma (\x -> if x.catchable then throwError (x{msg = x.msg <> " in expression: \n" <> printTree exp, catchable = False}) else throwError x) +{- | Catch an error if possible and add the given +expression as addition to the error message +-} +exprErr :: (Monad m, MonadError Error m) => m a -> Exp -> m a +exprErr ma exp = + catchError + ma + ( \x -> + if x.catchable + then + throwError + ( x + { msg = + x.msg + <> " in expression: \n" + <> printTree exp + , catchable = False + } + ) + else throwError x + ) +{- | Catch an error if possible and add the given +data as addition to the error message +-} dataErr :: Infer a -> Data -> Infer a -dataErr ma d = catchError ma (\x -> if x.catchable then throwError (x{msg = x.msg <> " in data: \n" <> printTree d}) else throwError (x{catchable = False})) +dataErr ma d = + catchError + ma + ( \x -> + if x.catchable + then + throwError + ( x + { msg = + x.msg + <> " in data: \n" + <> printTree d + } + ) + else throwError (x{catchable = False}) + ) unzip4 :: [(a, b, c, d)] -> ([a], [b], [c], [d]) unzip4 = @@ -737,6 +761,7 @@ data Env = Env deriving (Show) data Error = Error {msg :: String, catchable :: Bool} + deriving (Show) type Subst = Map T.Ident Type newtype Infer a = Infer {runInfer :: StateT Env (ReaderT Ctx (ExceptT Error Identity)) a} diff --git a/tests/TestTypeCheckerHm.hs b/tests/TestTypeCheckerHm.hs index 5f600ed..bf51a29 100644 --- a/tests/TestTypeCheckerHm.hs +++ b/tests/TestTypeCheckerHm.hs @@ -187,6 +187,31 @@ bes = " Nil => 0 ;" " };" ) + , testBe + "length function on int list infers correct signature" + ( D.do + "data List () where {" + " Nil : List ()" + " Cons : Int -> List () -> List ()" + "};" + + "length xs = case xs of {" + " Nil => 0 ;" + " Cons _ xs => 1 + length xs ;" + "};" + ) + ( D.do + "data List () where {" + " Nil : List ()" + " Cons : Int -> List () -> List ()" + "};" + + "length : List () -> Int ;" + "length xs = case xs of {" + " Nil => 0 ;" + " Cons _ xs => 1 + length xs ;" + "};" + ) ] testSatisfy desc test satisfaction = specify desc $ run test `shouldSatisfy` satisfaction From 5986e2108e2f5874718f898d4969f3e4204e615b Mon Sep 17 00:00:00 2001 From: Samuel Hammersberg Date: Tue, 28 Mar 2023 15:32:54 +0200 Subject: [PATCH 204/372] Added c output files to the gitignore --- .gitignore | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/.gitignore b/.gitignore index 3eaf9f6..8e68689 100644 --- a/.gitignore +++ b/.gitignore @@ -5,4 +5,7 @@ dist-newstyle src/Grammar language test_program_result -output/ \ No newline at end of file +output/ +*.o +*.out +*.a \ No newline at end of file From 59d9be87cb51ef025288bfd10aa82d628086d9d2 Mon Sep 17 00:00:00 2001 From: Martin Fredin Date: Tue, 28 Mar 2023 15:35:01 +0200 Subject: [PATCH 205/372] Add cases for lambda lifter --- src/LambdaLifter.hs | 54 +++++++++++++++++++++++++++++++++++++++++---- 1 file changed, 50 insertions(+), 4 deletions(-) diff --git a/src/LambdaLifter.hs b/src/LambdaLifter.hs index b85dd8b..5020fb6 100644 --- a/src/LambdaLifter.hs +++ b/src/LambdaLifter.hs @@ -4,11 +4,12 @@ module LambdaLifter (lambdaLift, freeVars, abstract, collectScs) where -import Auxiliary (snoc) +import Auxiliary (mapAccumM, snoc) import Control.Applicative (Applicative (liftA2)) +import Control.Arrow (Arrow (second)) import Control.Monad.State (MonadState (get, put), State, evalState) -import Data.List (partition) +import Data.List (mapAccumL, partition) import Data.Set (Set) import qualified Data.Set as Set import Prelude hiding (exp) @@ -40,6 +41,8 @@ freeVarsExp localVars (exp, t) = case exp of EVar n | Set.member n localVars -> (Set.singleton n, (AVar n, t)) | otherwise -> (mempty, (AVar n, t)) + EInj n -> (mempty, (AVar n, t)) + ELit lit -> (mempty, (ALit lit, t)) EApp e1 e2 -> (Set.union (freeVarsOf e1') (freeVarsOf e2'), (AApp e1' e2', t)) @@ -68,6 +71,25 @@ freeVarsExp localVars (exp, t) = case exp of e' = freeVarsExp e_localVars e e_localVars = Set.insert name localVars + ECase e branches -> (frees, (ACase e' branches', t)) + where + frees = foldr (\b s -> Set.union s $ fst b) (freeVarsOf e') branches' + e' = freeVarsExp localVars e + branches' = map (freeVarsBranch localVars) branches + + +freeVarsBranch :: Set Ident -> Branch' Type -> (Set Ident, AnnBranch') +freeVarsBranch localVars (Branch (patt, t) exp) = (frees, AnnBranch (patt, t) exp') + where + frees = freeVarsOf exp' Set.\\ freeVarsOfPattern patt + exp' = freeVarsExp localVars exp + freeVarsOfPattern = Set.fromList . go [] + where + go acc = \case + PVar (n,_) -> snoc n acc + PInj _ ps -> foldl go acc ps + + freeVarsOf :: AnnExpT -> Set Ident freeVarsOf = fst @@ -81,6 +103,10 @@ data ABind = ABind Id [Id] AnnExpT deriving Show type AnnExpT' = (AnnExp, Type) +type AnnBranch = (Set Ident, AnnBranch') +data AnnBranch' = AnnBranch (Pattern, Type) AnnExpT + deriving Show + data AnnExp = AVar Ident | AInj Ident | ALit Lit @@ -88,6 +114,7 @@ data AnnExp = AVar Ident | AApp AnnExpT AnnExpT | AAdd AnnExpT AnnExpT | AAbs Ident AnnExpT + | ACase AnnExpT [AnnBranch] deriving Show -- | Lift lambdas to let expression of the form @let sc = \v₁ x₁ -> e₁@. @@ -115,7 +142,8 @@ flattenLambdasAnn ae = go (ae, []) abstractExp :: AnnExpT -> State Int ExpT abstractExp (free, (exp, typ)) = case exp of - AVar n -> pure (EVar n, typ) + AVar n -> pure (EVar n, typ) + AInj n -> pure (EInj n, typ) ALit lit -> pure (ELit lit, typ) AApp e1 e2 -> (, typ) <$> liftA2 EApp (abstractExp e1) (abstractExp e2) AAdd e1 e2 -> (, typ) <$> liftA2 EAdd (abstractExp e1) (abstractExp e2) @@ -132,6 +160,9 @@ abstractExp (free, (exp, typ)) = case exp of pure (EAbs par ae1', t) _ -> f (free, (ae, t)) + ACase e branches -> (, typ) <$> liftA2 ECase (abstractExp e) (mapM abstractBranch branches) + + -- Lift lambda into let and bind free variables AAbs parm e -> do i <- nextNumber @@ -149,6 +180,10 @@ abstractExp (free, (exp, typ)) = case exp of where (t_var, t_return) = applyVarType t + +abstractBranch :: AnnBranch -> State Int Branch +abstractBranch (_, AnnBranch patt exp) = Branch patt <$> abstractExp exp + applyVarType :: Type -> (Type, Type) applyVarType typ = (t1, foldr ($) t2 foralls) @@ -182,7 +217,8 @@ collectScs = concatMap collectFromRhs collectScsExp :: ExpT -> ([Bind], ExpT) collectScsExp expT@(exp, typ) = case exp of EVar _ -> ([], expT) - ELit _ -> ([], expT) + EInj _ -> ([], expT) + ELit _ -> ([], expT) EApp e1 e2 -> (scs1 ++ scs2, (EApp e1' e2', typ)) where @@ -198,6 +234,12 @@ collectScsExp expT@(exp, typ) = case exp of where (scs, e') = collectScsExp e + ECase e branches -> (scs, (ECase e branches', typ)) + where + (scs, branches') = mapAccumL f [] branches + f acc b = (acc ++ acc', b') + where (acc', b') = collectScsBranch b + -- Collect supercombinators from bind, the rhss, and the expression. -- -- > f = let sc x y = rhs in e @@ -210,6 +252,9 @@ collectScsExp expT@(exp, typ) = case exp of (rhs_scs, rhs') = collectScsExp rhs (et_scs, et') = collectScsExp e +collectScsBranch (Branch patt exp) = (scs, Branch patt exp') + where (scs, exp') = collectScsExp exp + -- @\x.\y.\z. e → (e, [x,y,z])@ flattenLambdas :: ExpT -> (ExpT, [Id]) @@ -240,3 +285,4 @@ skipForalls = go [] go acc typ = case typ of TAll tvar t -> go (snoc (TAll tvar) acc) t _ -> (acc, typ) + From 7f0dab6dcbd096518ccef04347625701f6092f7a Mon Sep 17 00:00:00 2001 From: sebastianselander Date: Tue, 28 Mar 2023 15:35:48 +0200 Subject: [PATCH 206/372] adapted changes to work --- src/TypeChecker/RemoveTEVar.hs | 4 ++-- src/TypeChecker/TypeCheckerHm.hs | 32 ++++++++++++++--------------- src/TypeChecker/TypeCheckerIr.hs | 35 +++++++++++++++++--------------- 3 files changed, 37 insertions(+), 34 deletions(-) diff --git a/src/TypeChecker/RemoveTEVar.hs b/src/TypeChecker/RemoveTEVar.hs index 43a87f7..bfa06ba 100644 --- a/src/TypeChecker/RemoveTEVar.hs +++ b/src/TypeChecker/RemoveTEVar.hs @@ -64,8 +64,8 @@ instance RemoveTEVar a b => RemoveTEVar [a] [b] where instance RemoveTEVar Type T.Type where rmTEVar = \case TLit lit -> pure $ T.TLit (coerce lit) - TVar tvar -> pure $ T.TVar tvar + TVar tvar -> pure $ T.TVar (coerce tvar) TData name typs -> T.TData (coerce name) <$> rmTEVar typs TFun t1 t2 -> liftA2 T.TFun (rmTEVar t1) (rmTEVar t2) - TAll tvar t -> T.TAll tvar <$> rmTEVar t + TAll tvar t -> T.TAll (coerce tvar) <$> rmTEVar t TEVar _ -> throwError "NewType TEVar!" diff --git a/src/TypeChecker/TypeCheckerHm.hs b/src/TypeChecker/TypeCheckerHm.hs index 2edd1f2..0cb8a4a 100644 --- a/src/TypeChecker/TypeCheckerHm.hs +++ b/src/TypeChecker/TypeCheckerHm.hs @@ -421,10 +421,10 @@ unify t0 t1 = s1 <- unify a c s2 <- unify (apply s1 b) (apply s1 d) return $ s1 `compose` s2 - (TVar (T.MkTVar a), t@(TData _ _)) -> return $ M.singleton (coerce a) t - (t@(TData _ _), TVar (T.MkTVar b)) -> return $ M.singleton (coerce b) t - (TVar (T.MkTVar a), t) -> occurs (coerce a) t - (t, TVar (T.MkTVar b)) -> occurs (coerce b) t + (TVar (MkTVar a), t@(TData _ _)) -> return $ M.singleton (coerce a) t + (t@(TData _ _), TVar (MkTVar b)) -> return $ M.singleton (coerce b) t + (TVar (MkTVar a), t) -> occurs (coerce a) t + (t, TVar (MkTVar b)) -> occurs (coerce b) t (TAll _ t, b) -> unify t b (a, TAll _ t) -> unify a t (TLit a, TLit b) -> @@ -478,7 +478,7 @@ occurs i t = catchableErr ( Aux.do "Occurs check failed, can't unify" - quote $ printTree (TVar $ T.MkTVar (coerce i)) + quote $ printTree (TVar $ MkTVar (coerce i)) "with" quote $ printTree t ) @@ -495,7 +495,7 @@ generalize env t = go (S.toList $ free t S.\\ free env) (removeForalls t) where go :: [T.Ident] -> Type -> Type go [] t = t - go (x : xs) t = TAll (T.MkTVar (coerce x)) (go xs t) + go (x : xs) t = TAll (MkTVar (coerce x)) (go xs t) removeForalls :: Type -> Type removeForalls (TAll _ t) = removeForalls t removeForalls (TFun t1 t2) = TFun (removeForalls t1) (removeForalls t2) @@ -506,7 +506,7 @@ with fresh ones. -} inst :: Type -> Infer Type inst = \case - TAll (T.MkTVar bound) t -> do + TAll (MkTVar bound) t -> do fr <- fresh let s = M.singleton (coerce bound) fr apply s <$> inst t @@ -528,8 +528,8 @@ fresh = do fresh else if n == 0 - then return . TVar . T.MkTVar $ LIdent [c] - else return . TVar . T.MkTVar . LIdent $ c : show n + then return . TVar . MkTVar $ LIdent [c] + else return . TVar . MkTVar . LIdent $ c : show n where next :: Char -> Char next 'z' = 'a' @@ -546,8 +546,8 @@ class FreeVars t where instance FreeVars Type where free :: Type -> Set T.Ident - free (TVar (T.MkTVar a)) = S.singleton (coerce a) - free (TAll (T.MkTVar bound) t) = + free (TVar (MkTVar a)) = S.singleton (coerce a) + free (TAll (MkTVar bound) t) = S.singleton (coerce bound) `S.intersection` free t free (TLit _) = mempty free (TFun a b) = free a `S.union` free b @@ -562,11 +562,11 @@ instance SubstType Type where apply sub t = do case t of TLit a -> TLit a - TVar (T.MkTVar a) -> case M.lookup (coerce a) sub of - Nothing -> TVar (T.MkTVar $ coerce a) + TVar (MkTVar a) -> case M.lookup (coerce a) sub of + Nothing -> TVar (MkTVar $ coerce a) Just t -> t - TAll (T.MkTVar i) t -> case M.lookup (coerce i) sub of - Nothing -> TAll (T.MkTVar i) (apply sub t) + TAll (MkTVar i) t -> case M.lookup (coerce i) sub of + Nothing -> TAll (MkTVar i) (apply sub t) Just _ -> apply sub t TFun a b -> TFun (apply sub a) (apply sub b) TData name a -> TData name (apply sub a) @@ -683,7 +683,7 @@ int = TLit "Int" char = TLit "Char" typeEq :: Type -> Type -> StateT Subst (ExceptT Error Identity) () -typeEq (TVar (T.MkTVar a)) t@(TVar _) = do +typeEq (TVar (MkTVar a)) t@(TVar _) = do st <- get case M.lookup (coerce a) st of Nothing -> put $ M.insert (coerce a) t st diff --git a/src/TypeChecker/TypeCheckerIr.hs b/src/TypeChecker/TypeCheckerIr.hs index c307ffe..b3f51d7 100644 --- a/src/TypeChecker/TypeCheckerIr.hs +++ b/src/TypeChecker/TypeCheckerIr.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE PatternSynonyms #-} module TypeChecker.TypeCheckerIr ( @@ -6,11 +6,11 @@ module TypeChecker.TypeCheckerIr ( module TypeChecker.TypeCheckerIr, ) where -import Data.String (IsString) -import Grammar.Abs (Lit (..)) -import Grammar.Print -import Prelude -import qualified Prelude as C (Eq, Ord, Read, Show) +import Data.String (IsString) +import Grammar.Abs (Lit (..)) +import Grammar.Print +import Prelude +import Prelude qualified as C (Eq, Ord, Read, Show) newtype Program' t = Program [Def' t] deriving (C.Eq, C.Ord, C.Show, C.Read) @@ -56,8 +56,8 @@ data Exp' t | ECase (ExpT' t) [Branch' t] deriving (C.Eq, C.Ord, C.Show, C.Read) -data TVar = MkTVar Ident - deriving (C.Eq, C.Ord, C.Show, C.Read) +newtype TVar = MkTVar Ident + deriving (C.Eq, C.Ord, C.Show, C.Read) type Id' t = (Ident, t) type ExpT' t = (Exp' t, t) @@ -105,8 +105,8 @@ instance Print t => Print (ExpT' t) where ] instance Print t => Print [Bind' t] where - prt _ [] = concatD [] - prt _ [x] = concatD [prt 0 x] + prt _ [] = concatD [] + prt _ [x] = concatD [prt 0 x] prt _ (x : xs) = concatD [prt 0 x, doc (showString ";"), prt 0 xs] prtIdPs :: Print t => Int -> [Id' t] -> Doc @@ -171,13 +171,13 @@ instance Print t => Print (Branch' t) where prt i (Branch (pattern_, t) exp) = prPrec i 0 (concatD [doc (showString "("), prt 0 pattern_, doc (showString " : "), prt 0 t, doc (showString ")"), doc (showString "=>"), prt 0 exp]) instance Print t => Print [Branch' t] where - prt _ [] = concatD [] - prt _ [x] = concatD [prt 0 x] + prt _ [] = concatD [] + prt _ [x] = concatD [prt 0 x] prt _ (x : xs) = concatD [prt 0 x, doc (showString ";"), prt 0 xs] instance Print t => Print (Def' t) where prt i = \case - DBind bind -> prPrec i 0 (concatD [prt 0 bind]) + DBind bind -> prPrec i 0 (concatD [prt 0 bind]) DData data_ -> prPrec i 0 (concatD [prt 0 data_]) instance Print t => Print (Data' t) where @@ -197,12 +197,12 @@ instance Print t => Print (Pattern' t) where PInj uident patterns -> prPrec i 0 (concatD [prt 0 uident, prt 1 patterns]) instance Print t => Print [Def' t] where - prt _ [] = concatD [] - prt _ [x] = concatD [prt 0 x] + prt _ [] = concatD [] + prt _ [x] = concatD [prt 0 x] prt _ (x : xs) = concatD [prt 0 x, doc (showString ";"), prt 0 xs] instance Print [Type] where - prt _ [] = concatD [] + prt _ [] = concatD [] prt _ (x : xs) = concatD [prt 0 x, doc (showString " "), prt 0 xs] instance Print Type where @@ -213,6 +213,9 @@ instance Print Type where TFun type_1 type_2 -> prPrec i 0 (concatD [prt 1 type_1, doc (showString "->"), prt 0 type_2]) TAll tvar type_ -> prPrec i 0 (concatD [doc (showString "forall"), prt 0 tvar, doc (showString "."), prt 0 type_]) +instance Print TVar where + prt i (MkTVar ident) = prt i ident + type Program = Program' Type type Def = Def' Type type Data = Data' Type From 5a70286802e5afc441d030c691e9bfdc17456e0a Mon Sep 17 00:00:00 2001 From: Samuel Hammersberg Date: Tue, 28 Mar 2023 15:35:34 +0200 Subject: [PATCH 207/372] Added a files back. --- .gitignore | 3 +-- src/GC/lib/gcoll.a | Bin 0 -> 712746 bytes 2 files changed, 1 insertion(+), 2 deletions(-) create mode 100644 src/GC/lib/gcoll.a diff --git a/.gitignore b/.gitignore index 8e68689..0984599 100644 --- a/.gitignore +++ b/.gitignore @@ -7,5 +7,4 @@ language test_program_result output/ *.o -*.out -*.a \ No newline at end of file +*.out \ No newline at end of file diff --git a/src/GC/lib/gcoll.a b/src/GC/lib/gcoll.a new file mode 100644 index 0000000000000000000000000000000000000000..1fec9e8a9873bcddaccefe376f301dc380fcb024 GIT binary patch literal 712746 zcmY$iNi0gvu;bEKKm`U!TnHPPR8TN9GckfFN#J5&V9;S;U|WZY^O+bJh`=l<+ZgDK zkH+?~zcon6aP^GYnzQ%mAYDhpCw%NS5)3{AjNnYpR)#U+Wk1sDn}LGsBNrFq#H zQeabyGpn$f3bHJ|BtO2mq$o2l9ir7cxWqIWB;lFtYLSv3U!Iwgn&+Afb&*9tQGQxx zPHK@^QEGC2QHrZyaJ-=*)B_9##GK5M%J?z^ z3_~oEi&7IyQsY7128C2=VlE`4jNF~!!C`2SQkq*3Us9Bqj0kABta(aiaY24DR0e+t zn|P!q7PuI}t$^@Bj)tTOFyFW&18SI&yE9nC(4wTMGQKD^xiUE?H6EN4id|u$2vK2H z0FAr&)V#!`oYWLlJ4`b3GD}c}P~8o)$|N_jDBCq4H^4hLD7eI|EH$|#zsM6Q9)c4+ zgU#YyVX+Oi-L$woHMPJsDA*t#8p2>%S@ zH90#T#WR*57sr>R7MHla`KZCOHxx{DJlRh{)~(; zlU;mXYB_q+1H~0AmcjC{gb-X}9v=_RmWD=2iN%@8pe&Y|m+qMyTw-XLoRL@r%2b&p z#h%Ho!HJ&9uCC5Tp248t3h+)2@(wlzCnqvYF~l?lmcZem1S^NZQDO=X4A)$SR8V29 zmk+P3AaxR?9)hqTq?w5cSkTDK%)|oBO5mz@^>JfjWMqH=Mg}_u1P><4zz~suU^{@B z4h-@Patz(G8|AfCVRbbh~pLo`4YW=yn%C<4Yj(o9#LI+t)KNFm$tf^ooMa z@JME9@?gC1{{g?e3j>2kFDpp!FwBC%!iTv7R5*I(WtK2Ff>LI1Nn%k612h>!IKGKR z*$@`EP5^OJQy9SP;PTXh5(v|+C^a>O!7sHOEWr?zT3Vc%0%5}{I2TBf%@7@$mz|ei zo)-%W7m{(XN3SeMlSk+M7ht;E7EE>Ci-v~(OAsH9VQE2B10n?DSIjAm;w}k!y45Z{ z&1mM#+Gi6}j4Bxw9Xw7LOla{r^jlKlq2Qt4Yxl6K>WWWTeN9Yr%b}$LJHrJGRvw_0|8^f8KxY zzxwh^2Ag;;r?1#w_eaAx@6+}AyT4N1@|Jp@WjuT$wYxfBLE}((VEOxQT_{THNe)0Z5+9{_$F1J`}h2ApwE!%rQ%!(yvsmh;aLE*>N zEG&^OkXXyiw_NwYL=)X37F~Iaeam(?Cckh@P?lxwTe`jB@e8g3n^q$ZkFmCcQgvj4sPU5&xMiH@8fud}FbiL?3R9CI*; zgTH#w355#+I%Se>XV-4d>UHQ=50ic|IW+3wrudwM$&zMl4pt94uW1-BVt#HDcv2xi zyyT)slvv=?WwKvNXKb9iXlD<9fXt5WW6b}j-fH;ocDsT9QsM*W5~&@t^_b<={N*0Y zX)(TA>h(bR3RBILYs}v-G9Nhpg7v}qm-danU!Fe@AE0uoq9Ln+J=5p|XB2x)*Efd# z3#SjMErtz z2gEaZKBz`<)yynoieI?AVg1GE1NF=O8}lb@Z}=z@%HSU?{J}Sh)5cl4F+J1%gKib? z53^dPKeju$CC>+Pey}mUVIf@6c(5X2Ey&qLkpA_oh8o zUy`!re8ak=k2F2lon>S=DIl-YV9x`?p3ASESGymbwV>Nk-|7CJfI#`>8M7mKo@J;0 z4Kx0lFpW*pV&Wa0!x|y>_p8qw%DFr7?1k{i?9D-ihqg3IE?*NI-19SWRvdHH&PCTU ze&wxScD?!Dq7`Mn^+zsNE--K0w}@wd$d`|2c#b?(zx7ntb^r94T`8Z8chsy~u|9Z9 zezwEqw+m`l1ytS(F}rEZMxx)W|z2Wp-|&3N-njZe{gJ9ow&|QdD{h^M z^jhy6?dF?zrz#k;5b8Poe^rU&FN?mcjJi|~$CKBju7^$hQqcOO_=BD!O)ldVK~fZ>L@ ztEz8s`@VB2zLF3(>r>QX=Nkq`@+F)j4HnxMOq>~#l^&MUPt6T4d+TT~1+92?~ zamS*bdQZVi-`h9Z?z-9fE_>EZt)(&h-zJ`W^yA@&8;=fY%sijA*?(EPpv9TFH>cY7 zh817@y!^7#1D;6E&*B&O7wRv!JutO|X-C(&ZyRlCb6Gd~C;k=*J;$As?)XOdrk&Ty`5SAeZ0k?2o*cA(^Ip%} z7u9x$Zeq2$RsQ;mVZrUGx8}dqkq|u{mTS4uUEX4cJ^Zh&dcQVYFY=M5fZzuPCU#~S)r0Fg3>fD5_Z<54r3achtJ`zx8#^UF@%aIDVA=uk;$clV{M+IoKBD|e{G_D-ruoI35dSnsu>MH%y^ z{T5w&wa7Pc@3idh=q)x2Dq5$#?y6t%^q}G2b>3~yUaDzGKAX^P{p4foF8e7Kv$m!* zInR4BA>BIZx#gSFpZ~i~Pjt;O-@f*^vTc~cql>bePXA_=k(eR6g*SHd=Xw6F<=ju^ zg%vf}tGcbvH)flb_Ip?Rn^^yq_R^E5YA|ZZ1#)!xi*R?TdI@;BOc9u}LL*V5b&<=0 z5Q_FX&;Ddab_wz#nlXLn@)bDQzG2HF0v#xpVljr~2gKFG3 zvr~Nq|3w^%(48&xY-gK&m(MyqIWtq+GhWuge+>3Smt0W^XrF1tlQnmlUyEH>_AH^-VG%!1d#{<1b;@j(*mj?$vlS0&D}FlX@>oCd zGkYnquWFrO*;cv98&;n+>MY+n<8k$r)w!o6C#C*lp7ivu(aBH$>{U+x5}lO#*Lc#? ze_9_u^;Lee{jx&u+Z-L?%@3zztxIf! zdw6{1iIlybXO|?~KDB(;BBT{~+@`EyhIm3$TuJ4PiCh%{{HRRbgK z>on5a<*KRen(4IiddDT6)V&(QSJYP~-cddEBqpx$o$ylCGna4lyUu)cds)zJol{pn z#4XJcP0jmYuGPryGBduw!LZsTGT=-0(l_F%id~^F&hxPkmdZ z;azh)^o;Z;uU{#TrzUWO^cwiS3;m<3zc>C&cx<9sf10s9&-=MnDyQde4x0HReVxzI zn{j(8y070?VYTBi;Ll=zsAGQYuHrMkrJH|D<(v1U>F`UD=Q_7a9_nTH1$RhUDwOXu zP&1tREY-^6%k!W$lSDGVH2%~!>^{$O`AJ(&n*2QZg)`Sk-Ammi`D;evw$GWZCeG~P zAGM}yrde0#x^rcha9vhuO)ue^ATzVD>(Q_JAUivzoeNF(3%@(BdCp9KO4*}eAx~LO zYw2wNT^oP!9JRT!apR)AC1=>RU#OmoneP4Rez#Th&6KMj_ARPW?KZz0`R3)3;7L*1 zo_lMOJ&$@%vYPMrs>m&KuIE7L_9;vP+T7Gbn!&SHxk6X!n%KW8p$Uh-S9>qL8YpHkEG8}YL(_b@*S z-fr@IPD0=8qkDFlmOfIjywg8vz0QtE-XM{5|MxKc(dsnhDV#0Z<^ZJcQ>qNNAh;j{E|1@ z9wp1}Ui-u1c%HW1y^XiK%q`2JKc<0r2RGjC^8XTharfFEDjLDAnTGDN z+Rd3#%eVgIr?0~Q6LT7c_S8&x8M|^to2n$n45G=VOlFZYnPuT5Tl6vS+B#MS=&#u?A+h{^S7GcOusDSOE2V)zWl$mC+Xy* zCU?8%W}W+&2(7-On3rPra_aP{azUMQ_4at!{Vjb~*=~KN_e}f2zGA(HeW%PygS3tq z?h!tJTIo#tG1;>EZHEgv@7?Tlwv$=5`)7+}>FbEuCkt-8;reuQa|qMzD@QUTom3i) z)#P1gpZEihq;GqwE@#a- z{^X?mt+}7SCw;zP+`N5d?~E<&=|M$mL9!idG`1cO+uGW18_n7FbM|$)n5&BB?b|oR zNb-M8`EqZuPTap2huBT(KR;xSlDw`JSyQ)esk(RW@$12Tm6OWO_QdEpHN1`cH_6R? z#mUmou?;`lFNK(9^)24}GtFU5#<^K5_OvzeJ)1G(cj`sIu-m z?y>wqiG_CS6K+1ulN~zg~3CLC5!5Xl#hi`=B|VM&2Kede557c6@=$ z%d9w;Y|nMiKNS5)J2vy2-Ab`_E|=DyK5Z_^XeRc7*Ozhii@D5I%liXfuj+muBo}9F z`kkjjCiA0jXN}jV*sg$5-XEuI7OuRSxk_)k=sy2KlS>Wm#TLJmbLW0y4i&IxQ~tkm zlBif7=j4w9d7P8~I_)^?&9|Xo_KY=~LB#fV-?{Db9(zjb-}o`J_j>M=)577K4jx*Y zT(qDy`uGzC?(Kai4~pfiYBFlCwf@#C-j{ z^^0GxjbE7Fz1PVfGK2rb-b%N+9PB9GaBtO0%N={TXPh$VU7EwcK9Tp~fzVXW$D)ri zAH6(uxpz7Hc^#X*6={!O9=@E<@@?BZEH!+Z|6We%zZ3uH+x~@Oi{~_-)A&_$>S!8!!_&u~{6#-6=gX13XL0@f;=0Cr zGjoK*vtlO6or+i)dFPk;73Ea9NN3ZNO`cVB)fZNxA2Y(vMI5 z`0J}>D%Y8vn$tG#URGCocILX$tljfBeK$>Cvb^J`TKQR4j}>vP>KEj8@LZU5u~#~+ z;9QRTwe_!pbVIK>iB117dv0dQW3zQzw^_{DyyY{q?A)KFU(eWHTlv{rcJ9x!$BX{$ z4t}n0WugCMUJ6@r&D6~N?cd6(r2g|~&&s<98j*pG#~c9zNs<31%uoM*=G?m+jr(QG zmY;uVx4hc5VIPy0V$jX0vNsnwm$F=Jrl>RMdGu&8}!YR9jA-CDVCmi z_|QhDyWoV4Cr`|r_9@Yuq!_1*@orbi%iS>JPm%g_Cbyaun=@j&&;AH8jGN;6WfQOE zyo;({^A}y2RVlD+mnVP8){4OItM%6%H@eqQ89HwGoA5z*XJeADw%X{?i0IHbN56vf6VLCxf_?AQ_?=`yIiecb-&kZ>&{(5 z5xY;tVA9Y%iQkquuY(u2@R<#XYhuX!aCgzDxPE(0|eW3MhrLF6%{-<-#m`FeQ zvcxFi`&~!n{V8Ghq^F#(toc7@-KG<_G}!AqZ}dejpR{vQ+SgsbcE?Pp-8}QU+t+oo zU&&25K5ynfj?9(Y*us_inf9_g)x2{~%z~vX<9ViES>^}l_|Ep$h?<%Z9X5G+^Va`A zJjMSQ-?*)+W0qGx@!RV8RsR<+7rwd1ZuWu;pL06A>gS8svF{Agm%g|ENobSp(cj;# zq?>#GpZ)olnXhfd6Wx=dqWbrL^)bH}GH%;z(HS}Yu$k-R8}YloUpCpw{^u;8|NS|cR`=u}n_c9E$ix3{=4{u|H`n~ceNrmfL;GVJ4ZX%ELJEc|xtyAlxwQ7}`@SiE(wP)r1|BIhj)so)fzRr$IS7Yn{`n{v zW)kOgInS|HK<>)&NglnwrA$-APdQr8;Fz-B@&1YPAGR;tB|Xz)*`J?mrZWy+NH?CS zID3w|&`j}9@4k9oJyRl26(zEExvG6n2*B>diWEMndkvl(BXNo{_&rCu{e`HS1m)uMSd^LfQD<*(t6jOSQ>E9Q+= z`^VM~YCI*IZ?>&6T=Zs%F4r9!{T12!gYW)&{duWK-TUTDmy9QN;nj-r`#sKR^R9im zHH*8YXQk@dKQik+Wj%;}agW_|bH}0;)%!iSe^~x0?Ec-8CKVdXBCVe8naGl$zIFOs z<6BRTbtjZtB^1vSzrRyUB5q%PZRj>N{~6PB^}n9(p3rK1Oj7@K*Y(+lzph>XMeMtl z+oSXIofo#}*mCGxTp^xQU(@?Ttg-7RRIio9C@vM<64QAQuD7o z+7SNCp?-mb%tt1p^GUfz?k)2Q;(JVv3D-I7+@yQ-erld}7oUmMWUUL6_&GLiYv6tQ zj3MQ&`3~j^Ltf`~x(j6bxC$kLZ+mz>>G9aDm7``BxW~Nn%V*i+mkua#%nzMVKljS> zhpvaxex94Tp|Gs{#sx{~821~;GS4+X;XWzxK&4UiyT`1H4=pvsj}P!g$N1XH^fN6sZeWz2eCM6i<&2o+GiCj2 zl|HU`?|jDWxBVmG(q1l+F3V-XGks<@WvI=x*E&8^;bSY?zO|}Me%4FAuMSwb>(_A) z7t<5hq;)+Owk)qM?Apmt{Z40xy>6k%@BX0j{VhI6w=O(*(84uHC4G^>bPlF#l2hFy zKCjY{SeLB&aFNqTt>xx__Jup=Fz-oSzU9p7O@m3!dw8pNQJBEM%cmL(3iq z=S_1JKd^^>Z@acA);w@t@uNWIBY|6%ZmtdAsv6C)YS+YMuk6RRn@^N`NOWpEk=?3u zuSsJ@uF#A2{`h~tZ@Y&S&Ohm%sj<&|m$Uq_e`}N9Bt;9{x0%CSUbet_%kod`C)M%- zBUb6nynUo^@uOw4mMKIqcQx;x@S-6vzsGh@_P2(JobZB^Hr-3b-|vvy z(LQ0qL$QhjhLa5y429gHk zPg35&VcBYHhqETWSr_}cxN4^duj;o@nR31Jr{_20(`#jAD|ha!n7o*clDAEcD%_k>`tabtmRoc9E?jl2zEgckZI9}l#EG-_h`yavIpMZk zZ_~66S+{5RPVs(O^h|d9?Q8F%G+hOGrmT5j=O3nDKl@s*s9uQBO@*@0KpW?oU6c2i(SrSBAilgFv+Yrhqe{mFZI2p!Vm%u7^N#$FgWP{Fbn$nc;d(vUj6s`A z)y#B?yu57$7YFy;Gne~$A6EUHI{EbD6A$ap9{s6e73$TFKEr*TrUa?If-9a~-EE7rVN3)C5?y&0q35 zFUef!YuDDfuOmK}tP)wjlXXvX^U)=NCrY-=u$R>++akQ`rjePrgtV&L$&BA>i<$3h z2Th$N79ONHZ;tB25_zrrg1IlQ1aAHK((K>Lm(T3CnNBpC@3z@!p7f-L3t}$FeGt~& z+_7esL0633>Z|vTlrbpc3R}%EllA-HDy`jezO5wY#JP1%Qy79a zy;L!K?!QLZVgKXzy7peGOVsxo3k#a0FJRekpPFH_+KTzylSkIOlYDrd+*y5Js_Q<6_k`-~4J=zO=Bod6S;U3Trv1ey7o7Sj${O~0A@gqe*xsk#c%$9q zt-~%K-}A)(_#wH<&-!tTCu|3`IAHCnJIo*+qTN+7XKK*xth)vRSN^j^t4z7jeyM$$ zn#d=9r>OTET}zU;dinj^H|eR2wF&zz_Qi8=emzr_lHPknoX5t=%SrFz;xo6zOFmuP z^k-qBqqwJ)?6XDBZ>db^xBs7fDN;G*q)IMBxZ0G0V&(kz$98}GCZ*r|v}UX2Le0-t z-~D{Och`R-6^S{#Pi@XDtWo+de%bME=sAY@T{*wxpY<0_x-aysp8wgREywqVo298; zi8Bd2y5#o036+}~SvP#uP+&U{l6l%=mh#H-v>299{WDxOs~8sf&w3@zeN;gDBUiUt z<8!mT? z?328zcI8=R(5)?5zN?MD&TjkFB0H6TgSha#ZL;%27e{fd`o4le`&;|2Z$(Zwj=h@5 zvATiRV&#lk@6ChPWbeCwH2Z7B)G43THa}Zey=H3FkH25C&2L;NTT^&#^YiO>W^D6* zz5DtXy`u$1fuH$&-F!E!QCl9Oe5cAx?ws874|!J}21-v8ns@x^C*iHH_{;8wZ)0$G zcD7Q`aQ6$(HMLn77#I}5O>PDTcfU{uCI-d>ATdbng5np# zhs8Uz*~!3I6~w?;A;2ij!_F~*k%2*gfq_8=stKAjz+whaF<4U`q|OD4SOgZa9H`g< zC@leM_CwjAHa~+SpFlHH6d$Cs0F^+aJQzT|hmZf!guz^9cxxKWg%ix6{sx?fU@$YV zAvjPLBwSb-IH7zP1yKp}HB6L&fg8+ZWk>?k2m%x?ppFkLd|@)+r7;Yw48AY{C@lr1 zSsB8>G=h)^Gg%oF!8C$U0W(<{w81oj&;&DC8O*^ng3tpqSs9$bG=eY&Gg%pmz%(ks z4DGfdi&`=;FfbvBgX4{XfguRoXG5ekNH{`tGBfZ%7-%Fj10R|Qgv-nz2w|X+%nZV4 zA`mV!10+--JOs(iAco*TS&0k`3_?ih1eUg|q2iEu1H~Lf!yKqMC{KYzU?~7pc!JD9 z&kvx%9FRDye+*0OpBNx{3SLGtOw_w+h_z*`Y zA6MuaKUCE&VAb&{#rg3WiFqkGsSKcngo*KqC8-seCD5?-gVLa=0Hyjr{~;h5NgR|` zVB*C{;-InwCfG)P>Wfq`K& z)FDD3K?Vi}kT@)?Ktiw*6ebQUu_5&pL_MhVh163F3~C@vP;+2 z3=9m8XySK30mZ<;FbNtzAbUaTS3@nHhb9gxCqYImLlZZK^4CFWm^o~q%*VjMunkRo z3rGP21H*na@hoUSolXyV<_aMM5&R{|9_3=9lLXyQGfLV|&Tp$QrfF!NVI-O-0G4l0Bg7#L=w ziTgp_xdKgm6;%CtG;vtEIgTcN5LBozFfg1$6PJP}>W66J6QNCq7ii+{P=EeL6MqHr zAgEje71l`U(+FygB$_zP{R(K}LeLCkj3y3KZ-pk#1NB!Bnm9~-B${{;)ZK+>;xP3U zXyUC<{sbru@+K&qJOD8m7#OCbiMv6|fz4>*F!j68#P322l51$C+fZyb9`0D>U)rQ1_&uiJyn& z$80olJE;4r(8P71?r%pEKMu8bC7L*_eBX#BJ`-AaPlV=sn1Ay?3KJmy+6^!rJ?2vL&F>79Z)>N(v>ut zcox*&5;XB(X#CcoiEo9L1HEYCC!q1N6ixgCRD3U*_!g-6RW$K^Q1Q2D;;W$ItRN2| zl^aUXd@743eh;eN6ir+d>MtKO@k}T`7)paEP`LeurvE6A0Fu2b(DEt~P5dV`JTuV5 zTcP&mqlrsH(|H-1xHHsWwP@nEq2{-siL*oFeG-~DsI36X+B4C_e?ZgC0yOc{(Db$( zP23zRz8Ov21{%)0(8SrG@plkS9M&#Bh9(zpMa!6@nr&H zFfcHDgVG=hBrXbdKReVOn0PcaUkjs&Uxo7Jp)^eWQfNJ{jV5jc6*or{mw|?lGn)8) zDBmAS!_40RO>fa?;=iEoPe&6^gW6k+Cf*4xm+H~PqdNT*LE{-@EGRupgqHteXyRX>;iiNpE)Px5dT8R>P`(wEhM6x3wbu?8>i#A)aYtx6=|dCef|@@IP23x5{xURid#L%F(8L#k zJkG$tun$d~1DbA6p@|=Y@~=T@kakeK%!Hc%2u*wyG@ZOd6Nh?>;TM`XEd8-T!xd)! zFKD_ILKBC@w;Y=IGH5txp^1Nlnq!70&JE2kE@sc|OVE6=8clpRwBFf)CcXh0zemx;W1#-MgeHCl znosYei6=qLe}g6t8pi__SwGRlcS7Tv4Vs@|@w*c0FJUzC=TLuXqls5Q-D80!ei0h) zu4v*Xpy3>hCN2%NHy%wq7Meh-(8O1PJjKAkFcnSQ2x|TYH1PuyKJ1G;uR%y*3w3{0cNZY(W!OgQn-* zXyQRo_Z>hJZ-CY#XVAnqLc{GEnm9kyUk}j4Z$rzCS7_qR(Dd*XO}qvw&I+Yr;lKrT zr#PCpB-CCdH1TSvdObApSZKIeqlueA(_ti<_(^EErJ{+SgPLE4CjK6p9-7d^1EBnV zC=K)19H@Kdpoy12)ALF+@rTfSw+&6)ADYe&qlxc;hR+2w@lt5K+(i>FhnB0a(8P~J z)5CW(@n6vNzydW7<}Wo6gMooT5Ka6WG<@XH#OtB%*G3ax4o%M%XyPnT_qd{oPlc9a zL1^MhQ1$U>;x17C7flxyc-%0lhMRaL(}&HG;t+pIkOf`+y(0X zU1;I~(0D(NCO!umUsuq?e?Y_kA)2@y)cxlo3DU^Gz~F%<4(o^Hp@~aF&FMlD_k@bCMiV~(O+Uxc#Lqze^8`)&7c}3! zK@*<~<+DQbAIRAt|B6D>tqhuYEVLZZL=#^NtuOu2#I2#}suWH9JJeqj(ZtiC`F9VR z_!6l48))M4Q1`q?6K?={1e714@do08{52UG?~-WZFQNI)2u(a0ntuGy#OtByxdctz z3z|M_(8RAm`7@z3%sscE?%9tfUIsNERt~|`ABKkK6EyW3py30XDut=9hWd*G+A)WT z|Av+W3TWcyPP(m2lpsJI52_$Fw6^h6WShL*#bXyQE3eBFR1t_6+Xg=pgD(ENJ{O}qhG zo|0oDG^URM5n&pyC#2;@r^qwZkDEhC@6ChjIHC!YoLk$ zhvr{B9OB+M!~=1N=b?$SK+|Uznz#*Ad^MVQAvArSK@;bK=Eo0c;yF<9zi8q`P;oBk z1Sc$fnxW}g98Ej|T0X0wi6=tcV~8f+3@vZ%(8T+p>b=p#pF{l{fhKMbau@>xLn@m1 zYiK!EgeI;4b!R=Acn>t4^q`3^gt})Yns_`kKQ2QP*Ma7j&1mAr(DL&Dns@^=oX?_( zuZ5OBx6s5dLf!KmP5cg2{TDRxpU`k%ltxYGm!SUTLlfTtjTdP&@d9W$qk$%V99rI* zp^1w?(@7wj_!Fr53^Z{oX!+TQCf);$uP!w4KxnzK1Wg>)f7pU1J{uYid(p&U=3GY; zKMqy@98J6sYVQX$ahN$=(1jGBWC^MYgrV^+h9>?E8a_5?;u27MBhkd4K;tVBhj@vBh(`l5+X zf`(@vns_KQAN8Y&AA_cc4QS%Kp!xAIn)pnV{kJ5=}f1>K;z$ z0u`9Q7DL^mf+qd~S}xh6iI+kB>w_j<1&zl@H1R1=bJEeo!RLuGFfbIOiMv46SEGsV zhQ|ARH1X|F|E@$6PlM*8!)W5!Q1v&_#5X|G`D--sDNu75p$i{j;kF$bZW3tXTcGaL zM-$h9rcYNiaSLd_DF#g(wl1U=O?)d<{X8^r*!<8gH1UJb`r-kaxE|Dhm1EJ=hLKD9Njo)WbagcVX6Tv=af-c|#1q-O$&Vri5k0$O4 zHAe#P>kW zxrQbl1r3KgXyTWkk^Bfv{1DXMcWC1F(DvSUH1Vs@a*{Jt9F`um(Zpf)8lj29#@W5l#9`_K(ZoMN-IIqV4pU!>CawSthe>GS6QJeEOf>Pc z(Db|!O8eenK#9``} zqlwRk`fD{*98``$gBYAJkKqtM4;2T64`@gX>KukAP;rpV=RQ;%UHvzxI7~e_a2OaEI5i+FboJ2S z0GB7wE(cg4%pP=eVD1Hp!_(lGIzP`(wEhKav| z^6j8BO#Ba&58KBC6XyhZkb!~04Jr>4w}gs&p@|1V#Y51Xl zz7Lqa3!vf|XzJHM#dFcbw?M^V`>KE*nSk4y_Hb)7eSKH zb~PwpG(yF%p^5iH#c!jD&x4A?_O-ywht2;!MN)k7r;pzSZ%{x8rlEyx~dvzY-@=7N-h+A|<= zXz~ULfw2Qf5X?d)(1mrNdlPZ#M^}%|2kprRiNV@KFxz1E!|HFCI7lss4WnJb`>G-7 z79JEr0h<&s$KB%1rjw+bJP>BradIM1UgbINvG-V8+_8+$RTM!Ob z&HyW)LGA|)CBXEv$pn0}c5PeJWBfJs0N-T~^|GB7aIpozn{ zuyDAFL%#*6U}a!n*aTAuH5Xk!sGSH>0;?aP${1cj$Adxf1``9(AhpQ!JE;92F=WgJ z>p&t4Vo?ifFM@_X(2^+w2UI`0yI}5z87syJI-FqB;>mc- zyHm!-yEn#$!?*Q+y|QoX+fp~5&Qu1E&R7ng&Qbw1C-BQN_;kMW>HOu>`5bJBM|Y`! zkLEj{&i7#MYmg%$tyQSZ>nEPwz6_q7$36DJ+~cWv-ly}I$H8CB9+sa;MI> zPv=|D&a)o;u7^Ar4;3l68h&#%eB#l1iN7V{|Ns9lb^ibV@6l@u3Sh8Rp8I}446J{t z_5c6>39$HZ?EC|ck5G@!ugG!Y(y4%m6mY%e(U~m)iV)B4Tn2aqwZ1LU_2_ox@Ia3c z56lQ5B0fNY-08|dTznh_$487UgLiL?EjU87JX+tDy83qNsCah9sBrjpmZ)Gx2{gQ+ z@dAkm&u)-P&37KKh}jJjdHu$N$O!T5eB*&0A#cGE5)O(GZQK!}`Tzfam^)kE#TyFEHvR3cay7z_{i^rol;_;fx4N0&$QkN^DOr0CO| zqoUx``TUp*O8|pUXO0RaK0P{*dNlvw=Wn0I$iU#y{DYCdB?H82J;2|(o0);Zr}KqJ zXO4=*F%}I5kM0~536Ivd{4Jr33=BTqDJlXUy{`ZHp7&1&okj?XFP~@UeUk5m)f&g^NRCA;m)*5-t3#pjBWV zjYmL{<p;eEag{zyFZ%?X7^?+?k`I z;L+)#BGCMogTFb3k%7VC+ff$&R?ul2t#3;N`L~6r1at^Ed^^g-->S(3^0|wOz)N$m zL7;5O-{A)m?R@Xie4LTL<254#1H@0A%pRS`Jvy@mJUU5@NKpV6?dRc@#I$2aaEsyaxv4fIdr-_PB=XZ!Fm=Go( z1lijP8q@XYw)W^{(L}_or{$j#aSw25=A*)a6low{H;al#C$~qZv%t&0VA~rQKxI~U zh)RG*Zv}@>=QEGy=RZ6;1v+1OcKe9@@aXgr_~D`X!$b2J4*g*x^78Oui z8dRV;K&`J)(EufW4JcO>6i53&4Lwj&=sXA(_UZiY)0v`T0Or8UH!V=22bXW4{kotq zYt?4~m2VHg#g0dBjY@$}=Q~g_0?`Oci$2{oDixq&&jOV85JiiR<_{0c7yL~cETH`5 zqf+40yF~>QL4LhCwhTU&ANgCFz=ci=Skwok7POrfR4dAR_1aiM%CS7K8WRncEDlHk+3`v)k= zcIK!=_;f;2gGV3rvl*nt@IYE;^9_&`M7hWD z<_n<49|NeAFW~U#b`bFFu6yCrX$%eq#`_+f>`(`TjrZuy=J4oz@6j6oY9%{(bP7Wa zhA0BnsW9i1s08c+wTWR(AdhZgkM61$9*p-vQPKjM%QA!&JvAx;@G>?5DZ7HpC2~o__EIm8Z=Qel-8!;BVUe@Bjbi2R{ribzW>f#NpX(!{^ay z!)JM@=>5wXkovOo8?2Y}^3NYorE`G4a~Z6#OPjC*G=TK7<`3A(VEb8A__r~1u!Fo` z@N&W*Xg%Z64HXC1xM}eAs3S-*32fPQ*dG0_{IaA^gzP~sO>@v zCQ!T3qubb{^&5YSB&f~QUB=@7jqoUvg>ArbDZ+(3Un#P33uSe%`up2?uU*~;~ z&O=}xJo9$G_v}0Z76O;7W{jX3`$C6G+pei`-(RmbX3P_Cr z%yb-T9Qn6_5;depwF^{Cp;_c>`IWx~H2DeYLV7kI1r<$T(?Mmt1Sl6u`1CGOQDA~K ze0m|(2x$1ur}Mc7v>Mq38dE?s8rH!^4G!?ZNIsxy8+vgrw0q~-c?49bwQdJz3>Osz zkM0UkNe9j}kmlUWjo_5UunRPxg=QHn96UOY!Gi52&wo&YbzlImO+{DV4YtDJg-7=q z76DN12Q?NV85tNFYAqP}TR>sJzpvC8W|&7ew8MSe16u6&hJwm(fiw^Pyi*|JLK=V0 zDSk~J6_8ejH2!>0>EP-B3P%l4c_6{az`(ERqoM$o_vqaNE(swVn2|Lq2_DS{1VF(K zt+in?dsIOBJ-P$H6^ut`2q=JpUU+o6h$z5Z1lHLCRtPn=MFo_c;e~u@xkuv>P{K!P zSu?=HuG^JiA7~KXquas2!x~&$@wfZ}MM&rS{}=f8eR%m6RFJ^x18D#Att+$=0#%%d zQJiBQoy`1#3@?xTfwqkxZh|*>jze-LqWGBL7`h*n6~Gx3HWCHV)D6z3KHb`&(WVN| z?pOxj?o**hho|M8((}IE zsSLiYPfGYbL1RCi&wVtZP3q<&96p`z!P+4~1a>2ef5FBg`_!}ZD8#3)VQ0;P8WAAe z`QdO`YH~?_k(E`vZ+uZI_@43j%)H{%q7nxEf};Fn{o>S|H2u_yR0iZL(!t7;i&7Iy z(8UuA3R3e@z`d_{)x>yJk9bwzc-3INl8O=r)kFo=5C$$+&?V+poD5vSnN_J)3JhG% z8KrsIRtgFXTnY*>F$D$C{n;Q{kUL$Ait>xB6pB(4Q*tu%vK7)2Gjmc?6!P;F)KOij z51DP!B>+H42xKk+WxAl|pf#wU!RygoEa1_643f<~I$wjTdXl=5(DHacsI>&{V}YY- zKWO$4($j*Lnb1;TCums~xKHJxV(@v%F$Zl>Ch+J5b)S#Bs5pS7kGrT?fEZw-aJvXx z9(r^`i*HCt3s&vXc^F%77+T)J3zp8qufhH;@Ui?}A_!|=AT=y-wBVp#h9~as92E}F zZnqa6-8?Gb#wQOmv|#Y*{0}Kr!0lJKcd)h>J72% zZnJ^p*;rfH!6V`zwY-chpo4ip^&u#sLNU2_y8nc3Du)?YG3U)*_BkR)ud&~{x_R@; z^fI$Edfaa&m7UCNWSusrxX-&yHC@nC$w?{?s*Z|85(lwwBA1bG=HgwX4fh4HM(zSe%!lsZ`L7+%=Oa@ zTyL%ZE$&qvc8Du;{X=_&x2D2<-qpJQSu^wH>cehDYdq9Do&Q^3KjU_|*0-&!7xuZi zZ2IilTDnK$RP$>>ay)z z87MfTc$xAnnZ!2+Cj?LO@mt!w`7lX&nylfI51S9W_ob8_nWWq*Tlhrd5Z``w;eamL z&V8B!vw6-|3npdQbQikz8=dIUO>ud*V=&-_x`-}upZCU0-e;fpybA!?g9UTiy~b}YbXw$$bmIcYlT zo97z3yKmmRk^8ReEs6XY&v=cjrCZ$>%*?%_vU&T(#xr)uG>m>rar+co&-~kSd0A!W z8JWWpC(|O0eoL?QDQ21F`da#}+rpg(el*0W-jmTPT7}r zN8xkNL<70A*L%8_-JEvjdT-#ep9(YcC2sqC7MYpeo9|;>#5C)9&!lBHxz1#{@=m<+ z+HOmQ%O#af6|R?}Hi?KB&X|_v%H1h(=1rDsch`)+DW2kn`zI`&(vkS_l2Y5z(;X5b z^-WpdIy}})Wh?1l*|9Du)rE1@srs_n`U^Z(zm^ov3scSHJ++^0lIh8N8hpI=A2vOR z7yq}e`+&*Lv%xxf;Xl4lx|39E-G4FQJwO{WLjT*!IWI*#pvDwp#+mv2um#%+t~{Kn_tU1j_J`GvZxj@2nu{Ey#yY<}kX z{%Nhi=R5_=Uq==Na^Kpv>_fThnKpxt*qJx}+GKoT2($0bEh_3T=BrWn=3A;(+aS&x zvWdmw^n}-rc~XV$0mfQo4I9I`jIu>G`!#)B*5fnhto-3W>ksbG`dKyQNq=&k$`TXB zOOMnS);K;ouTbasMVI~0tBHLE62`ZWZDFtTUoOY@+>tMx=fk^=KlHNNX6&Evv%6ut z)2YQ?Z#}iPywujX{Ib%Hx8b?cTAf|9Z|wHm$5F9I&vMpv?tKqm&Q0EbG|sc4>M_%c zi*s3S1-r8rJ1tm#Oy8MxVwF(S3ja%X2|+tG{w>*VeM5S3ZF9cu(G@?`J)Z<7E$H_O z?DP>AUoP}Jrt^qq2o26ZQ*%I?vzbpM%=Y^Jz=g_9l{JWglj%Y z9yrA#dO}S)#5(*!ob(iBM-iE{HqNSp=XPsytV&Febq}0Uwd2M42akE&`gPlkZ>=}r z{`^kVn_v633fo=7h;G~D)0>V&-hLeAaAK}YV9l;KFLb)5eVviYD6bkmJ2g%>;!yHF zu{VL{yt|7ZrfN&w+POLsQPSZjbCT~UZC;xwuz&ByrZarUbWBc%nwm|FJo_V0Z`Re`6P019 zfniHd@Kr?}*T_j(@lqf#(#@$SaYe<%rmAFxBMRFM;e@euL>tSTr3C^9mN76YMZ?@>%@g z{i|-q;Lo1?_io?GUaDTy^-))WZ6QCq(9TKBEBWvF23E}Q34J1!_Lb%RK{4+;t$z+4 ziI?v`rt)D1+nb+$9IJ1f)CyzH?>_qcT9c7l(fYZD`b__Ot~lze)Sbw5pSVX|vPE^> zv!nTMk`*dK9i;9(Yu3$~&8kFAi%TIiB=u+GeJD?a`(W zpSKl+CS2u8*q^c4nt645N^#1uYVBvo+2+cqb94(7>QAs_T;+H3jj4kf%ZB*PH_tOy zYBtoKORHyivYFu5Yf}0z4Hf{KG!uom7WvzcIinAa5pCWuPD(_a5AG4*l^OJ4ob#wly zD%i6e$>0%}V5`32(&N!qz9nD}tDeK3if7$EAJ&WKi`sYbFmugl&^z!(oGai2ix0yy z9?po=l1FbQHTWpa?O?-1z?bePOwpdC_BuDu|X z;f9RXj+I<5Tp8wYirxuYs#D9_5HE9Z<mdSb2&b1uk#Ds@v_c3O9nx@d~CL+bO>#+%k_eXwSPx#526F+*+v>wY((KEXw@9;TsG2_gBskj0#&YV3aV6#CQ`IVvxyJYK0nVb-%;*N_wXBN828?{S5J}HxDUFCR*O+h;Mlo zqdfCWrJJjfyuq#sI}e;tEM90>IMMQn;65jnWi#Zf9=>KhyEDL(tA4I`kWtBjSqI{E zSOq8c-Zf-fFZQMJp{v^OH=R&)e@geF|47kFPa0{&ttQ=yJiQ^X2zGvo##*Sm@jTHMZl2;GNtP zfAbFgbDj1#iRssDsb!&cqNWuWyZ1e=J+1YaJFex;Yt7Gxf)w|D5YKq1m~g-N$VzUx z+=uV28Z#ZFmrs7avF3Ktv!zi?)|wZ~8>)@C{_Hw&>G;dLZx!2LT0KASF|p75v0>4~ zXjV1-X`4SNbNw^um^0;IaGT-p;-vljYu2mG7V^FSZ(n{#?~mvMWzL?3dpCL%>3ipC z60)}n0}k_f$gpd%2H?glm6*Euzm6*T)l42 z-P5;O{>TQ|ZvMD}@cqNBbB>Hx1%P4idoe|GeaaE?~ zU2oAeAK&aaiPHi~J9tXH|2@vro;5e(sJntC7ejeumQR^^T0Nf~KU216V!G1rTb*~< z*4Q#$`febdT*4J0uAAAXT-s)-SS(S&%8=+Pqab}!OZ=u*Fk_^hL@v|xoBhi*8>~DO zG#9Tr{hcNG7*qfL2P-1gRC#WkYgoFI>6>xFe3lzK&o^A=vCwBsaZa+E_giYYADg_} zY+0S~KyF_%6}2kAl;4^{f6W$adu~xld+^?HL2{t`7ft3B|Gw5Hm0KSZD@{?d7vG#W zpL>t0>sqF7y|E7Kjp~Iz^of;vUXnB}!6 zV%4%q2ez*``cSLaHQ49ks{=U^X9VNfrkFF{ZLmDW_#i`L*Q;3~GF9x%YRkOr>LaH6U zco!cDaNL`+NR1(>PuV~;^uW;-QyXriEZlKdxlO;9F+A{{218saOGcBH#sYoD56-h@ z@vE&^#$>dBLv?Ai!td1v+~Y14B8j;1i&nVomF z?9Bbwo9;h7-nji*P|_#816%O-J+@o;z!vy>mTg+6U7IfAms+ z9-Tk^;?A}-zSf_51r8m8nMY06mK3IITWrrNm;R&KEU0{o`DN6dnXB?eQPgg5H>t;V#pW68#Y+9hK&z0Z?i#HB48|2g; z_$KU&J~Z>F@>Go&)_Y$YG|rf%)~Xh&MsYml_H|%0SRKhQ`TL5K*}VT`y{(wzgw>=y z4TUO_y{)|O_Pm;ZUzhum9-Fe84*RBiOx#P4SLHwD-gYE#n!^GM-Y2=~cV<8Bxm@$U zCDLnu^Z)gJb6bAsoe6rR-Fo_+jFrWL*G<|mT)qdd$I42>#2!yR6F$Dd!kXFNU`VtPRB)32GUbFC*~(U+%|0|=Yd{@}uhqh^=*6!zKF{FoBXY~Xm3YlRiVEK7%;C)bzA zD7)r6@N5WJHf`C&vL(xy@;!e(Sfbs(c01F3z6+Ok9%!Cq5-9kGsU@#ffTyORTXg0h z(FNC53q&1T6(dqn-0+Q`k-uh2yXZ{KhWHpo4dJU#<_ABx%}`~-Vq+kBU&BbA@!#^8 z6rUfutbN)_-l05g?8_FVP0_t9@L{jhi5v5~o;8Q3s4>(9a!CGuJu%fv%P5-he-MY{ z@8apHzch^Gnf_fDF#6`Mf7++ZYl_iF$ys4WhXWtp*veP`bN-g*75pdUBr9#p#VnJ% z@34MgRdjjt{Dji;oQb^*_vbIXcKH?a|2d6Ip71)uid5J?;9d7*4O7sJ{==@1;vSskoS-kC zyF6X@!@O-jPKmFX^ye1WpVEdpm4};>HgvT$?crOo;*?{T?-L2unQSYxgm$`HOuQ_T zBJJ>X-JIwb{u(Db8>$Q}N<{a$H|Ddv_!pyG?c=zQaYcV|?;A_jpVA8!t$reQGhQUc zYC%@WN#jiq+j!rzTwpv{ARHOs=*N1cNo%L;wlz(6SXQJL_2yKwR*D70Ka;(=k1OW% zl`S{U+)=XjbDYK)au&q$b}VDNa^TDzrQMN^e#}=cJ-871!ufoq7Z!(mVzQ?@aaPvd8O)HxA@CWdRpVi$oRdQzA ziMb6`aZ1e2`KLUhn2Hz!=37omZ8FnbV9y{Buj?_Ft3I%CI&;SAmaga%B|_&}ZOTDW|mK5LX5pgB*`&%q*r`91XVT9%L+1e;0d<;q~TM z&lbhzlWMiT0M6p6RQ4n#EetG*8C#aeMOfCd<&tnO9YdvsCY}&++K0db&&GQt*S1 zN^Xz&d)RIrsohpmdd>T^mbUqm(wXy_f5%T_SwDOAot{fAO@~+~b~Wwyj@P-lw!`;S zcj6q?*i(LWv~KRvdqK4MOR5wwoLrbbVXNv z(*l>`5oJV8qP)O>l>tuGE5n^c}zHzzvl9Ur=Jg0AAR(B zaZ+9IwEqGX_brl=K1Cb+SNpK&mBo)QZztZ2n$EvU;)D0qLN$}wH%kxf?iG2j;Vs-; zWw64Y;h2@<*<9bfk|yE|{g#fYIRW-;x$FlNIi2=pq%Tyr<3@y8xIH^HH=(-TKV`?pD{6NID>u#CS>`J6^pmWc$)pUOi%Kr9 z%P+oAH`#P&S84Vyovw~$FKTRzcI{hf-12OXsmp_|Sxdx~SGQkLNHx8)Z~fKAH_vu? zsN7vFo$in(v1{3E+4jZ%fOQD@6kYYm(SPO`?*@ImALv=r(5n5V_mfNgm2MB;mfQpc1-`)EnI!@ zr%AT_d!@Hbll3ocGzs0JAme#$yPwE`8mu!+Hh8O=^nrCdt5_?;jC&W3WXwI@BfmVfI$~2c^YWQTMKd0+ z^GUkf^hMD5?(rklm8-nu`Tm>~n^kntw4D8dV9Oz6$t@oRwjX7P6lXd%Yj&s$&-(=) zGA9ok{66?Nb%KTZVx#2!Q)e8RYxYd&!+KMmbEl5X&+Xxtb8B=vICIjDtH(kZ>+ZVs z#qe$PnKJL~Yu_^+&u7nd{QcMH<5(m8|e!25*6BfpKD)_hjHcJc?uk^7uCI)l^~tG)cR+pnM3{Yr8}glgcN9hQ>U z-{{C3RO+~xd{?80YmIoS%LK)9SEoCE3H_MZ@qewMA6rz#md^fH(M~dt?(j@^Z@V$m zR3WOrbYa^qh0D7<3ofMxyFJZ5#8kDW??EDijQYVVOOyAyU(M-vdvTbd`cBiQ-xJ@9 z1f{%VJf_%va%y1S()I4ao8Joew_iN=`MtwCty9|$U!VEPU}L<$OJG-b#+l7~IvUv< zmu}~Hp>g|)NT8knQHkj-U1|&&?^#Y-WX6STp1(y1MvN(M;ttq}T<yIb5S$`Z>ZTsaLv8v^-?!>FN z-Oe*T3Fjpkgg<4&$1B_-LY#Q!uZcwY9?WWRlhPuG63me**_Ov(b*c=(-8o_j5(FFZWn%ys#wJnJ>!6 zPj(vP*NwV?$N1E{Ez%87op9_9D}S(oGwPV!qX+BS#l+fg7BO$xA9{f8g&@No;eYF* zwYN0zUMN0Lz453}p!V7~X66o;3t6HY>jRQ5d`p*JaG(9m_MoOI3uYuUn^d(p`Ye9< zUaN)iGTRGp30HkJ-@Jx@d;-lH8~b=K@E+JL$u&J{C2LN@JJx&7I@4D4)RZ!plzy1O z_vZIpf#Ym1Ob^`7`q*sl5In1o@xSRxoiHNxx!Rt znGkbtiq6i{jPlFw+-R8ij3J-%*D;NYZ1XF{>z-}Bpw3y770mgdBj6lw%<9M{PAkrB zL9Dq;zV!rLwGO@CxoZB6M_lzgJdG{#unxj?K(Uh&G(XQq5UszdG9PiuruL8rb7T~BZd^;^clj3M)n9G& z@wDf?4O2s=h;1{}HZAX8!FD=4^&d@>8E)jCE4ESZ(a^>a@vr z&xYg9AL=8x&MfXZue3|Dru@`|72(ga|;cj-C0>Q!!ojzMNp;c9ZLe zwqM`U@=a_0)PfIhJEpPJrFPy-XumkK)Py?V$dwda^Tdr zET=0I&gdSiW+*tp^s#x-MY->>hwd+0Tf-$R*{gpnyW{ z=mVwfx_#5wT+-Ov#cl=#-0t@e{hXAWC6{e_wAh{fb-{#{A(6K%Wa1jPr%b-VA;0hH z0TaKi=DO2$Pb;2oQti<>s(ZR(1J9uaC9D45Nq@UmBERgwF4lJa8KoD~V%@H#SL8hK zNUF`){37~5ZOD{kPc}aYKeLzBX{%L}LX^m+(xsw&(_cF;Qrf2!cVtu3>1|D#J2e;F zF!-~I_x=p-Img@X7=E#mXSpEwV|STidzt=@&%)1jKm0xMsDt^$voCwKxGwB&_Yu?Z zWP0cKq4oYrA&1#orCuTjj=y!S*At%k>_w>ThnFv=RNE<>P*#$kCXny0nN#Q9b@G96 zG?)D5$>uGOw#Y=hR{j0ND^lUCete<8jO8+)9`*d)=96&6o#DsHg{?}*`THh*H!xad zY}0Y>phuOH%%-1)`bLb`ZgAQrAJ3oL`HHdQp-}0H?Njx8b|ox&$9jZW%%QakZ{ljC&8g1dt1##YbzxE{VP45(w}+fJbV=3SI_^4G_43*Vb|b0AB#sGz(^@#|B3)$WCpNkpOBg;%ROna!Adh=)e69HS!1Q`+t6!vv~8u?~~s?sbBQrG=skLr=1Qp`C=W*9^6-q)-_W* zkekOV!E~nc=FX|w#m%h|3>`~vp3^buzo0r%_P}jvfum8U*qV(GR0n^0>3k^T$Y!zl z=I^2DJU=Vtg{R&=p)@|F;$ctr}M|ZbQsPGJVucvx!BMXyjw!+Q3XC7RQnQ=^^ zR>VNvl5xlX1Ajech`w@qVE2w^iooo{YXZI<_&*_-{dmfJq3_!nKh&A0yU7J6Rq>v9 ze|L`L&s9qEuf$#s+GYJzU*pr&hVb3Hga55I_&s@z_J=Cg6ZNP6EITouVUOnBxv4M9 zHw)-6{tunDCdzBivq!)89;k_9vfIdb)b~L2fjt_|&tH|8i88P1UZ=FWUDf~nwa;ZH z?z`SbX^RFtoqNJR=ZOjHO`d?8ek!5eJu%A^-m_ehQNL6tdnPNkaXsq`Gxj?ys%^Iy zJZ7+Xf5p?|+_X%F#oFYcJYekomt!+ z?`)f2Gb&F~7yoMAU>VD_VtwvvL!NoASL7LwgmtdEuWI3vyoS@3X~X4n0-9RKxWDmi z`^Uu^Um)KZ#k2>S82hkr(H4vim$cyS}$n(8gxH+p7k5ZNmLq&pK0{`G1hUskZN#L}_6* z)vNb!PrS?WW}LfXE>9MBgPq@myY)tAl=HqsHbmUIEhFf_-p`?N zaB_5A+=mTzwQ)D%MZQbjJ^1eKwdmM%mzEz}%|xn~Z@1*%u%>_6+2!YVoPO|C_}F?e zKZXtS`R<&sns*cXtlh`Cvons&v^xK9*Ok{99Dm}(j?LQ;eBpbr#Xm-t z;}N~=Ki(uv3=o!l7P(yACjXmZaM-Uc;_Uu6|7rC`Z2a5v{g~HNf#BdR-$eXB?o(Ux z&BW^1Vvd{7gM{qawmz&iT)BG9n$@;*&mC28o!w%!Nn82y`urCs6z+8S+|qJw*WINg z9#~_kbFt&-sZ%zeCBK=wTm4;}y?|>T)7s6`y$Z|c1X;1}6My*r)#j*RHQ9=ueSXzU zacuwm#g1Ju_nA3!&E!*C*^<6Q=(B}vnZIo6>-3ebZ0AL92By-Xz(@Sr0-MNY+TL{ykS+E%0t-z=zfl^=lcgR5sRoh|W@Z7J16* zok5;QQt6a0j)vM7?oZlsee2bodE#5N4y;d1-0|%D_UEg5f6Q$#cX+j7HRG%kU+z0} zIr_4l$l;#$+C{B5X!+aTnsxgvFHG2`Z^Rg%ze;xQd&_wbbN4=v_|-LG?)}e`73wAb zE!z8Qp1t-I@m`%5huK}OzjgQ;`io(+&i2RRAJ;Led93~}tS_YK!W}d3rew$KpP^wz zd(Ae~YCNxYKJ{Icd956??J>68Cz~d3 zW)|fwoW}NXa*Vr2YORRTidNO=Wm_)(P-s6gIrW`m-vp&!0Ui-sviO6d5-){jPM9Ob zF+=o&*hBHmNm|P6|DT?iU%O@7fuHhnzdwZ~-wZZ3dHX?ODR1}Y8t0RX?X@3@KTcS( zao_%>8%?uaavwH3AN8={{}q<>c%@S;CC|J<$}xm79=;_9g$GkVS)J=i!?S(kBU^72llCqE~Z@Z4v}KOkT{=hhFA zi|rkfAD0?EN^NWD*`eIHm|?oD%Sz`dqF<&sFsX;Ad{C%pSBp-F5mC&LbW2!x+gN48 zgmCo(@t5R0y@gO*8{?Q=GtM*RrQ$JgNY|)F~Xyja6d-TkoJ({04KfZ9` z=gH#Kw>t`F*@kp3{H)0?W`EyLzw<%VPi4i&j$(J>4yZ4`kSFSQD9@Vn{?mypZ2TJ! zdLDMVrjphoc2n?`fzEr5TIKKQEBZxGpWTyq>gKI45zCwWbKkt0xm4TfS>C0vRWk~5 zA1+J$p%{2xMQwKb?}FIJoGFW2Ir?8Om;ERtZ~yni;)oe~wp-#dvai^P>7UW``c`Ha z!`)Edxc#}nMXisEg563!EsU>pQMmY`Og3$+T3B(4srohTNn6d?CYv%uGIz9!3mCqZ zO!9TUW|A~_deC>(1cB44-L=mrzSny>yT4{RH~%*ETamL*iEZf*ltm*ME5^dfseG(#0R1Tzu<)1;)**IU_VhWzWC%~sgcW%o7?_$OjJDdKH;?e1D^dsf?8{*Rvau= zjbqN;HBWir6E!Kl^-E0`n@m>AP29V7xrAo!#yfYjU!8C7u$y=`$-`6h1+Nc(w%Bto zxzu?)H+1Y61#|p6+!*|~n}606Pc!|zdwuVbuNQPzvNJFE7V&wf#gw$pb@^_yWY0W% z*m>gHBU!&E7Z1&?f1_WDflL{Zx?IN1>ffWo)YBnOQRcsvt=URtZ?r8^=5^C-?KLv4t?L=WO(%Dy~&tUlGM2D zYqERr|I7lORQKYpuM%Zj6pmYzZ80e*{I62BrSo{`n(vzyujQW}e?G;1_X%@{+d5?> zA8L8}D&M?#C(FepwsCR#zIw)VN$aYo|2bu{Z(f|eX!A_j+C?7<->13X�L?FV)?? z>$YIom;OC`M*1I>GesTyTkc)E_O<0eQEPd&rheh;^`-Jv)7|q`W?l5}+7Vkg_W<|* zMUz$27wx*+cyxOBodt7M*KIW0v%rk9d!BZNt4u*TQeichqGK4d6Yt;_6g~X96%Cq0Q zdhDx7s);RU)~TrHAG{5&b*X6?L>|_>aWVO7#mqI4M`p=)P4(rv-X2uZ@#s@iaM$CT zH(mGWA7e|u&Tw;j#$Un4yq?lkvM!2`N{h-myl&sG5^)tz0W5{Bxo3fhzqVk$kJg z9yQbMDn2UURFCUS|9nO2ndUytb#)vJ?FQ46`pRFlo@-HSx=^uGZm-$0?cJ-JQXe-N zPiGWtT2!YHepHSv=8UMo=>}<`3%U#!n(y=PIe$J-)Fx@av}kUe;3Hc{_iu~*qq~oO z<=K3FQW_6$KJ%7l)0^r`zBE6++A{mi^d(=meau?r^Q}y?Rx9L2^wKZp3lG_8Fa5}L zXu*c~>6a?>69aDS_k0;9d}YJbd)cq!mv&jJu{{5&m=)8tRgf(%L?Z4>+d*-$HqK^! zof2+leVr#8_udej*DQR-E+l95p$Il+_NU3etL0{=)QKMd)bz#Q@XoHyjV4ShK^y~|p0_s^W}3!e;*y_qh} z>>epGxp<1ji;WeFv{tkgv>D_cc$|4;3#aHI-OfsLmbU!=UE)F|!A%+lXE=i|2F=Vp zIbrIe#dEWpv)0US_^#%=X+giB$lYEw%j7*yX_58boY_?q^wpx3RVDu~Dbb(Mc#D6# z;n7_?1m_iAda(GFzC?}7-*h(l!2dfBx?iqO{BZG0ykt$v-|K90f#Hmug|XFnl-WS{6cYt-w$~|>bP04HFm}Q zIUtnr#Vvl%gRYJ?>&F#xY@b_W4$H0!{#x&}Yrm4+YOQ&X-_?G~JH6N~)P`@~ zThrD5)ZT7gmF8W2chzdK$Zu7l^CMJ(?F`itHyxdEMM24R?|<*UtPkd4DJ4!3t2Jk} zT{ii0)9vx8i%$=o5Yct;xBjtP>H&kbuYg1 zMYBJCVrS`cZ&>5dxy)>bOT^P%LU(2z>=4vvveZ0y#{4{2ZYyIQ*PivMM`qlg`?ExE zOC5j8bK9^lD-4qZ;$1yG8K&$%zA~j_(GtlIR&7B>UY^%H7<~2|?^)?Ed*-$;8`hjM z%1xe{5YC*|9pWv-GiyalEzh3#;#H{^L|iXle^6^WWtn7`n!e4wCz^^TXA=eNtOF$( zBE>WkrcLqt{b7+_WXdvM<8Gd^n{!>$xH4vT&N{^|Hq-rJ`P`#|Q)OM#$`U3zF0kNy zVmf8TI}M|9b}`8#9rGLSOh|B_xU!c~&98OdgAnbcJ|*Y&=5W@y+HUzpCnijiV|XFH zAf;nbiqVI(cCeGB7;@%j9Sd1-R?lcLQ#TK5wV1(s@2x5iHH<{QnSKzvER!Yc+GZlk z;?S9?XmU2dVR2il$y``@h~0W;1)4>c+8cp^yDdt=>bVgZ*MZ4-InQR=zB-$ z(v#z1=T1o+{~tep+05A)S5Ezie-RzaXY_ybRKq;;k7+*JwUh5`O$yz$cFk7KfS23i zSBC8RyyU#g-(^^J1dp4)IKlIo_fTWebLlTOFDf&w`0QBsIf@_nZrrWBNH+h% zLp#QN0VdZkdoM^GzW=m%k7M;OmOYLgf>#@_OiVZ~Jw=}R3|rj$>a`t~_Y`V&B`JMK zi~1vwFQ6I8*`Ureg(q-|4AZ^S3#ar1P5R2ouy1RU)`hhFj?y4AL~@v(lrNN=7B#70 zkE2ML7=zT=f)%BE9G9##XJ~7?Wa50$M3{lwDbwh_LQPqcFhg0yf`*y;F~UnK1H)^5 zb=k7ugE#EpYeV5oGjU=Z6>x%_p+TcXD!UI;<$I*IWy?=S@#EjTUj@q zKAZUK&!s&pI_v}%Y43i?%-9{j^S9GfgN=3DJ-0mfw5sx+5tBGW{m!2Q^A!K=@E5gz z-{dC8*QN5NU%&jrkCP!?CAY2mx(>NB7MrN_1^s0@x>o4@-p@&Qc=nvScR>1?_EDiF zL2G6kzPXfql0*6M0q5&4Zk5|ls(SHd@_c))oQnL-`*j7HIV_(`JA7DtvR<;ov1QK7 z$!EOw?S4y}sd8ZWpirTC80j)oG17nd>`0FJ88{>`-Lp`o%Y1 zYkf;Qd3Nbu*Mqk%-3!{dJ?PENt{ncO^#MuAlI;gQ-?rXt`t~|NRY*U1*~344HjYVF zo2IOs%vU;f`j`jsU zd2zP6R95Zs6_tBwXD5r9{B*l~SazA(&*u*_zRJATTHP0#Bz?x%cxUoelP$CRvYvEY z>G|{djQiD%ySU$~M63!9dgAH5A$XI~>8qOcI=(kHE@mkFv9r`mv9Dd$wc{}V#^8+_ zJU7nwnG~sPRK9y(B#J4L}G{t|lIKMGeAFZ@q2?Kc|%Y^Z{r07ViZMg@rQx%evBAx&F z#%Jf5_PiG;@jIA*X?Dq%50{OP-j;Y<@$rSt#B~z4yqVl5Z))F}WN`lDF}J$HH-ewu zw3k$^{2=CTdO=W6{+VUms}(X+5A2DxdA|LGP$1jV&HSHQ*y8?47)(xMnwRvjSdl@N z^+KmgXN`dCha;lz4Lf-ua^U zo(;Ayr`NWx7MPYOV-mu~Fw@*|0yn$RRHKQ1xk|mXbWZ3>t`AIKlDqDYrirNWnSPm4dz>) zr8~ZN+{z9L;oa4tc-=|+{ac}HuRZ5_NyJ%6{Wzr|wJ5^bxSdV(1DCtdd#$G)m#p)} zKg87=Jh0<*n4P9_DrC>H%i3GY5*_YDzLR|Ed$#m_m(#wrdoRU4Ut2Nr=kA^qJ=Py~ ze)}Hw1=stE=D(`&)?z>BXZ5gTs6S-&Dyiy7MUD{Ds3acbr(6 zuBzVs&TOmvba{QP_}e!2U5!?nY0lezTe+iVxK z8>;uz8guD5H2Pjkezm!+h>f5BNhw>!9)-=n!j`LYsHjL#m}1>RW)vwv-<1u;e?*m_U?BvZ?E6E`g3E< z`57ge=@Gj++k|@q{I>QeN%>w;c%}GCRm%Cw@;UXA?k4jxm;&uDx-9Z^`7G$GHfw$c z<0971WdgpcQ5_kHi)uEd1ui<;u}skS`P$_!-U7OwTSP8iayc!a>%B$h;wKkvfwdkc zhhxsQZ85s2oM*I|p|MK>2|;asOJ znitbtW((&!Zc)7$<`ONO>%2wxVwuZr;kOQ3lrQ?ZSPQ>(+M<0iXVKk`GWA={8UBm* zc6?L2)t(W*=x@g}fw$)`ySuOp$-0ynTvT*v7m{@=vA8Jc;w~iXT4Hk1x}#6AO8w$S zm-k9meJ?5&33vFZSarU*>!L2axBZ34qTo(HWvjU__PV4C%=Ii0yZF1~oSIepiPo+Y9e zuew|pi1jX!y{O({=UHNVk=Mms=&s8Y^R#@$T~l9}ExO(LPGQ&N7kZ0!cfM2nC311E z%Xh)rSug4qofoK`_JVN{d#9cI7lDh1UFNI*V!Ej8(l1my@rB_ceL-8lFDw_Qcg89G z(hc0l_TK2Cw#$C?U(6TfJL6P;316Jw8K?Y<`(k`&ocgcXV)KG8Ie$O+d`j=a-w%ql zj$GLL)-u$lB)`UQS^K-*^DCc8UT-?v?o+%ub6>`+_p_gwUOqDU)}i86)i3IP&e7q& zt3N;Zu=DrR&#!#B@b{DDR@;*G)-zJ0HhF$O`~1q+3$>puzuK1EuklmnziU4K@(t(j zXP=vV1PPzD0SOoL-!-0p`I7VZGtaktx?ua+a;J0JaFvtQqM_g2Hgk~@oEcIX$RwVDbDOrFp(yYxrG>KR8gwCokiSpKam z)?PDDa@Eu3c}bHvK8t;@pETq9#IxxUN1rJF`#$Nr>L-);7gAqsJgygCvis@(xW&sV zj~2Z?R1z+j{Qq&z_N>{4FL`vV?U{zNO=p;N*Zxwx5c-TIJ0hPtDX>cdEo& z#50v~|GHMgo1q=P)f}4|uUa?Eo!P>+EXar9+7yPeP^pHc>c2QPgn4|sdt{y4sg3tH zc^7S&{3T-Y;YGYv{}Scu{xR(6STH~JB*$l==SDx`wp+~E#C~+g!saa-L}p1i=HL3a zpmnMER-2eFK8L!*7j}wS*%+)*DUI>}-nL9k;A~h#qv3XuqoVqZFSzG5t9%z(t>>FF zD?+C|rLShe6Lk94UlP>%@y!qVn>RF*-Pt=)fS40*saCoepn6UDj(uo7*XS*fe zyU)HTx#VSljn<5~o>`6T(p4YlxY*CTopE8NtHpx za%{}YSN}C$pd+ZnTE4|N^7X;$<;`EEPF{`+lIuERyCSY+`4ssBPVbu@8+*Ty zIQMUlpHqE=lTU#~u=mRxuA^(({=Lg`U11URsy1p$*&4km8_ykjJI`c;!+Xd7%huhP z_I>v4`j^>7lfQmkBl%kKb;j=P;^x1kDwgaL=MVD#dCljZPJzw_CfU~ALA-Z(Ub)&^ zZM@aJJ0V!_Tk4PC2No#@*%fS9&*vY%FIlkn@s*Ngf_6R%n%lFCUL3!=Cw!KJ=M25% zVm`iZhRWukjOCk8NNKkRuQE;l==GrWxY&dWrg?v|9!zA5`(pf|`BeAuCh3ZAo5a6= z4>Y}$q0p=C6TLW%_qm9!&$6dn%+DSL3f?Nx_KDkne9g=ww^SDgx6~{b-JtaAloWS; zSjMUKOESBre!YH3okQsLaf`nl7V4X>KjLM`?+VLayS&X_r}yXq^`MfA@0+4RwfaQn zzTN(Ok3fX(KHr#I{Ly!=bYESab^X=D?rB}ObHms3-g#W{KPo#}x6|dz$@Z`3=I%Kd z=KYsXYr6k+wt35bHi?|NzdfH%Zs*LVU*@H*LNCP-#VJTA+vWfA6>-B2NG9ru}!QIT%zJ{=xh8r#m-K zD~51;cSmMgXWi_3mH1O2-||$l%c@C>6C;d@OyXD0oK?o>Tp!=or@xOs{m%c^fA*38 zY){Dd-?=*fz`cXQ%jzXGbnk9|pP`%O!&rGFZ*|{^u3h@_`HQ~JZE(5fuyNkBi0MC7 z%-p)GG~}n{hkXp_WZvO?Z#%~egCqK!2Z9YcI7NM4X`a|T+rOnMZVvm}!=G;Nylk~* z$=eL!v>Scf5>wx<$&wdqZ_nG36uy0f*ObCp{OXr%{hdT6&ntN%qc_QeU4QSj$zJCi z8Kv8})lOab)gdzFV0^a0=7;ayILj-)_#QobU3h+ooQ>shEj!tt?^X~QW@>4E->zr~acIvLz%YF|4FnbnbOm!Oc>Vy?tFJY#aIgAFkn$2=C=h+Y~lIM=svv&ZJWR z9*w_CLvP&)R;sDm@pQ&9zO()9a!VfheLHThVZGdY@s8)-_N$nx>o+XFZ1*Z8=H0gR z=1Jity9!^e7HGe2)^hL1+$z}_*F)9PpWF&L8aKC_Urttbqu_pHGb?We+qlS@HOH;X zIJac*x`;J|M=~uJpJ^#|J>bdlhhe7!*<=OY@4gTyf7|+*iO|Or3wt`Vl|J2_)R(5j zXZiQnH`&!kO~v=!-C<+!RYqibt+emU52vb>_4GChOw~7=CA#l@?!>Ovi3Sfe7F%t~ z*kURA{onCCF0EhQ!J^fnZTndNZWo%Z@iBSpt>W$rI~7;%kh7_t{8eXNN0LR_*|%p! z0|mvCidXJbdiCg4_F3^T7CQ!q17BaL8E-xpJ@aX_3fGA92y^b;q zKZ|y%;A2Ypn4r5bDbR}V-~r*lJtw|DG*o|Wa3wcv1^>fJHM>31j~Q-!3D^BUHLN~Q zev-(M$M2a9?3?#XU)=WHKjEL+-r$c6A0|aldDdF2)X7^zH6N78 zIWQhSx^`1T@zxunx27ypSg`&6sx5X=Tv`X?`DQpjc<(mh+3d)u%g36}Zmn4zR9WzI z&;7Yc)6f6D`^7FJ`Qxe=Pm_!f+~*bQtd3dYC0H1vwyU&Uwx+tk9@r;)>bh z`s-ib_VxT`{3E{L|F5@=yz~Rqxux7Fjd;g}j1nZN+5o zJpXKZCHW`c?kQhyTdrFtd!f30zjWyC`OZZ`Co2`oYq^%3N^kk{wy`}flU?uh9l?-E z?;h@&!+qX%kxlEv!^L0O795H3Ui43D^)I`3L95=C0xn-`aIHT# zDR-w^rB+I%fd5(V$UV)%pR{JYPjCu2vzNWLwu0x1_==}pOH(;(jrMOotQB-&!J+%T z3c6c`wyd~X9;N%LI;;EFyb}|6Ei9ypxu!eJGr8F*Z(}{x{n9G=Zxd>nU6^bwa_{g} z>?th1Q?5|-@!SIQq`b!NZMMy~Rc)?3yKrv7w$#j3N$XF&*O-_6xs|na&KakTzBUV| zFD;I*NxZNv=BS0s`=BThk2ef9-?ip#v;Fzu!0MC-yS3f~ZR&CIiJ0os9`o}<&E{JN zuHAkcbSrf!r&Hvgugt{;f9`f{+pFGW8Cv!GL);ejfV<0L>p!hoK8tG}>t_iq2gC1L zmzvZI=ep|7Uo9A}RC-3_pX3>7jqX zwQ{bFcGtt5Q{QuJ2z}e6UC-&7Kc~>;iT1UVMSC=AZs=`#JmXb`XRBt3H28*c&=^{t8Uu$+I;G}U%v0w{r=GNGN)lz(Ul2XLiXsT9G-VTv1exW z8lAJn9EWpGd|b1%|9gv-S7-IHw=u0xuk%`D-Ei0b`Qcr|X^FM*Ycq7!>i6U+{L!4_ zR&na4s${dc%92O540F6MyJo(dFVozT!WfaC;rV5On7rtN^};jmJ_Kb~ZT8wWMUMTK zo2IK*lndJlpQ+@Kcly9}!LdT*@#e=X7g*J`?3R%I_M}?;*W&YvFMb5~g{4???C<=y zf5o8~P5sCBTJ)0-`Os?Ss!U}8ljQt_yU%~`QAobkw5YY?ri9F7gNdgW=q|{R zZ}MBI@GIhT?Ua7IX*K+fi?};}maJDUW@G+d?UVJ#?sEO^o+Fu)mO8z)jxFL}Ds}YZ zbhZy#zdvj#_W4@sWq(b5-?@PA<_xn}U$s*;`mmE#@I~K0W|@C0!_^PC|F<(fabq|4 zqjiaw<7So#{FZCGo~P+$x7okb>bYa8|E9ak!oN*<&U5f`W)S?!cZXgprxuG{(VX&Ds)XyQ>>EYv*77&u)~&}KzOt|Q_vEt0oqr~Nyo?|B zGau>p+Zz1CcE{oGvloiro?pG(!2W~QN(cQ_=hp^zJbb)fmZAF1@l8!XD`acs#U$kZ zwJ9mvTdwg_bUokyy;iFD+v8UWXBN4CoaVd5p^Yis_C^f*cWqwfr$LWSlc zJE#8L+W&cbdA9$naD2hPLg$gBt7LDU%DXe}lP}oqQ84)^DI>&tpy#4cy`IbJskIf3 z8N5ffa9`WJmBY7t$)k_O!Sgt~P7Ca1I@ao?Y#~*k&b9r+UH*jHxl1p|+MMdR_2Ik7 zjCN2P>wD0buMdBoULJTb{QQ%jVi}t4zPkIHDuqQC%y|2@T1@HZnx}6M8^5}I;N_~H zYc4%=KBD%p@@r;^+)n=Wt1|i)^l5o~-pcsD?uGrGm;KY5e3Ui)AT zlX7#$+4gYew{AO=r`<_fen)uOo#=!(mz{T2+P|-^?JY9b+4;$DXZNx>&l$edKY0Id z){|e3m%~}+RLx{o`=gh&L!fDYRDzjfW>Ut^U-b_f&4){h<4G z+VZy>_GMkzx0WGx9WT2~=#TJ#zwcfDANKpd`a;*-V=L;a99BkHv|O#am0IP_Kl|f8 zu4leI=3YDQJH_9hW8(48F(BZ_f<+D|7tdZ+!1iJF!TY@#XU*kSOUQknfp(ZhTzNc%aJ4+*<%7+Waat|Y3>^yK-V)6XVe92qf0zRC6?q@e8 zusY;{$p2$I&OEm;O?uj;J?opq)oJ_JUUt+5`T_uH%$I>SkPDdVp#9LcHJEI+cm~tyw=MeitrO8J{qChbp)y;z79TM>x}3{w_eXgRyFbloYrZE=*tc%guejEu z`4$T{M7+p)lp}Jh+TrNK={vr1Z!RdFfBf}vk-mA0tZKTH#o9a9%I_7N^`2R9b$rmC zul%9MBac43dGXN4f`F>Y9yx6f_b=S=C3#iyeyu4J_NOl3>YBbZuldCC@DPP6Lv=g5 z?DcOG{O;)QyQlwP`nE$CXKVF6xu@lR>rU8=HiLf$RCD{GIiJ-G(dv{0^OIXYG74Vtv>h^?Q}>ADjfY zYTQ|FrKZ`}^ZJ!>I;(cq>wRat)~~ZjDqMB`SE1G6`vRI(eUH|b2g`i45Y72(VXeeJ zb(e6`i(@n6zi(0h@HNQbTXlE0)Q7!u9XfmNOT;kPeUv-4L@sRpeY>weQ_paS{W9^3 zU&f^q!fFy@vo6FePxnK6=u)})Pb#{?Co^TMd}ZJI$z{z{SG$Fxb)IXdHZPc{efjQl zj=)P<@*kgbF*Ti2?~m$DJNbUy4H@fWGsV6+wCcyPD8H+Aweu;x6Yxa1Or!6ELh8Pc zZjOKFFkS3l-RIo3_=tO#@=w8~W*r<|xp!D?Yq{J$d2YQ_u%}M#gY(`OZQ{*w`{zfu zoC=$+J0;%y%B`o%Ham6C-|O$ma=H0x`aY&(VpBHw4|iuPf#rKch6|V^F})E#1BDx_bnJe#}k&QMz6%>ilxAjs24j zH0sZk|M;u)tL)FX!ju(r8#1QVY;`I)Jb$6tAGYJh(~sR-ELNtdZ2Vhwb&J06{8^SE zkBm)MU-^{ytjc-slaJGxPPeP)w!bx)z29w@{U-~C*_t|gm%UoC#KOdXTTt*U%i9s> zGg`IY1!`ZsxGH(Vqk=NKMLMGYi|6)tAOG+6+}XacdT#%V>5A$bKYz5p_LAeBVS;|5 z_%Z$O^PJY)3VnEwwJbDm^K7Nt^TJo0zajanXX2t}yT(6G<&J(yb_wE7)|c5HTcA*8 zJ14g9$pgK1W$p#PH$HrNz+FW8&ff{KeCE&3&o4KvtGC>+T5x@tsm~qtdoAI4yQ>A) zm+AYkYIprF65>9UTWV;rsIuJ9=!zcObJG&TqL*(=I^RyOi zW=`RyTMjPVt#mg2|20VNbz18^saZPNea;4%Jz1t_P9D@X_?KcE?xKJH<<$eXw8Rz9ignEtR}r}# zqRE@bS>k`Y?S12+%j~QB?sYXwpO5VF7maZhtPj$i^QHNi@qNh&|6)SF&g0^~TXD@= z_)5jQV6UY)Hr4ysc9e_s)p?c5gvl(Fx>)}2uKxF?^>@EbuMU`O;cM2}*B^I#S_12r z@B3bA@BL@K@8#2WGm|yx@xQI_f7!qHn}6-){|lx}p1}K7!6$LXrT$X0Et_0temb`Q z=7n$7kL{N%%>94N{>FuOm5<+>Y`K>F`||tx^My+fn*0vpuNLOo%YEa!=(K;!9z9s~ zRQl-g&+o!+C)OQXTXH)3=F8PlA3wec5IVnq$JIqQx{80SUA-a6pVc<_{tJWs zb&enVc-O_$ehirTrj(Dp!jDb-SE-WXS6_i$dtY7rxHZA;*|+^-4_2~VPY^NGHj{Q` ze7knfs?9N4i+AR;ZJk*k_kQoEw0U3S^sdg#SyjC9oL>aYuHxHyyq!>=~`X zJK@2k{C5R??9rVwyG%Bq{ngJ>O53i^S$rLLInRGxP2fn z{!@$nOIEi1A2=^hHM`swY3IFYLdQk<(Dtih8htl}9F_0xD+%<;Us!cLOjh)&kFJ2t zyT7(B8~UO;v{v>7y;7*S`M~kR`JVRjPiX~z|E{>cwt7mwhX3jX2UFu6!w-3jGsh{NU%8-AIYYjv>6q4m z4-SCk2Lia=iV6+}xNevb@>^m3 zEHf8vKGtPtelxPFS?)Msk+R^!pI>nouAiSUVd~m6?x`1#TX#k1sp=h@^us>vQCIzk z^V2O}m+w~fd(`YbXYrn!{Gpop6XlY*K&VL?S_vTzs=lT5gn?oLK z-gBz|Zsf0Dm;X9omYZbHs{XR#VEmu0Py5QO z)s%lOKP}t*eA~a0oyk}8nWkH>>So)K^RUZRTUMt$op=9NpQYqKvA*9&x4+2NUGI42fqtfp?;8du zMK=-QD-(UHr(K;#+kCvDWMdm0ospF{E5E{DxEKjJHEm0EuEw5t7TtpB^c^V$5IMf3N5k-zI=eQgcf z^s0~)v=cH5g^MB3G(>wmu z@42(L?xt3GQ5T!P)}BJkgnzDjKZ{-O7v1#y$#6?w^M|TMSIora_dV-vL!rgn@+y3KL=QjQozIx&8gr5_tW7hrElikT-D7Sn6re$-N zhu+ws7V~cYqGp~)_pZHEV7AMAnY(vIt=cJ8+rIL%$I_hEJy2VE=stVb?_-jzOD!y3 zaHzix46JHhcGi1E);e`@?TySbdl<8JN|^gqGxP_P>fW=_O+T|E@K*E3r|q{HZr$Bt zpmx9J)?JgibGpx-_1nFC;^&P`hfn@IW^zk*tBt(e=B&R?x$RMN;y&HFf0xhndHeq* zZv#%&@6&u}*|A}B@J64Ac+u^f8&7>-{7qeY#j?!*zol1%{hyJZuJ^@gjj%mi*u#a_ z4d(Cp_5IhU|5w;nRZ9HZzrE4x+nIm&l2)tQKfStfe{blS(!hi9aXF?>mLFiBa-Hkh z{ymwmSXTY-p1q9k|DW&sD*t~s^UeM9Q~s98*T?58>%RY+>l<9Zi#@CGm+kd`FKq+5 zFPq11zV-FTlm)k(>(?B6X`o@7d*#;ReUCnz3BIN}v$c4;`Cr}*ud}aAjq6|ade@cK zh&26@CDu!i=|{!Qp5DT$bNT=D1&i!eDpbWXuE+<7$NL7$KE7HS{>sYO*pB;7;mrM6 z_1SZ0Dpx+Mw(wt~{$Fawp8dPFy;)damm9hB^{x2$=x3aJx4rqbzVh2I=bFRp-+vWH zPk8pzclX_+);rf!ZxEYuaaa56?RPU+*4^ceu6e(uAp5U#PDkKu`%D)b#ak147ad67 z|J2e-WEZEzzvzUv`)=8r|8BR5p1ptP5#4QDHhG-&xmG2(oImt>%J&f2+)#Jss}q-6 z>`>?rpMLo1E;GGI-A4zfDy^HmyHa_<4)vBe?u5ThUH|TDUd-Apskb=jLI3SM9cTTU zyMONfHh-hh&rk0|s$2Evnd{oTUBA|kZ>#mzsUDeM+!GF#g>dg;{Svz8=ld}3YZ;tj z-1q-~%n#x2-Vrrp-P2tOKf@yOc!)5C6uxp=+~H~*g(wc8~jYI*iirtHHp zlWKS0eI0Ymw>v8GLg10F$MagP{HC5Ra?4)$wEkVuv7QO1CG(3LG%{*5wlD2DZLq)S z{nBG?ai@N$-wl~yEptca?YC)H?+5K>T`uZgGBO&naO3MY@pL`e-S?ZmO>ccsz4r2F-vcN9 zf8F}`AQ#`;llSJK5 zF7>)^xZ{S}ns57?S4J&guw|00)4Szd+fyeQ#v5 zG`5!7t)#Z_(Pl31Q*uGwr$bm5dOqx(F}-5d`hN|lrq|voUGV59hoH&)hNmxTFV|b` z6+TcKv+Q___421p(gJ@so=I1Bl?y(m=ys5Mm(VUZwvyU8lbsZoUHLpmgzMg{zv-`& zo5jOlYu{PgvnS{gm(al}b2`K-ed^jHqUUNo;&kQWdvGS#u+i%G;PkyYN zDqnr^?7tm*PWA77k(Qkk_w;yNiLvIl`Za$d+?V``*S42_^l$O&`7vSzk=7;)^=3Uk zzj`nC-ur7??AL$O`%<@^iL-KR`NHqJYi0l6|J7Ch?N|MO`}lh))9$BLPX6)WliL0i zE&l6UOzVD4YV6l}xmRY-{M7uI#1!LQ&LZ}oqqQSGoL1k&QL|o4`KM6Va{Jev%lh6g zS1eogEQU?2NO4+zkNBh3(`8Z&3td?&CN6!^81A$*;&GPj!6P3nt<1Z^erD`j77$e+ z;5R>!b5^+0vy6$^T^FYYXMny_nIl(vO=3p zc&`V&+#6cIFD!Xe+?hR%+U&BShD^^wy^WuQdS6?#_F_VkV9{bT^L1Ajg+`Y@WLl=R zry}!CvSx_E28ox}lcqe;THY0X^h2dV;mpR_TyxiR+sMZRFW5hSiH*GO(WuT3vNLux zG>XgpICUua;8d<%6a6c-qPn&oQ)J!KeQ^FXu%JF%=j2@%DblGP?ySi_P&3c51sVL5?i5g=JEB*qW5p8bv4K9 zm-ommEDtjL==JruezUc=%L`YL_dkqIl_-Dzc86a@ON>BJ~>sg_vJN*`v+9@7Fiy7?^O`z*ZtRu_0jkCLz3@}H|Iw(E}YsC`e~Dk zS((sN%$@IltdTW%9zSD!!R9{;w$DG*xpiIKf%!9An`1Wq3OYJFFS%jHwU8$* zOA9Tta^}r;`+V^3-0owxzRdFtGirEE_pL693*`P+b= zJrf?0Q^Y;R^3VS* z(9N3N$1FCo<{D18uuI7+Sb@oF1M5Lguenn=F1dtec4bW6wqS|8XLHA#3l59BytXv1 zTDVA;cdq&N&ELPJotM8Mw0zm`<8Sxg{C@AuyPChx_L}eRIK5`IF1zzJgTV0CY-y#} zT1v0aE=W^8XXVr{=%~$BaIr0F3p-aklW<{qPjbAgOy-ADmC_ds?e!=2Tvz<ucU4(zJ$?VKDjcR9bP#-6hIE3V8Hw*8`!y!QTf{|CwH@YpKG|*t6Ou|bD@6KfyAbU9x1Q93g;h- zlx%(;&ag{()_Ut}d&yFXyODdhBwe~^x8Ly9`OQ7Qj56ykZH_+d>8pJ^Y=WEjB%b1Z z;m1s^%WU_1PWrCe=;fG~oAoZnT`X$RvebyLivl9P?(;R8d{k3@VU7JH*L~CSMP41` zocpv7ik6<=6v;__cpcWvlDvaVZIF2VBaV zZ0G$Uf4gUU>%WCH$rJbGPcB{fzieOC1p{kym&oVeIj+uc32mSI_IIHE_Q+*tKcD^T z8oi9QcH=gm>g5V)(=w+@eMs&7w|Cz`G5ce=F42EpaGRLze{z1`?Dz$|SHItS9}!{k zYNLAil$!N+N4AGwPV)L8SlGI^Lyx`xv7`Nzv&q{x8*7+;^uMM3YjXd_L;sWlukC+4 z$U#kCyGC+!xd}wYJ?Xq+4Nm0yeQN&Dya0*(i2Oh zP77`L@TF$=yM#r3TK_KxyBwYG9`i;=Y-YeZ&4jC$&o^HP(%Hfw%-dlgFMs2L^S9#H zHt9V}O!pnQlJPm_)|H6a&*S)yoUxg{=DgQtE<1hEr`!*;CvQw##W}mKyu*JJo#IoD9p9W%#vFueToedKA;3$LPW6LB!inAJt7t)RM40);+ zTeT$wxc>BQ8|uzEUSw^SibG z?0Jm(Z?rmot9br#-iPDqC-{WlGfbNBK<#Q%xymHZ>j!TdlTK0zUy@|$N8Ss($+S`i^@1` zK2N`8c-VOQ>wO#*ZePs~7{?a7-Oii3ZT1o4{(G{gC;wHbaI0FXx=NDk{E~CMPoq@= zKlW^|3#mBvMo9UXu~*TP3OCO_hVwaLi~a{!q#d^ZF8oMJz+S-m>?vuU=aPGlUFF%h zKb=3;?@`Q5hGa9RN7Z|e&A+Akf?qLCbk<#sFAgvC+1JVnbjETC-dHM7DciS0%<{U8 zqDaU7K6U8{xBGUi>sZIcc(U(#$S;?f|ISQqk!kyqJnhSx1LmBJJ<5+GCsp+xnD(`s zC;ax0e>-l8_iH_Rx`Ruh*{V!Mx7&G&m`Zh z|IW1A$#?Tn$p?bd8%}PmW>jS8zF~B9pZ6whmaAg@M?EqnFndo9bNV8ynnZ-a$o z_fA{Or^U7{evYD3wA&t`>%5GXiXyZB`kjn@x$(rxjCb6Rc&3@?F>jA$cH-+v(J8f? zG}+oyCU_IW390{oFC{$>b=#qIkgv{@?~qJRUQE=(n0yYw0=rG7yPWKUUVQfsUlnd? zzF+MeLz5*(@rTr+mv>9v3Mw&F-xQ2Z+!*4qhs$=pKzhOUB7p}&mb?AlDYN`p`DW52 zd+jIP(evR)r14FDH~vWV@K_GK;xMYRMO7_Fi-4%R38C9#0XT zr!+&MYq30;CtGfQmQij}>3)wk^Q2an@QXhCSEh^3eK*~PwQ2dWCy`#4xqap>HPNUv z`xA8Mq~*_m>HBA~FVE*bbWv%E#uNR#Rk1NEn?p7|T$AvRxzvrNcg4h6-<(8Z`CGjf zcvoeZ&5>8&*WMR5t5jk0&Xvh;Ke=05$;aQ`wri76@Qjb!m_J^Qy1xD$$MTo;C+Zm$ zTaPXT-#`SrKWHvLn9Bg;SIo%`|DGJ;Dll*7?&))M%AZuIO-~m(p{1}$O~uYruUt)n zdrlK;Z$oTn?74LvLAoZ@2k%wCZ`zymo>#lR+dBH*?d|11Rez_IpQ&=eQfgleX4eeV;xx z;g0*pscW59)s|Wx$eU-dAjda@xiTVSvb`Cn#Q95EN#fsrb{G6!VICH9Xj)abCo_1|PM@kU?xzES{=2fm(>Lh=C5taI+@x{Th;=hroEHA3Vkk5TGv~#Yx;>dJqGKR?3H$L)iQpY z^g_Jx-D1JZW@$fXoHJg=vSh=0FK*rMv-!20e;dmP+g06Kr`!?SH+r+Z#EX`u}xCB zTiBOG+eNRH_rkB!z#JNgMj(iO5(dLiOE~>K#Yf80xRvGA!6`Xb^ zCd00Ez0#Upo{A3zJ3=czc&KgKqrf>WVRq|I7e%?Hd@X^0lp9OjTFSOq@EtD@EMEV^ z>KdQr@;SO(!pHiwU4Jmhyg!r`o8(iJCVYT1(5NMFX7ACs<}Z4RbF>|G{kQHgseH>T zu_D25%HIQllCwP)O*V2eIU{jCc*FDaWy}K~C3V#&!Yj@`-?n~=qrUdS&KA4lcc;vnW#K)Y z@8f}+r9B=e@*MkKy|Lso*Sxda^1`#7y>TkHEd297n9Xk7dhKWLE7NZkjZY_TbNyd_ z^XEPTC!1FV4NsRUCaw+Fg`_NynXH*Mc6we7?it*ybQ+Z%<}oO@u9U-qiPS1?yD zy8GC?H)-b+rTzbDy8?{hW0RzA#pt3bJJKjY-7q4kfB zojAAP+&s5D<5$Ac8~)8@ydm+jQp$1nH?x;_4K{G)8C$Ww4tpZD#XCs!iLckR3QmT+ zV_|1kY){a5)#ULdEO(xk^V3geAz!bDJj*t2s%6MKo+9+}itI&St`>)N)8f^tbzEnc ztC<^{+<38e_XQs-hVtYY63p9@&gd?halET7>Ybx;M3&Gl@z74@JMD&^AH%*H-03&5 zW3Xu`Iwd-Zy^!z1|Mm?Hmp|Ki`@fxG6{eHWz2SqwtA`5QA2_-!L$@4VtRZ2MJ^e|t z#tYwK90H7tr}BJYx%O4K`}H@^p7|GiHH1Ei96R45V$?aiN^< zuF7j4o$R(L1pCc%K706-TIamubLzO_HV9nzR|(dC()~h6`YpqrCtsRYJ)Zu0$+N!o z0r_c*?@fu=+jUJM;cU!$%TEjguo{Qe|Pk5%&!2ep$`Jerv zO?UoEbf5G7*ZCsj*MCjENc*dHhr=Fz{>-wgZDqNNjf?Pc@f&Hr%Q>c5?-y= z`9~R}Zcjd;zv;cTZA1K3ua`=kDp z$BPYqZ8vn?@AdECkH5W~uj7}XOkjw$oMGXIQFnbPSUdTmGQT4v)t5_20vg0_Z+ z1npj^|GFH^<>@U~eb+4x^TD0h$<=yZ1 zt}p+6&piLb=9^r`szb3Fr7q?4YSi3%$vIE+q0Tie@s8IlDzT4jeeyW|i8vG))EKus zxm*x@B&vAj(^vN_=XN!=O=xeM(Azd)a@&NNO%3k1Z02vBxW=ucD|PCNNln2__HLW! z9FvWYd3*MgpN84Vz`37(1S^=UpWJ(Xy-3>IsY#s%udjFC_Wb+y(fK9+ZY@wZ_{@GN z-AVZW%nv^=tf{x&V`uc~*@1;+dvo5-WBOG;U;m(EBtLHh%TuQ!h8xaJG1>vybCsES z75RA;rFj+Ac@>SN z^0(c5e>Kpv+Y-&{N&;XLnBW)?)gfSpKL7dz|v5Wz79N&|)zqi$M6gu7F zSlhs0x;D>u_PR{tSuDRYmqrFf2QZzwnQ~K7ZKKPkk6aJF`Ir@?7;vZa9rY4xZ8SG9 zocmPBZr-!gAz|^#hTWy7Ro(v1c~^$(p1|IwvkXlgLZXxT?#wM)5T2oURO-*$_`_^h9_0VeVA9Vx@#T+t zL+|}V+Y1c8;wPNNtJE&dD5p7|9LvW(MzL|b0laD6V%hwbkTj+s6* zQ$2I=Pfv5K@9i^@3)fCF4b|!{Q4hPXw3y9VWy*sR!!EnS4_s_M8A;Av`26m)5;i4c zUPXIeMQ>ika9+j770b*n%&T5w(eP{jzVwB@!GB#6k`6dnz5O*!ZBHZbq*sX+FJ7tD zO%8j(RcWkMQvIRb!L^UsR&Sh`d+RDp#g$ z;$Om-ESwu9m4DSKckk5&zt|4NoHZ}lG<$()oULe&n(tKsNz*p6~S?;&wq37 zIUFyl^5I#6KbO7CpL8yHj(<}Qc^@)OWV$bKZ~md*hmJc}$M*a4*4%&Fvz%v3kn;^U z-b8NGmbaG$w)r`;UkT%Jx?#kdxZ9*jm-*Ml9|>&m}0T9?YWCkobKIa ziZ|1e5*4gF(pJx$-6#7!W!pJ_KC3I&=iWJey@O>R|GpmK9}gF(x0<)aCNkZZwwrNa z=boD-N5zDmaBvzmv;1^u(z#LMlzY)U`&XLp{WULVo7Ng%cz-BGd_&-3@h7H>m)x9U zGJ8^5@TDBDU6MP3U2+_ZuUf7?w!DekR5bsiz`UoL?P|MhPE23A>%QC@pD%MA8Kaz2 zJOucss3*0*dQ&R%guU?p6NUQj=DF5AE^B9T%uPxVo?>!;lAC7g!W)bJ-q`rfdrNB^ zL+5t3=;k%O6JPF1+ZBCzRdz?Z+!}#iot3>Wj&bN26?Zqk>+;B+7^-C7qiwl=j)*JxGAYM0Dd%3* ztKHGW->v*YrN5)!IQCb;i$jSknE!rxd1kZZrkJ+cT_5L&J=^`!uKmuzW! zR9J+*boxK@%GCXj*L&RkGWj64=AX0=j$Hq3V&?67Q~J>Acq)JS^1!g*3(1b!3J2L7 znl>pqZk({d#UnsMMdP@E%YsKe4F?|FJNm=iO0?c5kYSky<7GL4M$JwPsru68Bs+^aV?2b>A};dl58?@sTp zUmO1SdCBwt^X@#q%;%WkN?{4hC5h4no(WGv3SZ7;J?rK+L4m&~xIso}$(igwGZPf^ zg|~Zn#7!&zJ;CPL|LyDdy!qD^zntS*&2!?Mm)>#bgQ{`uo3538cJI1+{`|z-H=TR_J1?JeetO|N7|vAbn04TUW#dHKxi-(( zQ#s~x9BWe5x%TM0_P1wD#{#n+yYIOd?v&yu6+xApC zf9ri#d5UR;qv|ZBuGPBlFFpw>_Btz@^>Rvw*B_Rr>90)kdV`fZ(!O%ej};O)o8)=y zvm4P(EPP!0%yqciROdTx`e?T}SjbY9`S-R+3A4YkB;)myjiQ|_P^X9w*TduT`EGyeyM!e{ImPT7MEX{bMGyv zyLu}(dxeLu*-VcRQ;T`}$2=zP40N?LnBo?;GU(X_Pp{{6M!vCZ9~N{*-)Y+q`1SKf5o8e-HZH{@g6cL$t&Thh$G;l(=#F^}#GQm!om zLYgOx*Uf$WbKcCW9ACt&risiEs=6rPZIhmTBjd(L)>2lBS*_DAsf%2xji0*H?Vd*O zF6q?iCRw|m_-!s*Zj*FPk7qt#@0)us`X@I2IsW36)6Q#iG$-0^KPlH`xZstc@RmjE zC+0uqdv;qPOk9VjzS;SsbnVd`xl?sW7gs-=zP6mJsayWWJ@;f@y-pO8-unHJg2YW_$9~IC-`)6UDgRISQkc?XV_5%fSu5+}AIz@Gy;jD+^7@&pPo95MQJbA{ zHP(2&zfR)LBfHY#;+JjuW#tgdF2A76;PvM9Gt(E|*fcl$nO@-0>}T8b5}u{LI2Pgm z>-e5c#qyWa-jx@{E?8)N^|W+L9#43-y0UyX-?0m?FIF3FS+v1T+HL2)4f`B?PoL0I z{l08cb@0i(E1%p8DazN{X+HJNY_E4qCn;vjC|eiRKl}D$^S90XnPK|&+4p-aW1gQ$ zocZhf9Zyp|Fo>LX*agC+nkIm6BQ+r?ySd*&chpc}4xo8o~YIc3fAq zm+8K6x|OrXan|)mA8r}ME!}rFJKI{w^znm;823lgdlNE`P1Z1-91?pgd2tzsM5L>G zUwcl!NboXNW{qEkWq%95WeQh@h4xe*m|HhnZ~fW2$W%p^=@rGN)h{jy{wck8;;~H$|tNpP1{T$#L;(5i1j`g6BPzoBh_=U2MTB2SqfC-U&NSPJ5wt_JZ%M zg|khRr6bP^9_bf1pK!#_@sa6|l)c|pN6wty;C9$W_OHc@1i@DinD=BZGu_~ktuXIE z%QNkUFM{zs@4tz4hc@|s-C=BhS5kYf(DPllRd(NhdM}E9ch;5ZN5y8ktx%hu(k}c{ z#h~bv?RWi_3$c3-Uf|$fR2VYp`x)o_%PYfN&&VXHx2;l`dGpn#Z5hW7%2f61AN_9a zH`{F^_tO=HNncm-^%fVFlFpaA!#>Qygj3?&~wQfpO*<>Oponc|dq7qrM zRbfF{N0R?3|JKk-_WNgJyGvI^)kUQ1*c+uTKY4Mv+l5I9a`*fKVmc14T>Ndd-sw*d znOP&J7a4w(&aJ-YakF04@ZhoUmVt*4`1EUq#%L?=Qf2E~vHft}&zlc(8YPb$QWN9b z_Gy>Tbj$OO3xAi0IMpZq&Fufg8!PiTwz2-)VXK+v-*r2u6e7FwYV4f+8jMC1%PPOG{CoN4`d$H%XsO`G-?~lLjlDq!#%j2@vSCfN_zHHZyS-tj$;MubB z8{fk=wA_n+`EJAewI%6!je=*l-JbRK+@+lAt#GQ$-hP|0?e~nd{SIfP zEZ&KQ#5m=%d@Z|S-n412;mw+*cC`U%PvV73UhKPaCHU;M;In+Ec$_s&mtVQFaGGD| ziX;93b)l_}eRG$VudR|f`^{pOZCd)~H#(I|7#gcwHua=gp5>awn{ln@?FZ>OX$N^` z{{6w|lKKDKHKSi^KU}TY9x!W#J>!-6e~fEp9sO}sWlninMo13V9fs z8}YFmUBgkTS!=Ac;@{o>7lUWbXMVc2tLO>KuO!LkmQUD1rT1RD<7PKujm~`O$jVRR z?z9dB zb6c&V3_nZOYpn7rI`%FTqW4_*bJ}vc z+qG$K+_i^YWPW^@vybn5)yi+q5oX;#`D)I5;lD+U_drio4 zn=|VkmEG+ABf9%c?s<@b7h zmd~RXx=wpq1pB(>Z6?lQ-QmA!UjDOV+P8P*C@-65>pNk!dHhAq=^yGJb7={$TywKe z(C?(h^-a9Y%ML5N_;d8mn&{>uEPj)}YG3qQpOXC{@BS9Qoo#Q!+Gf9fyemPzUi{6f zn(6V{B?q@AG27k0udu7M@$~nKYfAn0{8I|%Ic2^)lYPJ<;NK24yWMeSu}{wLvXO|^ z*PqpTQ}j=2-%H23j@QQ{EoF{1P1(5obL8~Xm%|s{3g7s8rv3HV&*v(fFC8pR#pWoJ8lJVO8Cu^n>0kq-^ymvKHS3#czDQu_M0_a*bywQuU?9qa!P z|Fi#8|GV;I54x>%$!Ys1A8pC{+V{`tJ6{q;@hm&wfhv=UK06v;u=rEGSApp(^B#rk&00E|X4mE)ws;%Ar)}fs$?{?UGyepemuv{E`E~M) z^sNlrtQlFyRy1?J4J_~!;*Z|FKDX%5(U+C0gSJHWn{)rMvbnHUT4v=}3$s^Kg!eV8 z-nZNyWAyZq$TzM?^Zx;?nfuFk{q1`rESwm}8p*GcwvWBT=Y2%-89tszU8XJJpKdDU zCzUTXc9Pk;%-72*g*jtOQ{>F~Ta&`=lS_Xz25BE%thizRMi(BVDjwD<`?t~SIuG4` z9B?l!UvJ3|zser{q7QRFNywjFn7As+_r@w8^$@p-?*Df!I@%r<_C$HfiRaGR+Mgz# zJEXbgI(zYzS(Am;e@(CA@Uhz;lO^AGXvL|{=a(1iUV0g_HEeS5-d%Ej+_k_l2 zhE3E^Y2V-Fv5)uL!`sF`-#jdOmLr*&)zVOP$q{o{A$?n(JAds6m(ojO-I@XG&G7m?ulxxa4feR~k-CK46C|K0v|`=)dx zRo*&$_RZW?%3WvQY`1dwp?h1*6u(x;m8JerL|xuk9`}yYa{wd4@%c zJ2iIQsF&&1P!hXN(I;~{l8XFX41caSU1afmj>V!Mzo(rNJZh=?f4@@K z%nfzvaf_JSystgViaVXx$=nhBL-+;Dya(-%nw)>t>lntbIn$%D$y|2YqT}(W)}_|% z{`B^4PB@bt-#2Bp__W`@zWhi|^w@kNSs?nlI1)wlF?)*AJPee^&iJwer-_?Xpw5?e$+?Ydw8QE-xuR{Ou$2 zjc;!y=cj)+uoR#B!#1b?@uTk!0V|ms{=RYb{UGEK=vuqu$7cuQ3l=}hg*zDj-Z^~5 z_48i=Z3n)a0lBq(dUbyDy6ri6PD|Q%<<_mququyUy2iCV?zY5Mb-uqmdow?jKb^Ep zerdtJZvWqVkH0NX72nV4apq5*f|Znbz4h+*pUXa`oM5{kEOF-4pEXY(r5<}V!EyKF zN2r2l9{blD8fUs~fhf14^FtZ2O3&$u0Rgdn3N)cA>T8{>&%%`y%mVVNSs1$8v zQc`eieG$j~_Uyev-4E^MC!fx~f9BkobLY;TDW9Ay!*@E-`j7nS!uQPV3zQ!EIu%7J zta{Mv98}*kuY-SC(ku0n*3ImT77Nb5V0laU{N4`30P30rdCc_cyvO6!gSpPjg-}rVXx&+MV~$;X|_3wsXFjbok|Dq?biX{GhaDm ziG|Lb==k&I`nJWgj((9FVmtcWYx2MNF5UR<8gHJy(62{ZzZ(>CEvxzS;-Q?K&|>%G zH$iP(6CTcMSUHtvYEIaRg7qnD&m{9q=jCMobi=7_>6#e}BmM{6vkH4?zf4N`&g+|f zdhOL83|1Lg&;B%DUbL@_#qz4yy9W{5S$}=}T=hg-!kq7Mw}e-u?+FM0OPUeq{-rKt ziailE^DEDD9!~aW2J+5!(Z@FU{13S2wXJVqPp%nL?3(jyS2y}eI)yGP?< zXCb@aMWz3KoZ}Z;(Ce}2TP?~+ zSpQkl=`$ab;1?i*9*Wa9$76UBq3`(q_I@ zd*8LGs^1@ceq_@aJmK4xXE|SswHoGr+Hs_0>f#N~SKEs&#QZP#;2aTsGQ8-_<@XOy#?fy^KPu)4 z+PRcE&E9!QcY@zB@Ac(dM6DG#of`}nIxJSXq3312xaoy}*RQgh?Aj(j5~N#%=l|oF zW0z==_-$2nyPVY~gFn1oyG*6h@0@q6c=q(1BERW#wU;m4N^~w=THz5QWBX@@it!a(9@o?Mck6N^IhW?2AipkOm`S-UM)FPS3T|GtL?Ay115fMUa?X7#IZdy*57V_ z7Q?Xaft7)?sfNjo^4`Y9JiZr9y}j>Fs}}io!~BfX9cJELYXVoZo211oI&oYw$V<{} zs~FFkNmWcXN*leN-nPgvzr7>nzLH*TUHqFyAwHKKy)55?tX>(1B=0=JHZ}dV!Te1Z zbN(mh*sQA8KF;8|t=C=gUDS-#>oh`cvv;iFo|hsbm3yk`xNu+J)#V1UithbMUuG=w z=q_FC8aFx3q4_{C&-EWBjY)y)m&dMAcc0ezW?^p5WZ~X+k36T6N;n!pXcJRlb~ddFIh0C4J(-zwqtGo@;q8_y2)O*HP5b6wxK;?n#2#)Kt)0u@PC zjb}VV95`0(I`7!#7M8fcbWh`xDxGbgxsN@NaNYLEDgV)yZz}H+fBa&SXy$rT@J;Q- z$?W#}GkbmSe0n7Rt+&qo@qWP@k}WO|tfGA;%;Y&;VW@6bqHgzlHH*#RjUDx}em)0n z8+Of`;kwa>To|$<` zO}SVgldyNfgi8~5u(NNo59{c&-11lR=tudTJ1(ALK&)pdS3|G2?nYHk5Pd2*Kfmf% z^=6&Za_?=+c5c!>4wp?A~7~zWad?tM;ekXJ-HV^?Lp8 z{qgemx1Y(}rn4pHb;#{aQ-b9AS3jD*>4i5(Z|JrEAI^vMmVITNHqmK*YkWY(4fanG z8EwHoT3e6D&7UQ2Shs`OX2YLA!v>M+{qsLb7&U18$zc?2J?^mh_mWUCxoi8*XxV9T zUruUu4|G`bCosgrt$kYmE@mI?x}=AfBl-+iA3FD%V|Hw-XkpLGC?CIVq6<%L6!f-y z)ymkp@MqnT%^P-}Wt_ug%Gj5!crR_ol2#5;sVtj0i$Wh*L~u{nOkCwNbG_W>r|l+< z7U|kb{XPkyPV7!A%RF>%gf28#D4g-T@7jh9%FmAoJbbFxdbs40vKVi9SVvvK=Q{=& zpFF*$#`QkldZ>-zxN$dg^csfO54sZV`WpSyHd{STj8%J5s{biv?uEdD{HTSz=a)}? zETp<_4%ZK7w@g=_ZOih{YMCAQ)w4)7YO7IK`HDS@K6p+qYC9lxbk0<%b+48vzE~IX z;b4s#Z)$FMnM5bw8$WG+_XAT8XDEI;@^<>J(uIppzWtCsJEUPB>l()OX0C@huD%U< zWd1-{>e3p&_V8Dn^Gh#mV3`u^dZqltEN&O>lEgxF;ba#cruM&AcZyH;sol}sbNyt) zvKn47t=8VP7W=M>pVxaGWE_>@CuFvBXKq{l%X>juCztn^xm~jJT`t3$ADMGJY~$m0 zE_WfhDYup8)NVT^^g84Qqn+j7S2NuA-=9DK^v5?(Xa4;;@y7a2*L!;^{Tzf}IiFAF z_i4QAyjN`6hmSVXKJ<7fY*RnE!>V>swEOMvRZCwbt~SY;wO5`0u_x1G&u-4iYcCgS zHCJ5P$n;QnqbdIbOP&Y$&Y`EK&t0E*Kxm@E>B}Y|nunkL{*!CBI>9gF1CKLrz&1X) zi{-|PqN7+Y6-2%hXxg=C!RzT9uO2*T*rhA*{NB~2PRy^`@7!~2vbw{*qPWuM`Mw+< zd-L7=+OJ-Qi~7|Fd@Pw$A?%lXxHH}Ia7Fy`Y91wi{|_I&7@XR3mTP%d+qX;u?E{M? ze+Mr-XUthMt$q2^kMon3O-{(*^8d{1IH68T(OO7!x(eU(6-iR zdO1g;{jvqG!^OVYvfg-p=Ycl!Z{O+PCT=;lvLij=an=#{!|q z*2}t<(R+{f=KTK?mn=5@(Va*xwJ(@falH!pA7K=I(|$HG z9yGhP)-6-X?a&v8JLN48RiFGzI$(Not8<7@|D{v&0>lqCo>V_9ti{nQbX$DG=hr*K zZzQFk)>^UFeVIq|Ey* zn4fPxdHh~#UHe4+_>C%&9d}Gu&FD$*ihZ*)=fd&k&!WetM<3S|kBfgWamGahW9d>p z>rl=;drmecd|1`zIt(KfXsQmn9w+I0W>Q6KEBwTiDvR2Gp`(PsLrh98={!Q6(af46c?BcqFR|kZ{6gyV7886+g zeLCowSXj@ZNmfg$OFdSmMem+j)t}iWmmBUUvploHSJN~5^d(Kn^%EZ6{4_`7{Ly8T zvhAD>uJVc0To&@z`>9ID1};y9I}XxTz2_Iz`UyS$P;hK{XwHw-SDP*el{ond&J?TE z5MKLF$8t#~pYX|RIu|E>=$YEJZ@1yQHb&3(=Jv_- z`xX~pJ*aK}Qz#vFU&NI0{I=OjMV9~Oms#$A#B)nz)`x$SPd!~IyzQIJuewJk>i)VU zOo^Cen77Ygn{z&QuaDGDyUFWQ<@)$PZOyrTZ>vtU#=6Cc;UO{MDP2c<|N7itb3NIM zSD-wvTg7Ha?~~B=rpNXr{1kj17%+3Oaqhm98Jdn86^x{>9?Z}`G(~d9q-(M+fnV4) zx*R=!wEkSQqqn)`+%G=&lig32bw}JOVBu{KEbMt)Zrbj`^z6)u@LM@LRtcy6)n8C# z)qh%55yD))Kd;+caOvu!ayC1yCwT3cT{_k4MBA0a(S}=(b5tzeyF_K#k=y&vZSfHL ze}Sv$m~HFFleJG->WkI|I9DHC?XU5)EyQYP%DlBP{tCNY{EQYSlm)Dq9WsB#rGp}? zygZA}Kik5U`l9Nn^Bk)(3$5$xH?+wXJzuT3;Lqtr>K?Uob*?AaKg>3eS~C4P&%&V3 z(bL~N6*9hm$5{9J(bc@3Z07FF{4XA@?c~v!e_qmiVqR&%?!&BgQhP4V>{|5BusV9< z3Zv6{sjJ?1ec{pff8Z(N^gd8e%3aGew()VF@*&O}N4SE1E^G=|o`2-l=1jIj%MX0l z`MOTz)@sefz6&4YCViRbYyWT-Ypopn`P#{Dp5^(Js%~EPwYjIw_s(cyxNlx-0(TLaP{mu-o?eo%XvQkUK(9uSt*~`efZn)v!`yFq>8kd@3uIox`}V;vfeqLgkP+A zaL9f3gfP48c_p(;xTNnKZS-U~ExNs?a7}Bp)n=AEcl&bgZSvchRy$Sfq2MCl@>iyF zZk;}pckPAO%xSec54XfET~xqz_k`>nhM@Tmm#M`3;Lw?Su>Qh4hgH1CmwXZL-VkS| z!1wynJF_m`o!tMz+i%`=k?z~Spg_{**ng#W4gKkrR~|(A_y}Cwa&eBR=SM3GO@sUD zMaqeXdA-)1KfU?j@t240ySn>4v)Aa2P~rVLV@30`B^#82&v5N*Fx_|K$e(XDMhWR| z_2;XNWS=rR7hBZsSGnQ7W9cD@3mm(j8@2W;9b?Sj+0(}P{^ zZ)p0osiow?4biDf*)Q#@v0uOE#qGz{?-OGlr|#Z2@4bGV&)26RE?h6TdAQ!4`C`Pi z=+kKB z{OoaZG5gJy*1xk2-Y+PtU=Q5p`J2G5^7lhaOb&)+^Ty3TXYBNoRuVRqmD@&3Kf zamV78RF7rje}Rk2HzU`d-*@5ZjlGkr!ageI9N+Z&j7fF)n`yQclF@5s{^BaWT^IW1 z&7AvtQs*1(`K1|iSLQ)@_vxFGF|7L6UVnXfec$OzIv*FapKh&wyR+Z#(553FH(x3G z_$}twmfyVgXU*!SY&=kW=}pZ6qln*vuZ@56m*v(ilo$K_@I=bD@Y#3y{+oQLymI(K z`C;)ntK(1PKfGTkX>~vH)&Jwh&*#4tzV_sx{qD)%&L_=!&9Jm>>b#b`br=0sn*V%g zCBa(|`{Cr;=;A!-mD3+SW}SC%ji&e9weCWk@$C0Eeqz?|I$F;AnqS`PK2*VZ|Nr#4U#sg*IjCGd)42TWHopypM)^CRZog3W zQqR#P@vY;8LlfrR{Fl;qobC6E9dT(XhL7c|;;J7B`u{BbxbeOD>Ral2>>9rcYabMM z%4I!m&-;Flm;B@97dq#~{%{aEeEEoW&1*)Wy!rQKJic^Zz0IOWPCRkpjCOh7Zy)oFq9QJL`mVpzYsdS%WXa2G z=XZ9@H{|wncrSD0P^4buqqTdEbjMsW{&VN>OtT$v#$o;ix7&7{maVq&n6G>%?gs~_ z?!D*MG2P~09_zpNT)`Y5dG+bM=byw*3vW$WR(s6BU!vm1^$ncaW&h7yGUdoQeRog6 zyj&|B6>=1Z4%~thX)mzmS4E{4CG8djMU!fH9 z>xUESGD5C{5zLkN_W`m zuPD9#X71E5u5~g^Z){aQrtz99hPrO*G_q&;={w0n@+;qqy|L=zd9(N&l5_o}#HLkq z-A-6@tzg0hu@am4vu-RZH9GsY>E?8vFCR{7`OTY?vT_RN={fAhMd$L&K1AD``SG{n zid{pLEbno(x!cP6ck~HhZ1-I99X#`ue-8-g&=h9dGhStG650#H`oZ zx9Q}EYg4$E9NqXjc7Yh{Nxw@xOF7Ogec2{^cgE)G_XqoTh_jg2npNF#x&LGCybXO` zk~KOvzI-*lxlg3TNJHkw@dvwR&F;+(+4-^f;>DWtx+^Tr+_{9D_>`+r961>n%(E! ziMrCO80MFcVkqyNGd*Ya0yS>iQ*?T9c{DYf=Cg=IHdt}eq z`95EkYqK-+Nn7^e?m531Le9RD)i8K}-Q4t2*1zB9ejRdqyzuPb>g$Z&uhP$F@GKQB z%)a&Q!?6_O3gM1LH?A0$PT!zbU3+j*pyuAEB6I9SkDAne(cZwJS^a6V`{lce$txPF z)3XhN=50=SsP=i^=@}0^%-6CPt$y?K^^a8xUz%GO zH+pc7kwep4;eY|Z?bGxh5*?c|{T}MG?UHzK>_F1y-@WoFbw`}^r^sE+*1hqqHD`~( zNAX@Cn~sB`!Lz>0&+XaB$US)tQ^C?XPZ{rV^*_9K%`pYyVQIAcpq(&jk-KRX!K-&D~p%dOjJFwxN1{hE8W$`!Yl zr;FxVwL8ch`hB3%gV)EUQGTU+$RGZ7#*Pgqsx~j3Z29BzCI5$S1*Dex=gC>Ww=dCp zZD6*4#^Yc!sXn`dccbcOro_p*z1voC<8-9Z;(6ZZgwOX*PW?LZup9edru=Ksma`R- zB~~2Ryx5d~jtR5-*G6?~50%-gcx|4Y@eKa2XmpX$eJ^4&X!k1q9Xv;I8q6H9F7@)p(;ODoLg_Z`?_{QGi2UfgAE#czt#sf3H+jSEucV)XsyuM5mv;weaSYO;`PGauqEqB4t>PNp0SteSCUe$=lQ^ITNKO zo>Tk0Z}&Yb;nPd%50~zLwE3+!i^ajopXV68f6rUNb-U(zLA8{YolRJ6SxfHAxlf|R z^Y6_vI^(O^%2UnL9`8AgN1bco_0$(jHTTS#b@$yvo%4&$J{;YVyk_S0X>uDl_VDSi z?=h45U6AloZ-(P;_Vph2Uk*H;^RUSMLC<0Lrc)O=pB|ieJ|bJNYT3)Y_m%4k?neF0 z-?^Ci^|MDO6++Eq`zv*})GagM7tL-F7pUx;R2K7q=>hwt(v*UWjjL-c)2~&O-AcdQ zFYj-ycK=+f>ybUGGZtR?5qP3k@}k?+&8 zd)v}P*JeHs_hRAez6-xzkn4(=Q?to*s@sducNa^}+Hu(DFE`Kap3JsCHA6%0(UYA| zlH-#^1=gzO-msb+f9Su|>&lh!_n+AR`IYvRW##vM3ym{3r}ET^nukB*`6{gX=-G?A zZ;Q3JIw>4oI6KD3aa~)2%&}>_My}_qTb8Ym+vdOWwaboU7lqF+zY`^Vd)G$s`EU30 zM5-qHO;cao&%NBkZOZj!J%)OT@3(wV&iO9#xzXN>bNZ$$U-ep zgzqQjeH@o{FMoX%g}*RLe!@6HX9agv<4 z$~`u#^N|Rb_OJPWZtrNG@MF`qwwuOre4Eu`jH86--I}&ErbP1I!_Rwey6iBx_lei$ z+wZ>fOO~!L%k;2dW_|yJX|2>e<|`BYCr&rn^taP}pZxdreP_Z}xjcTPKlSJJJ@1m< z%1()wxyNmAup^ms$+uUQCOrOIecR@pI_Om>VZ+qG;_DJz<+y9qaabNpi z`RRM)e|P!jZ1`dP@iDvG1a@&<*FS3LwdDH2MytdP?9m&S#Xk^F5q-J*Cj0Dzs_ygCgFEh8c|C1ioi68F2rVi~i) zM?6R_U47d4*|J*St-15KwnV;SEf8gk;ybOo!m{ee{Cx`x7*pOnULy2u(Z|!G3)}o( z=*T5%@c#5pD7KJWdRgzwuMoMzB0Xz*PM(O6RSZ0R_Vwu*n-4OWq{!V1_2TLix?lNn z%bb^oOwH5R)x24JO|Rs20LyX_#vchr`wzRHmHZi_?K15|@#PioW~8tEy85)y%r(KX zn-)En+2U~BX{omCiRuUytCS}jCn^+P31fVEP%;@&y&7L%B9@daAb1o96d|Fg@q3s z0{&(FbmF}C_12f4qT$DPTKLAcq?L9!`pP!F`!w6*zNAp-4ZVP4M_BwPE%84$Yx#}` z3W;42?gl3hyj;4aLAa zD#x$h^kj~XB#txfEqbO7mV8m+YhO>$U$Rl+yi&7lcq8Kt}6WbM=eV z%bZWKT{qW14i_{nxpAx@=0!uimGdG#9w9e&9=X>&D}Ov~Hr;8))RS!JB`6l~-IH%o zRr%uEQMP+lgk7?-ydUnB4D8QEN7pv%M;tV z>_S!7wiKK+zG(FJzjqvOc>QnRzi+?apY8P7(uvnKAm#6hCTqDm)qrh$)~hccEt+Xi ztIfRh)~Q>PIcigR<~iy6?0v@|cvkW`>)g44d!x9IxL5EiH6LOWF4!;scKzgw-c#*< zSDpOZ(BHUqj_<3dlH1)P1V5d7zj49!XFsNX{1)7leWWA zjtKg_daptL&94Q9A~TB$1Riqi?!PY~dj8t%H=O#JB`*XoI^;jrl+k1hf2HO+%QaKC z;d$kSh=9&_YL31i&Rlx_!H)0Ns$0RnS3f0uVb7esZu`yVR{u?EEA?$SuSwXvKAMzQ zyCZtWw?1K?P~KSiPX}86mRJbzpHdZJ`MmkllK=Kxmi}{pZ+Y|S-HO%U9=^U|)p`9K z^Rr^tCYQGAr;pxnf4it5aO#PEv0d(z!o5>;1+Fg1p8RQdQToP|6VA212conX-uaXY zpIx=0eD?$cTcu`CiS^<|1w6VdGZZXt_NNrsDV7-QVVg85N%q25g$UCXslB<5MkfwF zoitO~CO&21j(HE=`^!&FT_vQh_};{!-etw(+aF7;l%@S9UQjd8_&jNS7_)}=JjtbN zGS(lDs5t*Sb=NehvW$!8Ht=oQYvUrgGSoSg|HK`c&;zIQ*WTJ4obk4y{8{JrbI%vg znD!+8+_V-`_g2pP^LH`n{mD0*J5%`H+XpVEEmHbkS7kdRUs-)_FcYh zY@vG;CcK)_HMw@d+erfJJRY!aRF>AA{qW%LSnWw0mQ~tqI{z*$ZSq|8`;#`*FVQgx zn6c)O#lr6od)_?}2-DYuL$Cm zx}mu%^nksz%tOvU?h4@>1uy(Fi9gZcb^VUG)PhyD%GOmA@9lr z{&_oBXna0g9V0ut+wa$z?d^{l3@-dKneVr(+-#2RUamX4man|wl`+NpQ9)`;w9}nm z>@5#IuscOpNI%OcYZqL*kmq+txK#HJtF>p?Xhd@t@U3mFPFuB5`szAzmtLH_dv06u|05~f z+t`*L<<*-uPx`>Oi8CAjC+dIuT6HQnL^Wks2-BP?aQf%n#>%8; z;>DXz>=Zf0zj}^9`M;Z?I~Rm1zrO0cr^jt^(JF^4?0g*!LE;GqET=pYu-bcz=|hp~ zvx^DK^`sum?|9_)L38fwBh{Ze|FI|TStR{c?5_Hfdk0ja%aasZ18lqGR%Bn>U9DpB z>f;x?7s5CDo-E&3U3xT#HRYt3hd)|4kqIR1X6*dKdM%a70BEQ|m1v1Gb61V0)kK8#Y){|7JvuA2|p7ri|O<^zRD!*!JUGwstPdKA=)QO{ibV52=raW8cz0h{o z@pWJSy?CeFT%&w8NNMgW!DTDXd_E_5h;vJiQt1r)jHH?2#xZBru4VPix%zCY?2Ky; z&1(zpSNva+v&g2QTH7RAFelen^w-kqmUR=#MACF$su}A?809Tb53PFXuDQ7F`5ePe zRo7fMuO%)AlXYj@w2uCz-MHi7%EXYs+K}q!)vx4r9~4xHAJBZAxJ^7DRoi3Yz|S zt@Kf^8-5*oFaFebEshpj_wj^KPP7@<${fpI-iPgH@E+{g>ENVp|7_zQj(1rb;}3he z>J+KEKNWEj)RWv9x#~2Vnef)tcNz{`eUi9+XVHzu)MgH;N0}$zYH$U#zlypaTySb} z?e~DU#fDsSnU6W2FrQr5#dSrc8vPo4f^Z(^Qpd|mEY!pWpJ+OiYANzI%t zotn=Pett`@<@u+RXM4qjcI)&nQE4U4|uA9#YFpJ4Ce0=n?q}iMRQ(31bx39qKCe8 z)8*-=hYt5IiMqdXQCb5lw=L_1%=Vuvo%}1#b856ZuX*oGRG>u zSvyBBvwX2T@?3NJ>y&fJ`~3qpdCqvVO6k!THVvEjud(*M*Y|h$OgXzrl`nWIYuS!{ zYI7E@R=Bq9?6YS%It{*&HTfHSTRb=Ptr7gyxze81=+DbHJ0w>xH{D~uc+>I1*0NTw zRZNN;D~^?1n<_5QprkTs#oSND$DJ*F?#>lEGT+(cWkBb0-6fGy%eh#b)thQ7r+=O= z|7Nq7>Xw%;cL=Z~FUVu}h{zVbkW=dNptwuBO(bkZi@ISlPfBv~9!JwdCsu6;opJEo zpXZ{A{@H$!5$|t&c&fE}2Xn#fII-8hSKif?G&YEdaBy;j?4NGYb-l#mulfl$#s8%a z-%oE_Cch}>)}{&oyD&#T&D4^O)K-oG#a>y14!4$)maZb-rv? z>-_8!nIo5$!`jdz+*$v+vv=33hwl{fzqU+NeK+?BXW*yPyj*Q{Q-1t!y?$l)k>d4} zBnwm;C_Y0kv?_K-+l2m7LJz4R6mhSQFt1`cs7+w4y zY=3l7@UBVdn&ONGOTP_gHFK9}Z}Ir5`a^}|wd?X@bxigwdo?e7{$7{9r261p*ZIC1 zLKiAZootJi>pU5$C3`x%QNHQ6=%*=sOT%U|Jvxx3b!($q(T#ilRk}03?mu0Yaa2yi zU2e_G&6x#0((eR=X66R`UR?TpgJW&#p9v)&l)A6!bY6QS|wGtom$3y zuG77LM)+kV;q%gJ3ZE9mbRTSslsR;K9>@2E$=f=u78?JJY^}|X==e43fUY!O-oPe0toX70 z@0MMCwVc+DmI<$PcK%DcdHH8}ny;N-CKhCle{K9zG%~y+cI`4fN-3SaIsJgTAbOwwj~qr|aiU-t1;82#&3aZ+pC3R{8L% zsLulPX75sUh`X2h@ly4<13AmNMU-B@`&m<<{jh-F5HcuAWos_V*?%QZG8V zYu(qr${N-SI|Zkz zBK_&YJJp42t-?3Vmv?wxhJ&6;!(SL`1>DTxFgculRHs z<{b~NKAOALXI{zUYwP?TI4@4x|EVrB^24PI!kSJ3PZgNgzFqU}(V^5ebMqqZ8Ti~w zY?5=-ITRhJ^@T$#a_01fZ?d`m*WQ^}`yxi`)CsXi1`4h}uI3bdUdXwu+9)wJt&FGi z=#2GyHrdaw+p$?(rf8j;#x2W2%a>w;drrFV3i@;9Lk$0`ona+&x)SFq&X|7nd+clh zwmZFImn{$P`=Th%uXB?BVo@~!L@jU z?Nf`N#j718-y9I^Szy!1_51nsUo&1^O0;iD<${+^>(SoYpraC2vCAa`!;S|M-IlW#9x z@qT63eNLm|f~CreySZZ8y?;s?pLgf&S^k4}R?1aw2j){Z6$4M)*kfid6_vN3``NQ~ z{Y<}RJ1$e5@WxFtYA*ASsV@vH4m)bTvzTBmR{3U?#;R&oui-O zvnN^YBwwCS6XP;VxfP6Uyysq*wxk|pkpH>=s7T*`LyeowUCgr|oX#x}{dZ&UjDKP( z=QcH!FsxW>-e(@-S+ijJoV?N&Ho+&0JZ^r@w0O=uxx2EN@0(it#eZ{DOqT^cJe6eH zWm0?EcgL~(hg%LRRx3Scz3UmeI^N!UN6M~9#h6c>_h)U?<%$nqw zXB@76%>8lp(t5u>!@3hjol2J`f4m`Qzh2PJlliJ|F-v7|X>ietzVI+3U#*I42PMDq zly6a=Z(J{QEIVyGcdFVMu8>_a3+~uhEU%o!%5-7QZq~DIF6V6c)Ov2^_OMtUXj>=C z6Pc+}a{s~NtyXs1ci$~#7Ezmca+2#|HWr`eN0O$|R_~%s@1N6{{b{eJ&7zF!&fjgH zgudt8;nlXhNk}a0s#JV8n{1Z+2TLLK<$-thb4>pv$rt6~*{}Gj>u$Ad#g>jXLH4$3 zEBkj}Q0y$swW;s0wAm5V_s+uPjjp@;|CkyrjT18qQuuz~vAmygeBR$rNAyD9KP?M6 znBe|-{pO?ROV&-8bb-@)y3MM6Onr;yTzojCpfcCBy7`fhb8&Q~v*AUDWoG_7FBtmR zf**Cu=!C`T=T+U>u%Kt&UFB;Z%}z`_KP~f&+}sSwlGx2m@9i0HR(O1Qx%%wmMP`0S zEb~K-t!8bj6OoeLw@s$OB<1GXN4Ltho>*M1u=l2A+N^`V&$3>4#2$`~KEz%(=k~_4 zKIhz5xLtZ7;;w%{{G4oU-{i;{^-+r|oR*5u3!mZp{BSmR_k+*+YEDWS9?VU1>qXeo zK3CeZl>M3@bdN;!9VjCG6$d zy2pYeLQTP~dro&w$?|2_WIi1iaR`51wfoNHFKX-t+Ex#vFK=@U{#P@_>0)Na+Mjz1 zeD_*}Jgo|3RZUVqbuer9q7@fSo`g@|c3b9nxl4Y!F;>!8278Fig+FE_;q8Iz6vq4s`8Yh;z1X+CC>1_UW zDPMcq(jS|(BY$rBy;GxD>E+`64_>aDm}c#g93mIGa?#UbyXikwqjXyG16%)n{J1q^ z)~7_3SpwZvt2TAUuH3P^Hfqw_sfqJj++2P?baHr>XY6^!@b_YmD~ajL7s^K})?^$s zdGPM_mvgL}_*Z^TVF=-!B(_~xR`lD{KM%b2F23T$P`@sB>EF}o$3OJ7tNu@3s`mM$ zxz_ae6OJu9UoZS*fxf{1%SQ~kj$T-Q+F=_1Q=g2UKSuZNusI%l6By}r;`YtBCo`%vZUYwRz#Y!>*jpycnHljq$}J&ZnZ|Ng9W6LYyY|0Rvt z_vF5vyXm2u){aXo z0gF7|8$FnkKXEa?=zab-`rBPD=6pQz`1G2l{cNm}mm@gWEn9eJhTgY$mF@|Gu6lRv zOBAMG3k&~PaBIo!>JanwuODgp7(Z|~t^d3KLFv_3$MZ{NbAk-3WGl_An~hTz)m_;1 z>5$`*C=U~v-eu*JTQv&yACWj$R{HwZ%NbmYov&(4&CYnnC!VPtwbpxuWNPuJ&d9x| zIp?Xax;ddwSVa9N!}hedr=*^>M?7o$ypwgeyN!!Se3Hi{?YtL-dgl+#xi9sy_)5|q zmi&ZcHo03ZB}2p~bh4ddyO+Xo%CNi+mkvqcuMmn)J`&4e)3Y)3_q}<{H_H@#lwSk24;>adD8rT7RwKEa_FnS*d+Dp z_w0@RMaL#2^Vv9y#ynjw*K?{y`)kyKf7dov>mL{5c;C*)_1=hi1aX}@A-FJSOGBxnLPRJM!5s~ca1j(9Ws8uTu*@hSamrV`8iMe_mkkL3OViesvR;hQTo(RN ze!*15HTmx4((jU|39j>=A=I4qi}T{KxQtfS3#Jz|J65cG5`Su^hx7IRi#NTTK4p6w zgm2io*~WN_jL+TdKcNW>mhsYen<<j4L7p~c;)0oNJI6*>j zKG%{qUxlKIzjrn%eD6mww0c!Q~a{@$K)bCt+z)urzLB1y>+&py}?U&k9y9vt6p24DW?uZx-2!q! z+0Q2G+B1FU_-6a$ueFS++xowAk9jT@c(+FKgdP9sbu%8aWvIp8V-i@$yJ$&8(aNKW z-&eSlJ)e4Qp7A!LRW|08ev2HMjo;)ntqG7eFVcLLcd2RLs*St9R5h1&HrKD+v7?K( z?s-j1o~iSPS=$fGezRZpIs04V3Z07YOFrB+Y@YsIE!^q(9QCc=Lgy(x+55}J^PABQ zpY6Gyr`mPCzM7PME;{PYCBAzN9xrw;JQfxz{MDm0R^_qI$E|b4_LwSJ#^!HI+P%>2 z3*u6+>6wx@^0oztZ*w$C9UaRWvs*OxC>T`NSjjSUmfx&cn|Cte*d2nZ~kc zp6>Fa880S?NlWfh+pYQN(7J-Gs>=tBF1OzOlXh!M+B{DQyXubQ-n)A$V^;EKR4gs_ zkSN$FQ}boMqTIy?+x!0}_+9f@v%61sonq-qk>e}=O!!`sy?K+%+T$l@*xjAknCQlS zQ=`}aVM)l1^*SDtcPj;V6}LZltNpa*<>MU(%;RSiHw)~se)RD4mzmE*Gn178vS0J}C7ubK!Nx_DL76%fHw! zc|l=WWbL$d?mvHVwH^F>U8b5_s#(mBbBjSh#g2!6+BWN}*4)3tYZS;bd&BC-0rp)R z9#)m|Fp2a%Pb>PK_NBl6i~qeZzy81Zzxn&J`b+kjE2+;-Zpw7Ci-x%+i?DZeZ&-Tz&M|jU;k})QSnBx8x!M_(*U7U! zsTH=kxik96Glk>Y9<%`1|JHIFYlwGZmLDz7k!= zc~j}RsGNdBxt7!R6jx`<%@b@}Ox#sJzWdm~@xWiO@%$}0{@Mq-zQ-O~pS8omM65KY zx?<8yPnRE#CpJcA=jc_Q6ANWBO)i(Vl)j)2o$F83cTZINJF6Z%3Hn*6qvOSSHSBRQ`TMNyh59zS*UHif`83h_`(ZQPpNB z|H)ruSGKA^`GMQ~doyNN&nP++Q5^QLtHWJ7IWf zsi@W&z7@7Rj?S2@ImNc){{Ch13Tbn6o?R}KTyL}@ZSkxn0a~>?XGn8KPp?0}!lyUN zQ!dnQ*Ibp5px3Xwqw<#9@r86wkUNsH#YY`Zo^Bc2%GWmEWrpK_ z8EGG`mSn@{s~#0+Gc9~_B!*+%p;gyTN|&0vwB%TQr_};R+hWF*^Cj{P zC2ME-t8eJd0?xlTteGnlWVT;R*FB$5Px~lY4_QCA;Nc-{(PQuPHoxQ z{Ln+CAw8v0ZR?-yT%f#+;o99j$0V=K>Cg@j_*gpcm)!(jy)$ofa->yMO8g7AUJ_kB zWrdSm{-=A#!{@kq99Hb_h*8bn>!B><&vTWa8|(zo}l7jN&VT_9NJv3kLb zu>S6A2D^`6EIaj!Gwes6d9;*=yTv+v*H=pyt54olW3fSH`Od!#RauL8bKXg~uKW~k z$Gx;oC@JIi<%u)=&dBH2Dc|bm^gf+`a?erQq|XnZ922>4?_o{&`ICZE8`Gy`aqi0Q|Gehx`}^J&GLK$dxVhza zcfftdNb^NW<-BP%yW953d|RY2?P|>_?<0va4IxLq?e)l(Z1hvH-qAKqX14j^i{WeE zi>@}9|GMT#u$4|7Tb!9qljZGOw#Sb1OYNCGaXYgG>$NS9jvRevyZpA%%Mv?|#T=Zn zGLzdT=PcIZ{QhokAd_PGHnlwmO1A{Hde=B^;A;2vIWlMN%R6b8PgZ;iy5wkQc&}6A zn`+!H&QlAni!I(Y=fTNJznR~^w^@tuzH*fMw6(9ce8FZR&zG478@`3s=*lfq+%o@a zuSS;Hit-7UFTZ#!qpxZ?=jOz`U9qLE#S7z@zhBkhcH1@eK>U*U2O(Z^D{R(!tP$GA z_1j>frELFA`DLY_GZR<)oxlAuWmiLlaGYCnPD$pvbC#RDJZ4{hb8#`-M&6j9k9>W{ z=HF!6=k;pB{rdab$4)IdIJMGS>{8s>Lv7~nM#}H>^vzE)Ezi~a^rHCxqVFct^rYN6 zo6XKk6#bO=)VRKw>Dl9%r;e;L>Du~n%k<}UB~5dR=bM=Sw!Ad`3a{#~mY~PNJKZj& z3cqCUiv4tGx8Js#9Icb9B=;O+zxV1uaIo(h_*(9Yi z=t#zv>G#SPU&?YQJz4seC3#=X?(jJic67_tycTiSsST4k#oDj<{eFeb%7RNG{&ICn zjyE~_R(s(|Sv!+js{i*Zv6S;!H%MFY^8Xev4V0m8h#a&%N-KRGXw+G2MZvolLDQVYY_!+m?bgtTVd(O|A1s*=}yx+8s7l&TF=rVD_ z5B|24lR0^FE4FwRP6%9JZ~D*vfzG57(2fq+{*EFx5D$5O$JCJ9c~=YszW!gcDNH-$ zV?zalW9t$7h(2RaH;b~A{@J?m=YLFkw`_}$&C%kIGiMeb+j!%&=?_8Omd%mjis}0s zda67Vo+?lJv*;|(HTKM{vnS27km#xT^GklFShZp>kI>wWnGBhJ>Xqg7`|R(Zl+*lY zeWmY%o=nV(y%ArF^^1($;_U2JwDaH1vg+20-F0%Q?BlaiThCvY^E|J8qJ#@J z%*EMWTrTO53w~TI!oG8j`K>0Yt&CmIe@e8d7nIEV`Q_0$H^1GFjw-2AJP*(T;#Dw`XC;tw;^-#s6 zOMB65FNgMQ`}Tykx~uuUi_brwc-cY!(02XmtKRH4FE2N=&NjJZaNxv7r9{0m2lj`^ z%_?XtT4ACQm3L02TYE;0;{4W?XE`@NJ;&O8@=vdY>62@#8oC>&Ua;O8l-50YlXBNw z$F0>C5*4o%wKlI&EsiX0V7{BGx3zrVC!gN}HeyyKfe>qu%XE-Fa)C?OCK!`(_VkUmE%j6rna}FhFR$9zS4_!UpaM4U)Xi` zYHBxWZ~ZdSB=l$gd9T|4A3xtN<)3xc&h_`FKMm8lWO+`l|7x3Rxr1Zp>ZyFsxOeY7 zK6AO`t`ivsCA(LweKKiAf6S7!w--Cl_N{)Ea=Ke}zk%ayerMf-LickjOG_4iowY7a z-jUsSx}|&E@@;<)uZ#Q{c64{`wXAEQa&z;ZY%BV6=Vwg4RMY<`mhL8j8i9I-5Jev) zNcx16?#|9u3L5Typ_&SYMtVkih6+XoM#ct428LiIEDQ_`3JeSktPBhc?tY;RObm<% zKw_};&Isjmf>kpxh(Kw^svri&3IRrG9(Ilij0_9{3=9l1P&sBOoxs4rU;t(JgA8=y z6X<7h;*;oOcH&d$WpU!u=wWr_GiYP;;In9Ecj0qj3gY6kaO5*^~Q3Ug&kv6fDbri*=K`nl!k?G00RSq3P^;3f#Ea@0|O|IAbxen5}sgp z1oAE5WM0e2#b@Dy5u$F~(0H$an#sWkHIr`vXES>nTMuh5OCNJT6Ug2(1A} z%KQ^#FJ=mIf!Uh@HB%m8FDtUW77PpwPnaN%I|!nj_yl^H-1#JWm>u~P+E^U`$}(8R9}((A}4(99IY#{pvF!1uuJ`1l{2G&3ZYF{GFo z*fGRF0?Z89ZDMACKIz zIl;id$)JfQ4&pL1@Pa553_2!`32GWh0+dccH2BgXEbjCGNiuLUgn?-U;mg3l05S)r zAC&GuvXJ!8$xsO5AmKVNo0FjlOd|;JW={rAh8~0vnAHU)IT@ybX#_C=%;aQP0HzTH zL>(tXHbMx@0_S=LE_k^K7Gz+6>gQyrf(bzBWnh|%Ap%Szh&53EPJ=`=11P=2WSJTG zU`#lD9;_ZA4o<%e3=FRsKy4jFdV?AV*2l~s45rZuW(H8Kp^GvwFf)i@3NnDi(NhmZ z88f^_f$(7@GlLwAi9$1@_!1)Zi-Cbb2`OJdvnPWnBLjmFQvL$hPYetUcF?*Eq8mXr zGehb)gb0M?fwt#OFQ;1I9HAwC_4_+lL5=WvMM!6DAaj@@6HIK;znh^ONa@4z9x0EhT_ z9O4ggh<{{*|KF$UVdOpsE zAi@Mh7&F92`5C!8TLcv4r)B1(78#nPr#cN7CD(FS5z1px|ZoB=jWt= zv>1U1GYowe$wjG&C8_ZsQ{szDic%AEku(`X>;>yJGzOVq2)5tQ6vVaw5tbmr5bQKV zOydnwN^=Y1ONtVcQ(?x&yZiV%Ir_xM7ndf*d&U<)eV~_IP{0r$6TJ|{IVy(A+(wWuh+D8QR|_kheni8-7u5AX|)H+9Y^&C3RP z0!0tb*k*7E*DFd*(~FN!uc(MGNG&SP&r8h7EUAnyGhir6O-#wj%*$pdE-A`M%>#Kb zxu6p4FGF*fzmgJD;uCXn@{`LL;^T`;5|gvzlQXj8(-Jdt7~(_o$}{s);)7C)OLJ2h z;^UJm5+RB~DJZofIkli9Gd~X$tidIQ#zm!hC7HRYkT7yKbPe+M3obDS>8da^G&D*| zEY3^@CArMJbkF4A5<|n}jKm^PTFERa_DpsSPV`K6bp`t!!!#E|*D{9qs1Q#K8K|qk zkpyL@6{V)eqqq(^I?~UKTwbpR&A1BkecTj;0=mc<9N^f;&}gp)V$pM6i|jD z>_yY$oYcf3*WeOEBd})A{Nj?t5~yBcTnkMh$T8*ui80iigi=63@`71>d_E*ZL8U=z zQ3=+V3POYfRJCVFe2783Yp_{-fOoKQd=4ld7`Z!}LyIFzPzjw3&d;E<3vvcb$^s+> zD&)XP$}c$IGTs+vcYt@9t7}kjeh9d@LXpbFC6R6u>nfUpq!ms0I>~40mu>Y zCHc^7iJ<`O(BjOhRESJ)zHvcm3Ai*40VOyhQV}Rng7Zz&a!QLcpoWwX6Q8EZIr+sf zYeA_3lnFDF!S$ABvMV&Y!LGoPDKJwr*c~Ni;B1}>)$NB|*%%tf`$B4)cyM+D#aVEP zp&4>PnVeW$0ul%131V_L#2#?5nUtEInHQg&SdyFpEv8cQQeb@4y4^e_v$z1s^Y9|b z#4|6m1d%OK#i4ek6z9ihB<7{$z{~5B)QU{-`~j@z3+jG>`qqE`LjY{J79_60z`y_# zhmDVDF)%QIFigA=+ExLnM>c0K4sj-EhaIF|8_9e@Byk-iaZvvhWE7~$1RC3c*;|98 zUKdIIDkO1a_iRTJNA}k~s5r<^APh5K5M&{EER2Bx*&JUS;6 zvinyfi6g5&izJS0{y!vfQzUoFLdOL_<|B(M;Sl#n5;sFKCk!eMieJ!ZEi7F{L&ZVn zBgbzNR2-xpG>QvTpAHpASDyzJM^|4A6-QTJ1rWSAPph967(dL=tyE^6v+z zILLf{ByrdfFvxsIBynC)pg_|ha{6>b5(mvq!NOq|k~nfa@_+&hYK{|<`NB|fP@V>j zMZ?T-LK1gDQlAYK2f5P~NxTRu4l>6LNqhoS9HibINqjbvII=lwk;Fk`;4t?bM-ul$ zGUq;$IC47wjzip+2UH3`=3$W2|9%|eFOkHN!&4DD#1HZpvbYD5II?@nk;IYR{~bvj z*&HtD_z}o_ppLl6WAJd#*smLFRzw zoMGnNhl-<{^9D&g2+5ouP;rnspjio+Ip7IvXud}Fmn3vB6J&lck~s!Q;>hKaIaC~E zKB$ccGv6I54l)P1TndJYgVc*7nI8=m2dPJPPco7?a=aHJi6g6T#39~^Bp!lf?;0d= zhJ&0g`wek~s^I#6ee}z`|`QlDH3&`ZZ8-kb6KFrv5%u9ONG4a{dhtab8d%0`)Jl zdNU+(WPgc4+ohm%1!{tU+ytt*+L781AaR&``q9Kec7W7RM-vB?K_KxX&~hGTzC5%) za|TU38Y+GTP22}6eg{pQ1uFgwP23(TUI7gsn7xyr;tgoxi=g5vNZ|wW6U@KRWCfo2 zL>33JLHgiIg64L4weDM2;_T=NQ`W0C^o|4rE>% z(%!H_GG`x>IUqN~)E|Y4gVLHclKL}9;xb;QcO@fMp{EJ*}ltRTp<{+0Fy-4E7?wN%o z9*<-`EFFQ&L3Yn_B=w-RSFrG3gCw4aWX?vYI4IqMFmgEy3Q~|5s4EOJ2ij}|r_W?0 zbD+r?JQk9IBo12%05T^PNn9CZI5fSbA&EnU89>gGhH;SQ=Rs{ls4>C-8S8+lhm8e+_@Fof(IE98 zdz(R(Dgy%ps7;70{%0YG$G`xJYY+>jUKf=47#J8pZ6Rdw5a@yyP#uRX9`p>vV_*Q4 z`5+d|oNtdnJO+jw2nFtLf!wnSY7T7O3{3qRXurA^O?^N$M4%f&!Ogk!0wMreC&K_2 zcYrKUWPq(bgPFeoI?%NXq7ANoH&px>n)vN>hyX0V!_28&4iUczq2T5iWIzO-LMXWS zD`@z2n7)`TYB2naU|?W)izY4$ zEpNY|iSsUoxQ7|qkAua#J+zS}fF>?>0is?CP23aOP*Ot^p9yWq=%a}*Uj#A798Emu zE=1fOP5ck2Q^LT&;DIJyR0dHWh$dbSEw`i4#E(HcK(KLsn15mFv(VIgLc^g1O*{(J zd17E-s6!LyIs|bKtRD?CpC4LZ%tBLN2rakQqKV6bI&%yR3nJc=X^GhYf#yb#*HRYMa` z1a%e}7#Q@>#Cf6V-w91T8CotxqKV&zc8JT+#7m+1q7O}c*L6rZOhXf21b^bChi99c=e-+hd~zdGfYPl z|9u(~{;SZ$v!LyzO=#l(p!xAKns^5^zu!R}_FD_l#9`_y(8PJ69lnWZ;uE0ljTva-SD@|fU1;JV zpvgA|28QEk;to*$IVcSahf|!5H)!I`TOjG@Gn)7XX!?|d4otwzc?(S^I%wi; z=ON}8qltfjhO;}GI841Cns}Bh#GG_AaaemJ4^8|7Xz-hXfuRdc{3A3yOhglJ2My9Q zFfgn_6NiQWMl|vH(DLUTnm8<+FQbVchAy1>geIN=-FWv4P22_AUtogHAHl*o1)8q- z(Zpf#E`uh%6WR_@MiZBR00~bEG;x@Edo*$BEQtC@G;x^v1T^u<(Ef5Inm9~-1Dg2i zr4aMyp^3xdcPX0qL}-8HAe#6ZXg~2BnmDXK^#D!W0Gf}Uqlr(0inBrIgJ9ur4{ayN zqKOM;Lfo%{Ce8<%v}a&out5{Io(xg%j3#~z+Wvvf$HDBi+Xzvgfu>$Q2_l}4CcX@6 zZ#$ZJIcV~bfq|h9Oct3t=|)}o2W9D&$-6iqw{I#728O!IV}JJH1VK-0r* zG;vt__A#3Hj~Nj6!v^SK;RaLB0i8&IiC=@Z&-Ky7Vd~A%#Ji#6FBxd!F!cp!;w;d9 zaW9%UO#M_e@kY?3E~sCOCJs}71Wo(|XpsT~1H%V2@d#*o`++7t9a=AoLdSPu;Q&)F zizZ&Y2NIrEXyP#SPH5tPpzZB=G;v?h;u;19hIBOXH_-9t7Bq2~`W`fKH)uT#8=r=` zAEtgIntDrUd+8jSIK2OYCJtL4`2$THrXIGn6=rW1biz{!ntoy8F!fq!;+GFV!ZQ#} z9Hu@JP23yW{;Nh4XMx(=j3yoin#^ZlU|5PK4pYAtO}rkuvFbdUI86O@H1SZ-B2Wef zhJR?{F!gNEeg-TYnxXwB4K(qC(0g(X(8SZB^GZQz;xP45XyR)@i((iU7;4bOVd`7Z z#8!XQlLC5XQ(ZtoD@e+w94pX0qCN2)kM`+?O z_1$RV#xo)DwFylerhXTi_+4nf@(!9f2ejSt1WjBL8ef0V#CJjS3m3GV0t>hM(DWmL zCJyVrE24=rK*zle(8QCV{dZnyzXxW1EOfp`5>5OPbUa55O&r!=(?b(i2QAuSU|?`V z6OS*3gl7brIIKUFiY5*-KNn5h9+Zec{Y^A+NoY7vM-zwj6X&CeH|&PEX9t=%tQ~s* zP5cjZ9`Q1o_=l?yb8e%F|Aw{?-=T@a`bWRf#9{424ru=X7BA({{*gGEI5TwoMFmYf z4cdP(L=(4$rUPdj;$CRtOQG%5bTo08IeBQ}Y|!zOZZz>AX!~{sns_#J+;0w=_!sDW z`bIQySUNm~CcYe6Zrnl>=LIbaW?*1=h9)ix9UuOTCJsx7tkCffSorrq4gz5iL=#Vd z<_ifl@u$%7WNkF@d(iPKBQ)__&~~Ojns^0t{4)lJcru#!InW|^1_p*|H1WK%ko4J! zCT=+6ZePK zL!Z#ZpMy4SFfcIuLKAO-w&#VQ^O>-CxjG3F{!(b-snGEvb2M>Sz2J!^z7@JoDHKio zB6R*Y7EOFAXz?`z149X#I81#Fnz$Ua|1ud(+++pB{j<@;WkHJv85kHgp^1Az`<1)U z#M_|pdmBys4zxY}7)_iF+P`Lnu8V<%XFqhjix*A&DRjM)9-4SDv>jrGCVu7=#9u*Z z;>V!vz$i5F)u02b7#J9e(Zuzki{Pr!#OtB;{uDIvlqV2-=b(u*gBE2oFfeRI6IX_= zTiA;x{uw$Bd<{)J2|BL+7)=~z&TBOB&Cq(E1-cFe7S6EoOhGhpm^qSY;lP-Xi9d$UtIkFfUjgmE z96}R6(hG6tDKv4=IW-`e=V;=vdhI=$_(`aHn4$Aspx^>E-C*ju(8Qad?HMIBahQ57 zH1W^S_K7o^I841anz$geotB3t4pU!-CLRSX2WFy)!_+TC6X%20J15b^Vd^iUiNnS( zzMzT2)c-*f-wW-(h=KwUY5o+ZUKUN98`>YUMiYmrcSaL`1X}#dz`&4*CJs}di6*WJ zO^5Ah;y=T+eO#Lr3@mT0M zl{mCKgQZWHdU-T)7U(#t4VpMiy$hPSA#}Vl5l#GMIVcw~Fl3^M|AUtQjcDSqd6P~w zaZ~8}?eCVmq-zVsJOd<}FynhVW{y3YI4fw=4+8^3IGQ+Yo+Tbl{2z3^XgQiVOnp6?_<<9U zc$tnS4x4Y9k0!1Otyi|AiNofb_M?gO&V!hL9ZeiI?{gnbd@?9d85kJ8qlv@jeg30~ zGeQm~WDtk8k6`fvoA;4N6X%DvL(I{{Ve>xrXyRqib&TO?;;{a5JeqhfbRMT1P5e7F zo!6s@H$vw}=Awzi)GtL77lp1T+=nJU9opVFh9>?7>fc*v;;?!8M`+?3p#7jRo4;+DoCrrH%n)vNk z5clY#iC01MsX3bXUg$xqA!y<-^)YDTd!glFGnzO|eK(r8HEezyO&q3vE1LL4X#3<6 znmA1TEi~~y==#P#XyP#SET9coNbRmFXn$W3O}qrUzCsgCydJd4iGhK^2~8Zfp3MtQ zJOkRVOh*%ksn16f7lj-s%g}=+4pTn`O}rPnu6s9{I86OvH1R{w@v^6A;xP4Z(Zt_F z$NjjV`4X1iVCsd?#1}yO!zO6rF!eTQ;%8Pv(q|-^cm#C)WFngQCFnR_2bwrc{RA}e zUZ{UIp^3xP??My*1MR=uK@*3me}X1n30>zS0ByIz!Uv{a0!@4sw0~ufCJs~Yjwap! zoiENr6NjlUL=(RQO+Pcx#9`_epotqm_hB7E6Q2TIM{yoa+!(r!;yRl6W$3umPc(6u zdPZnF9Tq;Jk0J3chb9hFuZAZ69okOzKoh?UosS4W6MqcdkC1{U{s5XjbI`;?KnEu? zFfdF;6NjmvjV8`t19ATuG;x^vD`?^!(DpY2bUqCh4lwl`XyTWl^|C&iI841cn)nfD zJ2Dwf9Hu@SO?*1keUs3{Vd`h0iO(s3`1cr^I86OHH1T=R4T4|M#9`|HqKUtSwo5gk z>&4K+#}G~Y2y~n(7EK&xekz){BedT)5ltMXekPiDCbZvv6ipna{w$jKd1yQNCz?1+ zJtK5nALg%CXuCxNO}q>$Zh$841r7gbH1VC#e3XnPZUzniJ~Z*m(0nlsP5d2n9%MV3 zIBZ?eel+pV(E9ZmnmBCT(K|HpVCXyrJ9M8YEFAox?Pq>8aZ%_vvpSkMY@L-pnz#yd z{Lmdu9H!nMP23E+UoRa^{2jEtmyafH3*E2LjwTLU2hxuw?g(9vy$wwqrhXrqxa?s_ z{(68W4paXEP5do%eKi+!eFrQ&Vd{m@#5LDL%r`+3hphv#K@*<}U8f$0CJs}dh9>R` zoiFG`6NjmviYC4cI{&gAO&q3vKbrV&=)BuQG;!EEke6uUFQM&QZs>RwEPP<&~cbPG;!EEkZEY*C!iM)>_8KTsXu@wJ_odE zo`HekIhr_3{d+X=4bXPDAm}hAr1mgOy(F5rB(#39MiYmv193(Z*Msh7NktQfsn10d zzXh#-r=W?$)XzZ^e+@N%ADTE!{V_E0F6g-Z3p8=qI*<=&;_spRM1-L8&#?3ZQ!j-k z?gtHDM>KJmdQUX*DbR7+Y&3D0`eHQkcIY~^sc7P`b(nL}#9`wg`_aT<>k^NniQ7T< zpFTkohpB&qCLRuLX9`2pH7tB!>ZQ@douTW`ebB^V>O;`PpF`KT6rzd4)K{X3e}tCL z3(&-2>Q|tNFNF51ub_#;)=Az$6aNa0-=ApWF!hYk@>Q63}%%a%kc(^=fG1bjQYl9{ZTW95p zCJtL?<%cF70A05bhbF!oI^LCyCJvj&tUwd@hxTV%(ZpfvRVJZ{!`6?@M-yKOT`#u` zO`IJX{)f@TVe_FE(8OWpTt^f4gRZ}NjV2BofBu9f-UgkY;)2#Euy}#ZUkIX!TR`_O z7@&z)Lfea>XyUN_x>0E2OQ8D#;?czSL(@+Inz$9T-(HI*ZUAkU_M?fbLHAotK@)!s z?H9~L6K8;qQ!PdlKL%Z2u@+6-7&?Bq2~FGqdcn{hH1Rg*`6ma_#G|0&38&G-+o9{S zE})6?L+j03XyS9A>#6ReiT{G0uksR2Tmrfuzz{2#9`{Q(Zubc>lymd#9`{Epo#y4 z_HWmqiNn-yMiXBJZJ%F56Njn4iza>*Iu6eO9nXe^GXr$L9y^-&ROoz-JeoLc-ct=t zyan1Gaz+ymg!Xg2(8M=D$Gwx##F?P$STfPXQ=sE!ZD`^a(EQbhCVm*&-dKz#t_(e3 zY&Dv=0<<5!4NW`%T7Mrw6K96bD_uep7lH0ue}E>w7usHWhbI04x}WzCn)p}fxDyvN zoM7=43SH+ZgeHCvx(-tnO0ral)>uWCP z`Y%}czk`-bLTKU}p!3w4XyO^ra@!D1{19|qlOLM66?A`J7@GKM=sK2SG;ytKkaDaV zP5c;ioz)C9@oms{<^nYFY0&ivd(p(VLC-5ViY5-L7ayUCheF5MUZIJzL(>m4bbbRC zo-p;?XyWJZL;PieCawXkU!2jzVdb7Tn)rR_`oI)4aUW=VFAGil4RpUu0h+i0be^jW zP5ckE{H#V3KM$QJYDN?P0v*Sgh9=GkEwAUHiQ7QWPdJYzJ_B06+(i?IrRS$;;@_a- zW~|WtI(G5tlhDMsK=bJgH1WyMdCz%h;u6qxl}pgXH$eBxtU?plgzhulfF{lkZC~v~ z6X%4c`@?ABLeTx2C(*q6(z-=K*nK-+bn(8PnG z^~G;A@jz%gXNB%#hNY8vpbIBK_j93%`#|%l44U{)=(=SkH1XNc`D+a{@h8yr4|-_g z(CI7&3p8;>=sG{#KY0V=Rn(~*=XXwq5Xm)G;u5Fe(-KIahSc6(8Qae z<@{gXyV(U<@07V zabf7Z^HDT$m^nAm#5tk$-2*i78_<1ypU}i%=CDEc{lmho13He)izdDgx_?avO}rku zzQO}d9Cj{HD4Mt!blqJnn)oE>_-!?s_)cg%Hlm3aK==DELKFW8Z4a+U6W<3Nx7mg! zeh@lNei=<1rv4V1_+IEb!0%|{F!le?#1}&Qv(lhLZ;{5CVd|C8#9u+%UG`|=uyGp? zG;!FtO%R&+Iq1H>Xf$!yxj-3c;!C0BUIChTG<1FS6f|)KXuD`8n)qC3`ZxLoGCMHfTR32u(Z~ zI!_&iCY}mCSFHj~JRjPAXh0KR1x=sx(8OWq8m&eXhn)+s8BJUQbjUFS1H)}JaVF?^ z?_)Ia2xxv0fTmMezJ{HfB#S0q0X_dm6;1pXbe*;znz%4DoWsz>`=IkvrD)>v(DJhu zOqlt4v z>zzMn;xP4$&~xcv;co<8w^3lahUqqXyU7&<=tL1@n_I>&Ji^6<kJ~ns^Fy-KiIv_#9|?8;&LpJ2x*5 zO&r#~EJ729sjoy6&xiICC!vYM_Vv$16Ay&W5A8-1hs|@HKof`U>pzbs{tr5y{}xRg zcFx`xH1TWD^dJRo*TBNF7TWIDMH7den`eS1o&-I&!2?YkrrsY-+yy!>pMfS0E1&bx z#J!;Xw{A3X*g1QX(8QIX<3+2{#9`sT2~GSQwA?t4CJqbdD`?`J(DCQbXyRv~`v?D{ ziNp5q^FYUwVBrjNj|iH$1+>GjgC-8!FKmY<4ofHAXyP#QgVDr~&xMqe1!&^1b0lif z#9`skiYC4RT0YD}6Nl}KS%xNl7uvqvi6#y^N8%uwxF&R6>=iU|*f|mp(ZpfrMZ7~3 z7l*c6zM+XPhPHn=p!2}6c-aPBU#*TN{vVpI^wGpWLBqipP22%GE)j|*-ct+-|70|A zn7z$t;>)1>D<`0dFMJL$XD*s}9CUnp6`Hs;be;cpH1UPd`Nt#Z;!yKXqlt4t>$Q7m z;xP9-MH6p=rnkRn;>FN(&H_ER8y5au(0M>vH1Trie6$Lhcqnu{*$zz{mhZgK#LJ-L zeTg{4Gtk6mLhlKvMiYmb(}X6z7J3fhEHrVL`h{rX8=>{ZPBd|t`U7a<>d<`_H_*gk z>hGh8b3)ho{Xr8y4qacw09{863;#3F^&z5Y;t9}pof?|>2k3a69-4Rw^!yE1G;x@E zUo`P|kmSsef+h|t_h9?*VD5yiJFP=gUkuHU)6m4-p!2_T(8Q-g%kA}O;xP5w(Zu&b z&(}VWCJs}79Zh^Kw14p)O&q5FJDT`$XunYu+J1-m7p7hsO*|iZ-j^|&I841Yn)n^) z{`z1vahUpOH1R6vxKIU}I81#5ns_?&ocg(F;`^cV3ro?&-J$;9izW`6=Q@oheha#< z;WC)Ax0>uX@)><%6OltB|uf}SgGhb9hN@8pXn&IH{r z8HFZ34?6Fhh9>?JI-gR2CVmE*e|MsZ_dv_TgJ|MQpyN(g(8OWt@1Tj-K-*XE(ZnU7 z^B3RI#Fs$VRl_b`f`uEbyyb zA;ZwbMWN+M9-268-DWkKILsW_eN8ZX>!9tZMQG|%q2rbZ(8Om$>xJuR;;?feo}h`t z&U1K!CY}nN?`DC{hrrweI~PI_O&n&9B${{x^gMAxG;!ED50+@+9?CTUv*hn?GCi6*{i1Ehf)geDGC zAB84f0bQqBfhG<+=b-^j+yT1&1hx+q=6={Y4|CAeS3&#ZThPSApySVb(8Tkh_0bhH zao9Nzx6#B!pz~Z`(8OWqCon?OBg~z!^AkAH#0{Y1%xY-ju=5;@(ZpfqSfh#8LC3oy z(8M1=*EuAhiN`_v1@&m+ccJaKg=pe8q3ekDqKU)KVK|B=eg!&DaTiS-rv53KI0H0& z{zVgqox{KiZTG>#^A}W|ESfk>y(*eG7j*xlEt)uNKcFj`I43kc$D)bD)WhaKVeXNF zt|P5QQx7{gpcPI033T1gJT!5b`ekV1&!F>|`_aT<`<;)YiRVJcXKtg3!}fhYLKA-k zou_7jwj*Hvf~n_06Tb&7fArAAVd~A$#7&^#8G$AaQ=fn)UIRVXv>ipG&)#5X|aXOqyx_dwU{HlT?|L-`$08s<(R=(zD}H1Rvo z^+KD`#AiUypFD#mZVv4)TtO4phORq(gC>3fI{*6xO?*AHJs<`>{~qSf>(G6Ca%keV z&~a)9G;s%LxOt$7--XUIW}%6@Lg!hF(8ML6?dNVZaW!c8Pev2Bg3bpmM-zVn?cc3O z6OV(APo6*%hn?eh9!>l>bRPK)nmA1TXEgB?=sG}A=sp!#cxFJ?8_S}J`$601R%qfd z^-gHw&!Fic9!)$RI!>LACcY0kFJFo#4jVU~izW^mmso=)-U6NX+>0h|4ZRQG5Slo& z8OQ)Te-RcAuzA)qXzK4m_u1V*6aNHl2R}j+Uk?q>Z)oC+q4ScQ(DVYc7dFo>h$haz z3DUmOM-#7wu5&g+6K93qj~0g}UI5*PkcuX*49(ZDbulpaz~)po!Ou=OM}(ah(Inu>pHffiT{PJZ@-5o4qJEe3{AWj zI)2UqoezP94{Tir51RN)=(vg&nmBA-pE;U1Y+au{nz$2m-$y!{IBfk%KAQMfXgJS7 z6Ni;wE78Quq3am8p^3xR`|U#$e+MlOpP`Av*13H_6Njw>gzXoBg_|g}JtGZGM=){N z`XwbaaZTvD4%j+$n0i>ga6(hR89JVmf+k)Fy|*X}P5c~m-nk7;9A3_&iNnizH1XNc z{TfTr#9`zAd(g!HL-)&^L=%UVGgr~XVde83H1RFaaDR^`4lAF3qlv@HXBKFu_H@l0qtXD^!gDro(C1WmjL+Mm6HCT1zQ)&izfa6+E3I%6aNccKW2y~ejB>}${S5Q9y)#-geKkq z8;?a3hvk=YG;vsdX+sl#4=uNQ(ZnsF)Tt^eX0^NUc2TgnpbbazeH1UnleSgo;#D78ieXr5P8=?8@1DbdW^ge~} zXyOIX^9k9Y{brbd>!JJBdC|nfq5U;wG;vrz!WK=u1bTkHE1LLiXnQ*WP5dRu0SpWb zm1yEF&~>DZXyP`|c<)0K?}DyZn~o+9yPtXinmEkfeQ4qnp!27v(Zv5k$M-IyiQj^b zGq6KDJ|ORa_6uBwx|1JGd^vRAjSQMNti7j=CcYFp&R~Ql-T_^A;e{sN3hkE$qKRLH z&KJg^iI+gj;c_(bE@=O&4o&hu zfX=4~qlv@HZ5cFiSh=l@CjJasFB_qW*FyVQ!D!-_p!?#Z(ZqS6>mpLn#9`snh9=Gg zy_ca6O?)$SoN6|jILu#5(8OW>T8kzQ8_zk2CVn0|ZhR6={2jFZx`rkWv-dulILzL6 zXyQW9`sf>)xC3vozCLRQB@8zS3!}3ulnmFwIvI%J7`=R^0SD=Z*)UQVqkA?QLj-!d2LHoJq z(ZsW%<--j$@r$tin`q)oq4(>(LK8m(T@UdMP5d=<{k$;LAFz0_gqBwlXyTus>w=8Y z#9`;>_@RkUg{~*aL=)cwZKt)Mi6=wnWoMy@!_JZ4fF^zv+77vhCY}u4M}Gr{_#YhN z%+T@)77j3T6wt)`p!L2rnz$`=JRt~8d_A;3l7}X~1ggFdO?(6N{MD&A#Mj~w--1K@ z44Swvv|V%shxi*D;$Lux^Fa53!NTn@w0|dpLtF=kxCst%A2jg{=zMet4)Giu;w3o5 z`_RN4p!11S(ZqG3^Tl(}#9`;xEJhPIgtjMFqKS(@`!!q9#CxIV%I-%K-wNFibrMY+ zcE9*#H1QkI`GtFE;ttUA{2iKj8+0EE19YD~EFSrw=g;tC?8k+bT z=)95(nm8x)oT30U@own(ONnUW8=>V=E}D1_bbVSCn)n^)eKhT8;uE0jLZ_gKPlcY_ zxe!g<0vhk@(8TMZ^X9wJ#QUM+&~tmj(Zshv z>)#YK@d?m=ZXueuICOlz4o#dDx*xn7O?*2vzGk3_r$Ou4rD)>%&~dR%XyPo;dEWhK z;)|f`WX_<8*FgI(H_^o7q3gb$p^3{t=e@q5iT6PJcMQ<_0Tz$U&~jTGP5dNuKHV5i z+!}iRSTvgWA87rOiY8tG9dBwx6PJdj&qZkBzo6%+>_ZdZ2ldx&H1QMA@!rR1;_lFR z|AQue96Ap!0_~r{!eIq;AC@ATxEWNxJDT_!XnM;<6W4?87wAM2e-7<`Zb1`&0Nsys z0ZsfcG+v&giFZKHC4ikX4Re13w7)M1?We-To1pt1wa~;rLHG5zp^2A6%kvyGaoD^< z37U8{G@VRD6K8??Ydf0w1L%1d`_aT<`w8!$iQj?lul#`~ehfN~&j2kKVg6kX-Jd0a zCT;<(FD%i-1)%Cf(8Pa0`*Hbb;)|i>PZyf_b7=ZsiYCqg&8G*@#P37X?K3p-VCXpH zA2jiJ=sdd&biWtOzmuW!0yb#k^P%m@7&P$^=r~n7n)n5%`bB8sCeZsk4x@>;LB;Q* ziR(c35&TCJH-?HUK=-}D+;0nQCpe;sZ-TA|PDB$IgO&poXyV$?_??L+{s$UvyU@h* zq2)6*JJp&p^*7S&AkOn;+kZCJq~~*o`J$2rZXR zpozoQ$)86PFNUt$e2gXzoA>#JCN2S8_bUM%4}gU;6Lg;108JcrzPCA=cp$Xi3_%lz z-HR8ECN2RTPtHRVht+eXXyW?NdAdnx;%lJ&otbFj$0#k{2D+a`5=|VI9<3lL#D788VVj_duZHfovOyES30+4TfF=%8AC4wI6*|wJk0uTa zhZ;0-HfVdJ1x>sZS`N=a6NkmiN;L6x(0siSP5cFPKJp}*_zdX$%SANtgZm-tonE4e z!_*3$)zxJ^~h= zuzbXYCO#Eoq~>dJR}Oz`|J$O&nIP zs-cNTLeG7*LlcLUlWu6@w$S;nI5csX`ZP3gYv?#tGnzQ8oa{yukAkkdSd1nPQ@UXyW0}apv1-;xP4((ZmCw<7N!d{XMX7hUG5~H1Tri{x4NDaajH`LKBDO zFDo?h0O&YsIGQ*tf5oGT2SMliYS6@C`Ktv@dEc4)iq1)6w1bbkK}n)n51yf8rL zLty?DhK|?qpo!msuAi4c6Mq722dbcn$3y$w2590BpySduXyVVH<(>zccq?@NGz3k& z85#}=XyU=pan~F)@!!z<(JIiyqoCz~3!3;X=>C)mXyTmE{RMN-#1}#5b622=L$6I> z*or2;6uR#45Slm_blmJbn)qSpzJohx;zH2ye2FGL7rIXA8=ClM=>8gJ=zK3M-Zw(m z9SNX`vq8_VlSLE11a0SOp^0-r_sN>0i915qrMsYscR|;A1fq#sLgydj(8T9L$Ck1$4Z6Cz^OCbR75?ns_m^ zyuFMjt^!Sm575N7Lf3P?Llb`p9cSQ#_ETZ;$O@g0mO>Ms0o^B~jwap#Ee}o5#Lq(K zo!!yI7enVagVDr4Lif)mpozCa*N^3*iNn^#RiTL&K+pMUM-wlBj>k?x6K{s@i&=;! zz5`mntV0u@2u=UH(Zofd`#8>_iEBgm-Csu&XMtwy$7teTq3!MWXyVZAp$t6G`T-VS z7SQn}OEmHM(DdetCLW#z8E2?N6OV$nL$;xbdqKySVE3BB?5%>s-lU*%&|ukKLec~^hOh32b~uSM-x8+JrA=E zO?*D|e2+P3;ya-JU4lb=JDT`L==q;#(Zp{<+eJ^%#QC88h2Lo6jL`8_C+PZgSh)R# z)~AtZ;yuuMycA7*Cp6toL=(RREjKoyiGPKz)4Pl&ehj)#^DCP8U1+#*Ld!*%JB^{^ zt72&4^P%;!2AX&VbiKC+n)o)Tcm|qy8MIy0fhMj6ZP(356IXz)uR4GxE(&cI-9Zz7 z3EhYL15Nxcw4KQhU1tRIFYKIpeKhfSXuHK9O*|j!uPik2Y-oAaiYCqn9iN(nCN2bR zZ_Gy%e+#|mWi6U`IdndE7n-;SbY0dVH1W02e%v!O@wd?Pfj^*$PlleK$pu}90t=sc z&~}0Xns@`$UL!PdBWV13poyzM+iCG=;-1j?zA`lNaOi%b9yIak&~f?2XyT60_T&*X zaRq3;dx|EW4y^|nq3hsa{ehfN}HyKS_8oK^}9h$f? zv^{VVO9 z2cU`nhnA~hXyWY9eG@Tg;+vu6VG^47TWI?#15I28I!={`Cawux4_1OEegaxARH2D4 zhMv>XfF^zo+For#6W;>uul1mb&x7_yCZUOoLCf12XyV?`bC~C$i9dt32bQ3T=Rni* zDm3w5(D>SbCVmXsfZK*9eh<2Sbq|_&3sn3Nnm7;i+^rL6;%lJ&$8%`nzoG5eD`?{O z&~oDzns^$t9ryrEoEO^8e1;~j25ncoK@*=1HRltWcr|n!;Rl+y4z!&4hbF!XI*!Kz zU3UY^7Xh&Kk!a$RpyS>GXyO;3>$Swt#P2}IIc3nqbD{eVl+eWGpzF9a(8MF5>0A#@ zJP(>5P0+-5LF3m7O?(BkUkO{E1@rF(X#3d>O??J*U#$Y4%j` zq@k&gg@%6)ns^_y9ae-U{s4NOLj{`nN@)75LlcjO)?Y1X;$={GcA<$EK-U#dKoegB z?Ke$B6NlXsHU~{y4LW|Z2u*x0bo^}vnz%Of95Fk6xjv ze+@0iKA?#kLdPq=_e{1&u4 zbU_ne4DHW)p^2}9t|tjV6K{alcVTGaccJ~k7&LJ{SoPfF^DQomXl@6aNFvUp;8zHqds_BsB3Q(0XA8nm7-1zG)ts z_!DS*atWF^tejefCf*J$H#VS&hnhgj&uwVpA<%yJ9yIZZ&~pI}p@}y`+mk2I#J@u4 zDbAsZ$3XMr6*O@xXgz)lOp<%@B{cDw z(DFwEP5czpJ$h*3zEJZ`(8Omz)2$Vn_;KjCgaev*Dl}f)(8RYu>t!D_@%_+pAP7xd z7dpQafhPV1+76FH6R(5z7gEr~??BthS!m)i&~wWR(8QNQ#~;ej#LqzI{cF&~PeIc` z6Ph?IKX;&s+e5>%4^5mKTK-Hy6K83IwE{EdBR>fNE~@CcfCFSH$d3Qe3Dx-aYknz#>i{OTH-xCS(S z@1Thvg4Vx}(8S}Q^T;pI#Lc1g={q#>xzKj|7c}vW&~ow@n)nZBdBp%t*Rb&U0zIdK z4Nd$PwA|o96W4>btA)_S{h;d=CD6p#p!;g&(8M=D!&wDQd?$4MtrnX29cVw-08RW0 z^qfF5H1T%m{uCQDao9R|Cp2+u==hZfn)nsy_>Ui&coo$AOlUn13r~M&c~XWZz6m;y z1KZaNQ@;sn&IB~|?a*<*xoF}r^OvBB>qFa12hqe~>QA7F>p; z(1)&{VMi0sg!bzd(8SfD{XTUx@u$#netR@=L+CuC8=80*bUq*sP5dEroGleiya?L< zuSFAYhVFl9K@<0b^5;Nln17c-`)iBQ#51Ap*?}gm30;S95Qq2)H1TZc{+iop;!MzX z^&>QK7HGIJLC5J~?z{?Z-}0b|$3px2!f4_G(DsZhns^U%-G~;NxGFR}4bjA_p!1;~ zXyS9B>iyBgw?fA`)6vA|K-&*_XyV(U>u-wD#8aX32o-4JGobql+tI{f>U+?{^Pu(n z0yJ@$`lV>%eb9c^E;R8F=zR7;H1Si={`F_*I3K8*gKjMVH>?Yw`~P6^XaOCkszno@ z2JI(yp^2M9>*X0};;?dIDVjJ;{RT8~FKB<{ESmUr=>DBsXyPz)o}!5-LBo>?n(ko! z5{AxG^P`Ew%#lD7w}STL)X>CNLf79~qKSt?&xtKZ6Q2v+hueZC4zqU|n)ohgeZ3h? z9H#ytn)nWA`|2E;I86OBH1V6z_RMEAahQ4zX#EKbw}nvi`Ow5+=kBSZiDyFl%SLG8 zF!Q6(#Lb}X|9Uj>d(e5DHZ*a4=z6eOXyP#S3(>^?LiqkX2@n&d$%@$1@maal^h-aXQ!_MO^L=%UdXIq6P4s(Aq zn)p8G{Rk7##4ke2AJ}?Tn19be=LJ@wsfYP%JDT`X=(^U+XyP#czQ!TW42@@)y)gB1 zXyPZK=eb#-iNn-q;Sg^{6Ni}tTbBp37ZyId(bU7j=LDKKEPSq_iNnI@5t=w`9q9)& zaX)DN$O|23g}DdjFI61k4rtBIm!PX!AHn12J%#BV{@eZ``QzkrsXyV1m9{u}b>^{p(G;u%Zyj2;RxGuE4*Ni4^ z4s9Py zO&pegBhbWQ`L_g39Okc?IK+3MiNo3u`Qo+hA)mqObo^KghSLKE+VHlRX&NtiE1?CJrknH=v2b%E@DB;;?h}&ZCLL?z6aoCT;-jWPd>uhxu0$x^4~@ZZL5r zG;!Fz30pLAn0hxfaag>EpozbLcD}RG#CxFq)*du*nE6xD#9`*oLlcLkt2Joi{?K^2 zgeDF%|2CR9%>0*V;zH2U4Ed1A_iNo402hqe~`SBc@I4nQDM-zwH z%MRT)26HD&+!BYlJDPX~beuT@O&n%U8Jc(!EWXghVd@v4iNorbJ!s-E^;d9+vu%d7 zFVOwPk0uT?UlC0_7TOPTM-zwHn}b8V6iwV1dM?!jG;x?YGttChIK)5V z5dVcH{uNp-h(pI&Vc}B)ZFf1LiNoxT!XXY@cMmfs3Yt$V(bT_y&eu#q6Ni~U7fl>i zzaK*rhp9i0CJrn2ZlH<7%GGyh;;{Ar19To0=KlTA^Jmo1#9{T9KAJeJ{<1(5hn=J4 zh$apzPyEotVdY5{nmDW-UW_IV3x^ssaacRN15F&(4xfo84r_-mMH7d$pEu(W-;O4} z4SMd%eKc{HIZx2UmqPmmAJN2N{^EeHe}u>R2paCawTIzgP-Q9A=INnm8<-7@>*7 z+TqS<;>V!tGZN6mCqwTkC_od3wZoU9iNoBp4oy52I`g)whmE^-qlv@JUxp?g3hgJJK@*3mzltUfi?4fV z;;?-E22DH$Iv>gmU6&2>?`i1xsS27n%wA6%;)yuKD{+W7p^3xXKLJgA9`u~^jcDR9 z_v}IwhnaH%O`H|F59lSDILw?+XyPz)7@+f(u<((E)_00%;xKdc(ZuIL_qlkZiNn%u z2%0!7{lub)!^+7tG;vrtS&SwQD<>P!#9{UL95iv5`?uf_KZ8U3Dw;UV{O4%m70~tv zFLb^X7M?JB#n8lI;je-wUIZO4bwv}0nd65h4l^ePO*|XAj-nP#9A?f0G;vSpIeT-_ z#QmV+f6&BX?NV;&K2(^0VdHFCNaCP*PhaS{!DdL}p!rIed+db+6=>q&(DpzRk~qkG=yGg^ zHZ*bQ_C$tmByo`WyP@mG=Rw6m^S_{}BX#J!!wRT4C_F*omI4j8y-4C9d!fs77!IO| zLywVWIE5w-O`Z(r(8QtLBZlixadh`Qgo?x5(+hRacO-F;dwxKg*$ltY#J@qsS)k($ zAag+K*+CXDFfeeSiL*k*1)<^~E^_!t;}Exiio?v81ZiYoV6Z_G7l(?wLd8K`Wb^%T zi044XVdiUtG%_$S6rhP~Ld9#4#6j^m7aDGzNaCPy@Q14JMH9D%icf=zgSa4f>Oj-U z0;o91Js|UsLCuHt8$jY9^S^^MGB7Y~MN$tE{|Xh~1r-NzLFOAm&A*H$ZUPm*3l#^M z53=_f)ZX_<;vn;3{`!n24)fO^G;slt<)E|zUB?PCA7l;-RGbq{+z%?wize;_6&FGh zM|P()k~qlxRZ#WvXyTKg;<`|ASoqjM!@(RX4ss{R{6Elea7Pjcna>FwFY-ncXN8J~ zpo!~1#Us$fHK5{2P;qqkZv6R2=4h52&~> zR2-xpl-~TH;wnhuAag3A;u>h;#ZYlWH1SzbaZ@z$X;5)HH1RD^aVIqK4N!3(s5s31 z8=&W;h2ap-hl+#z1#*KcVWkqltfqiXVWAqr2x64)NzuagaMf?%{@p=W8@^ zPN?`7G;t}Y_zyI338**|biFFfJ&{m%@<7Ew_JYEv5h^Z=Bo10TsW6Cf)`We+(5zcmG?c zILMu#_?-+5x1UJjpzvP+HRmsy_$;V68+05OWDZC@%)eY{;xPXTL&eeEBMTJ=nS<;e zEhKS}`G=wQ>Y<76g^HV_i9dphTce3TfQq|7#nIj42Ng$mPX>}W$UQ%x=H#G>e}ak^ zLB(O_KZJ_+;t-z>6^Gfo7#c6jk;FmvibMN}tI@dF#X;@_xhD#0jx3sZ1XNrDDvoZB5f1TS9OAJ!#B0#RVdYXA4)GN@#5ds(KL-_u z`8N;huS;m+Sy1uYXyQFk@%w1v9Z>NXXyU7&;&0HzmqEq9Ld9X>3G?rN9O4qt`+s2W zKLs^M22K1JR9qEJ`~_586HWXHRNM$n9Cn_q8Jai~bo|*KO~Nl^E9qls5S#it;NgY2z?nm+?g zyZ|b`5Gsyt?`o(x%-%&%^Y;Cf*4ZH$@X)02Q}H6Q2bYcR~|C2Nici6F&hJ4}glJyFUsl4s-u= zsQYt}#6j-=2Q{YvP5cj3yb?`Z8oK_u7EPQND&B@Bo&pu`LK6>ziuWUlgTfi+&KXGJ zAa`zos-J@ z%h1HVq2jC1#66+nTcF}F_rUJU+Xoegxu+27p3_L;AooN;%{h-I9sw1Etost4H%GJg})oNP4l4N&n?s5s1=Ls0kE;}D+%6^EIB1ZvI# zH1R`F@l{Z9bn~}B#X;tP%E?90@Hq<=hp9gab~J-B5eEq2eHOK8Ge;xS0#AomAB%}GEL_kfCLqKP*{#dFcb>!IRhP;qqk zG(g4C-P4OC4sy>*s5ukS#OFiBXQ7GTf{Me=3j~=DGUpmpd^uD-x_dT4#X;&p@e2!| z<4EEla~PoaDxO9Y{{}Vx0#qDkK5RVX1)8`bw4e0@O*|Va&Ivs?7i117i9?TRXOKV= z2Te(?gT|v0R2=61hfr}NByo`Y^`Y)JLlf79irb@!+d;*h(Zp?_;=WLEkUNpx6OKc? z1S$@4C&)bkP;)BK#QmV+?ND);`LO&x5h@Nc2NYi)q5fTnBn~pa3~J6&H1Pze_&PLk zIp{)@O=#jAQ1R_Z;>h+Mg^HuQ^E^}>=1vn1P$!Xr;Q^93$eqie=08Cbp9K|vizfa9 zD*h2o{1sIE7gQYGJuJ|3zhLf(fVxK%NgU)JQ|P{RNi=a|sJJpz9Nm0f9O7P3age3cqp3qTBvv=n)qs{coI|`-90%t#5*5gif{KIO33AUH zsJ(t@;;*3M5m0fMy)geK;SjHfio?wR2Q{Y|P5cj3yca5tZvJ$rILI7Ocy>U;b0v~E z$o*2#{d#NB#QC7&+t9?zpyIpG#IvB{htb5hLB)@wiLZc)pFt8wcIQ!@^-DG#nVA>+wP2AoGnyA?bq^O9~QildwF2Nj2ze-&ze9FjQ5{Ao~g zlF-B_K*h7s#7{uQ^U=f)LB%W3#NR{3YtY1>Ld9F5;^^-0hl-=Se-4s3$o&e?dukS- ziAzDnSE7kKL&evkiQ7WOVf!;c_JYjMf{O1#Q=b48KMWOzxgWM3<}6ekWDY2P-$29v z9+Ei7{FzX59-)a(g^IsM6W;vs0_pP=FiP;r<$zd`eL7E~N$FDRUu zq5Xv_Byo^?n4#yA)uD+qLdDzB#D$>Z-Du(hQ1K~Hadh|0!y&#KDh_fd$UTZsbM~W& z%R|Lapotqm#m}IL>p{h@LB(P2`2`K12T*a4y`b3;1G|2io?uFf|`?nCY}Hl z&w`4>%vXS>=Mtzm$Q)4ks6)f21xXy_{yL~R9cbdP`=%$NiEoCgpNb~F8Y(^yP5d!b zd=Z-XZK(Kas5s31no##|g^I)6?+A7OQ6zDY`&FU$)15>UmxhX8LK6>zieEz$4}yx{ zhl-=S=Ot7e-96us#6j*UgPQXTO*{uG&I~<&2xJaO{c@-{JDT`nsJH-B9Nj%qP;rns zp!kJ_j{%Z6$o%6_b4<|0_d>-jq2e&}t)bx`h$gNE4gW+m@n)!a5t2A4iNnS*8j-|7 z;|7jU^ShzqF!zT+&6$lP4s!oDs5|GQiGP8LuRs%Lh3<1-gC@=l72gIGhxr%go&z|< zZ$QOC?gY6<1ZvJ5G;!Ge`lo2(%24$$(Zm&@;@_a+F!#X92L|YVT#&t>_)UX`k06pb z$URO_b41a^4WQz3XyRv~;!0@ZyP@LhNaD!$8X$>-?A4Zn)UPIJ;*wBtTc|j?zuckX zFn{$x{S|>E4l=(LYEBHAcq3Fi6-|62R6G++d@WSG2u=JfRJ;sL{3KMo9!>luRJ<8Y z{3%qt2P%&4-)T6+H$%li;Q;b4BlNtB?P%ivq2}*}io?v0hlblZBymu_gC4KWa2H7& zl=^Q6zA;vjoL@jDM{&KD$ckb5Mc?)iZx&Ic7|gr3t3G6$qS2rABsChh?h=R*@; z02LQP6NjBQD~=?N>`nzFage=Nq2{QdiJyjw>q5n0;ido$2Xm-6$o(Mm_d~%_R2<#>c&Iqc{PR%rbCASA<_kj2DL@nFhl*E1#nH`ghKi$`KLJS` zWWEB_oGEDHa!~OFP;r>~X3+3i1r>*xe;?}p-ALjf^Yx+T>_-#Vg^Hg*6Ss$opFtD1 zg^FKA6Ay)o-$WA+go;0cile*#4OAT6{Xdb!LGCYrn)4S;JP#_)2E8{AWDZDu15}&~ zO}q{&E{rBV4Js~a-qKU7Eiie?zAApKS zp^5Knu)SO>v;=iEc zY|#4yLFz%__8%H<8aTwwki0_??e;-4;9~wCjJ{Lehey(?w$)! zagZ~R-E$X79ONEp=(*Dm(Zofe;;+!e9iigy(8O(_;@_d-=>3TdyQyGI;J9ORx@ zs5#PT;^9zn1*ka8dDu7 z6^Dfz%>4(T;vi>((h1D{XOYA~?mq-I=OUW;0jT&bH1SJN@q1|E7og(L(ZpXs#b2X| zKY@yWgNno4FAEKS2IzS|=;E?aage`2?q`Oc|D%W|&IlFPf{LS?V}e6G5GoEcUkGYW zD4MtcR6GtUj&6Pi4)I2)ILv%Ss5z}@;_^`O2~csE`P$I%nS~|}+efe&Dh@N>0BX*5 zG;uws_yII=2dMZFG;uqq_*tkpx_hoe#XYUZ9ElLd8F# zi6=wFzoLmJLdE}~i5Ee|VfRLYoB^`804mN6z0V5W{i0BDka}eIDCLQ6JG)qcR&+g1Qqv$ile(f7%GnL{$wO^koz}7%}GZS-v|{i zKodU%6)!;(KL8c4MH9aU6>mfnzXBC+hl<18ZvsuvbI`;sq2kM+;xK=efEWx64BL^! zLH>FQHGemn_+zN}5j62HQ1KIJ;-8@6m!RS>cRE1ba|bF8at0`!w15~43=D6P#6j+1 z1`!Ml3?I?N8KL68(8PtH;{VXZ1)$;_Hz4&a%ssoH?h(Qvt`8LlIS*unB8XsMU@%4# zmxqemLd9X`?}eK04iyKP1M=?_5QBk%Ap}VrWP}ljU|?W~Koi%4iYKCp`#{B0(Zt=L z;(2J|nNaZ}H1SlZcr{cU=KjM__qXB@Uj!8gc?V=fJ&0gnU|5DGUJDgpk0w3=D!v&_ zyay`22Tgn#RQv#%_!6l2QK&e~{THF`zlSCcYv;VcA(Zn}H#re?0 zk3hwR(8OW){3=7mLGFY)5u7k}q2eHWLFr@(h{3?XV1*i?6Mp~|&xeYmn_meP2N?@8{~UyX63Mt~$47#KF8iT?vjGBE6gio?u@ z#ldkL;t!zWAbUYZ@I%dif+o%j6@QB+E)Ny|h$b!z75@blM|Tek^xjvHy&$EJK@0{4 z207GgLemO}r5*UIrCMcYgy^ z9NqmBkijtUhj=?w9A^F(s5#we;-8@6Q=sDL z=Fh_+4m*boW}N~TmdQ$GhYj8jtZK%22@-hDh@Lz5^BCB4)GwUILv$-s5xP1;#N@ccrsom(ZsEw;uoOe=;q(TA^sgI4l~~m zYR+#oaUZBS3-sPLbo2Reh-*W|Vdf`5&Cy2_kAsR^K*iC`cfuha4;6=*Uj#KL8BM$Z zDxM1!hnb%PO;_bO#3w+-Vdl3$&6$EG-UJn&4;6=*UkEjSB@XdJP;r>~)1c-YLld6@ z6+e$Az6>gU8BKf%RQwK99Nj(7pyD8VLFE`TbiejzBymtVunTI=cQo;BP;mz6{gWVb zKXpyKH6SAmLy>_v9JA(A-AJwKr4n4*b)fr{Iq zi3>x|gLOg^7lev?qlqg)#r@I56`>gB@`7Ka$7@_xO!^E4Q;=E9CkollKs{y1sVi1RlgVcl4l`u44s3VDk z+&>L!jy9V36sWifR2O#}P;pl^NR2*jhYN+|!k;Fmfi$KlUjV3Mx6+Z$M zM>qc*R2*jhQKR-757IIkAjK^qlrgA#bco2=WyIiP&;9-1%KAc=$A?*lbw1Dd!8RD36zcokH9FPeA>RQwoJ9Nj$^pyDw1utLwd zdWIwpa?f0-Ij_*fXG6t5qlvG9ihoBFUj-FscnS#+boX%K5LbtagWL&n&pxO*+Gyf? zpyDP_adh+TaEM1k#bM@OfSMDJCVmboo{c09ibn}(xK$vDgWUN9s=fwI`~g(F6)KMI z&VHyk$UPwQwV~!OMG{9geO#asQ6bj@ieITf2cUjozUyE7&xCp91L?$9MnCMNa7&(R6)&=MH8=pimRcC zPlAeTp@~m`iW{SeuY!u3qlvG8iaS8X(cSL_6-Re}IFdNX{X3!NM5Bpshl;15iJyXs zXP}9nfQlEQi9dphm!gS3fQr{a#nIj00ToAg|5PM#ko!ME&6$ZN{vIm62u++x3lgu( z(8L*_;_K1GrJ&-Q(ZnU7;`^cEF!#4YjAu9r6^FUM5So5&B8h|CuL(8hE}FPHRQws5 zxD8bN6`HsORQwB69OfQadj1C$hqK?uq5C??RE1}{b zdqL)RLCvW}6YqeEx1ov8hKhHgiO+vru#XpoyP`igUb#L@3OBSi4#XhqyLW9A^GQ zs5$y*;`gEAR#0(t^IdR=$3n$n=KqA6lZYn%9V(s!6-PI}42Sr19O4Uch#x=`Uj+#+ zhEq7ipFzc8?&sEqXn2Jt&IuL&3>AmDA7=hv9O6>1Am+i$mxY=mhbAr!6<3FfqnmGt zL);H44l`dLYEBTExGq#Y8Y+%%eku;}Ca5^fd`GA`ZD`{5Q1J;+ahUngYm*sf;Sk>p z6^EH03^ivvns^{o{18+eW_kwO!1g^DYqi7$bQtD}i8f{GiUiEoCAo1lqr zgo@ij#nIjG4iyK58?yUDkit-CmA25C@=(D?r6z<_AN~ zQ9%;8mw+&4^87kfn6^FS8X8ug5 zILI7OI^PJ*r>l^}LE%{rHD?`~cqvqTJ5(Iq{DV+&nE3~x=3hb*2btdqHRl?dcso@5 zK2#jt{FhL1nE4l>=Kn$x2bn(`YR*42@tII@j<=}s4htV49OBwgageA8Jk_n)qI*cov%Yd8l|En)q3$csW!Y-93#^age>B z^zaZGo_$E-ApbswnllMa{618CHk$Z9sQ7#|@jp=U6=>qTx{&x-gC@=m72gUKM|b~z zs5rX&&mf6|+^+~V=K`9zEL8j^nz#*A{4Scf6;%8gnz%Pq{1uwGCsh11R2<#?f1%>& z?&p062@jAs$o;WUa|F@EqoLwbXyS!XaXB>cT&TD@ns^UXTpLZi3o3316^FV1GsJle zZaBmPaENC@#bN%M4K+U(O?)O)ybLOiZf^q)@flEYnE7j==FCA8Ukw#s0To9#e-jSz z3rOOib>IS^&BqK33{R27K|;{uSQ!2wiG$P!L-#dvzJ~-L%-#S9mq8ItJRT};fhG=X zhlity!|IECH1Xe1bK23wnL!R9BeeW6M-oSNk3Et&C|_KK#-lTu_+F@Z0-Cs&9>g6fXyP7F z@k}IfkiD>b!z<9lFGB}n+R?;sL+=5ah9=Hl1+jMlk~qly#ZY^fpoxb=#n(c`LD2+C zKP;dC1nrlEii5bIaN~g9yKx3d9ArL=KE&P&XyV_X=HEmU_kpUvize;@6@La5M|aN$ zs5s0$T2S|}eT3K#5(l}b4r&e;ns^OVTo_Hf7b-4}Cf*GdSAdG6yGIL$xI0uF=AQXb zbG*^S=R(CppyKG}$KepKhKj??-v~9Q9!-2bRJ0_Ux$jr+{puS00RTVL#Q~23o<_*YW^oAagg~X z(23q}XyQds@!wE!nE8Sr0~r_?L_R^%4@_JHDlP{V2XR66=0oi@KoSSp3-gx=nmEi~ zwrJx0Q1>{Zi8n&Uz0kz3L&g2j#Lq*;gOS9M-5G-<4sxfgA;g~vXyWWp@jR$FEF9!O z9%o=+sDO%txFGZUpyAMgBn~pa6lzWnns^~pd@7pw45;`_H1R1=@x@SaboZ=~yP)PjMG^;@{|;)-OEmF&Q1MS_;#EeF z@c)J;o&y#Ck0yQ;D$WdT2!Y%KvUev`oChk7?tU?-I7mGxzF_WGMiK{^!)Xk0k2;$8 zcc}RWXyUO@^(JWI{!npSH1QQsaYr=qIZ$ygs5s318XyOQ_K8EqL0pjgA3(!D6-gZA z{s&NVGSS3uLB)&E#2HN>{w+fj{|i-Lk0ve+Ro{#zE)Es%g^I)6ZvbsqOvfR<0V)pi z7s&m_P;<7Ri5o)2_o9hALB$WEi90~W&qBpv?lA#b1Ul~>Dh}d;!jlntf75d$agcig zq2|0s6ZeOTe?b#ZfQtV>6OV(6Gk$@DH@bVcafoX`#X;@_xu*zfjt-i50aV-+O}r5* zZiyyd4;6QYio@Jv39^WRfx#Cl4&s8sM+_Q1aY*7I_e_SGlY}Nd5h|Vo6-PI}3@Q#Y zUju4>2a-6*{H0KHdeFodL&c{<#bM^Vf(&F}U|5Jld@ocSqzq*KPN+Et(Zshy#ZN=U zVdi^4)ALmv;vb>nF!Rqs&H0KZei|zN4^8|&RGjH6B%Q#_xeFENMiYMz73W72e+w0t zfQqBLUkNG>G9MJb7SQn5LlOst4?A>$yAhf=BUIcPO&sQ5do*#Fe?6e$=v6!O?*96Tne2blv>Z)gtT z^Pq_a$iTqh0Tl;v zLFONWnjeWI4l;i+)SOr}@r6+Fbf`GY{8*5I3=9l~P;n3!Wd1d%`E^L*AoCAH&1pgt z-wYM+MiZB^fP`m1nm7kkd5Bn}#Hgq`PXi6jmhFDeFE#K6Gd z3>61)LFq>xdjDVmk~qjcwNQIQ(8Noj;<0GrE1}|vXyOZ@;#p|occJ2WXyR9);>Aef z$nLB`5(l|c6uKd;0Zp72D&7edhlN`!$m0wQ43nYaATG#!YiKwuK@ta~0Z{W#Ac=#_kA|9a22DH?Dt;9zj&A;as5s301gQBRkin72CnSBMiz`CKLH2^ouZNnWiY8tQ6*q*6!^~L$(#XKTU=0-qaY5l< z0Cm3)k~qlx$xw3w(8T+p;*n_LYoX$?XyPlO;%R8&r=j9mXyV7A;>A#LnEN+@9L&JL zP>Vx+7E~Oh4CMaDP;=&?i9dvjFGmyq1QlP6CjJ2`z6DL3*%}g0JJ7@#q2ha?;xPB` z138R=f#DvSxB|31c>xs%DFekzJ2YOtB8h|iB?LA9Cz`kbRGjG-#9bhBKhd~+{7#O6X;vg=_J=3A?(LoXinQsI&#{f;-04i>YChiCow?z}Thl;yF z#bNF_0dfEX1495*9K;2=XC>4T|7WG~44 zRH!+#(8QCW;)~J5OQ7P*(Zq|O;v1pjF!#XxyBml2O{h4`J#A2P?xKmeK*e7`#bM@8 zfc85+LB&DlfWmVhG(7(!iG%#R0BR01bOH;c9wa^kD$au@eikY&fF^zvDlUm8&SV2g zud-<3zo6>X(8P_Q>b20swV~q1XyOS_adR~B2&lLXk~nfWxFU&z{5un>-V;rHB2+vG zP5ca0JPb|z5L7%KO`O3N5)R2|;=iEkbD-kr@mPjKd@@uV7GLsE^QWVU%RbFjO37z9H0{<7ndgQ1J^;adh)<;Sm1}6^EJc3^nIFnz$oWocRwV{Lszkg^GjB z0mbiaXgZfe5(mX^B-9)wH1S}lxHg)2GgMq3O}ri|ZhjPILQ4Mq2?r`iJyjw=b(xIfQlEOiGPENS3yI5(R3T&Ordn)qy}xCB%jWE!acf~5x~s5r=cgZ&l@Ch zkb8`v=6paC*MW-vL=%sLivL9ukARA^F@jve0G0)%LzsI6aER+d#X;@_xu*?kjv<|(nE5lH=A@yCPlJjVK*iC`uY!t$%mIaGH#9uEk;FmnUj;R% zA5DA(RD1@S_&%uk95nG=Q1PW`;@6?#E78QSLd7>h#nIir2Z#6-s5r=9Aost7nsWn9 z{5e$oA)5GasQ6Pf@t;ufcTjP3_x!*iF2Dp*i6{?wognp~2%0!IR9qHKTplW}h$b!z z71xD|gKPn%pF1FrGcYiiL&ZT{Q2fq@#;*sGI4FD!q2~CYiR(kfL!sj6=Ep~e?SH@Ffc^p5U+rWgOq{H-vc$L22FeyRJ;u;j&A-0s5rTXyWss;xnP*FnhhB_O3z_2iZFZYW_Mj@flF@ z?P%hApyIpH#CJf&kD!U)fQp|$6Tbo#zX%nF`3vU$+c?C3K*d4+0=fSK)SN$P;_sm1 zTx=kd5$T7)6%y}!XyX5%>V=`=AYGvJvk@AehG^mi(EMTz6$iNol;2~a;T(u04ss_y z)ZS1uabBo+9GbX1R6GeyTox*x4HbvE6Xu>$9O8XYagaMf?$LvqGYL&x2P!@rP23JD zJ|9io1}eS+Dvs`+O*q8QLB(P234@w*2~9i%Dt-qlj&A-l9O6vuAeD%C&x4x7h9;f^ z73W72uY-yUqlwo*#U-KQAX`A`q#BwYG|;>)4pAY(z{Fa_%0{b=H_e0>i|9OO=KkVXauhR;aiAah{#&R-njk{l3?AoqjZ zxd!SUSv2ugP;oV=I7k<=`35+|eWBto^Y=l`2}Bd$0~L>kildvKibK2(Dh@OM0@R!) zH1Ts#@ouO%y7^Oah_8i;!_0pKHD@E5_yef;UZ^GieH%f^>B!LL&ah4mw=k%k0ve# z6_0?5qnn?EL%bd;4l`d1YECnnxCT_b7b*@j{{l20O~)a=0V)nN-v(;V7Bq1ysQ7-U zIL!R3Q1egX5Pt*}hnepOHRl_cuYs z(cM1@NgU+;;W$I=8LLlakpieEw#SB8q; zMiV!Iir+^QH-d`4fQqBL{}WUk-Th3wAeE5%5#)Y1s5xwC;x15eel+nYsJJkicoIoWhnYVOYR*J7@hMR8xlnPC`JjG^GKj&zz_1)D4l)OnFLpxn#daidko#9a&Do76 zz6>gU1S$?P7TNrBP;r>~=b+}_M-m5_zYA*4V>Iy{Q1LfVadh*)LB(O_KZcsm&IeM7 zNLOc|=5V8lpMr{uK*d42klil_6^EJs18TlLk~qly_n_t&qlw>virYfPVdiUq7z_*y z?l{B~pyD8VLFRvenv;Si{thah4;2R)3v$0Mh{3?XP>Dl)5>y;!K9eV;Ju?kWoB=96 zA5B~cD!v#^TmUM*1}YA62C{p$LB&D#g3=qW5X9cYNa7&>szJ>;jwY@I6~BNc?g$mX zf+lVc6~Bun9sm`8h$ij_6@LX4M|b}hs5rX&8Tmmf5$P=jY7Q%!cmh; zX1+Vre0L;qkojs*bG*^SRiNS_P;qqg7-+ zj3&+n6`zA9t_c-ifF`aE6<-Dwhq)itZrqJS{3s6bdr)zZe?k7TfSUgZP23DB{u(Nd zZtqtd;=Is=4Kv>hYK|b9xCc~R7Ag)iA2z?BjzioTDh@M025OEwns^jcJOC<=ZhjOF z@p7m*%=|p4In`+5IZ*Kys5rX$eK^EdL&ag{H$crqcv4)Oa?ahUm& zpyoVA6Q2MTe+w0dnO_HDFfcHD$005t3{e0xe+kqa5j62dP;q&vI7k<$+-L?d7#J8d zafmxX#bM@egPP-pCcXtK?vEyZ3@RRsCVm7e9s?BzIRn`}X;5*Hy`XZq5n2uxBZ-6Z z%Ppum0iDy8?nMFW0BI?r=s5lRrcr#R708P9RDlP^U2bl&+KNCR=1_lOg9O9-p z#QmV+Ape5=H3@2d5SsV|sCYC~9Aq7`y{S0FYoX#W^Or!)X+#rW1QqXuii6Atjknx` zo-4ZmP5doXd?%VX>>Qh0NaCRVVquWv%*k~qk} z&Jbk`#!zvPzd+}y!p?(rLlb|{0I@g+O&q4a4NY7FdJ*OtG;x^vt!Uz3p%*h;LK9yL zb-%C}#KGw9)W#w1k0zc7@-zbjLlT;}4YdC<8%-SM&LwE#iB}=vunA2Zb|3s@G;x?Y z57ER=bV1Bv636Z@0W|S+=*2A>P;rnhQ2b7SmaFzqaaj2D?}wQ0i6jon7u%re(-%#A z3sgJ|Dh@M$CDi-`s5r=cPf{Me`_d(TnA&GpyD8VLFNlU%@05m=YxtzLdDU|PsSl$4Hbu(FAp`R z9!*>pD&7SZhna5$O`nU<#CJf``5LG=$b3*b-vSM{JxJmpe;Gi{KY%8#0~J4sBn~p? z7}T6=Na7%KJfP}tp^3Xe#UG=IM?=M*qlt$?#eYG?Vg7~ri$xM70;#V-?zsVVj|h@D z$URk1b0pBj%b?Ei*io?v`1C5t3 zs5s30S5Wt-A&G;`-vTu!3r&0jRJ<4}j&6P}R2<#>E+lb~`4^$)^r4BLg^JIEio?u5 z0CoQgs5s30KT!AYKoSR;{{?E!9yIZHQ1PQ^;(C6N{Cg5jTmve887dBQ&k3k|?&1*t z2^9yq6Xc#0s5yVp#FL=n>{1|;5#`SXsQH38#C4(KF!L**<`|-hmqEqNpyD7~KO?NIY8(8ODz;&o7Qn7uIb=c0-Kh1$CuP5dWRd_PniX76mM z`G?WOXF|o#K*eG9!py&hL;N#T9A^G1s5#%!#8*JY8KprcBjO8YJ~s|=4X8NG{GCv9 zbkM}NL&Z(e#7{uQEz!h}LB*ZW#BV^w-O$9ZLB#{0;vipu(gV!>Q8>hlq2e(2zkr%k zjwb#LD&7DUM>oFDIcw0wd7$E3 z(ZuDT;ycmAWuW5wki?PQc^oPZ^A{7e9=r$@hxtnd>aTl9;vj$NLd}1KCaw(?e~l*Y z0u_IcChi0k|A8hR0u}#*CLRP8XO#iD9FcBe?&pV!qq|=QNgU+z@5GoEz6`=f83f=eg8Y&KpcL`{E_>CkEGJh)6od0OzlcC}qav+l- z?PrkswNP;$H1X9?aY3j!NEgUGtx)%vqKQv{irYiQVeZs|y3-#?9AxhysQJNY;=7>Y zF=*m1pyCN=;!mLBnNV?;>3UJo?!RZ#IjH1R!9@lZ7JT~P5T zs5r>AAor|*y1y7rd>2%_7Ag*NXAIPxy-4C9cb5Ld8Mu1i2>@YR*M8@pP#8Ei~~) zsQ5iJ@p`EEW2iXHJuJ}j?H7_bC_EQH!;?=5q!N)Hc%kYgpyD8Rg35Lzq2eHSg51Lq3`yv-(Zt!H;!DuP z6`bCp6R(7dN1}IHq3&l_1%&`4JVEJs zIkcZH4iyK^$oy=mIW=hFnNaaos5rX${ZMgq^XDLmgUqjj znzH~+yaFn|5-N^v{${8+%>47vcsYzD4l=(JYR+*q@ph>AMW{Hs`L}V1e};;K>;;)W z18UB9H1TOraRxPz$%y(CmVUT!h$}(GVdgJ~nxlp$z7#5M2o(p}0!p6&&~WfX6W4>L z^I)hr$b3+`eFRmXj3f^7*EXp6>1g6xpyCBkahSa@^Q)lZ=;pU0iG$2P3N@!2P5dxa zd^S`Z-Tb9cahUm^pzhy_Bn~qF8q}PfXyR9(;)kH(=;oh+ildu<6GJ6*O@!sJJFn9Apb9 zo&15i#{o$k)DDS&7{d^XB#x{;9x4tCpFPlezXVAf2tx_wPp%2brG=HRmvzcsx}644U|Q zsQ3jm@s&{Vn^19d_dJG*!`$-<>Ygu1;vn~2hMMyOP5eAm{4Z1-W_}4YU+_aWM#03z zpy4116^GgT2Wqbxk~qlTw@~x7(8OOt#f{O#IYS`{$Q(_a6)Nrk6^FTp1L{sM9OB7P zagaMf?oouAla3}X4;3#!6E}p4m!OI3L&Ynh;xP9JK;1J5O?3>uz0aEM=p zio@LR1hw}jnz$WQ{2o*s=AIa+`ESs~b)e#Gnjn>k`UR$504ff$7gWykLFfGyki!)gS{I7#MD$ ziEn_4zd;fQg&WM?Z%}cN`$6#%4h=UREr>>tILKe8q3#zz6F&(Rmx79ebb-u20d>C$ zR2*au$ozDu`G!d1AoK4)%`rt2zX27uf{Me;e*iT<5KY_(+OEh%6VHd{mog-AP`J$l z8OXrE(1#|z3@UyQDh_f#XkG@kj`1o~9Hb27Uj=4JIr9c84pTo5dN27mByo^`S)mJ9 zf1!zghWhtEk~qj-*nAVGHpoUqy&MZQhZjve94an^Bn~p?^%ICYWst-{?rDRnS3nc5 zf{LpmiG$36%}?ngiG$2J0ab5|CcXVQ99LvDKunI{Wd5!EL0rk z{yeDrpQ4F(LdD-h#bN&X1@+f|s5s1=hfwvLIv^29x&?)U7*t#mNgNao7ohHuMH4>< z6<33bgG>Wi2{YdSDh_iG%zPUpagh1D?6s5r=8konS3bMB*wOG3q8K*iC`|Aa%F3%U^=X1*5G96mI0 z4XC&zR2*jhS!g&IqKWrG#jT;@AoD@#)(I-^jU*28mo3zMe>8D(sCWdLcokGU22DHz zDxL}zhq-eO)ZTm?;yqAtkUK%{IR-Un0-E>{sQ64Y@mo;wxoF}ypyJEW#9u=YooVf{Mf3^AsAMf1u(Z zdqMFV2Nmbl1F3|RSD^5ehngdZCN2pTmqHVdfQrkZiF-lC)zQTFK*hDu#MeQ^4Uoi< z-D!y=4sz!gsCrv8@lQ~3H#Bj*C`h<@p^582#Us$fZK2{ZXyVpT@l-VNFsOJYns^XY zya-La3@ToRCY}WquZN0*Vh2?I!{V_MDh`XsDrh{;LJ|js&wi*m^U%b%LdBP(iGP5K zuSOGp1r^_lBo2xfn7#Xu#6k9IMMJ{*5Sq9KRQxnl9Nk}6q2e%q!ODR*P;qqi-=N|! z^*f;9z^)HciAc{jPJihWP!L}9Z4KC?hO%TU@%7#2dQ5ORqqHD zhq>oG)IC8+;-K(}gW4O0CLRM7k4F=q0ToY16Q2eZ&p;9f#S6^dLZ~>*UyM+9R-=jk zgt~JkR2<}fkUN({&7X@Vz7#6H3@VOp{syQx$Q+P+VC|MeNa7&#w?WN0h9%Q^Fzhe zafrJ>#X;@|x$_Csd=E77M^N!VH1Qu$@lZ7JZ&2|#G;y97NXkt@6X$}8XG6t7z5}Ia znEOj{i1$IoVeXfPnllMaToNii8%8Or4}&2{C8GQ(g_^^HCSC{? z=S36mg^CNJiFZQ9RiNS^TR`yz3m-kGIJ$eRk;FmavlMEMJ(~DJsJI83_+F^E51RN+ zsCYDzI4E9zL*peCDh_j}A2c3&(ZuDT;?tqxF!ysq#aAGSgWP`=YVR5}@rzLLt!Uz( zpyE5x#NR>1&p^dt?u5DL8dMzJJ&%#ZLGF=_h2*d2XyTGk@egR?R#5RTXyRs2adsn+ zOAzG@%sqloadh{{A&Gp7l_3QqaU#LdA>F#2-M#%h1H{K*g((#6jsz8)|P0R2=5cFsOJR4)Kjp zagh5#?)(Nde=C~!7pV9?s5rX$Cvb?rhKj??XN`lTllN%i%uw+kP;qqgnT$aqi1YyS zmlRYSX1)m2962;`A*i@6R2*a)C?4aW;p2rS4r|YZ;1JJ+io@(xhMHf9Cawq-uY!uh z?1h=%fYB`cP$Q6SswmHz0|F%z=%gb|Hy_%vk_c--jmN2NjyDvoZxGm<#Sd_$-??r7rrQ1Jk$IJ)^! zP;qqg(~-nM<~u;m$wm{mgNm0x#nH{LgNmb@-;E>=GT$F+PCuHsFI0R6R2<#>MNn~= z`G-LY7#J8fA&G;`kAs@C4NW`-Dt-Ve4$_Vs{-;;*h3pM8%ns_!;{5@10 z-Ta?8#0AYjDiQ7B8mKvlVR6H3?d>2$a2PzJ-4&=m_AO-^iLm3Y7$xv~SJ3;P| zNQC6~>1g6&Q1Jz5;yO_AC1~PWQ1P{B;?_{{jcDSQQ1M+*agei--G2m!_+6+t%>7I z1e$m@R9q2Fd=*q&6-|5&R9p{DoG%FyUq)!+3{Y`%BynVSIv|OI-022Y?}8@o0u}c~ z6K{Zu2cn7BLB-?I#QUM*$!OxeQ1Kiz@fA?<0yOa@Q1MDM@e@$-S~T%JQ1LdXI4GJx zQ3#922~crR`T>QHAV?Ba|00Ql!bdO}63$D}#Mz(IoVpyHd*#BHGBdyvGD?LCSl z4zjlfs{SOJcokIq5>y=BUw5G5Fn<|C{q-3tj;{VMR2-(>AF7_u0;Cd>&Oz?!gW4;E zCf)@VmxYRhbb*Wzgtia$ki?P4E$xuRLFzw(2nGfQ52!fIJ!w$!NF;HPdp1DrjYSh* z2Nh346MqF2&q5P_0Ts_j5(mW#%-#y9ILu$3Q1>*Ui915Y7eK{9?gzQ^C)E5UXyV_Y z;%lMe=;m*Sii6Anxu*hZ{z)Wpkog=bko0*LO`HuXehn&)ZvF$PIJ)_7ki>q75|AQt_BtVizcoD6=$~uxdhRV2!#4e1x-90Dz1k^+#4zmazDtOW>E9}(Zo%l z;t^=#UQqEEG;t58cq*EB98^3LO*{rFUIY~f`3~fCnEPvRh);!z!`z<>HD@N8cs5jg z5t?`-RD2nlcs*2nBUBvbo*0m$7#J9KL&ZV%g3?t7RQwE*I4C@)L(RE>CO#P|eiKc6 zJyiTIn)qs{_y?#sx_f>>#nIivZUs__D1VMa&EZB9KMWNYK@-0Z6_-F0zYP`FhKhr1 z0R;gpd`zL@=?yh9VuhKhej6YqhF|3(wq$^*N2M7B8h{{fsHGsBZ-5|nFLjzjV9gz6)%B`gS-!l zDo~t(Y_5ZfgZv8;;{geR*54wDgUr7NHD?l<_#LSDY&7xrQ1SU_;;*6NOQ7N~_ozYb z-Ge3$z5bEm7*rhQPUtbN4A-FIFmq-?&3OP7hpD%Nihn>72l3~UkfUZ?tXJ5agh1SP;;!& z#1*09E>LlF^ZlUW=;lWwiG$2Hf|?VLCT;)~&wz@fn_mPKhnWxE4#LocBn~p)5o%5w znz%hwd;(M)-TYZN#5Y03LH2^o4}hAp4Ncq+D!v~oj&A-*9O4h5;xO~$q2@eA6OV<8 ze}Ia^%x{GxHwF%SkO-n&f*vo#AOsZ$nGZ@=Sy1&#Na7%W6+z8cLle(|itD3^uZM~o zqlwRjirYZNL9PO&L+G+T1~(ky$xv~SJ3;RG4K*hnP5dWRyZ}v{KNI4y5;SpMsCX@! zxExfx5lvhMD&7SZM|b}e9O7%C;xPB?Le1HTCaw(?--Rab2o>LlCT(ZqY9;$P9k>!ITR(8NDN#hDyHE`*e0 zAbTG}#o3X>k=-ePBo0!q2~D6PXyWQnaalC+WT?0zns_2qTpvxm2r6!jCSCv)w?Px{ zhKf6&iMK<=J<-HhL&bg3#OFiB!=U1zPy*!(SUe^`#bNQd2pW%tNaCRI`2sbk6ixgU zRJ;yNTot-;y$MZR9xC30Bo2xfn7vbx#6kAPL)Fhj6OV<8FM^7r`)dtU9OkbhP=6hU zileJP3l)c{e*jf~4@n&4o~9 zAO-^ig9KC@=AQ3R_h=%CgWNM2YOgMu_(Z6<8JhT6sJIoH_-UxPJ(4&mUSRfmK*d4M z1G#f2)IC9H;v1pj1yFI2`$6u!12w+{P5c&AycQ~sZhkvd9Apm2J<#it8D=7hgUo*o zHD@lG_)DnxGN?GZ`5U0(=;rT15(k<83u?{*H1Qu$@snucoH>wyIEyCE4i&!+6^FU! zAVfLC7c}wXQ1O2_#HF1;CLqc^NvQeqXyW2faSb$aU8uMYnz%Mp+!RgR5h`wpCT$z7kD*5>$LGns^^n`~XxO-94wE;^^+VjwB9p z&nl=nx6#CxLB*e-i64TBzd#e;2NnMf6-RduEA#>jboU4$iG$p83u=xSn)o%SxICKp zC#bkGn)o}YxDk>#C|;n)!Z6rC#bNGb12GsF7*f#0q1Q(+VW>wE2f3ds z7m^^F(Zt!H;yq~M>QM0sXyVFH@x@Sakn=$4ALgF5P;qqk>_QR;xhDu}&OS78KdAU| zH1T|>_-QopY^eA>s5rWNUO>gs-SZVm9ORx^P;-8wiBE%yGr53FMwCC>q2g?4;+vu3 zGEi}lF68i0gNno41GSF997!DHo+nUqtkJ~pLB&1M#6|NU@#~8wE(jG5LJ|k1w_uRN z7#J9$q2eGe$epnJ{!(#>cRv%m^xo%vXyPz) zj-!dg%(;pt9<~kQ{%>gFFmwK+iNnU9xjj(B4YuA@22DH)I$-LKCJr+{08Jcbehiv8 z?0kbpg5MP2r zd^?)BrwYXUBWU7&Q1Sn0;!)Qi>Uq3S-Sa{oBCd=k4pVP{CJs~Yf+pU<4Kc?XO+0cU zM7$JD-0Cqzyb>x7auswbIap#LR2){0Wvl@UGb}|DhwY0$g(kjV4x;`Xnt0?ci158XEq0 zaEQM~6Ayv%e?e)Oy)bbesCnq((m2F*(ZnO6=Gx;B4@MJ@g{qH(ile8Kbf`GYJy)Ro zN+^vk-ibqe3RE0sz8EweE`*Asn{xz*_+uR6KXHglfDYY5%3lwm>eO+FTcU}>(z7QH z@n|%0SUHoACJqbdUL4}9afqMBA^sAFI6JgZhJ`20UR^ZtBxt;cpozoOr=f|LK-E{^ z5O0Qx!{S%r5Ts!4fr`W212bmox^~Z3C zD}fx2lulsk%W#OdqKU)ooq{G_1C6J3XyP#QAL9_`hqhnP{VRti4zpJmO&n&gGnzQe z-XJt_m^q1P;xKdS(Zpfp<^dey=h4JZLG#@`H1S4g_)JQ2n(M+FoIW zF0_D!56pZ4s5rWMF{n69J6Ni~o zg(eO&rw2_OrhXxsIL!QYXyP#SyV1m9=ATCshnaH^O&n&{#j zc&6eI--;#(HGlv6uFEK1VEI0~rHy>0S=6;y@ zl2CDU_3}`0n0lDKT2OIx_2y7dxXuSB~5RXO^huNEpL%b7*_(C-Cy-<5M;}AcJCVmL2{yLiYNvQZE zs5p9jy@iUy!l4_Qu3+~$po?ol`&H=TW>9gM`IDjP%?XEiFjO37&J?J3zv2*QfsWI|-2V+~uP_dAB^=_0IK&;$#9`wL{y4;w z(Zv5j-IE6uN00YOojI@IogXLE^~f z=pczBt1m$kM^@j4B#x|pGLkqbt2jcUm0>Xs@l8nL$mX2GA^r-7IFmHQB9On3&5=YC zmxT7OgK>x_K*iC+GY5xw1rG5R9O4sjh%bbS!`u&Z=QT8O1*rR(Wl;SK6BoiEu82e2 z08QKsYQ6&wac`(NdiaDv#bNG;nNx^Eyb*_Z4^$l8{OM3}bn`c%iMv7Fe-MZG1vGIl zsQUY8;xKdG;Sm3eCJr-4R2DT}K0?bkb2M>gXlC+36Nimsmf;YegF}2JR2&v=hF2i& z*os5^AP(`fIK*#3#bMzO^B030#2$2U864tHIK<;{h&Q2$^FzaJ5)SdXP;po|z{>d* zP;r<$VdfmhA$}Q$_&umNy7@1m;^^kHK<8;;;<8Zp3*!)1!Xa*mCaw)N#}S8k01ojK z9OA_|#G7!4Ps1U;6o>d09O8#@h+oGc{tQjr5*iL)afq{k7Udv~S35w}3*!)1LKEKw zRd0+Y4jX^>#UY-BL%ab^{4mt~i8#cU;}GA5Ce8#MuRn@I{0fpd)Jky1eT+l=6Ap1k z(Bdj+cp{r4fF=%;Q@|mvk3-xUhj+@}i9=i)O*{l@zAc(~BvjlNhj=0m@fsZB-8jVO z;}GA4L;NHT@!L4W-{TPH0xh0{rdv=r!~83WCJvj&)y5%ii$mNWhj=0m@nRg}t!Uyo z(0G}SCSC{?Uyeh3HxBV@IK-dg5dVooTm-sa36>6F?oq}eZi+)3wjK)IoD>}Di_ygE zq2bVqLwq`tIH*j5-EX@Rhxl$B;%9M)-$xTS1(&J}3?I?Nt)SwJst^XqzaaO(#6@w4 z8{iPP#~~h!Lp%?Mcr6a`ejMV9aft83A$}H39J;)b;XV%Wk7(l1;Q|I`==w@nxWU9l zafqwq5Vu4Vhc;^&ywSv=#Rx+*4)J^(;$1kzXW|fFi$nYb4)N+H(Zr$KL>Quw#Gzdvu!UJT#H*3SLHPn^&O99AYjKG0$02?Zhxk(* z;-8SjK~sF%VAnG+Flj&-pmc~VE{G(K?0z{UapZ8&!y#^uB#vxO3J&om9O8>`i0{K8 zei|wc>(`ul3i0Q49O93l;-GLqb|-@-L?61i91d|i9O6-E;)M`n88UH*SEGr~fvRsq z5=V}&$w=ZL_ruiBLlQ@huhmH6$m)0D5I>DW{2G!tviXmZ#F5SaghQMey1*0`&M^1$ zA&DcKFO4LQY`zwnIPBa2TO8tHXyPz?({YHGp@}br#!EMvILw?mIK)@u5Z{GE{3ui$ zmY#1y)AKo~I4s;??zssSM_2y{Dh^W*E0^9Pi6e*eFC=kLIK$NQKnoC}ShBP$sEl_*QaEN!|5MPQzd~!Q3x_ zL);jLxD%QpfKaVC3Gv_^;I81#tbl(ZO zImd8_a~VV2i>^Knhxkey;t$cpH9#I@U|?V}K{X#HE`vkd1WjBW8vf2W#DmbpO`!HB z;t(&!A>M>TdL@ za?b}z98~VX)Gt92M^=9XNgP?dkU4hqjgZ8V)i)rCBbz@7NgP@I5;XBhsK1V&iN`|4 z{~(DYn=fsFa3{!onEEs%ab)$aNaD!qFCmE|tABrhNaD!m z=-?3dz#*Q7L%a@6ycim8t8j?l!yzsP9r%Lf7uY@lI~?LMIK=aCh&SL6pMoa70_y&C zIKl@O;t-#OL;NfbaYkEIdrw2% zsemR9bB_@YaTgroQ8>g~aELF!A-)zW4vHpF{pI@`;_jU|#E;?-zXTPBrMLA^|Ng`w z&JR6U5?#F+4sjnG;>Bp<7ohgG;}BnrL;M&H@uz6wx1i>K!y(QG-Ea%@7fih@nmBC# zfF2HUH#Bip=)Q;q9O4Z)#FwCnD?rWJj6?hw4)Mom;>OT&;|mUPW(P<*f`x-V)Lv0E zac8Kw3J!4#9O3~u#1nCdm*Nob#UVZqhxi5@;zw|Z-@zgN7EL?=8V-MOi1R@gw!y+P z3aVZfhqy7C_*qZ}XJBB6$06R1LwqI<@zprQ_u~-1fkXTi4)H%Y#QB_1(-q8L3OK}# z(8TXR!@&iIco>@aQ>gk39OC6T#5>W%UqQ{8i9>ufns@^=e)pn@|ACrw9*6h?9O9qQ z#5th*_gI`!!xJVhj6+-%hqx&YabGm?R;a&4NYtvU*b_ab)$8NaD!qi;%>T)iqEnNE}Hm!sQ6wS;x}=Kf5aiq2t6MK zRzASY7eEtFhlalb4sm@P;`TVi!*Ph`;}EaMA>NN94hrXZkVhC880Mjg!_IwJizJR5 z{`+x=U&JB)7>D>*H1X5W_+ocMq#uyIFmXv7;@UXGZPCOpK+X3@6Tb=-kH;Zij6=K+ zhxl9^;u~>@pTQx18;AH?9O8`bsNn|lmkbVZZ8Y)6&~UKDA?}YuJQ0U@F%I!o9OBc_ z#9u(&vl31GEmV9b4)L=%#9!bL|BgeP8@jLolubbC5N59$4slZ);_f)aqj89r;Sg^{ z6aNhjhv_)PS0agn@;mHY$K5!@&*Bijk3;+;nz#lipg{N8c_Pvw$X;EjxG)ZJbsXYO zIK%^Sh^OKZZ@?kmk3)PR4)Lux#4q3wzmFyky+(xLBMxz9=s8B9-~xpkY(7F1hqyWp zaZ4QH-e}^m^A%&!#Dzc(U|?X##Ub8^LwpVn@zprQ_u~-1g+u%$4)NbO#QC8IFoC=S z3Qw57v~Y-9qKU)ui#HDOSTylUkVOm(4EZ?38*zwF#v#5GO}q|j{&qC+W~lga9OAce zh=0Q&&gz4je_`fJ;t)5%A?}PrJQRm`CJyly9O9GF#3w?-VJQyr?MULF^4tfyuk{$3 zxF=NnDh}}{IK)5W5NGm5geS;enE8S@#1(Le8={HtfbM_xL=!&^6^}s^hpDf|A>NKA z4hx?dXyPz)mY|8l)Ne%--vf2eK{Rog`b%iyF!c}6#9`{cqKO}Xn$O?|31?9E4K&X7 zK?0H>*r4Jd9w_`jK-CLE#nIJ^L&ah0VfHFP#nIL4L&ah0VeYYlio?{uhPuZADh^W* zbB{Mv99?}NR2-%r=AIa+IJ){&s5ngh38;SypyKH2E1}{r^%tP(JJ7^o?wkx2M>l5< zR2*i`U#K~&aft82A$}5v_)Q$*FL8+fz#-1>4@oEJ?v%$Nu7@Vh1T7z2afpZF5KqA& zUX4S%8;AHT9O5f+h#$ZqegREf4|=Z0YaHSl&;txX;RdQtr-2v@3=Eb?;-LHmGshcE z+zoo}MjV=W3Dn*?G;w#R_%t-}Qm8o#k;FmsWw7;x>yX4j?t!U4j3y2<|0ND_=0MbR z0#h%ECO#AD9!(tL7HHy2q3S(wh==14Ps1TzhC{p!O}rf%o)eM8LE+W}@g~DOBymu< z!PKus6Q2z=XD<%%Gic(wpz5z9iG%Fzf!g~FNgQM^Og-$JT2L|riSLJ+!xIG2h%PRT zCVmg9UJXecWbZVHb_P=wIp#w=Akls=gYB_+&KkOsM)*IK+435Wk2f{t#-;103S-aftuJAgPbi?GjWR z-95LV;xO}J>R;gy|A|AKB@&!m7|_kpRMOYhY2ahUpiG;x^v325RI zKna_Hf#CxVai4fp{~m*?Ux+4t8!EmTNgTO6e~Tmz%8%Qi>i^&n=S@Jh7p7hrOUW@t!_*%^6Njn4iY5+I z{{l@Mrk*JcHQZq8jd6&3qKPkqhFb&<@pK&GWoY8C{MCv>d>WcKEWa;86Tb>|&t^1n znEHcg;xP4((8M93!oXk$z1I$w&Y{cL7$&2MLzg8mEJYGWF1PO^iG!R7JsyhT0}gSv z42TP0_RfTG8ANf2tKbkf#v$&6Lp%_NcmfXbVl;7BI5a@TVdaLWEyyPf4Ba@yr{fUc z02K%628A2U{6k3M$l?44NgSjeIvl~k4!y4)-8}+OahUlq_3}8x^>Bz=LdDU|cY=ze zn;(iM4!fr^2`Y|mPA(4dN*v;SP;r>OF!OgHi6e*GCnRxDxWUwGLGPc3nFG5IGzEuv zF%Iz_G;!Fy)oXBwe?=3Axkn9pA2`fCFmYofapZP|GY;`!9O4N`;>h7pghRX@Dh`XU zHt0R{-8jUjK*eG1hlS@k9O8G;#9{Zszri8?8;3X-^dJkEy)bj6(8OW!q6!s<`3shR z^`PP~b71P7aEJ%u5RZY1qnn=!6-PI}8ciH_&-i2<;;V6pAI2em8;AI39OB&2`;cMo zgxy0ejwTMfM_U6;9H!nHO&q2^7)>0eJ|0aRroI489Hzb*O&q3vHkvq0{c<#MnED-P z;xP56(ZpfupQ4Gw)Qdsy(M1n89W-&+dPQp-;$Aq!BhkcR`6~m5cqN)RtUPH&6Ng^Y z%rFg29HxE=nm9~7^mse?xHq&KXMj$p!S7*&i9?U=1dD^_k6_}k`CCx9L5EtvQqb*9 zVD-?WrorOSZ3$p;P&o!YcAEiu93WgAdb}9My_T?ZgrL(Muae zfewGb-2+Rvu=oUN1Gyh29s&|TvKJd4xY`;*!uphzCl;%z=$#%is{#!69ygCJyr#Y`h$1KJ0$pNF?>h}ltP?W;N=b?$qL)9P0A$}cA9Cq*RUo>&pJ+S;x^I-0WiEH8z_eT?l-P2ltCJwtt zwFyleb}#A_H1QkIif9R%IP9L#EjYxFpowQg`B$Jc%wMqk7MY;-po_!qLqHcdz@gp; zhj=oYIPCtuDjedAaft82A$}2u_zN83f}q7TNaZB#{x}UB;`TVi6VSwA_sSKaiNo%X z>q8TV-3PZAO&oUb8|>aZSop*4aXX8q9(K>#BQ)`4Q2r+<4KoL3z7{kSg2bUraE)pT z<$%ON`3|N&5{GyunmFwKuSy)^ooM2)d#P5TiNo$=+Ji&<8V>QdXyUMYlvtqWjlui{ zyXQy@O&oSVkp`N$0yG?*(8S^Q_@IefL)E9FiNo%N>BS*FA59#V4-eoFzkoyh0h&1M zevl7n;?B@~0&egk<%ui9?eHIGyi85(lMonEE3~;>haHBZ(uczlkJ{to{j_ zI85#fk~qj5*tzH|(EWli|H97q7C{s5hWZQnzFm;nu>OW74)w-J;>halki8S?Aaf=|{ndmd4l)NESquyelaR!b)z3i^M^?WE zNgP@IHY9Om^~aFJk=4WYC4=GxS^Wbf^&oNBdCniu#9{q0Ht4x2Fmqtyl4#=4>1+la z9OCvk#Qo94Ve9SVaflb8iNpGdO=#k<{^2AX;)~G4VdsTzLKD9MjmSed#4q6xe}pCu zJ3sRik~k>7VCP2uMG^g+m;+-vZ`-*g0Bv(A2}kzoCi4&Zpvr4s5~9ISkD|(rDta zbES0A#9`+$*`tZuK+|gwnmFv7pClaOMQGx%^KE)?h|j?xz6MPkcK*yBH1SW+a6X47 z4m)S&9-27p{FZlU;xP5Fb@ZU{L@s}1q3gjx;-K;erXIGQ9VRXftv`Iw)Wgm*i9-|L z2vuKzCVm2%uBwp4LGFQ_D+0UM7-sJUsQP|1^|13sW+91#+z&gyVilS=>>P$&XyON; z<{v>42e}8fkNZ55ILLgMdf2_jAa^3Ge}Y5(J0x*r^*@osk3Ck~l~`BedMvizXfb<-_)~g2Er99wz=6Di0G^ zhnn*lO;zu8k%h099{`L);fl9JbFc7EOEw)SO&2aaeg>iza>s zsviBmY1qEDxoGNP`_9&)iNp4Pq2D(R+Xr+7O+BofdW}Q;FPb=P{|-OeebBIdH;PE& z$mzilNgNcvsnC4rfh3NsJ_1P`q#m}vCId|zR_;`wiLZpFkA5_9E2w`K;Sk@7CJx(2 ze;kMSO&sE{(Zpf<<^Q6I!}g&IK`$(WrCZp(Y*jRI*uG{9Byr^VBX1;eP`E*x+YDhy z;-GMbi6rwwc?0|WFJZ@Bmls5tZ(W4Jio8dv6OK2GN6EEU|@hA{{|O_ zZfjtG9@hjHcY~^j&5yy%FNcalx2?m~Plbv@w^zc&7eU3L%jDtWo1x;+<)U!$15k13 zvL?9r1*kY|{to7zyHN20sJ~(2&!OU_XyRX>;;?<3F!hYk#8Qu@UH~fIf+ns26^G3S z!pzZuiua+Zw}FaJMicjjiqAk34}*%s=HFoEr$WUSp{a+>S1m^qZ-%O0gC;%+Dh``( zgqgnpD!vU({YI$xZZz=&Q1Jt3;%A`Zuz6CL`B$Lgr_j{jfr_6;6MqgBhoyIzIk0ti zH__Dpf~voVCe93<2YQSq&J7iRfhH~r6@QB+E(aBd9={GxpIT7y?`Z06pyGef#GRnx zjL`H5^OqM?9JU?-CLRbC=SEW>3l$eY6Nl|j6h#xSgsO+lFT>1lf{M$dshS6PI7HHx(pz5K^@8IG504nZ;rv3#~+#OB)1614x zO&m5a7>Fj$0<8qX(8Rf+;?Zd0u=zsRdJUL=HK6KK(bQW)#k0`F9iig+XyU$5@e(xg zXs9^sJSUjF8BlT9IZQC|0;o8wJqr`Bf{J&bncoN%??n@b%|}i`6Q2cDKOIec1ypVS*ZGxXzF3}qvz1XjiBl;qlr5}#c!aAyFExDHzT95$ZZ3T*^~%mJx~^?xU$-G4m++V9v1T__GxkKEoyzV8xhB-maU0a6dW z3Ii+zTUQ3M6WRUH>rlYS4kQOw%)r0^Ye#{^Kp3_!4_5zz#6TE!{y;X!LeM=n3=9m= zD|f&~H6V$D)WgSMG!gz#wtq9Nz^Mzttes8OGzwAWY9}0 zE@l7==*36*c?Xx6CYMweq~n z%gM}6&8cM2OHWRYPpwE!EhvdENleN~MOIZ@l2}wyS^yQw%*!l^Pb?}*tOUCTL`1Fd3_=41;;{3eCoXnES_%Z_qz2yAd+|;}h2EDxel2ko+zfj%clEma}C_g=~ zRIi{YzaX`!q!Q}l)QtGFqQu-(2EFv6{8Cu23z~??pe`~pFhGYwP;|rc2`H_DBtX}q zg0AR=l>smsmwxE6uMEigL49$UJ{XNlKlHdQ22h%Z*$*loVESM*sC)utWoU5=QVPb< z?V}8V(D4?qAOiz@{Va?R$|E4NVE%=PJN$>RI-ui>Ape8Z!TbZehZr>O0J0yN?I4;M z7#KF9*$a~ZsfDpYH0ZiMkeRsjqpL^fgTe$P#s z1_lO@IC?zKfZ7jJ4>bm!A7SDv86bW_xBmpxeponx`~h-1Odm{q7Xt&>OlGtITtL8n zn0r9$wL#$zHUuWfz`y|0?+x9T1(Sl=598m#;r<6u_fN2eI1J=|P?Cn}hq)g#zJSgC z572=qSi2HtA51@t4_fezO}_$kK=F|zTqT%+t{-&G54QL(@Pou?LJ?RSIQ~IN5~d&K ze$e;=Hv2iC2g$+4M;_@bxCS=+Jq|+bUjW^J0E#~l6Q&>J7La~BM#!E4^z_339f*?wWe$)+D2C~Wav3Zc zv8VqRw;}dNfC>!;NIsTSz`2I2LL3=E(p zf@scXxB=CV?k<@7L3%;>IMjZ0{T#1AvJ4CskYIptkis7(a0o~GiGYUR38;fX;Rk9z z!R&{HA4nSAZjjjypn{2kfnfzFh{wPHx^^9#evmYp6Tuo@d;?Pqp)d;}Tu^ZZWkD!V z+Yg(5g_jUf*tiHpH8iimI1CI78L5c{dinYaFkk>nwaB9MB@fkB@^53CmCe^3~L`rV+c3Sxu&1nLHZ*q|^2 zwb4N4ga&)`%7Pdk&2KpPw}D40S`L&5cr+j3@aVh|9eX&9U*3g*!2@zRF-&pid+^|N z>w%JM`xzJ%7{EM_Zt#U_Y5eaGcy!+L=mk$#@k2(RP$`d2utgrn!4%kf1oId~5Mm_M zB7}1$q^0Tc%Y&LI3=I78436QBVUD4WA)cLILW4b;-$+2Tbq6?jbVpctbYAn&yytQ7 zAG3$$W&Re>220P*V}>VRE5VHLv3$VavYml}!K3*gqet^$4iC$Z{LS+i7#MuIwLQCC z1w1W}6yNgEe6SysIz2j%g3b5r4i)g|E#~m-JmT5y%Hep7MTNnmm*s+IcbJ1`XO4=1 zXQzt_hlk~-5`GWOPad83p}NW(JbK-Jcy_uucv`x7@VDFs+0&W!!?Ux@!L!>HDmczI8KYu^y>TuuIC;Y9THlJr_ zo`PqmpN3~=oWV<{|NsB{cGp>WbRP8B2eI)#zmMimkIqvND?jnKfG)o9vHXE*C8+iX zTR8zV{BhgxtxsnPFN05S3NMF8>&bdC-`4-7`JSD57QUTn4xXKH9xo65`~Tmk^B>4$ zXmauFF7xow{O8m89~|(nFL-vB8Te>E^XYu<(dnbY0T%V>_EF(@>HZ(2`57oAI^QEC zK^njcd^DfEJ^?lF^*WCoFt2!69`fLKzu?g;1Ky_Q(Rm-C8LZKx^QZ^o;g@#*|NqCQ z3*r=r+WG(f|M%Ga17bz}>(xl?s~)}J%mr3H0g(kj*%mCuzs*4cluHhy=8sU1&ZnS! z0rhg{VX)$s1Epdf-L4ECoz4Ot-LXGT9){%yLr93BN@BAQW)2_3QkZ@a4_wVmfRr1K z;hvq}L0QzZ^Q>b?s7L2jkZUYFI%`xEz(%<6Z%dGHZF$1qx)GcJ|MEA1vZIgYU(fDX z29M^aKRkO`^gX+CIXpUDR0KRM@A9{RItZ>UPfCqEx|uz@#X)(%r@Mf|r`toom+_;g z<+XB7AInqxO`!IwhvnB2FOSa8uP=kkF`sT@unuPq-)=t+-|jF0U&d2DmX~}wLsU45 z`8+Kz`gHoJNbt9T610cq(Got7&cm-yrosK!?V=*!X?eUv6y!XRvpk!RbAVjcngxpK z<|7tJnKf-fg9QVBYsLTn|2?}yIgT+fg7T^)q)Y%=1c?^U?otjPP-^sOe#ha_U8ADl z)A`b;^OR?2DThzzw-?(%>7w)AON0Oa|3mY?V}l(7e`_>2@qXJ6YOR2RM*|$BAgesO zT~st2kFha=%$4xz4gnQMhf35uG!J=n9`oqD5Av`CvJ+f6K&m7_>Nz}`Um&^Tl4qwY zhfn9Z7y4j#+<5uqAKV@LK~*By)|U?d{{Noyl2*Kwe7tNAdr*tEP?;_K6`?ATzV!ch9cwdHMTut&G6gNL=NM@fQDrvj)b^yqYT z@aPWJ0L8QiTB+*MU8(^Nx6V=x56gR{n?YqJavVV7z4O_AP`v_nD$M-S1s>hL7NGFh z56N@?`8_nxd31h)lu*C;Tdsj>2FnwuB^0O`>(P3tG}+bgzpLRl-%b^C-`*5+4v*Gv z_3|FACrcfDI%_R_I#V5dI!irXI{*LwACZ1KKlyb2_vk$5(aEC%bxf&;M>mfO*yi(K zq1XF8x=TGgG|#<$i&1p=^qPPR9G}kb9-SpB97yJXc-=fIo}I@%8IK{mioY-I|NsB5 zn?3iz%a#K;$`i-%{h-znG}AhUfGbrEk8U>$k8X)$%#2|7d2|s$Vo8B7ce4Yd{w{4GI@3=I7HN}XY~qDSX(u%W)) zUet8C; z&UgDkEjzGIusJ@kI<5H#2gsVOzTG-1jt#X83?-L9-eY+E6qKK!sz3!dczv=*w}XL) zH7Ln5@V86=XWaMyFYxdC@UrSemGK@Vj2{V7$QJ1X@?&(RzTtwT^*-!PW49;YpuP9ZjF!R1S~U zxAm%?jAuNWYg9NGO05ua&7uOXHeafMixdY2u+bi!=RG=K`GCrMa5(sY3SE!RgPx2> zJi1L(KqVvxNSg#$iHGJtuqsfkD*;yedOngjEH8NQyC3rDRRKAV!Kd>%L~-Xqzg`xF zmr?)!Lu)*w`qgs}JfEBgM+^}Jw7v@s_UQZ!s+2vt!yLfbrt_kQ=0T6fpA4ov4CNjk zmWN7AL6u~5EZ9(R6hmCp9c=Mh(4)KJ2e|a@bawD){a?eRI^TiSdbGYR6@n=)z43Yjq<#k5?*UCbukTL) zwHF*ieITuU#}H5v4$ary;BLY$P=~^!*A&zS_3S(X%fvpN&tOb&y71|I2g}#HKtp7p z<`F~_*fE~nB`N~AGu+LWVDRZI1zYc9`INuK57fB8bi!kh6H4!b+7=Lt529Mk-y#Zb`eRs*q|pa#qXRR- zMo-H({4IAt4S6DL1TADic=aiN%i@2a&IX2!kkI1swR}_h@MS%y*qZ=yHpKQ27KH6! z|Hct%doK%0K=Ze#{sT4da({UCx`N}~qxEeG7pQ>dZvj^toku|~xcl<&-~ay+-7nA1 z<7hpw?`&9lV87X+J+No23=D=RT@Anack0-A_vY9^dSIaH5!?g22KJA!Z|4_K0`lne z7I?YsFT9-wss|y-%$|jT!Lt*RCO}zG>+k>nKHb?IKHbVMbs zFF>k*6Z|cp^#DGWPj^CliYGi6Pw+R1gWY+6zZJBr-SDle;eX#w6LH_(9B~d%Z>~Q9 zluBBk@V7dH)0wqz=O0i?_2|qNcBnfPX*Z#oc#itY0^#nKO5dG3(0Z?7WfxW{j0ZPa4ArO4w zwH%aCE#IJq*9}%^c*TI+ebUtsHN5Hz!C?hDV#B8sC9IAWv3-y^HIUF@c`1{piN$DuKhCqoG zCyod3&IQAqHB6gfWcd3ije9 z{#MWuWmk}m-@H*uv5gGSObS}7>eFcq%Ar1>q9F=o9VDt>zK5ki>}jchthBTSrVG2F z|3EEgsQt2_@*B#wf+e?KKAqpeX&ICekdw9lC*#qVyFh_T ztR*Y|kmG44vUIHn>DmkLLR|NNvtOozk`sd4hsp(wMItFq1*Hyz;(vet|Mx_2-=XTQ zMCDG0_NN@fLBsK&0XS%1-Xg`Ln?)5gbpjqRGCaVq2^v;A?xF&k%3|=a{8#Mg(fQl6 z^NZn0P`|QU+u_?$_ELU$qo%|M)Nb`?e$C-&d8g<;s52(u(fYrH+XFPXdk&lqKpjVo z6c25PMf|Ox9eN(9Lu1f(I7p=gxN%~6qD099GV%>_nS@7gjfw!&G#?d(*S+BWjZb%t zihyV5Iiyk+G|u}0-bes#67aMk6Ko2SDk!3^XbTkI&b4kVj-7{_Z>s?js^~KPH6k0u9fAJDHIF z6r``I3+j)-iU}0W!h2yOaTZeh7F%05VJE(fQu9`6!2HcNrue!9j@Z zW5}SmXLlKDpA?}4>>5xbegVkc5Kqt1fDCTkE=g&qwqPhx<=6$f>;kRqfcgNI`aHW`89-fc4WG{Up4ufU3Lf17FF>ka$ z1r57_=EEI936sC2mVtr65hZoPot&fM0CKX0r{&!eS)}ksbNAiSH?Z-t!{G5cNbT?0 z&4wPI{4Jnya-Yuc;5dDG9n@~0fE*Q=8bHIeKF~byG7{83hs7pnD=IWxkc|K(MXzpn zQsi$r%)r0^PL64y6yQ!7F2;j)AY*%P~Q@t`jVOO^xqGTdr-Oo&FzB6pdncoJi6?l;bG~l zz~52;nw-Q;?eIJZn&9d#)&Mnxw2KvB3C9CVS_kJM@SwGC_Zk*RT7S#m0$M-_O*l(n z3C9OMfCw43_ULwoq+t(BX9xZkN06I3QIasE$S8JzxC5SmvAF~6J+M1a2G2noXF%z< zBoHO(B9}4X=m4ijNSOzUP|WmY4;s>er7t5;`a%vYboC`u;pK5RV*U$U;(~K6G(934 z0ZKzY-AlklBd7-fPLI%`xfIyY9K?mNG>IC3t@}ak7)atoH`oJ_&`a{biPI63I6XSw zzkCf#*RbfpI>MPJ z9Gjmr^0%rpF)(!AXnw%d>AHr$^(P|(L-S*n&e#?Ft!F{W4YGj4r}I6e(bIVkY|Adt zDm!qmI(GpyroiH0A?TQJ=RK$vNLmJ!e*z$LKnoQy^gxUSHSrFo^`Khe7XxU1r`#DaB`&>gx4w6FoRd9mAd1!&p=Y=3v{22g93 z$D_OS0Agmr^#oFD7IZFyNAnSnXjtVAUL*rqlH$=>3$wL$1~fylqs+yCDg{W5aO>ay z|Av=b4c{7`dE_ZkIIRDg!hE5OBXi6^+uhUINoit_1B z*6`?#R`9gEQz8xTPoUM;cS_$tW==qnbr^5`TQUz;_r9J2_7ZaY6E>d>mhk8faPaBQ z0Ie_b(R>GLL3vtUlw}#-`)?JFZAd<4KZ8uHE2dtz_YiM!=v*kDBExxa|Nxyf~+s{=!_Nc=yZjz zE`p^3&u;Y9MW8VQkIp>Q)kOi&DRso^q6e_{jAQ)a39g1uUcca%X8_v{ooPq00exN3 z2H$SbsvnefMejkYX<+M$K)Wn`EMK5bp;v>-El~EeVq{=|tSd@EURMNa#(>&xt#iOZ z3bFyZuE+yCxqyFN5oiG}#=0WVZY$78bn8U$x*}J@x1OCjybPYbImio(d^__jJUjCs z3yY3}$A&-)i;#i<+rpxE;6fEKfD2k!N8Z9BPzg-p!lHSg zoJ_>RqO=Jwf8YQAA8EZ0cs>xm#_kWO7nXsoV)KBnEaGnk?E~}aE*9|Yd<*U}K-!1S z8Xn!nu(BVtwu^yZ)3pJ#SV8kUf6Eb27C|cefABY51TT(*56dZl%J6Py4V04qJf!5W zod7ZmRPsxLOa7^#6*rLF)D32X^fF%b>3j$7(?9p<^zHEI^=*JC>AZ(1SrE+b+6Guf zFac{tP-@}Pd?W*@5&)IohL;RazKjRAF2LnAQhEClv_1xGBba~{l}NpN(0m>=tU>e0 zzdf4YL?8vWi;4%d83F6ZJ9ZvvIZ&GI(Rv%!A9m&NV7%dB3tE%O-wxU+>d|=*){X)t zoYn&+KA@#j>Y#Ot9^D}-9w{E$BH-~L{#MYz;U3LLB9ICMkIrM@1tDN3zdkj=qw^kk zJ2HgdHUV68fjJ)Cp$wpbN$`3|HUZQs{v%arB9~; zbY+hQ$UXd?-EJH&vq60X$T&~uxBZ}j39!+xA0hR}Ak)yGeN)hC5UC3Ssy;lr*GPb> z5AceMRg92jCnfSIEoW$_&+x#@pWv$1fdLjqpvF41+J>*6C^-&q2k-Uh_64t^gfD6I z)I1N$;^5Nm6MqYMqziq)5GSOxE6p*y4W69x?{xuBPSs0-Rtx$1bml7fbh>JIbjBLI zd=GXIgGc8%pH9%E2y~bUu~^6ev{(o{-UL}O4G4a)N9S*k zZhMH%?rIBYmM!)`WZ7y3kf4}HcdLb8MqvMeEgjqLtI@H zoIOJQyn_{#8T|YeprW4se!*M}Ty8IY^K)`ilR*xH$fV|_pa?54=<4b! zID*0_u_QG`0qm1v1zlZTE(X`4qWmH&1#o!fmzF5xrzzy7=H?ewGBE4|4OfCv2Zu)| zG@XK0Sizcb9-T5O9-TQV9FTQAJ}MlbMBRF_^vvr!AYB5W^*{<9n*Tsi$O?&Nc#o}i z1GJHjDLDb0cs+V!7eMs%hBhG5uV?2Gh$vFQ-(9=Fqt|tVhvo4SUXO0q4e*5P(Jcx} zZ64j=B`@%b0;In4Fm^3)MKG6k9)A7W15}@Mmx8JiOy{Cnf+&k>RN$Gagby`C!4*L* z`Tw8MT!EE=!G?7y8$&MZdNzhq)>Ui_9n7q=*%)>+vuV0G-?5@afd|X#G}Fpz%CM{%tHO9j*ee??Ki_dGuC53NUE1o58d5D7dkA%ct`h*mR%n zT!z;hkO%KU=><7UK%EWRznz(wlUbFTqN7lhnwX+cl98&AlAm0x$N(;DtQ4FR^FSU1 zmqH2#PI?M{`3gyuC8@;1wkxZ{EG(k({P_c+#{plZwxAOmcKM88|_~kx{i{ z!2%se!wHKUSX9$p8JUyLB{}glEc!IJc-87%RZNSn|E}M6f9~^{>ptvz9>NzJ8*6)E zX?CDg_tgj6n;vf6Aog(kq+Yqp@!t9e&+Jn+U8_=M7~fZII>YnDhpXDw5)D=<`41cy z8~%CU_MhX&Zaw=2oLe&O8qc-;ujyR&{gs82vnv0FxV^_F`d+rVYN~3X-z{^8@5g@T z|NMau&mTOfSjGFV-owPFz~}RtiJY%Q+8w96R#$0GOJ_Y%VWjZKnzL5Pt}$BgxcV38 z?)uV0Iu5rd|Gl{+bjsX+{k2a7U(9!TWg~DH5PD%b*b>#D&6W8_sSyY%tA5Z!AL|UR=aBp0|o_C%9`Swm&wN_2kaN~># z>&jJ%+NyhZPg$4AFSJdOZ#`$l%3X1nODY9_-P!qW-K4!<{U?^SJXt^Ef|PHujWx%W zJt^~#lqhb9I&PG4%}08loNn%{Les-fTT4P+twLFEyCo(?naUkFyrx5usp1IVfz$}b zkWv-_k;s+PTDcY09SA9Y)|_!K|DDoj$ItCIGtLU9elFp+8p<1#m~Hq z=9_Txh>yz=KkONDsE_wYYs}_nEoRERD)%-kqcQS-a1gpS+V?=lm@0 za*fQ{+O$lgc%$eEKQ~$So%#FB$%uc}?GrXR^AtaK{Is3ves+m!hMe)~$(46)__Gh=raBu=ZCtm7J~ zl$QVWkZOdIxc*6@ofVqXIv!m~6kj>{gIG_E=>@syC9^A;WLC1=nJI8!Vy2R1mD=J! zL$}LWhwqn494T$`7QA!2*Uh?N7sm~!Ujjw^Kl-L{^m@4d3jE*X^^9Q?!$si^F=Y|e z1?4TTqco3CT-dUQ<+`wu*7{o?IGXM^zn(7i&ob;#GRHo~>n|c0=R3b##Nw~~BlklB zE2F;XYmUZZxeb=Q4Eb-b9B!WJJ!c;Sujq#C|I9*h4j)V!o_S@4tgv-%_L`V_a+7@> zABS|3>$5YDeu&NU_+Y7_c=j>V{T)iOlkE>YIVPGpgWdL>a^p6W-3MzfT)ZrG;q=Bo z`i&XIlhO*Wc}%+07TbG$%dC|5=QLJ$F}#vbHrZd{)UkX^a_iPeh0cWkjLKW5?6#16 zeAoWmqoT%t&c`w|%Wr?+QTJIKc1oi!*>0`lpV{h1Skq<1UNZVQ%|G0f;>c~$Vi$jO z<)SQw(-tq;KX^8Tys~fMeo{F*#84@7x9=+@PZ6244%b`x&+luf{7p)auMU%#{K~Q3 z&+gR87aNW4Nxq$2cJHlt)s9W+Hya+7XKJp$wJGM&nztX<^31#?BQ{HH`oz?-V(eb6dTVBJ+n6@%(Q=U}7?`^JY5z`+Bx1#mvBa^34ltywZ|C+syPm!+$a-tIj#i__NeZ-7^*ljrDPe}opDc>JTB8(x<QoU2S(T%^ProQW;@B_#@W0U~zr-CTjmw3;X5>wrvBLA2 zmc}c&7l#jboKpQc|KMZuDYedOnpvufod@_;B0Byt9%AOGJJx+{`GY{l2T^`p*Ee*U zY++royP-1QeWuXXyXU4DHuz7~T48wCbx!kB|1e7tcSDtqM}Q)2_nx<5jaz-HZoC z3{Nc*YNMM@EIG6G$WOrq=MKD_{DPy^y}aa*X@S8ziD?b4$7~J@t@Sx|$5Sd`k}c!( zsVg3pPkCpV5K*sN+}~1u@V{zj(ZlJv54S(~6emz~qOHF1G%x4p6Ft5avPM%2-x=CD zC~Y@5Q{Js^89H~C3)MXrwnWPn(l9YSj!;G z)nvcvVL9V33yyz5WeeVz&pDxPZJZdw6s>3c(E5>5t7x+~>%ph4_couG(EXh5naTB^ z&yVf;r{!x?Ibz&S3Y@ez?z;ISW`~WG$YQ}ghYB{$o_!*5_rp!`lRgW)dumZF{Kwu) z>}tQ#Va`gOL!nn5a5`%w2wq~;QR1|}^-=fa8=iHnEoE{O)3VmQIRCY<%51rP_m}F1 zs`>6`m8M4CmivA)`9PHF%=5RFsBvZT3&e4UF25A5@x|Mr_iNkoc9&&)l_FSLPI)=L z60%si*(r;u#rkkY_=~$DzbqEm2{o=ews^nogUzJ}?my(6tl2DbDcfO(hNp>A!6kv# zFUA6SZQd6-T17k>rRE5!?cn6nWal^=bcn?~Qt>PEp$$_E4(bNIx|E}!Q_8aZ*rL*6!@yFs~6^xN!BCuUvm!7tHIBxOtZAvv9&+3BygdMVDFoUjDSywd;*uYb0xg?xj4* zn|rxx83K;CUDAD4*SeD-Li@6k>$i?WcX-!K7F4cwO045r^Ll&V8*Q$;ubbDM7uVdh ze)V7Z4NZ9L=BXDisGM}h@tJ!H zpV|6}mD^`-U^-iUW>E^Cq4Y${D|@=nOng>iP>3K3Q{Mj_)&_&z?rm@zQ39NRo&9s5yL*)HSVBLf!SNf3BPmFO?sa_dVl-T zQl?cq`ux0;l)Vo~OGe2TM7G`u-4r;j{X}Tm3m1p^7d=jG_Hq)nY$=?nuPApcxJT{8 zosTx&2biAsIqQf8FR=BW{QHa8ntKOxUVmFKVf*Br=C`Ak^?#M~$l*7hopxf`R*m2Br(~^e`J2S`D>`afNDcqi z3zs&RXS%L=;CkX8&-^&X&nCzCb!#@B+dX{(|G~#bZfi7`J>2A@{?u<%d2Q0kJx&S2 zs#cPBDj&X|wZrShMtV&_ZBAY^=T>l`znvF+%F`mIsHL> zq?VTZitg*t;dUB5HGLTcHhqs>8BZ5Iy2|-I;NfGH<(voBe&T#9k_sSy4#taiSI!!y?zpT+l zkU#1r`yns&lW9f0{T{u$8!Bw3l|ef;AY^Uzn^ixBkH2QRwsyhd zS0{sluf{(A^3Y+fl-Kj}`EkwttZxhxbcA)*vL>FqVw=l$-!|wUbLH#TXVW|P@jcjm z?njYRWOo7Uffr6%jqc7DrzQt}W?bteu}bLiHnFXo7k;@cShebR^q-Fh=4$^m+8pwV ztNWM91v9T#9M-PYI)@S&&U-WQwXB-;SM0TrL0##wfJE7i5uUB4YZDSp4W>>#{$Nc` z!WB^+yE}pp&OT___~7g=#zcoich7<#%T^On4t~+F&j*#R26&ujNZhP)vwY^gXw#DlJ<6_(z%Zw$w1r4X<2X-ah$Z=e#ZM z8si4*B{j-1J3q^rw*2sLIOd(%H_x!;1CxW?pyx0oSXpyhe^hpi2{e22P=Wup14Id5b;R#>v`XSwlIVb7+fOE zzvs0$XLQhhcgBk!ry}3#gmEX7lx@&)GVeBEIS}YNH`2zX^H9tIIo_^A%+uaTeYh{@ z_mio+K89u74u2_JT|5A%zJq*OXpf_0PsFY{}Uy|D^p&e&wJ9P*>@LDuwy&4{ox~%NJUri z_Dsi*9LloG?U!8G+<0rn4l$dm$TLg1Hj8g~rzfYj@wLb$9|avfxm$ZIirWv}VOewc zsI2BQ)4%C{N$VLaHdf52DR#XbRmXPd?4!g@OBOkCO=;+??=*PqS=>5>xrI+PZ)W~o z(O&@z{PYAh@3(23Q9V$#%VkE*>_rp4F+Q9sH1U&ecw!yn8g11>SEiURep`69W%eN_ zRo2dB^AB1XC+Af0E-)*~~H)$9`>AK$^$0zK|3?#{ap? zeG1OmEx53rVd_+_h0$k3xs3HUoU)#I@aM+Rll{*e-m1OK2+ltwr|V#O(yT`uhSksI>Gp9WCDHGjOr~mZL3#sF`CVraQ7FqxD z!V>MH*PIucGiCkf_%cDIH=Jd8!-Y!*O$S+b1Wdfi_UEx+ip%pw7wp+y^%{J6u&Bm! zqNn!a%%!JVQWnknQ_QtjF`&9_A^Y-2laz|}KRkDxu_um!GoY!@x;(Vdq*>lX!Y;@a>3nBO7%hTGxK#y4xb=6dhZQhoH$ZEMEP=&P=Jg??UFn95EU zP2BbQ{G&HB@5Ub3wSLZw`!`mzp0asow0v``!|ADB$8VXwGxs}?aKlgGjqooW8?}4K z?lZmFt6l$aSbY0*K+mo77uK9({;jMtz_8H4Xo&_ZMu9MK*Brf_)D8V+~FeoKo>rC^3 zs@K;h`j*`OBHyqov`ggXAueP74PGEt*PKd~hR5<7th~|+Ui4Z{{$|U=e67VRYm?5U z&s>>;0@qqr1;1<;`K7p^PNq>#Xr{U7L1_h%*vPY7-Cy=PX|c4tIkoVXXjM&d~Hdx#G*M^WIF!2$e8C zTrBY7b;SB}qFb%sT?uAa7HR!zytC@fkyY0oySs(YU8lF}*d^1M>snt#O<(uDe8HXc zI~R67eB`EMK51uQhjdI1ckJxR)4T7kEmZv?H>d3Lv$HGtKe{iU_g!I=m&p7cTa85$ zYKsJ~emQjdQ`W3)^Y+V6tC^p->D+_58FzwTemwYn!O!#`yQd|E6+NkQN@|=Lbk^y| zq_TXk8$3lhccoi{i1bytry(Os8P{rPBUMwx;6gqsuh{|o-)_gQ5p`;7S$El=$6 ze3oGRR#V$Q?fQnSn3Yx`OTFw{b)}wdN-JF*`!Ks;-J0G9d!6204?UUM7~wl%r0sP^p1 z(%#K?E~>otJ!5fcuEkWPp!X~lF)aU{2krXEDOmT&YW8RK2Zg3i!Si>Vd?v!UC#Uy< zi~7H$Vkzc(>)bM;gxhb-+07`gZ5bYS{m|E}Jtt~R*B(!M<0-z^>a)y=T!))%GyFr^ zZ}{2rx|)A{b#H=xvr^~FlNTdi{HiYa8RVfk*Frk+MoP_s7wcXsoXp6SyW(u?{j##v zaJG4HM&{N`>xwvm+lOptv2R$m{mtd_En#U2wr5}P#HQ#gyvW!%!LKFbfgz*dS+`pP zMS@%jf=U@1Cy2Gwu*yjb{ygP2OW>1Xg^c@?Wa*W@Cn`VukeK+{ET~uD&ewY8iQybC z?JMSlC1@-DNJ^d;C3YzB-@f!iHs2RSU0c`P(ptjZ@!sd#iqzEbx4*B7J6t@f@2DS^ zRhXJRQ}pB6u1#Cd$`}=&@%r&B>gKLz6SihtGk&kSdEd^CGi=Y)jHG9&pUg?A^GHkn zY;H7r#>v+ga+2+Qe%+dN^qS^-W1Y2cYvw=XI`Tv6Pwd>rrxo)LvMgJ_t@Xv->zU`i zOI9_rpJv+A_hi9a{d?&zc&7*kE!aMxXwUfuxy=vl?hMwjj!`>VHUA;=hrKESwLFJj{pJxi@LX_d?&Ae3-W!WBt=Q7wd_R4G zPbNo&^h%{CwQX@iuXGE~Zr-zPZ+~`*Y^uEYB$?kkmNouS`|&zB;19!%H?=VPh-JJX3K$#ccF^m9MH6zOEsvpj-nnrgXB z(ng8Qdu#rH^suMAV@Aw(bDrjt3(uYyV%XgmlWJ|uQcDCRC@1-O8Hr~M!lGdr%$i zc-e#N($naL$NbG|Ls+c#?==uwxzUbe$xhyl=iOS&Y$O?-!W!RKHNKdyaOU!NuG7wM z`5g5E=CGV=`kk!VU>5pHkL-JgJyj_^fu$ zPpb`f{D*zEM<1-wej@E)EN#6a{Ou3h)Qw!siWf5pzN`m#HeeOFVx zz2fSyNi5mR&#^G1dpS*6t9V(-hVy}zq}6+0`2|r9u^00i{Jbi2qHILu&MF3$E&r;y zp{~ei@f#NZz!{vn3tvQA&A6gn^em_~QZzz$uFr1Mh`qa<_H(aLmM!U?B9=Q@j_r`q za=)ZcIhvEL5VLY#vf{}5=PYl;zI=7K zaqCo|?Bi;qNaZh=8}{DT3bMQ}sazcOpEV+It+L_oqbJsR>2s`Eb1lpI>3PdG#pD@J zwr0JZku7Kyx2RlED*yV2n>Gx!LO;$=x_Dsb!qBtkw>zU)fBd?Zr4}`3dd@k)1NRFG zEGGK*%zL&lmg&&?NhPWo-?ns47FxJXJmay#QtNko84D-fm%U-m@_qKqgzq7li|zUs zaK~HKZ1ad`jBMX1TWo*vnA7LEeg{6A@AxYk_4mQIaN$V?r=K{5&EIyeb&c(UhYZKI zw#cZiXb9u-E#~E2psh4;HK+ zX8U#Rno!EQU_PtNt_iL)CoydNv|U)sNo)+4{|!c9<=0-n+w0TK;tBQPYwWM@>sC#I741Sgi6V z*4V&J=3#gC)`QzuI((@#J0pJm9ZSZ77J1i**cfU3g{mbXi=N;8_U+NFwv(qGMZNEv zb&bb(w`5R-Kuuw;{R@k(s-m|Cem=To{owaZhcC}_X6Ubrec$kX15;f7;hI8S*#$~M z_mU3R6t3lR=#@1HPu$OYD{#TJ+Y6GOzOD6`&VG6Ex;<|h?#XjO`W=3{=nx|JjXVEN-I0G*iP5OKKb#rQ_-0R zR(aTzJYCD0a97qMe9@Xcyv!9%OXh5E-Vk>08S}T6BinE6*!pQ3=Z5LBpR#P$PTl_5 z;m4JUe5NYdPv2Sz^qdpZ%y^nx$bNR`r#9b3DigHJ`6gFoKV2)CQ0^h4dT8w)UiM=y z%f&2RE_6vvTk-5*UC6pUZ(roB-=moG`N^r<&uiBnHSteB9TXYClX&oy>$Hi7Hp%PQ z8mzc5b-RPO?xj=FPxWrauiKOONme_**C9iS%d99)Z_V|l@Ov8yD<-^-sC53e(1Xh< z{GPyXGp4&6KP@Y5y|`PO&!}UCc7Ejn^I(Nv)4y3A(bnPLYRz(W>UOaQ@AOzNEc1%g z&X@aAuDAaz!~CUwJM){HYz|!7*j6#Ej5n^%n!#@Q(hs86l{G)#IydZ__93*IPixx! zE!GRR?{}VhJ^x1U(Wtu9EKa@FA-Wac&t9{ei&nN zcgo!t+MkZ@{8Ppwk$`WsKJ2A6Bk)+%aWrC*KDI{k2NSXMOlv^bh-i zb!-pSMgN{GcY5`{@5iy7oz0=%&+-CtVk=`UsrPzs*o{(lcP% zeS<6J5B@JS4oLmU>%6l|@oUKoNDUOHAoA`dxCY8*3R}M%Tm$W9zNYT+uSuz1KH+lH zleJIHcS%RH-3WI4bnTP09M`#TOl2FEZ`SI3x_$e>|H6u^!-O{eDch@l?hmWt$!iMJ z?lUoniLf01Bwgxyl_5*(>Bh{D0Tm`|pPDCqW4)%KZhX@3gGj5Tc*IUWwXa=sc7`Or zW4V^8emRdfZ2h_m_Uy0t`F0im?DhD#SCPBQx3F7)#8Xc<)>#EUtd!XvWz~Re?*3P%}l|W*FH%fEoI$c_BHT! z=7~?zRr@X-H+&d0?f!+&#V)~bCkdU-H$Py%YkdcsAHVGBe37e74bxw(PFs}xv)6)` z;r)XL1&fk@<_ZYBo4RDR<7V~jpSf}Z)2uze9nrjJ)!=K-(o_Q>C7UK^_Sy<7ce&cAK*_ZH8plGs>mCFak`zq@#s$NmL#FXtXyZ2l)! zd*hJ{%fvS>U0t;I)w!3M4d;ZI`sQBNI39NJsb$Ojjfwk;rAjydEwI!|EPZZr=>6gU z!JUuJW$qJc-`lm<<7WMZhHAyXdb9rOM6u4iEFb+)tK}E}i{+}~TNZK&P12ru_;B*cw7Pb_uo^@k>cj#GbvlW;8zw+xF#!Q^?WP*jfBUAhvA)#zpp+M$C-U-1%Ld6EY zTYAK29Nfen@jbbbRp(&+{sNs8&e&y9-{)I6ZgtWyKWXdT5|GDrw0WE7wArq#f$|$1 zKV0umUSg50CHuy;YeHVW#ZrkM+m5djHvF(xVD=&VD8{WbryWUIuwT0|Dd>trIpa4w zwqNU{GS28c&1KniJ=sD~hIHnxa%U>F~cKHs!si)Gfm{@jm== zZolr{D2u(5FN8%3n=QJ)`988{^PA}M&bmpzuc_b9U#kDsFwW@0tlLxdJ!2zfb_73s zzpC$d!|uoXinDS(i!0o_s@I%misQ6Azh_OPuhq&_(OccVOO`a>ap8N-Hl4BQjJa5F zh3Dx`W5xwD&wV(Q)BY`C&B_GrEt7s9I?o%jgR^P%B7Bk z%C}X`Cb`=8mwq!oxp}?8G0uulv*h*GeUv_$`^3!ecMDVc(us~M?CM2-1zfpfyVzwV zpY)O`S+QTli9W=?&d3hk2jlHbQbPXVPpH> zJRxbe>qMq6c{Vq=IAv1~2DX-2f7bESc%t;_%R#TW6HBvqRxPcmUAA5JvWoSxcIV`- z#v6vbw^Dt%w8EcoUHEa&Ci^VUw>nrw;C{lzi|u-Irr+(akbih4b%oJCP5nm~R~(w}UVA1vzGj6~ z`#qzSd24e!FIQxEtowXjIqdWiU#V4hkG&R*$yzeyR#|k=o*ikocGhODxZ05y>2c7u zY+>TTsmi$#Gfp`sc}A+3iLz~BJG^Ga#o1&B!T z-&MtyuK)f0V%S};ho|{{9bEqN?mt{CY`^yK(%<3B{go823E6j=IBt7fxL8MR`Sv6F zO1{%xB&mB<&f7FiOTf=9-sQ&EB|B11sLecNE&Ihn-9oHrg20y@R$ihZ&J|PdGcZhH z4_bb_mHXkcCr?@)e(2||oT>74vI-YZ@u8qC9%;8zo~YPq7Uw#AwfOLLf%$ShMXg=e zd&-Vg%sjK{u@mQYlm2@4%%xMF{JDDR?_wU49R;>eAAhvCW?`_H>5k2_=V_s*d)Z^m zZ@<{SrRvuccjo(!`BrY5<3g72dic`6-0JTI@%=NM#n+lSGJoz`QT+X`+^QW{K0QCTaiiwCcaKeL8czH+k6PNL`&eo6UB;@agZIC3@y*xe(Dvv4 zu=rqkm%|s|Pn^Ly%T_l%C2?Btf-pr*SlbM6M|dKO%&P<`|H!QaMUU3K3elUVuo z-O`6LW-ZG&#or?I_;5zmgvlG;MARynh%Q-RDr+_KVDqk&sWa^lt}?Q4vs!&7=E5h9 ztXpz1sq>icuVuOzUlKC&^}$fK&Noakb`G7>WkR3bexTJXBUY-XG<2W3(0Haa_8H%;LQnPS6oBl+PJp3q5KB{`~Hd`h?641Kov zftK^ZI-WWCOQR+ggh+B(OK}}FKDh8&V5&!Orb5U}0k_L0uEEg?CH%`zt}==!%h3^d zC%j~VsAXJg!1OoMKE{f?sf$1R@LA32J()9q?91A`(ehlLr1{D^j>He)Raf(VntwSO zUjOn_{Of5SbtC*gcb0AM(ZAgFuKb?W?%%Z~b1(h1v%UDP?)TNe`z?G`5BY9iI_en~ zeJFPGxostkUuqcY!?n(}UETIY`Nuy+0ox66!M85mF>}o2>|FDr)0A*QiC(|bvZy1+M9P01A+mE0Tp z4{J)UQhCiLut+`9@ao01?Mn@Fn{ElQMvGZoRpZ>M@-V|&q^$bGyN4mKGrX5%+En=S zFVCE{NK<^zeE#Jpv%Dk9-Y8Vai>t(WZZMm`x;-OX?#j}feQj*b-yLrh$mJhDt2eFk zkWu0NoXvB}&at&>Gd@-Cwhq|pxOK*x2<0F7rW$v8Uq_nV%nR7DGTdYZ=j*p@rm1@` zEvTE7W4^-Z?N!;Ej=x`Qa17mjKP#X@`DIRk>hg>zu|Ki4&FstB9^8&n*zzUIe8s+l z&B8)ABX-s}WY~b(ESY~zW4ck?lih@N6%Nf%9LcE3g*jy9Wv%UBA z+uFzGI?J!&`_F<|%QR>0V}Aeop-Ch!*Xh2>g?tZ;^|uyu?O65v3;*^HD=PywuCed; z-TvzQhY7!oB|`Yzw_a{~eV*sTTz!GRiSBwjcT@vS)w!s?sa+mqfT#ryJS!EX(X#w#i|InQf2S z>VFA0H-2+?q2&>#y5iL$SAH|OKg<2YwS@Tl!p=F(Uzs7t6B@Q|v9WTQ-*JcM+7i#) z4^Dlp{Nb;gLj6@s#fg>a4u9MCzkVHE?sp=w^uZ;MNwQO4r=RJGYv7%ssPt?_%nyqe zU)DE@jqNLAmOPPESi>D;6cAX%vf=t6aB340s1q~1dauy?3x_ajEyNu-1#mPp$s2 zcW3C2z!P#YQ#QW|jWAK4aA@usQPYYW5@$Ehmk5mMkUpvR?onGe&-<)B6_STyVvW>4 z|ENroJ0f7QNWHj)=g#RxQ?+xSF(itgjz4@~G}_G9VAZ~PT<<$@{e*U#7+sxMsODs=i;tm50Ld-G17_xtEwJ$1^WOL3-K z_iPFG-uN}#KUejwY0$d~-)603Ub1)Pb-wL0h290J+W9}(`gUhmZK&Lq{U?%ke$GfN zsme?Zf46m|;N(Lsd(-xqCz?&$|6#?~9dntt{w?#$W`A?#>bd0QE6U=$SpSXb5NN{`TsQ1t^Jc5JmOKC+o_-MhSF z6Yf}^sJ2L+QR=+Z{N;+-raiO|LCC4g$(e~OI(#OrDr{p|V^lo9=vcc9(Xjhj~*cHzYN$U?p-rmvn zEHNUs^TNR$?0cCLFKy}HbtudDOUp|B&LwA_*BzHw`Bckq!_f9)y%YhArXP}Dh*81}x)f*(CQD?%QK z^WAA$w(QZ*rkr)mi~9D)O}d#iZ`od#rGe*@_nkQwdg0a5il5cHzg|kVY7P+gJtAwK zK56xa!=XMqO#B;nK3aOeDm7V*^I;cXRcQNavAB%v70Y+)-cfi~s(2?v;KbEa53};Q z^|!X}KBjVJGl#9rmwkNK9jtHVH+^6-t2*G38)4^T#C*NOZt<3fmEse->pSvYK3*5S zeu7DYE7HC4pxG*cxKj_8UbD&8Tv%6sXya0Q1AmjstP7T(Iy3*yJ92Q^=CXMiPG;?0 z8~$aj%65O2`O5iojZD%N`90R>1Gg)teA;K`A8gl=o>|@Zs{B`tXi##=%p{k?Pihz^ zXYs`=NvK+TivE6D{Pfq>86xu5_XQLC!V`o38M=$;*xZ|T{~^!3$9mEK&K5i@-}tni zQ@qYP+Ag$9H?`O%8hp&{R@bu?S@$j0*##=mN z^~B>dwjTI(BvUz`D`zWqq|Zxn_rT9v1oZeeUcqRd=KE5assy)~hBj7AU`>;LiDO zg=gQVJAvIYS9dHnvwT(L9$RGcw6E$(#%bBFCofL5mijeIubtDR+{7=Jwa@X+#VJX) zP1ds}Ci9e=nClqd7(dIVms$+>i^B(raeY{~8_oVNh$adyC7tO!fO|U%F zy(E%Hl+*O!vr>t}T_$A<7pI#2_wsjozw+6frjSt6ZgewwCS*BpG>#A*dKK-tHr87$2m#kPVe?<&$vr#n7k%0YI9`KtL;3# zVmHIujeCElzB})ER`T$l>KB1qw_m)tveMi$%+pQwa-X|%n&g~Qkuz&9ec;*@r^s8q zr0rYGVbhh3IbI3jM}OS?Bh^2@K5)jIKh4RJOq=&qf9T2D?vbH>G%HVcYjO4!r9hsn zyroi0D(#vw0-a?KT+NSLlD4_e?`*fNDF34!vPY~FXT)69SobO|!^g6FwN>(Jtz8kl zYgc7ygol@K2i60ck->I(!L|!O>T>x)vnm}Tu^3veMBb}1>Q|w=X}||-&wZ{E zmGfF-D+Bv$Vnj@DPMOxu6myj^Nw3Dn$I&On5}C z@8<@p%sHKxQnG)-7MG(}`U<2MOSgSWEFWn+gvmDGpA`zYTundyFxC$?)0d%>%BPldTmf=kmPrRT@O!}CS;}B zoOsdqeyKrAv&o^V!ns$fmBe=O?0K@_vVYyh!i3c=({~koywo};`0>N0>WhD5-5wq{ z{pfVga`9TrRPX(JwXPZ^tasUZCV9Qx)-&1bEw*aCmDhZm%2d2$Z_WeFOnvbix^G39 zCNJHaH1GJ5y+QMOFU47&56oQuaPsM*wOLC~TwN8mRkXSUVPMufNx7ymBp9X-dCU#VjFju98T%0E(yK}L!rB$JOc~Qx;KI@YgTdk`mHlKeS{ax|6?467KGIw_*Gg$5_J}yvn z=cKIj$&1b3m#tO5B>PHuXV}(f-xHEKX1%Ev+q3uT0u{cEb5C$wNV;eBzSi`wsjt6PB=cPH;cr|ca?fr33{(ol1nz}8O@4Z{NEiWFME_eHg`t;~L(FAGp zyIB!^Eh>8+Z@M<&wu;n62Wy|+^_ee^th~Y@t>fN$V9`_0Jx>=r_55R|c*8P%!Is{b zJVAM}BO>eeWu-z6dCHw!pQ;jHxNg?AzlV4IkJRMIxV*r~kLg>)AhK z{eJz|_rpi4#kSv`#*)OhO?}lK-|)z(=ANG~eV=~e@NRSIoFADw_H{o__sfTUsc#Zz zDVp&7c=vas1#y37Ocu9~eR|y8=wJB7w)>8s9+ijMcn5OVojK9(m!#c`XY$@!kvz-vny#l&;B#c7{g-|byg|8vXL#$%O2FJn30eR%eALs(C5q2|74 z{9Vo8A6@!zH(Xczh}nVruKGIygK4g;8UWq4RhwiujmMaZ8KmCgJRHX`Qhj!Tw ze!q8GEH^2<$M(ltz5N&SIZf|5(hctR$%Rv#7h8oc$v?M9K%1jt*@K7z)uxY{@~0VB zBnrgbY-d|G;VZ+6c!4>-{Syt1a)cZ%tJ-uQyXY6{VQscWRp`;p*Y9QW?f$L_{WJIO zl(xSIEW7rUy>>bJVvfTJYtRH~#j9r<4V&3A=6=37Pw>k!p%-%^JHByVa$GjI`?ATt zVrk#g%#NZ}VJn_xaCXVm#jcZ5uoSX&D|{a_>A~-lfo%GF=ZmtQuze}`^hmm_>mfla z_T-P7`^s_n7-KS`0S@Wag%nfp6~E2yr(Lm`GoOa z6GhJRj(Ya#ih9+W&ieC1!u&G7a&7r?^7W=T&5c{voUVErk#o1kYjya?$Me|imR?;w zX|Ysp?v>TS%X>rQDtvFf`XIpa=S1k7t4tPFl{Ib9yjCqUap&QH*1^!L^j3rJ7#4dGD_is1*R zuNBqe+}HiUj-{G~B`hcN%fHk!*K6#3zHZG@-Qc&PxAM5voHj1+&q)U>Cp~x)ti}e_l18?Kji^`S5w{pOq&Tt2{VY_@80R!`W3U zWbw~ye0!XE=iU+>)pw7q&VG31>d!A%`*x|Z(Z?+r_Ht!!-IvSrhkiTX(!HJi)WdH^ z_U~SNv*#DrmwWg6Aai5!g=fbfcm2)y{HSq_oQ=f8TU+#(GgX5E3_TKne^`SBeD?d}9YW%hALzwRKC?#p?};^i$JzHP%}@Nj^4(*-ME*SA zZ`TiXJhCh1f2aRV`N8osA0EZ|^XIXD?RVtLQ~mZpEXbZI&SukzZg!KOAKMQ1AD$>4 zKk4KB2D_8p`k_BhcB;Rv_}Hqgzi;+)_u2CNhdw^K=D`2X{>vk~ApUpqUlzw-JHO?> z!{tZjhZwdC%0D=i|5Iy6O6-;eJ|E5%ImGQ@|FB@bxPQjS2a0-ee{z>IbX1;})I& z3VJ0n2fl|cyp*x>i|50i61Uw`Gh-Z8wcngoSN-ZzRkPRg%e!99Rht)GJaI#XY4MJt z3@gX0tSN7=u3WZ#f}PFRyBB-K&vw6_WyAG_Bb+Jy$2#BF;dhK8-)(0&_Q>^*g?`$^ zb8*S*&i=T0`})nTz81EkJUTm!9|#|{db!y2?V2kxN3Cv|XLd^*R=#jv@YJ3Kn!Xy# zcE?{`$Xa#3RlP7jEN-Sk(@&nyiHAk|f>tfoDr1^@V&lZ6_Y4Bh3&?(Xb5rKs21z}$ zPF3D;nV%u}H?C$CK z-CxM{@ZHS5U&p@b96kT=B2z^||HX{cYtJ8fIPquG&vxxTpR0k5e&rk?`Te_3ZDW~# z#jc>c!*yZY-d_(2-~Ie>q^zLF!M#=_?u^Tn4>}6Tr>8ymTvHK{8(}FYBKITtPi3@V z|K+J2$6wA|b-2r79#_hg8&Y|<^$n9}yP7UzE@9djq3xFQw?F&n>Im()`&mbKWo4|9 zPxM@+JpWZd*3rdl(u#M7=_K8I8?7n+afXue|83E7jxMi+xORG7i_W)xb+hl#x|FKL zC)?%gG(eqEdr9LtsN}}7g%0=!cYyYxbfv$No|H*zW+UFVI62Bng4fnJgjWI&f3ti9q zAOEQkZn*zOLCuHf*>8?HKW~Uv@9;mUpdMquXv21D#z&_oMemlY-*Ua}e}1)9SMagl zAF|cB9b5OkVpVPZ!>ks$Lb^Ws;GOo5&dWZk{9^m?L*wys@k6p~N1HQFWh_#ZajkTG z{4vmNuk7~V+y&f$vNKm5US(FXWlG`sz5?mrsp3xRA6RZFem>M!;5#{d#vGoqoBeNvp6dthx$As6`>@(Yx*==M&9^#5tFCX7?WmIdVP(HhaASMYmH5wgXIH#y zPByXfdiY5zRoG(Hmzdfgt~-^ntKCU%>D1Yw z9eq-~4FkI!SCUu++AEEXTQ z_rU7KuZZ*atM|UuIIQmQW9ob(2eVi2w>Hf@`}t4Y46P{({C~52IAgK+{k;kM*5pd* z=iBI?yRqB6sD9(F9e3T=tV_N<|75p}RDrNrrF)OaH`$cyOckf*2=3P3^l0MDZJQ=; z&HcTiVQodv{Oem%8-6)V56qZ9_0sW-JwLeqoL*RO`tZNPuiqc-Yzwl~<|XMT38ekn zb1hW->5k;NtF89BK0o~asE_+xe~!7oU4NTC+u*dP``CGD+y4A}dsRIAJMW!~nBXaI zcFL*p&s@gOvLPKz$HczyKKQ=2M_Z{N+;uNw{+x@;NptC@j$`;X-%%w<>|}4?Xw(Hu#aO^kZvxu(o$%G7D! z%^qYVShszw_OJ8m;NNd&{8b_CpyO87pL`Afg}&6Edf7i;?lw={ub<6|XE#}%?mj!| ze8H^ET3-S;=!7)vKY!qlr0Jp^AC==z>e9ZMg`sT4$&J)|ay8=t! zJX{nMVrm!jpge!uqIY}SWor54{$>7Ax?<_~L8s@dO?9}TjdF9E$IacF-hQ_EyMs^m zz-Ig2DTfu^D}Q|mW_fz>e#N&9S9=$BmnR$j6gmDwJW|l-e|@J=<7)ekwLGz1 zlp?d<>TeR)19zp2ERH^%H^o0{Dgt`MA1`M8Fe7;J$%zwIewcqMIZ=9DGAx@#QjwryZi7mOQPqsfhPJFx!Q)8qX|J{rw9<@G6WtEU;yZ;g!)XBe5Vd_5}8ebP|r zYm(}$iI0D>UwOK8-}__dW|rMMvaC*YyU>?CisFa&Gha1)@c7q94LkFu?tj)Xf8I#c z74zrZntjCgZ`+}B^*r()f#1J5@x~tk&;2so=bYZBS6V(dD(HD!@w?t8g`;%ipE*}#JX9x4Sv={*z0= z`LgHu=?@=8k7{-wtdah@aKlC!{cOQcw(JxC%gmiVmr?b=gTL%-BE?QS^Dk}Ei{|?K zAeP}D+oUZH*8_KilpX5wI@PkLLSkj=dJp!=zv5T$73MHb(fm<6Aur*fJl98AmIQ%S zvy_@v>CB3MbcLzcU*UQ2gEOw@E^D<{y*X0a`l4~FKHszE=n2I-Q#NbP6`NW6gK@F> zgwJO=m-g$q7&mXaxbjQMy>Ky+zgw+euosGAq{QJylK4Zs*%|Ht)gGej7=l?!GF!U*F=yPCdxCn(;Y+(@Wy-h3oD2%c9!O z<*GNgOFh26qUKAin!MbmVj<_BFP2=&WxbmlQhIf%p+fd-(L4DGZgYcJc&;SQaklti z_4Uj0CihFCMJjt|+?VszpXT`gxWqbxl>PDR4>0sxQR;|N4@mf8_4LFfH(QfjjbG<& zo}LkU@$c7;PZ!On*ZfG_={|8vwU^}b1#DlhY$<(F{~^Sq?%%sp3-qmisyW>MDfM7i z-L0FNJ=gXKe^t6R$z8rACHe6~?WOlJtBia%Z#^!Vbv%CKaJaeY%`I~(6F0Qm++UvM* z)$_b;xQ(-?1)bv2f<2`d#bpeUCKy9r!VA{^~yNF6Dpc&-Sr@ z(D-ZP{krF&c%ZkMZ|RXX?Ve*{i9W}kzYS0cTqA4Oc74(8JWf8Q`jbjK(j%>2FU`t- z|0F#xz0u>z_wgKW$z$dG^!u zb-FtkWKV96cHP2p>g**RpSXZcr$V?qr~dNZE4P`eIqTVq;QDv`(>(uLB#M3WtT?YX z(dVjQfXq*IE#FJ4rkpmq>9qCgxe%F+KUj{=G`s#VXYPW zR6`j5RIYEjq-n9V)2dtAB2(%TUmBa{0~4=#yfatvXm%+#h#gq3DIt5#ZJ*`MMbj6} zp3G3^dT>UWS&Kn{emjfQtOJ4l`kxD%(Gj~Q}m6+ire&IzV(dVhLcXTX(p>H zEV$#Uxc$E7_S=(wvz^h_D4+A>Ue4-F^T2b}ew9lWoQU1{#E9XzSmGU(oi_~@9|=pi zV*Px^D={6O%OxK!{hk+mEZ#NVcJ<31wqhnNhiztaLl1wq=Touk*`$3=^KzVPS(EB+ z$uqJV-8pB&xr@FToZ74Uq=3_F;_bwfwVcn&HOgl^v1_{do_9*O)%p{ek@q7@JO$5(qjdOmlHY)wwz%QfOJssyL+U`#qKVq^Ds!rKM1 zH)ef|o?`!5)*zeVh?Yi0n()zyhn{Z#DRiGH%AYlHu88}WdEdS{OkTzMKk0p`s&sl| z(j0}jXS}WRa##abn6n99Kj@Yex>io^EvK82_3DafsnaW@oa;Z{{u+GnmTV!PXrIKS zS+)yaSg7vB*1TtL(>xQhJ-2+|(CrSjN?VHALp!zAoo;jJGV(`X?t>=1etd7qeS-^M}lG zG4TgNYsD&G%8>}J}SwrcS@t(3grs#6y(9gQ>n6)Rx1{6a>c@~_v9+jSoP zTF3O}mx5{4$DLkfpB5zTdg1Ejy#M^R)#blmU%4F-BgOx>bKT*DKvutmKXL&XIdfh~ ztg%@1v2m4))0Ul!zM7P+_mW&=pe>@==hF>h<= zp2*UxfpLW&q~D$E>fb&8mBd0Twbgy?A;*P|3jUw>Xu}@9O-Fv;Z(p!K?D0a)pSgcZ zZglySF;yHtAJRS3nC-}t=`6BrdcK)y_ckn@t9FIAOY=5A^O}Wifqb%?_FD_=;(3zu ze&JKG`j)Fdp8bv9`rY8E*uuTXk87K@O^^N)820Q1`+|KNqBj5OYA(_cD=)NE&h$xX z?Y;cqY+Tre8{bZyRqmI(XCu{I{^(X))6?U=>x}A3T4%d$i~N}C9&)Pt_TjrWQF-p( zTQ19{&it4jvG1Gwzs=J!($`=37OrdfZ_B0CpHCc#PjS6f!?Nyv=!;Fae%CYceOvZO z__puKa5?VBR;Lfo3+{fzc{K6N(MvN{O*>|L%A_H^=ukj-;x^B@S~g3I#2))3O?z}W z`gPn<^+PXgO^Y7cr?@8B{X2a`dd83XX&KDIf6ohLM|AeSU9g7X)1!k0k zwfe=PujKY$VjHvgIbeAYU4%K!iAg;~AMuj|d0=$tqdAzvs@#D3}T$zs_{qT5UZTRXw zexG%8zuCX5|AekQ7Wi=fm@RXAL%rEONeh-g&mZ5hsGII}-XhQT)?RtbmD{DBDye)7 zTO8f8St z=(d&d8SeeUG*$oa)4NF-{(|rF0%IQ)dw%8K$Nu&Fij4u&f5~KX1V(+}zb zqI982;Hxy#D_3nwH(uHJZidJr`?~0bzwY08Rc2x7@?_gJ*}a$4^6os|{&QPh@$J`r z3->>m^W!z^)jjwB?T-qmeR2E$PS&gO`)~o-o zoU~a=PHV>bc<+6(f1}8vqvv?`zRp+{p3=W+yLJ>~Vr3Su$JV39sYPFAgiX(Fdr=el z?vcE*?Z#6Vy;()}OB$J}>J;DQzqWYEuBxVA8Y}r@MK4}>p3%3??u=AstZn{E`Mj%F z+oyRSSr_-V;tivZNe<7ejq-U{KfAP_aCudka`f$^)N6ORZ@IQ_KIqxIa`Ei?q#27v zPwaTTW|3m~g0x)mqB$IllP#|Cta6;9bfV?lB{#d8m_BKyPt$ogO$t+*E^^d7E^oVY zR3-0f_w|;lga_ABzO8CHex7HhpQ>!q&*|}u*M(RonZ9GT5mhNWyX--q^paDX{;vA& zcT{k%TFO<~ddVj1LmizuI{a57BA8w3rWmh@Iuu`~*mF+8_<7sjUg1z?Bjr@1jKpk_ zSw8n0Ud;;fGG3is6fACHVpFnemfYsg?$H4@MF~6WU2-z6erehwedSl+a2e5wYM(VA9?H-v%Ky?;1{m_Ur8Vju}fUZ0r8oUlxzq{cryz@hR6|+y8j|_6w_n&BxdE zSH!1WpDnWEBmeKF8y{*NpVS@TdCUGm{ayD4{~4d61Ll8NU&{PHq3Q81MdR}qd3!eR zZv3z_DpG&XuX641|3!Tgw$zX6cbrUVStE8=IPL3F>Hllj=qc6Y z*{^Q@uQz?AY^3e2b6Gd5lj?7JTCC76JvZgeJhyXGPQA!`++S}Myh?cAgwrovr~R$m z-72&1jnto?=BNB})z1I>_I?Gdem+njH%K!NMzIWPVkNh8!n$$zOKyx1R2Z@^%w##n#&i=S|5ATji2bAux?U=ir@mufS8B@dHu6)|Gf2Tzw0OG3tTCF zvwuc@ed+C)3)25IJp8}*_BoZicf-=RUtXbh|66YQq_{UN2mh`2G5zfn^51;fEYGUX z+HM7`9OhS9l2pZa&t0izSHNu^r}i?}t~=@ftK8=?7rt-Lx88p|<5=E(z%BHvmBPbeAjmI|CY1vGaQz_biLP|`2QkHmfETR zlR2-5UwpIQr12N~Q#+NmzgM4pH#_w=;>>;R@+yP8Ha+td`)8EwU7&8Zq@H8*7l8|R znUnrc<`PN^;CSJBum88bu|`k-?|4ZOrmDX$e%zK6X}DqX&t6J|scQ1;XZx)+))?iR zYTR+VzhL(Nwfi2*>$sjXySaaZ$j{E7?|V5vJzKTl-Ma_>)P3!0LN!*1|1)`LFU=>W z`lt7yLoD~tqkr#feX8FeRuq3Io{wEntoNHLi|FRH65ii>St6%5UGs0sEBokd+9o%7 zQpWLsh)BJA@h$Z`(q4#eeNe9BuV$PZvtKak%Kf@LS^28jV!}(S{Z-lS&N|w5Z`R#w zZ)fCAKEK?tw(Qc{yyH&ic{)n0#U848y^-wdymt5V%ti8`r!DVufJx!TK8(+ym>zB7VhU)3;nxl*REezSBJm< zGw-fOY~L^Wq;$Sp1#g9X+iwR33E%tnwkRd#$cr{+bopjmc+LR|HU%8b_RNP-QS8iU{R9&>DKEPf>`Rshze3#U9PO-hlrpKQx=BTkh z8WkU-BewrgQla3LY*F`Lcbq?4t-qXoMm(Wc)bZG&9Sg2Wq?ed~(sU5K^UrloAJYNV zds5skoLvg5&wgFlw@G)tkjTM~nb+A}IeXkKzpZ}Yc5-33?$2wsO^1W${K@!SA??(q zdeyrn<=>PJ><-}2B*bI{uK*w^#uj*6*lFFlV=pP;e6;>7zoOhU32%qRD1SbY%X zkvHZs-dMV$agoI7Bik*w3ngwH+F21g@5Gc8Rl#K`cRmOnVqLLjq3X|`9asKxUpb@l zK+#evcNL@JuOGLHERxQjdZ8Gyc$q1mdv5T#+8TK;24VU5ACdMN#_UU9Ezv){Z{OaJ z2ampg{X4R0W}Z??{C)GRiSJG?U%&p*tHcM7m(04opTE@V+P3XVH<=rJxtaE11YuVl4j`b5xMnpA5UNIR}M8B=f@NuEUFR*eb=m#{yd?|G?#|8TH&xi57G`XO z7uzrC|2H9|IF;kc;xeCYe*$CQd_UqH`XT!NHob4RFWItwoEv=Oz0db0%bAYdzy0cY zSj_4*b$O!m{@xMuIJ_~%HnTvq@Td7!K}FuMlTH8UzE`ZC>-DMagj}e`8LtCpE*MOF zFkhtNeX)nz!}RTq6&!`)P3Pqu-|q+!XnESuxxV~>lV*T|<*%O1TovJ)jG9TGvVRKk zCYLoI`{J?2nnmu7OYnEOkcH<1FLl0@e-P;Bv*+>m=m)Q_A6U2Ty_xgN6_2dm)QQ*3 zZh8@KbEn(L?p^|av%kky>l@ZTK21A(VMp{T)y~x>4$79t5>Lb|lb^jZZp2)^lxGu#k6R_v*yX8?730 zwT>Mz^YS!|`~$n^pD503(M$3*s5)TGn|p(!qB1}~t0zd1jncUNss}(Dz z#kC%_e(~zau`LHYE19;uch?s@zxc|JC+6=R`wF>Vyt)~3@NsJ2vvaHy1bcos?Fy)2 zbbn#IaG`{A+Csy7rF^lu8s{eLOfxQId$Ww|)g||h#~$~FPF=eznA^XZT{1-qmx<%WjHt zo@h2P;$OsdPA90KO!0rELE)kz&tultZMjx%n6j$u+;N^B<9};9l;Rf7&RNLSsjCq) zttVyO?O;*23*Cy+pBH{p`mcKL%n{Z7d7ilv{_DR6zF@E~VE5yAx=vrx^M{<0`k~g4 zt;K3-N6xAKuQcf1S>&ni@nw1Y=Md95i@4_pv7SG=_MemKO4DOP8Q$g@F5*Hfo3?Nz zt<+mGLnKL{arVlr3`g;xl}#q6ZC6OmJ)rJ=Ywe2D<&CG;YlvUk;m+yivG7Q&iU0Y9 ze$29-QFU?JAs^yb1w0Hc*fD!Hr>KRql6w0pU*A@)H?8XJj=s5EqJNf8&+;l?=EQpQ zPU9T=`0TKItz6!-rsgheYP1Zo{dxT_Ux?hzJ9_)?>J|KFU+_us_TTONcmCV0xU<2P zo^-eXt6R*n4fxxL;H7> zX4sbsqpWpXbAuIkuNQ0y7E;;rA$az1wS{H8>jN=o(#&xJ7 z34X>5- zjS}5rhf_Ar*KLojoV|MO=c8XA*XleiI^QxY+~{Ih6Vv4x_X{d!^DkPZbJoOo|3jHl zo-_F|p)*yCcDaW(n^egro$_M7AN2IonQKR*Kl7S>m!HeK()_N+y>upCvsu&9DlODP z{e{-4Oqs$Np2u@_&Z$iw+3p`(Y3{h)DCxP1w5Uvj*7wpaiO-iz4EQDJ^zoy^?By@| z7<1-{s5@?{e09fA$IRc|s_pu-m(Lo^{KJwhr!V_^*<@$V(SI+e1#PR}wK~|<=qqQ= zf03;_9IUu~Caf~OtQ0QW{$zHZZd>L=*XKtKbuaOVPiLL7=aJLKhDqxZbQk88x$Mt<+8a9a3THe&H79WH?UZvFh9SJFer)NV z<9STm$~5J6t$8>*VyTebtG{|_HNx$TMl-~x-ah*NORl(phguQany9LS%{!koM0 zvZ(%w9ap?gD-^QXv0h@kn|4a!W6rtdj$hs1nQXSa{y}xqq_zjXU*;bCsM^}l!`X6f z;)UC*mc$*(HC>louObqn9T z^x(;FX-76~m~EN&z`lIzp2q4MyfzD@8TVRm%;=S_2sE#@p4xqHrN!xM&(=L%RIdB2 zyJbW3&KElqrvBfN-EPA_C*#*qL;jpa`vsmkZZ9tE*!}Wc>fe;rQ&)Q)(*9nuV)IMC zc^RIf-U~83t25Gz1t#TX?YnpP&4swu%;xrQ@9v&8lQ%1GSn6DDx-Ig7bG6Rp4$Cc{ zRkAKGd^lm=QSHF)cbU$Mz9sYvOf zvNmhjk9Y@0@0{OsEB~8PFIT4F+rU*1Zf&_A|KW0J==-aeLfP*vbV$$-&G^fxxkN4S zn26EyiQ@Izc3VwL*^O2-ZJStQHB-{~;+{aR+a3GnY+h%cc_!R_A5Y)%-z@91?o zx{E&AulPLS&iA<|!aHQ=-0}F={ocewU_yI=*|lroZ`C<6uDp1$=8ApeS6|W3$NxPs zm%iOOt^Z?oHTNM67Ww53{~cM*PdoU0!hLnYnkgK1JNp%MoIhOU`oSRh$5XOK`sdx= z2d7;=^rjfF3;uCtt=Y=4FPhEXu`cl8TNj0g**_|DBfa+?td*SlV8v^(+Y7ARKSjOZ zH4W^)>{}G_g8kx(_KDui4xWYg(*<8HQ{1un*YCj0<*RnPsanQ+Ul97DG-<2mKp1^;LB@bX>e++DH!gS6t#!v_Rx_s8!#{boj( zlct*fM8_MRhA)$XeI7k!s=v;7$+yk)a?0!72g{b7T+hz(@I>tAcN;WJ#UB3X))#y_ z_xp<_y8m3Jr19NWomf-U_UT$pYOJo*Y|KP1f z7B8bun6hU$*sgjeuwhosq{$wiik5DRtY@11WU|b}WmBI_mbrNSsh4N{&&e~tOqrS; z>1B8F*@Po36M5gYI-FFGbev>oJh$7=?&WlL&CBvGN?!G0o}ux(*WR00efEj})fsBj zKA9Go9KQX?nx|=!kITV@kTldC2nnQN@4N z&#wea$<3Y-e9J{pZDN_2y&mgbtLZ=4+4Q=@^t!V)b4%S$+4xHRo5uDgn<~{OHd--V z%lhk-ex&+N<@k5oW5T=Gt1h2}R@Z&M^sOc-bmDZw-@*>T$4}pR(;8*#J}Y-#T;02e zZv-m}43vJa%n3_yYS_+ax;S{2zmBB*%R=L+zS%xy0usxVx6GQi#P>KyWKd?7x}d(( z!!jQA{wqP2{Ju|BW*uFa6E|y<=N69eg6R*fvYxqQEnAo*H>=BYOZ&nYza=qJU8=H; z8JkoEwcA20Cx&EtOeyJev0D0yYl7WU9(LW{N5Sh?9NjG{IJxvzXU+uLJK{w`QR~dL0hD zr`^P>7ql5K?zRm${Ih*MYu1EyU6Lyv+8a0VUYTHVt!_bE4@09Amu&QLR{7DQye~H6+ z!pFnMn@&Fcr&6hy^iY&b>**cESFAJCrhbw>aMiiQ*G>JMan{fIg{4ZBZuwlN%-eqR zEcMLEO~1o^BTb6+*=rBch~?{VxOCK}F=bwE&YSFKd*$S|&Q_`KNwc?ok=_w@$>ZoA z@ysh6T;DE+uFL%`VQ_H$;!fWttq*c{U)HU9@N!%D{~b5jCh+iIyxRQIDSp)h%M+_k z3U2@Jot&r`YvCmt^#ACq3;fH^9AEjr@0sEH3$4W=jm=jkuiW|MOk8d{Z-m3*+kUGK zOuBsIZ|DPA-MZ8Zx)ywT^Ht2}yTmzM_G(`IFHrT@ZJ+sz4hO!MV7o7%pY4C~;nL~H zyfgU(#aH`Xd$`DauB6$c_=hUNf0F%|ipu}r6MV|@-(Ex4{(7mM6QUe0cB_S*ULQO~ zf-6XeOVe(z#LB0CcycdHf4%(Df}Krf2|nD1cWZR-N?s+D>L&chwN+DP`SFWJXLRcl z?|lx|l-#T))LvGRKk35)@S?m_ghTSYtu0fvU$4n@nej1fa_XlS&s>dXEjk`~^wO1|Mn4XnI@3J=+a=p2o0f^cbM<6Siw=|U zOb?i%d3|1LWTJ{@{hr&8&iid&b7NoJh4^Ks7EAmT{AzX1;Ig!byMpuC8VBhHrrP(3 zn;BP341buz@a*iKG-d_6%^^7qIugETXNM-a1&gPN_FtT$z2RcW3ASLTEN(TMZNFc> zJ3TS$o~w1vT}Sb}g||~!Hmr-D@?=J^&9TyzKi8<`6c*j8kv{gYL}qsRvne4m(%hK` zXW68=wXQubtD&EHaM?Li?&-;AyY?Ksqp;=#`&r&@(VykThoz*_|L=KF^W*7BP40&U zMNc<5TFAIAYY}^4E6;B#)2H=%Q~K1p=fY|CzD!$tx!3lXZuCm&>h{~4!ooL+OYi$r z=uu`P`Qho=oNLT`w#Vz$Hw5F z*Z=0+^0@qWQt#G_z573|^Qo>5?1+n8D>j93{hD;K8=p^o+7K5hX0wqgXU)+EeOsSt z{(cv+cz%#sQ22x1DVsZ^ZfUl*9(|QxTCi~8{;5|J3RNFgiyqOt@%QC}X|5aJ*5%IA zd~O#h{A9*q4JVWPukB3hu6}wqeQC;jqmQRIy?L+qE9v9kJG_6^&)Aze>wg?uc8O>F zJ5f)`ZsvI+kxmD#HH+394_7%GoptkbSF%s}&Y;`M-Dg`kWDYiqDl%ouw>!0%ou4&V z-J*$IdtSKRwwq7AOyjG}7CaZ#uD!r5WK(mwy8B*O&I`Hs+p6A9pCQ|tJVR|7%cOq? zY^Q7wJvd3|>$a}ibxTy%Zl1TgVA8eE=i?`D={m0?o4>k;Vd0ABOJ$?7q%sUu9V|{C zzufKIqoh*QWO+7o;Z~VzE06d&Ol4xadUNuJ7Mopv=3i@E^6gd3?2C4H&qZ~WU;Po- z8G19$?X;xyinWFWW>Xs*2T? zrM^hIcxI|&hwJh6JlzprUY**|FfEfzA&F^`b+h%*uJc@7tDSCxi+6V9=A2^#cCgJsc^rlqq7#SzojOYb?2Yg4W3$2 z&8$k}EoW*?S)5N#HkjF*_Uzl#Ii6{6wSTUdy5rgzJMk&)$NyIL&a7RRbKE;1<8^l0 zx1F10^&MxwT;Ix@JLPKhy$flFXMIYZe_HM-r(WvX)HjEjZ+zkNn0I>1#)Qk=&z9$} zW%W{+zq+{gztb-6w@>!)y*m5*#M$moXP^C=cETb&l6{k3(B;JBox9e)@m_z=CH~{N z*H?T!li$qV+h_P~?%s1ZZhW6>=!*S@#4iJmYK;P{L+oD-!8EFolx6pZ4`Dt;-0MJVzX(=?rxnv zLUW{c+~iqq@k+TV*xmfrft6EyuN9s;{Afz0Lb1Kv)O?v&+iqI%6)u{&I^(L`>PP*; zLZ%bHyqK|drc$8OWf{rq^HlerK54Jc#Q8D(y;#duj(@+>tT;+9KQ;Qn_^F!X;PtKt zt$$e`N;JubANbz+pgrZo=O^MDZ*@8x%Gt4Zf5-HWqkXrcS8!aan{_iJl2!7F-Koh( zEgm}k5nj*1)YT>XUHk33SpPEbKgzqRY`nHS-7nqs&}Wv`q8Blrtl4)TJmxpW#@aQq zF9=gj&-C^WW0X8C&)#zV@BKF`;=5RtxyV~T)%&z`H>Ssa#J zHY{DdN;lH=Ux)35X%`&U^vnC3Em?iTckh_iZ56)aq$PHw)+lYiG8?zk zp+6g+Fh(xP{Clvuox@N%>*>UKC+~lsyx;gk{=#P>pX$%9za{YCD~F9UtK3WrhhMW9 z`g7U@oDLO3~5L!4WeH(q#S&GKt|2gmoEmHqZB_zUg)r7Sii8?D*+#7{lYdlJ97ebfK% zivRuREuO5bvD@xRy^GX-jt)jiK>VI=j4j0dOct7AFe;&J{bA9x#w$uAt&Q~-$ zEPZAm-LO0CYUl03@Fnk-=-prQ{>;RC``(%{ZJW01vE`93&(=6`yfBnXGhf;^p)<#N z(^;7%tAZ^bMvEPht!=jP6F#K+)N|Dl&f6Ol_@)I4XxitQzE5H}ZG(9}c>XeYr@!#n67#RhFJ|g) zUu82PE3Q%`lw-=`-2#*1?k#oZ;kMjm{l+NxSJe5GFeA%dkuE~3pT>W`9`N^to^8;_ zPqA~Fr0oBjx=dfTboc2A-okG>S?=y#Q((;yTJ?78>fO^jZx)pIc2_rDxNCl2TI}xM zd3zJD-rfJ_dBd*XpC-JG_EX7Kytlx#`c(5r0!Vf9Pa*fB^mFnUY{$dz z{ppYU!ObdX?N&wToV;(p>BOWz&*K$0src8%v_(wnmUkEPo>XO0GVMvbzgL55WQoZd zos-PRl^olOK1OJs4$!JE^KD!7MI}`5*pt}Ho+~f(bjC_@X)|t=Ke&!1Rio6NpZ{>t zZ}Ef1I_h@oBX~|<(bqB33HEO}vEj~_RLP_Wu6;c^ZBH++cS?_l`?ZQiVwzuTVrqm` zoouGj6xsOcn|M;Mf9#mP(B_Ztkxg2nA#I!9x>Q6=I`7YRev(bqrlgH3p?;Amo<`?d zPE4w)SjDqZW#<1rooOo1Z(oR<^z8mL2JfOTw>NB3iQd=EBI)()Wze*RUw)o9mF&7S zImA^$_vU`?+#l+or!x5NCdR?f)>*Q|Q0A zjrXSC&%2IJ`to$H?NQw1U?y{^}E*73ZjKk?|KoPVYz(^CGdS3NN4${vZZX-}4S zPgHO|`Frh@RE_hoyVRTmt0t}DNWS#A=!lV;pqg`JxvCA%>EHjwZ4OWRT>o@_Vjxq9 z;^9YovL+_3?A@5_lo;`^Y%7nU&e^(town3~z!yB;QGuKWI`2hWrzYO?+O>kgXv)i? zn@pdJlr6lbSMI#|aK#KGk=Gvs^w{P#Wv}syOb<0VX;#E~uC(5up5s4%ILm@9;5)Y& z!6XC2YJLa<#;=%@8~#06BvfGD&fQP_;@){g1p5g+&~(Y+JQ7;usUpEWr-`*!vCQ|4 zz-}e3B%OsfxWC=27JsAkEpB7^m-hwFrrzCNJzZXJ_vdH6f1g$7Uu=%7TUF>Buk3KD zc@zJHG(m^9`%Ov>;cX$8PpLH&>ROzRZ;}4J$7;@uSRJ;#jEoa<58q4LbwPF4-boUg zQ~vT@43_ye(dWq_-oL$JwX}ixe*Ftp7TNNj>2Ds!y{l7+cPKoUFfLeooHp^0JbkoUd{>Tq4#k);tp< zvdm|AfIfCRX~mpWQNU zrwm2zvcBjo&&oa~y}h&5>&KdH(avj9b3YbEC%?_zQoUqBeA>AMx@V{S(GfS4Re8Y? zp|JVZEXP~#9M3o}`0zUO&pW{tfj5h#I1JsFa5HR9*SfLsr(d?O#WgR#2BX!t7axA* zrOI`A?wQtBTOQ_yy|)x@rZiaAip|_RRpNr*v%X%Xoez)iy?r(0%S}r|#&^Ok#hdl} zIaj}1e&*?%1#|bkpZ`Xl`}xctPt+7PemP{z@R{{!e4g6#xk3zl9uw`S$4y}nkhRa`ZDvR2L=l=vy7f@zj0Q7{bTtM9+l#| zMYZcxUWa&ErEop)SQKrc)p7Rc#iarr4990M8Rhi*iXDG>u25!USy|0iruEL9QJ-5B z_*#T_w%Q(@$aJ`BMawpsHP&w!4rLzq6wMJTFDwfE#9*QNzDGj%}h&sXR;@j&P*jTJoB0lZlMHzSR7QPx$)mml|7NcDJ6ToKI@YN!&_~qef+Zd zdbi2Kod$99)-=tX+x?h3IpT_CY*PA`x$Y*pVGLnULM`TA+__`ZJr!?_>xXx7HB!6a+ zIK1jWvcwuQZ{^knD^#;L2*%Ee?dEbX68)>o93gJCqV#!-(zFAw!jmUWV_bJp^7sqR z2T>(~%Tli|e7ALxt7^8~{+1`#7u)Gf`Xt@6{lJ$uZlBK;uTnKvj6cti=hnN@XM4<4 zMJ|>dtj#x$CfMEzzM%VVt%UuT6IXI23YVVY6J8qm^!8ji)rc>ATQtfTtJRP3J8r5I zpW3?4*NC^keAR7r&i9HEKKehDY*Q~y`FG4}&C1)-+e(Y?$wxZ8 zJ}?;Bo!Js|V;J%yJt8^w_FgQVa`pbh z?{mEQXK#ph{ikOKJ?VTaNDkjwQavr-s`fhx;(#qj!@W3ZlR3_WMAlCE%>zdx%OX|mvy~0 z48289_Zdc;i0!-jM)=$B-7If6z4`63!&!0CHkGh7f7&N(WTScW2W@Nj5-ts5@N_kY>zw^^(=THA&e~_2g2~sUE!0Lt1?;!#(e#M-(wVZRN9GzNm z{bOl;t&jhCh9<$s9CDw(J51Owt)#Lj%{2QEm$Ai135maJXCLnUcTjQ7ZX@PJ92!i@ zT8ma2cd~P>JIL&~h|yIrU-0N`=jIF+K@m~WJKtYf?^?HhxitI4{kKnrTwVP=Zf^Y5 z)#2+`ndSE#oijuFa{b2xhm-G~%-r+)yr=B{p9*!{mTRZ-&vH>P>GV++Fz$_Uj=0=$ zP2<(P6piavHb{SN(5Tq}2QLPLT_cF&VyS@q=y z?;FfebH4Jxz_cQ&=Tl85Vakb15 z_a8Ig`1t&X!Cc|?s)u?jj|=F|xKyXQ+(p#yx1+O65#O>UhhGcCwLef`pR@e3m)?nl z6AUX`w;a5_TK~r{IsSc**&FjOC|Fq?XP@hwweVC$%&PrXH`lu!yWNt^kkoSYu7}(i z^+}(m@p;9C%Kli@&-3c(lg&-H64+#~xL=+4;rWxz3xZs>L}k42>M-b;Ut=Wl^@;I< zbW0_zrH^^rwmkIzIx#?6eSXhYMw@KbGA%35fH&(;a!33UfARWCW>>7l>x1?S=Cj{ZzuA4}`@R!u zj_psre^!k#$(hlrb?wf2(`i>3r^YTRd%L);*>3vkGly9MTUj2Q^-juqFQ(D*O5;jk z@T9|zUhAR?*fz^}8!B8+4!YnNlzHvRwquhfnw<2Q6{6y+HA!vl#U0AYi<9pDetVs3 ziKaqtwc^v$9H&(KZ!W45vO3_K-7tl3f*W(V?5mj49YuvKn^Kx06HNF|im$!Y-|C+v z$@|Cu^8WUJ);FtlKExlsU6GhKqxzs%#f1J33c?Q^`Kmabry2R^ZgqFoF>zU(808zZ z?7MGT+HZ45#`=0y&OQDUPbSKqS>Df5SN|yZM1MkaqJqVv6!ss@>8d~H{D@QevgcZg z>r{tXhmNwevUmQmy2P=`y{9Min~eA$k9XPs!}s~8bJnDocD}v5a_W7DXOk{zJe&0U z!~yQ)TKorH1quC;$2?Bj6UC7_nZ-}yn}qQLhH?VouS zk1uOF)>G*bWTE!;md}li++V#I4W516yJY28HQ}$%OjrDxIKA@eHO4&x4wJiOPFp-Y z;wrqVqAIA*m2EPIX(oqvz}3^&-f2$pto}LIx6xc-k7G|~;GQo#8m2RTuiVH4V@Vpt z@BE(`D*Li}mU`QKi8V*AoLhO`H>l(v^P)LoYKy~+jzuOKrKvu)_@EtMwW`wcTY{mx zeBBOXuPIp}lUdBN4>ta?{3G$hc-6@;&qeZ#O$BbIFM|cHtP{FY9qU!Xp*!z2gP3Q+ z+pTMMatU*)#Ygt=sjXgkzODGi>XI~z^7ToNn>{D{KQ;IGY;pBhWT>`$)iMu{Un^!j zeVlCYP>7o=Fi>aaUWF4U{XP{~oUU_y&rw`$A1$ZJNp=>n_=TIBZ+PmW|sLR$1K> zb1^-3IAzmL^E0!OI`;P7ab5D@c7Rs?nXMBXSLQ2wFTBEZc8;B;W$)*r&7Yhtx*LQ& zySS{ISk-zr{;u#Y$278$<%llr12K7X!s>rTFS_zSK6*yxR`ZT7ttwaE;RSzg2&zDaP|1d$DA z(jN-E*w!A?ShY_3gvp~^O&?|c)4`1`cX_)my^RSveSYq<*GE|L*7k)vN+<7G#4Wk1 z-c~QWrSr~PY4%6+LbDtVy(X?{^q# zCsp8t!r7JLik))ID$C=RXyyLzZ=cS;`r^EA4i6_a-149D^y&n!D*^ghE3DXO`n2?w zcqyi;Ejja3Dnq?axmN6I-TX@*SA3g&biT{h`F~R~nVdC9{ipz#644XWTUlDn_;Xy!{o}kRyw!0JW zu6ua$r+tH;*!8NpcTNWNUj2A%RmFFQf=hP456=0j{PmCFCr!n#%gSQhFYLOv@8G-> zH4~QB>_3+j|EBfxNw)p3+bq3j$(psVD4%%s$feZc3#o=)Z>PFv&;6FM`Et-Q9@E}a zJ1(tQXMbvc``@MWZ^d8gHJD)jP5VkBUt9nCrkO4|k45^f@A6(=vG{tdRNdp>CBOV` zFiWY;tUW4V5Zn=Ie(h3lkb&%#-q7#OXAb&y`ptSAWckT{XW;3Mqqb+V*W|ju8Pfip3Y;K%8KTvF6YDeJq_f^?5U#)d3F7=IC z_uTNu$*t^*tA0M^iF#C2Ci+?J+3Fh>F&(|d%c>UJ&VQ9t^2T_p#Ha0nCtiz}XtO`} z{x>UGTixf%O)tYh@1O?~wOMkD{m&*}S$R{iVF%NSZC`vn)&_^0ZoQY|V{f~)t}5&A zmn&ED&pk{InDgg;r;p@}V=shn&Up1>Mwyz?9myC+Wp*{rgELP2nYgm`o`>==HN%Np zFSxJ#$jEm+@TiMfr=7=I;hP15swhZLTEb7YyxH2yNZ3!O*b{9avHrMGz5{aM}0zY5MC&5}2L z%5XL)wcx>2OIg;0?dYfrj1|79zbgBRj_k6p-G{HdFbcM_Vfb}`adyWY)+bM` zOd^h^?nv9)lcVIeSym*FSyRA}>&le1k3=oae5I$h{az@wm;23@vXDi0ncfH;(0e%R zY>`FC$^W*;i|4A{)(mBDzcFsA+@N-sMtLTbH{H}kh?5d{Ovv3@$+Sg!v z#O8qW8$*T`PWcD=XLZk93g|hg{P29mCnK#>acbEe#er)quQk`Z91Ff*E&X?bQ{)z} z)g0UUs(g5JO-n@XT{7DyD%j$_u6M;-UCS4Oq8lHo=6|nt=@RuiEt}k{d*?p;&ix6= z8>*j2&+_nCzG0T6-j$a@N;div`CE=Zcq%Gv!Fu${>Yp8gOW(Yi^Sk}hhyNG8Tz(dD z-}yuQ{EZvA_wQu%oMrN%c(%{yi6$!@D|+J?GnYrcSvKePlgg4^eosp3F4#}Fd|0jX z=+uKxOU`ZHv3J_rCtY&w(Ru8$?GqmN6}$fsIGl21_1EPmZU=33&poaf*2wr$;@0uQ zj=r_kY^vMju9;m+3i>oRzihAMUMbt{Cx1lk{+Vi~ut&k=cFLApbC0@qudZ;*y7X*k zZ;XV z8+*UZH}npiY|Inz=ZTMTs;=eir(X4mQv}04WF9=eCa0&XO-E) z?>}>2G|{^AnzObp@$K`Z-%De79#)>bd&||?Co7?d`H)h^(vYHwj~54X97>oL#_+`C z=Ya|5O%=0wHk|wS;Oa~s_Cqa>8mBKBE!?y(*#Eo4qjo2c5T_&oBW5S%h(KL_*E6O< ze&P1>D?OG5K3S5ly&z-j)Jw~Fr1CBmOg(0prLjO!i`Ot?2IE3C@l{J>T=qs}b%``} z#Hlk+X$}waf6r>W_xjQ~JkO_p>bw*E#{Y@&5=l$yrj1E!NC=q;dCi`i=G#zyD2mf8^**zkkb=JOBLt{i>k3 zPIq2$g!lEpYeuy?@$UKVx_@-`wR*SD{lw{>bcq%U7P9^4*%f!#lyP1HU4;Q@{C6Yy`dS`D<*IM zwx=h~oB4l5o#pqxYUvweizRC%N)I$xPK*v)`k|Fet#102?FIW(zPC%IBwzmHZN&OD zAo#`K3zsGzJGJ#w^68>&Oa2zrpp)bw|IIM)po7rd%*cOI)LG7*TJxIeSe`P#vOAcO(W9Gp4C5?^j+>( zdDpw}5+i1Fd)5b5JA9r_3~hdzWgsrQBze`=g3vWiuIn#c&^GzvCAv4rdHt0O)+dXb zw-{&W=%vhD)P28pMPu+L7R8fEqHTL7Pj{CCKY_(8lg4>C;nW0*zC4wTYobr5E zFN!>NBI}sM*-L^&*}Ecs>iBQkZYbx3`)c znv`$g@3TRweJ*3uQ^~`Tr#r&z{$y?PE}AQ?sd`QPhSr(yaaL|O7idh;%AOy4O-+oO z^P|RuPWGOTJCk`A^X@b>skGWu|6sNK?g<|+PkbIxuK%j?uccs{-PQeF8$Pf6H#O^c z@sw@Vg;S*FZpq!>`SgEt;YCxYGyisNUFKFIu%?yo*PKag|19r5%#HdaTcXZ&7_mPo#a&!8QuaD~O3dB4QI|#O= zPyFo>$ec&km)9}jX_^W?h_7UQR-u+W|JaS~0 zo82lcdO_0sftrz-CfokB`3t-lz55Qn_4Af#icsN6x~JG7IZf5}`0bA!KJNpztWooS zIMpJ5vu}k^g7EJ4%ZB0~Ezbq9-!-4hd#LvOO|3hgA6Gwm#rAVw+2PK^39f%NVi~lv z{t47`&Mp5@{qyVAPJj1Z4j*(}zenCWG{;cra0^{q*P4Pk%l=H2JC2cC|CH+|J**?AjN1e|e$T{;5$~d6I&BUZzOt?1t5A zxHeo&aSYvFB7b|m=^EG6eII{(-f6NYyy5;adA`5rKZss({Gac3|K73wG`FnX@dv7& zJM4X%@?X-C@8A8l4+hWNiXtnn6td}D`pV5}B6i&PkKg}F4~v42is>8|N{pIYoCW4P zh6yp=^Eej#rRMS*i6b{JZDUlQ^x891cNw3awv%7U)H9S@oH+P%#%7=UXnpER|6i=D^Sn6D{h0?QKj+=YGmGxE6?V2!4 z%0qu$(d+EY?ippxzVVf}B|fGU1{^=yC|bBB_wlI>x!raK%dg+Ocai&xXs`m-YK(lx%B9| zpq-UAtUW44mv=0B==Wppec3BJ7Ff^uu)E`(j#%kj+pir@C#y`nair<&8u|K^Dp%g= zKQ~PKEYGl9{#%=UdTdkseDw#ueTRRPv1Ol5yyR3i!*|O}*>jiIPt;xbUn}Cv3*EU} z=0@pS?3f+Se@G`y@WT_~!+WptGMRCy?)tMf^zLDwh=e;#-QEU$ukVy?G~kvv<-L2> zKMA#)**Aq(e0`StC+}T9`{uc-eeY{eR-Qe0L-*YDLvsb@i?WADRe#Z2pe|sx{IE;- zJ-_Eh4n6j1mu++(nnkT={GRFmEDRBH zSMH4Vc%9d8ijLLhjZL)o*ZGL~5 zbo1xnKmF%&`_{ZNxg-?*B>!@@#IE|1yz&cwS8tBl@p?}ATnEurxwEcwrW8zLTKAV_ z;f0=kZtF$XJh$#@yS6p06n^nQ!OWr~=Q8`_iOK)eV%5KW-M?(Q;cGtI zdzPIZ6<<{ztTTk4|(vuYC`?m zt0qOloPjlLri5>sT96SD-e-G)ZuFxg}bS1?hI@7B4avQ7KL)A03+gkMYsww@Nx8tVT%4GGYNjEpH zWSt$Ipfl^R-j@RV#aZu}rm>$-pSb*Nok!azdB0XSA37e1B+K5?AB zFl<+L`SOoSA!VicA`h3DwXHk1OK{2S?!1(WKL49Nf!C&e-SgS-!}CAkAG+>`pO{^7 z_tJ_8e!J;;hm`Nk{;=q-Ak!zyx#tQ5(M|XpNvCeeJy}sgY^sUc??wanN z)PMW_DX>rcw(wcbr334g|NE-w*7+RwWbj+W)cU8ZHs<1i6`j^!SX%zPT4VFXO2X5z zZ3pKK)T7rI~Y z!l~m2HhwS+;$HKM@pW0!{T9LJOnt5P$G@fPem+(;V_s9ISd#1Cn62l#I?J>Ubp7%9;>vA^8f3f3(-%)a{z$w^_(lU`-7NLFT8+MMXE0aF z7byL)d>L|LyU7F~0tJU=q3m8{`+DxW=;;%(Db0*8Pil@%z-Z`b>e3X=!hD3mvX~kYi+1R!2 zKeo>{UA29UBKvFA>=Os;jz=x7IxbbTA#P)v%p3DHrrU}SM-`QnF66$pMDBWP@2a4j zb{mFPtLYk+OjlQ3mufmX$0C?xRrJ+m7p1h8rS0c>GHuma9{c=>&dx1snkGGNX6F6F z`AIJ^Iq_S?^qgZK{5H+}*)GgGOVMJ>m5=|{8@{)ke*H#TT0BeGLy66?85}45M0&EK zY|kBwWsjV(QEb!GGd9onGPTYMKRH=r`v-wl3%&>nh0OoQqigbOzP{7*|GNcv)+w)b zX?d?U*_QG2)!h&FZ{EeQQO{w`X8YO(eiNC$*+w#I*OyuxuXC|meyWp&^E-osbrpvt zv&zA*Kb9P>GMea=p|p4UuT?S0oEKaBPB8N3o@2b|)TFrN6W`}(;gd|q7yB!wf6_i_ z%kt;@g#7|G)yKjo7m6Hs{KDqdeAnc(-rkykE4_l8Z&?E`cs%_OuM#TxCw=Lv7cmzj zB@M1zbnfj7`7}NJgt({It<(?4i$p&yom64DNUF(EY2`W5t$%`yIy(wodk?;kJMz=n zL#xTJKk((HjU_B|_ z^I4M8oTF?#oD zJeZ^Nb@>d=xyShTii($PzqH#XIR+{0|is1A786We#G8M}wuL$;X`ubn;mRT&5 zvXBM$3#Nikr?a0rigy+$uPZj6LnJWs`avCByOGZQBCl ziT50~PL4hHr^HlHyiTe0gU^!iz`}!zSSN3HtalL#Qrzmjyv*M<3nXeDJH5L?|VO6}- zV8J$3_3)>cljr~3S<|>jH04L~rnxSuKc>f-3Euv!STx~b6DP06j0qPnF)tFnWKjL% z&OOf6cMg28*du&p)4C;_3oaOz@U1yg5wmyyFy=IoFOjXI_~gjzdv)`Fb^ahhA$cs!Y$448Kz; z_TKn}esjv9rst7+?&YiNRLpZdopnrNiAWgh`OO?o%%5_vmalvsU@~jbxrG^9W3E_= ztZkBA+|+H=E)=+ZQ{!uatM^Jf&OBs)m6*cgRh?K7GV|z^1RvA6N9XI*UJx`qXZ$MF zC3Rb`ubjMK_ji@Gb9O(PYHjY^rezzjcD>PUK|yW)Ri74U@vmd!ee9_1y=+s6%eSb~ z!|^NE*Y@=BO?de#QCVK;HbaF#=_>b*m@fOUVdZQ1W zpU*h4J@oTqv#&yr1W)81wPA`pukW}rB!@d!u{fYuS+>Hl6NN_bzx{sXP)(~7%=^Fk!w99hNGzx1x__D9!#`<03Bd$wa*{*zm;4Y(rX zS4=wnQftl3&=TEJx9;T%+b_&*{9gG@>+|0An^sn69#-1d!`&M&V={9o@7u-5NPhNhwu|@pFvkUd+w?*vuOuO%goiUzr0x^wre{Z@*y{yQG`|CJ-?dGdY zK4i6HzMkeI$y1a6Y*&w0na_GYKq>Ky@s#~yp-h=v;=&?wDx2(`BOjd(*nDD+(0#Qz z&hOs-NY^;+!JP6m?zHig)JKwDJ)3QvBcIt%Z2uT|KHysA`G8Z0w=H_O=Cr-D<*iRV zsSKO#oh|$AuKY8e(y>K)-oiWHv!e2i-Ybjq{?fH|wyX-DzmSLX>du7^jHi_TShKj& z_Klvc^UKe#CZucB#w{Q;q7%Bk3CA6ZU(Z57_5(PxySmKK40X)oq{7ztP|QQ}WcM)usG4 z&OezdkN@IH-76lPU)^>IJRu_H37Q@eJRfk6JNv`?Z^l!S_b7e~Gn(#kury%Ri*$|G zjDG_|4A*?-TCe!yyqDBe`9rzKHa~qdV_xdS;2)BwoNJ?*I5$|wEu1o~=xNoX>hsZ4 z?%!X!cTw`Xz}~YiSIh1=Pi?IaVr*&r{&UH+`Sy43Tg~^gJGl3w{|TS^<+W;adv`zC zoH_gdtT5^5?&HPRHZA|N+H3x!_YYQgy#K&&8TH}8+J$jP{OT-kHOIW$^LGF4uV(vp zhn_aKik3NY=h2%35BQ#Ey`42*_;&RaLGjG}Kb5s^*)6sXy!dUw=Sjl0|2bz}PTY{O zgW+FHfgy{2ocjIDszph<2@fYQO%k#DdHcEggWo3|KJeNJ*QCdFpE~CLLX~F@{|%o# znNNbAryV!{a%qQ*TifTwb!_$XREs4oF8`2OXSaRIfxGOM5v$pBqb}Am|9nVxJmq=s19vr5?Gydtdp_!(PrwzHC2BD~r`8Md>IcqZFfOX; z)PC{t30KjbhzQ%q`|TF5ek}XpkyF!^4->;#eid0Z^{qQ5VZwX$+2Iy_8;2Z?lD6Km zc~^FSH5LByKfwBu$cbs})$euZ%xa%g9QVTftI7?Q`laii&Q|bZa$Pd%i%Q!2)tkQT z+q-DuS2p3TY-g9&pOjpG!Ky)=NkrAsoKBLj;Fq^Mko8{iknxadHC?I?KpqsUrp1ID*>}Te0aZhoWJrS#432@zW-OX z=0(3*WcqXO$thcAzxlMgb-LOE@kdKFLv+5~dd0OsKtK5OB$>O`7L0}k3)ZKswAAL` z`Z6Nx$AS0*^Ji^7a*)^eaMN1j4?2IXFXRYas)~R5$}T7Bzs9AyVr`a7KIIesvGh#R zEo4k?p;6`%sX$2ERSo9U$atG@BC5h>}2IeM&ZAAhH2nX}koj_lZUWgca( zHScm-5?wk?=b7>-ZxU=1biGH6ZuJe^0Enp70N z4z&L?&DGvYj_LUP2l`bitM%VcEvQ`B!Ep4@X%?MMQKO$iEM2X!k3U5Sij~DVT`JJH zENZafvbKEbFPW!R?0&SSKGK!# z-U%gr|2x$qw&-BGl-76gwQ*H?yj<>HHwr&nmKbNLJz1Bu&-GzP%A8FKlEoTYMv{kf zRwo#(DcE8;NpvRn*;n09=6|$}6_iu4UHIvkC(9hS19LfcRT`{PPBD%b9uh@jkC;EEcOi zFYo>Mo`&JOOxtG$`YY|26;?7{Ua~|a)nE6$v2XRsTU%pGd;2$**a`gOnX6XD8Z#-N zUAy)}k;u(^E)V)X{gd$FTpMNZY{#v+>%AQIe>~v2t>%G3y}-4kogHhfJS>{qegwCM zd3+RmslT`C_tV(emIErhr(;iKo{CucPsQ$TVr%IS{RjTq^ZRbKS>O4pXQ910JHU3k z$#=nh0)K0sU!A)&y_`o)GG^IAq4!dDj5F^%+1KYYEj`{zjl1~u#FNQ$!dsoF=d2zcKsav{&k#)rYjdMr|%WEN!s-sT^0{sfXre^A^X< zPk+oSD|mBJl(y^Q~s;b8A2T zcV$w@gZ-wPmG)E>#pM-NYNKxM{>u7fp?Gt5m_E(>i4>N<5HZU4S-v%MShV_uu?{Z+Ti>i5#Cq3h&yUR}GB z=Indos>>VkXJ+niwqO6`eslJjD`F`NDf2X9OqWNjLz30ycEw(dP zR(q0mbMN<^l2PjpGacstX8L*W>`AvLhs7>jR(A1A%h_di>u#=7zjD=lRo?~y`L_uh zPPt#^7kiZaf_?JIV=)OrAFQh9{**dodXj&M#O~GuuXDKfrFE>>#^vYK%sC~B|ESFx zVF^}`x!do&(V4WivFX^=gegZG%M#aLoAl6M=`H`?OzrynjOk&oCW=_ppV>Q!`T0ga zZR^(KoxGb&5<PvoWRVLm@ znfv_5y%6;)u=DBnK-8nfW-{d8mWMi{UfxYC3gN~)0+-EmpC1nTZ@Je__DB4gb*Eo7^(@_^-g(-}@0YrN&(Gyj%RTQb`}X|H zr!5_k^XfF;9^K1w=I;&h&G~7rZ)Q*E(E4^F@#K)tBsLIWOP!*yt+uS|RcIU**qu3Ha*;&M4YjPj z?O9VxYQDMooS66OjqalU^Y?TbQ?BDnAOZWBtzQ_Obxy=s| z?$b__W(d|~z3sF$n^dMEBi(uQj-mb;o5SHnnmeY}AL5>AZFl(kqmTA3-9l+BUTfPI zef{@q#y3L&(=cn#Gh8*6Z#{K>e%&%>zkFkd;qjfSeCIyDV~G&>bbPaRfI*$!chxTW zY^&NA-FjtJB5}K980(|vg0lQOaXpLfO{XVx2K?rEu3uV}UVh4;Of#)%v+t|+xJYrHBYNIsruEVFaC#@Rt3AC)P2tw-94#|=W|k<>&grRGcVU- zk%0Y<(H9B|TYpcx-RB!#P^GZtK~-~|hu}BGzfI2;p3uyHvyjt>`IGKqP9x?NN4CIk zYZNx8-@0qGvg_Jg3tr!gZ82F&OJ@`&t_#2TeWmXN$!A9+-Z`xKp0uW@`~2As&Yh7* zMCQ+4>QdDvmWX0=t{TTjil8ts%0vF>ijO}yH7 zpd;jM!kQ(w45wIce&JLTUR9gqy~srNyiV0>fhiM=_M2>ZQSnDibID`JDYn{DZ)bkn z=JRBc>31vH^INx^)six;Fg*IQf@M``*r%J(B{p`ylS*vts=ep_exqw8H^0^pL@eoh z9(BvB_WiCS%Z|h?c-$%0o^~;^(PE3yMzxFcEKIuZ^*s_;xX zh3@xLik2H{+}Zr((ubs0YoYJ$qQ%)ot}9;5oVn9>@hKaj<&N`;)OXrw+H^>-y_0$5 z_5=)G=S8@p3ENolIJg!Ixo zmNF}jPh|g4@Jjk4@5e=aZ%R+EE<83-@{v)8R^GAHyKgj$rFf3cL4{NE zrY3yz*&Ur0d~sLx)FSrlyyE_<%NUxE-!nKA@OH_9`s5bHwND}=`<_;=>FHR39ULU--_+y;}du{`_8ZX{O(@-`@*9q(54J?DpiuWs`4K=&~q@ulp-q(Z~C0KR%25KCR%{K9$R2Qdj>iebX7Rr_$nkp~k&Eu^X2z z;`qpR^AR)m0YRA*Hoi}esVp0Q_^m8)%6|O(X8S^~^i9RNJ64u2{q3Rg{j9g1->OHw zTZP!TuAXtY|LVt)_+MVLweLp93Kp-nKL7RYgvOon*7`d&G?T;~mEPV^OOCtfBDsl^ z@0q~a_{Me2EQ>=sc{?v@n5melfAaogxbdQ_vcy`ZZLOhJOv*t^n>V(GSOwpRVLNB^ zPf6c*sd4LBk!L48Bv)RtRJ*Ul$~%cM^*onL^|HOW)y6kwRnPTG7n+^8)jjV+QdjUx zj*!(}$J6rzU;cR04I*?)-)-K$qNL{AQ4ldvYp&;;tY_8oPtU*QO|!oE=z@ru>ITPs z^YtIT?Q{;lp|i!&?TSXB$AT+W8oR@n2JgD*XFtJ5&%3TG=(OrgR*kK90?X{ZbfZt@ zyDdHQSJYekmg#Lvp?^8$_6}!qIZC&Bb*AJ7mA?3;42g>UnPd z*xauB0$G*Mc6P^xewk=7S3|^V_9I=+hmLnL&ho`sv}rE#Vi#g&zkKke&AlZnoa>lh2e* z2wsx*d`8V_5s?&z)bm_M)ywYcPF|I9cdysx=AHBWr@PO1+aa;~W?#p~Q@VEM-8cKr zpH*7+vM`-}oMRd~=T;_qUbvlGktk)-o&g zi|(D}PFFM*x`6`qzNf6eMNp=6#CMhdEz1{ed&FWlC;wbc-?=S!y5?*uUivor?z}mj zF4C8#D}TFhH2cC%o$Wf`b?2{`HFJ(g)cifO{^^+PthL;1B~q|$s{VWaO;dK*xjfX|?C4qLlH48oU&Ft-Xq;Trw_P=)Q}us#eB@@Ue~~dqYQ*-NJUkjZ zYlqsy<8hOBSSlvv`)yHG@()?KimkYvEoXw^6n;g2S%pV;B;!LKg>2XOmr-Lr#kTO*8D*2^9-MadcZqhc|D2ni>s$)i0v8{VYz%t6@J-(4*%`XMQNM5bpZe%% z@FT8!z4FzM-zW1w(4EM?WZH6>!V~lAr`((PZEv^nY2$t0JKr4tapHjW&b5~R6Pq~h zO>HO@o!PwSy6Stkd*#cgvFy3;ozGpNe?o_|LjPP{!=C#m{>oOC&#`$Tw(wcyrC5no zm2n=qyh|5f`y#ur#AJ6)>WWX1QU8*5YRXD}65PbfZuzLz>Hv@Lj7ENo6N@AaUqi1`(7*mNv=1MbJ@Q( zt?U+-$i8sUq%eosYPL;C+$~Yf@=vaNOuAhE1m3&&{pFO!4lFgkbNzQtXi+#-G~aLM zevYFrGOFi2tkI0@U!NT3o4;h~z2%#ytP%KTqkUqv3csr#>-)k$NlZ zyWU*sl-rFj)pu*Hx=(Hv>y|UwBVu^%cZo|+sK}?Ck?$^l+!?7NKYzCCr;p$+ME8Qn z#m37%I{!VNV;Ctu7OncDR#p1@rx&APnV>osLuMPkhSC%dtjFB zl)IYhfBE+n*gaqX1K2*31~88Sz7M5h&g#U3goGppMn1Nb4Ib>Rrzf23IF;`9)W~At z$K?w?UX|Ry%uc zU^u)^$JL=Zr)e&G?x%f~hMiC6nEiZSyFdTgx$Wo8i}S1Q&yeu%krV#+`N*H&{DyK7 zjUHBPvqU{_7wmGo#8%T;vTv@(^VhOUnet49FMb86uvpj{r1?k(m>w?Nc3zm1)i6h5 zs;XjtBCodc;&}(6Yt|m9Si|P`K*r$U*&WTu-D9D5o=J7m6!)cx0THl2NBW7GPFD;}2GO!}|==b31m*R(T% zr|v(jnEzhkkK&C(-!@LGWGb^MO%`08bmN3w!o&g@p^hrOJF6#rlka#n>qh^sUFrU( z-rFxRwc<;zZ*$*fTyx|(*Be3M#>^ASYCo0rj8~pj-4~ItGeTFX^87<4?dKN9xml)l zPHmd?NM^nWuX}W&_5T@-wfBx8pjguO;|4IO`rbW#lr; z@5Qyvrd4dta?yf)4XrNP+=Ydcf)705@}6p%YH}{A@?mFX%Vp-~x=vOd&kG51CL-LC ziq3|&4+WgJOFHr7rp(S7_2Z0nE%DD^B!!((v7R2xZTH_sc4g*|zr__Fk9u5bdHHB* zNn43o@78X?X3m^L^^F0U`z&QU7T-E@{BfuHitst}AM$5*z08#DJe<6I>XUP+st<)` zT*-<%J;UhZ^h%ed(iirItH^doh;}tzFqnKc)u5 z_}i7k{f9{7&v~wLuS`WhChE^uSn+kOLe=-f+u0t^Uo>&UzV5R%I}dnm6uZ&Drg83l ztC5}i0tXQ$)gp$qLEnNawoN=)Wj-{prE8UCT zFaKQZo_xo`=1a-u_a#z}8@=wVkbcZN@yp$cg&r$I%Q!ZEd~t2N?F#82g`3NN9Qv0l zv@YKz#4W`cUPylBkD;vIBY)N_6RwA!rJgzoYWWDT^C|FOBXB@yFPJU>aLKL z(d>ygx8cvwP&t{&;O> z(Hhh1i>hjCnLp0Eq5493dxvgQ-%VY;t&Jx{^Lm!NX5IF1Mw^rES;uX~H~W>omoUV$ z1tl9=ZwvA~yKV`e+JfhNjZ!k#KFqQ^d9dX99(nG&!i;mcRgNb`y_pq}^+9&U#|LXB zzCN7#zexP&!c@hqXFum<@pGN6Rm+-V%V(OmFjA1${kG}Rn1rN-ktzSKzg^jwoWTr#6R-OgHsV0RdP}4&%XT%( zJnw2|{uiltulW3q9dGhDA1!{cS}~=4TFZy94Cf9m*Q5821?uW?$b6RhkhE{w!o@-7 z4L6+g*l2jwuh8JC!`{XU-{YBKuPm;UVA~AN$iphSGj~748P|r2$ld?#hW42B? z(&(qm(fmjo?~g%d@mJW4<|{{saL@Vp?(zmF`*q5vS8Odfuxe}JrFA6+H+A`UXSfNR zZob`gL*7R8$kc?W)%Rweov3+@L+0zdD;q-W7bss{u`wY1>J5vW{f`w+#)_4lnWE6u z^qzgA_K!k=^yZUY{$^FDO_#iUT`IFx`l-+VkngW9oCrLhWV`!-f&b*pdC4J?9>HF} z1vvG4+ZNY;YMrOmE*a_eTj+SR{c^3{^_wm|@{-?pG*=<(o=obE^Tw>NzU~y87EzqL zW<&Wciwu9x-AVZj;>??yBV=lfZ_Hx;X87ijFzdEgMVn7=UUoAgD}P&HzCXw9x@v}W zCP~LL-23E~i2ZlBaF5^iNq5bb)j4a5?8^%c3fkU$JpY*a<4T8B>22(jzizei>b=Ug z^+!r=o{3EENB=D;vcg|Af0d>jWSO|`%{fga*PGqTJKmU0NagANsn@sin4<8@Yl_^{ z*ThJtek+rf|22J=#RD;x4Q3lm8~mB4Po1{hoqt#KmpGNj6Z0R=NO@y6G3o8L4>L{g zx^3Kh(QRveW4D#L`kvGf)&i9a5)1S)E^L>&k?gm1Ldxl=ohS9bfBWK~C;630ul>B* z`h_AEFV9{KShfDzN^ZZZ^%aXBWQd1Uf3Mnjzxv4Sdv_O2Ss%X2k9B=O))}^cfzlmP zU-ut&oObl%I>Ylv!k^i2=SP)_?c1`1@zS60?>E@QTN^()WIO)1conJTKGX2<5%Fg{ z-0P#|BYxbO6z#NW|CRpCytQv?nNEu|pEpwb8IV5DI568Z!s2!P>7@_%O?y9mQKwcT zTmC+`vv(fYK0R8}d+1`?x)1L@C2cRC|J_RIua5Nkh<`HH%R{DX=NRS7N_IGfo&V5U z=wjBKHm_C6d)jZ=a~1Y}yW@ARs=c_p-)6(L$*H>(=I=dSaOuWt=f#$n4^?@KefK?Q zIrHK>alNg1TjTN)R=+ov|8z!GO|0EGYwv&O`X?)%8%z{0dh_J>4x5bquMWEAugXfF z<0P`?*3EvdoHiT7D~t9%j5&BOyz58SwkX3_Y}@v#E_vDczH{09*p(Li`&v44n2)PH z-4`@(t+2rZ5ohJut`e&y?U5J-u|_DQWt(pR&T5Z`J?Ydr{Awr}{iqc<;MIwaF{rP5HLy z_V>__nr~CI6koBdxNRyPySv``ql8%_m8e8wK~gAul1Bu@Yhav6*V-R zx!>{Ahut2DsXep4_!moD{WnwRsng}Rzv_eR)ln~nA-De&;7F!Uvh2c zuH>otp}Ojs|Nk`|8Ns@L6_0%1C#TDJmdAc+b@{5)>GwiTYwf(7D90tDKE3_^!qkLa zk5WVpH}<>@5z5q!UwtLDUYs-U!GCey>W4dRRG-PsUU1}2bN$j!zj9cFKWLtQc;m!* zjlYe@m$B^#_q=cD?|$jMt&e=1*K+ z?ckH0@FABgaM#g(rdjdKTi$GwDBx}EdvRsHS&#oEtMtS>-9Mry1^pIrILut%vt;#* zHy>W#`XRBvS#R>q7$>*CQS&UqxMD=|ncWN6cIf!eGufWB^u*i?xhd5b{N`$`eXYgo z{q5l?-h2D9eeV?ZITePSI5df0Wbqu9yZIl^JSp%OvuixDsp;&VdBLuA+KUUAy&qOI zuYa`S+169P5AolqyJqBHoB1MP<(ugB-y9}>`2Qohp<4cczq#?1kC9GlVL}u7WS%BB zX!~S+R*hHM;It;tj%~+@d(SM+#|s-V-V3y2vp65T_~DCw#dgEvh7D)*QqN!TJZ~*fej#aoM_vDA&g5fT+-AQhls?vT z_^|!*yx;fwKTIy%Vso$7zV-tDyJfrBru;5gA&@X@%C#+Nv*mN%-SY16(tJ4mUnGzF z&B``Uo8BL}5^i_;cFP@d?oYC}KAUpTN3q5`EiHSC$fEimORt@%K0I-!vsHlHdc6(P zoEQ4<2){4ox8w4gHA&yr-7TCUn;f!VI)6zClVx#?_DSV}=doU)VGGT;j34@>s(NjB zmEwGTL1|dVTGL;z{w&+NX_oo>_p8^noNshq$CmG)sx447Ki0u$Ph;ZTqOF@}Ka5@a zh4-M+w=k16&o;NIsFgR=YzxRtd-?FFKEHnAi|kcV(-lLWGcs$`U%7EDBhz@%cLkn0 zq1P@`7YNL_*2UG1{-+gUohvhs2u--Lyz*XC z`|LWo>~nXYW%pk6-M`FSe%J3Kf4KjbUt)px=k^Dn_sibeWS7i7I(63jI^$n&eu#S4 zwN9xx`6-LPY3bd|o4bX|EY)v+vdr22dvT4~+kaWE(c9)Qhjz$s@?n{B{L)&E33@t# zPO~RCOl6zDmJOaO8%-1wZ&tsrnXhwllJ4Z9yad*?GoS=KdGDms_gQ|d)) zrZ6Tw6HnC?_!r<>)g$uv=Yh1k?2T-jPiP#io7!kmAMqv7QGV(dL*3tjQ{%&D{#|kI z+lQy$HNFK-w0Cf=yL)1f^4cDi6nnQ!Q1;pSHqXpFE>5RabD0dqpc;T z<2+X;o9c>PVUf1xIZTHRonOMdJK2ddlKZvejAc`}?tQ=M_2S!7Lq0rR-ME!G1pYTM8_gh5-E`AWy$o%u6Pg_92e9gYIIv#>K@3!vTb2Otg zotMABd6WN^tV4eA~^f#pTquWlQRL|M8rNnxEKJzGUf|`sep9x7v6IUXR+L z)G9nn<1A#Puw4+n?Dhj{Pa!U{nwBi!;#>_K<-13+ z1X3M7_3(dHJeFnsaAm@YbXA)_(Q6pYN=~Gu$?!Znk*=UCe&bV&b!+VG#87b~OJ(hX zEj?aJ1~vXC(rz<9=bV*j>NN9}=DNF&uWwy`@RZ-Gxreu|_ehNTu;oH-$Mb~c4$B_4 zEbCqUy)?4b{`RvItGYLuxNl3;d^2O34fnlIw{I-womO%yaWm68_jf-Z3arauO>}kj zJ{UXgz^D5MFF4(H%n)fmY&S<>=H^rVcbewfg_qnjWwE*CyhG;OD!HEYz~BvM)gK6^ zC93v*3S9o|OqtvNhfXuND*5*8n~?B#Lx_dRt+1CO&2!uq+x8dz%&%qI#ah!WmM6UK zv?iBUOU|s>3Juo3I5O?m1S?0F9Nc;$cK_T9CAH4VU$(h^k~Nt)xqDY|+SDl@vV0b- zGr4d}ow&*&rC& z;=^Ne$9-2cXQ!UwQX3bQrVWQTRUS0c*%B+}>SobmquOHE;cCNk#%szZx#=gqm`L+2 zikRPBAziT8UgvzPed)5Gm;%E+kAHj0EYeI=UwJ&P*yY2<9c!acR9(H$-^OYB#mYp_ za`l4@r!i8$38HSNqPp zm$sYv@hV@<(3cldP81zeJ*}zWz5X75_18~(Q#qd|JZHNhEzZ2_@uWi!wVuA*u<*F- zx5E`zOdiT^5mCP9crGA7J&4C5CBwZWJl|xY?Mc04lQokcd7A%j71heW*27hJ)wF3< z)Pu99mW1{j&t*QnUWBuJ)modY0{&kmxPDr4MYT*m&{xmv&Jz;y$}&W=sH*Rx;oP^= zxl%V|8^2kr;(cdT!UHdDC%%PKWt^mE{V3aZ+HH1|`J*t6*V=gpmt{Zk$zgK;yZ8_L zAHgkxXWWYG)Mtr(GUP5^b#?R2byXpEL!~}%Jk0&ZL|RX!u+k+Z#=~XF(z%Jca_eHR zO^n{lD=L*+>z1k$UETjr?>f&c*1XjA+aLBn>sV2II5>kLi)EKV=f8D~?&{{kA-->t z?}aC}{8IX}pnFbWv_qKD0jJ7ILVlB!CiqR!T@z`yaNSDA^{*L(f|XylxO-?BXIk;h zP!&>KDH0<#_1{rP+b>yd*-efv$NTq9&-pH8+Nu{I{WkNHh=q>Krh`!@wmS#Dn54GH z^PtJYp5*n>#pQ~fCp!H^7NnJ$D{b&i%D8-HV$g4n^cA-k z>CLwMvgrK5W7{5|Ua0sa;MPnhG2Wh|N>BPc51MFZcbUBBUh<>ox0^r1$^Y6GH;yji zGS^x???$VPMa$vrwQnYDo%LY3?L(J;Y&m?U{N)qBtXEm56|v5OBeUW9j%{-%#=Uau z-OBZ?M6~DevDNMtbKXo~pu5}$r@subMpNoRUG6hF34<%I{o>;OQAY@ z!A~;#-&UomAK#yLtY8DjF%fx#O(K&|hi>3nv4}0Mul2Nwy<`%5?e0@45z@uQ=ToLk zI`1%H`WN4o;`bVE?`BP|%(i(_aMUj4Z03IF)YyjAj$W%TZ&>}8sqYBaVh7;_UXgW5 zMHv^ubyy6uCm8;&nYC*B<4m{z9fD~rm-b5Jh#4J<-gBFq^ZBjN*6gFtp8d^NRTn<&pxfT>_H1FW9zlKFD2bXmI zH4n}ap7P9S3G?NLzJ-o`(o&aR=rJAHqs7X=hD*S`=8VwgX(AV z1`pRf!!K?Z!gKTQx33nLOpLv|>h$xDYaGlqSEP$%PdkR_P2sw}%c!rRP-~rI`2L(l z@lD;^yxn^i9h-9Uw%K{+M^{fIE@^yNB7AZq&w<5-*$loMzB~4ZTdWn_!nmO{O5^CH z+U#_}slNWg^H!F1-ArFy%JbVMz$92Zalw-R+I-nR&(34b<(a}b@9H*zK+$#VA|XtGIuWf2HiNe z;QWuTTrU`}m3Jwux|GBE&f~hbS$fOy9E%&h2bVbh)ZX~Q$YpupKT-CWw?*4xMda9H ztEXrr)+*n*@A+72!{zrkB1POyUP{ebdRx=3`0D8+7vq1n-SrWix=e0fN|@vZL%FHC z+&f-zI%Z#X`X!RIKD>F;R?i7%%vC!sNLSxXR(Qdv+}mLORqasANqOG3!Y#he>krt< zU$$La;CH?5ownDvyE5X8@Aho;c;2{4X6oeEE7qN~((-*f@gB?Uo@`z}HmO5Vx9+`B zoih8OAG2wr@7cYJrmXbbctZb`rqYSkjpf_ZGdg$PDoOphSWfpeXE8(S%w=;NOEq+_ z8$FPJA|YhRea&FSw2s`K^FKM~p0~TA%CxCwmBMZlYS%Q>h@LUjmpJvza=cUW^nK1*j^hX@bBkFr-+LUu9*=vIT;IX zJP%IsFG=awOfMsqb3)|rG2a*eD%ls-FS6zk?g~&Z zb}9N5WBJ^&I!jW-mr1$Sfb(^cjQy<>t zo7kIPesa?-<+^GAu=%Lb#m{`^rAe~7wuL)cR!nGeo?OVPK7(tjje)(O%ioqIFNAk_ zB)2IzAMaigSv+H2RPN62Gt}2Svn9o~sm(O`deL{MbYtTCyq0$} z>X$!yk)Q1I*0wKc$F$r1`t>O(-iKWzOLQjAEjqT$NmKnP&%^%<758?EZgi43!+vhs zu~tdWSFv^pY+o0x5zdk*o~JNBdB&FI-`_Um$laXcr5Lhxjq=&`p&R@ywxmaee|va% zMtO{~>$@G7%@VqTnRSnGL-0Gs4>R5+7%eMydcObdr!QstecX`?T{xYCoS=aV2^8Gu-_jDLpZI12VqI4kHq5As%9^Q}lz8+ri zeO>Xl6~>m*cbqGw@33sqoW^?VkaBKcs>F*xiJPgDcE zV)6^ti&skDk$zm&T)jG@RBhwIz0#Z1P1j3RPLG@S{^InwYcrVhR&73Oz59#ajw{Af zHU;g;bmHD}{dfrf^AG(G9=N;BnECH`oVBH9-LBK(Dt8FK%nHibWlzGiXrHv9R8>OK7YM_6K|V@~VH zT+wk^b}2Bu=SGddsDQdX1~%rt%$eNO0B2nZtk1$Wq!uG6oF}vtbQ~z z&UrphE=B0?j-GvAkN*7YA$j0#-0AOkr|DmWU=Qmru z{lwR7*_*T(_k|eBs$4vhc4``~{nr(VMpM?vB^-zf^Sb zP_xa%)K7~Ia|Po*Y~(q3{?{Cx^Ybs-$p0!%{aLJcy1eJ`r+$IxSbbjGqLve&1mxN2OV@}{#};P#|y7ONG7IVXSUI4Lh)+nc?*U2*1CgVSz0 zXY@B6`aflx!ReVdJ|8zVC~Mqu`+xls*^70Tr+zby{ATm~R@=^BL5EoVriI7LoHwZX z6ggG-(67Gpr7}LO4>stZm)-Yx*WqZ5wG!?vf$hfyABOC|cHr}W~!o6>D3OB8pu z?)&)qbi}ORvdiAt)&6ekyeGTe=}gO3r8yURZpn(DW)F?fO?xnZSGcLtu0no&LAGjb zOS3usqMU243*I;4oqe+N$FZHhpSlKq%n#D7xKtYx5&mJvhQ4#W%%6X+Oii>+=|tKxS|a*fL6(3W!I z+w|=Y=Sso1J6pFLKegl6Va|NpocE=d@(f;HewNxQW)zux_H54)n=3`R))Dh%WeiE1UOR_W6Y$(hhiM zpBLEmDk*oiLB}DbKb!qBomZ~V+tr(AXRRo`HGwC;;>6Wn(c~j_+xWKEw`lt&9&x)C z-?Jn8h2~`GLTO$>^B>X4H-!CN@{L_P%Xf4qUa^h|35}f1`O*1K$V2BlN7rr4PYauo zwb8~m{>kHO|4%4RzHTD=dEPy%KVP=-E?>3F;`!Iy2+q3OTMntLx&7d&TwT@frR?1s zZf^N{`L?cYtAGC8;t#sZ>dH5Y_ual6{ky_u?_bS~p0HCz`7C=L#qHVSJ?;OuZ~J$@ zeET-iGC!Yvc}u_giQBhLdN#bce0=-l%9`ju40&Dh_wAnVbBR*4udT8EXX$b9adeA+ zjH$ykBeNbo+cS!~ZJVZ?Kle56)<1`^g;8gopZFH`_uX^n#~Mvmx9v_X;B)+z*mFuS zHYG`LZmh(`oATZ+>8~g7oelXtAt%OdPW#o52G`6EE%4aIFB5+J3cD)>w<$>-eQR!=CxmI4_oc2I=lSvYW{4fMX|>iy+lc!;fEX$@0aS;-0gfFDez+or00TGtU|bJ?HcPxg#w@72}La-9At z!gsEF5qn16BeI%V^>$%SGzCM)pE<8!%rm4R&8GWkx%K=4O`=vu5Wp5 zMJ}~I*q(O6J7e-vC%gBRlV(IU%iEs&7AL<^b&W@5S(!!kQU$BFpM5F0e>0+GWKWB^ zyXP2cpY&7N&nNzP%Fa#ivj0?7$W09hYTwd&^A&e`@7(x#mvnrq7C)Ww^~#SHpTkNa zk5;o-FzMzu823dTl=?V*%LDzzn-@)9WV3ah`{Hd!s-?a--nkZNSJQe&Xy#AntA1_5 z4a?UHm|XS|VrQAj{$JQ%rRJ8x6U}!)ij$HzoR&+q5Xy<(mSFzs%kPczj-0$XW8UNQ zyLi^>Ydu&XIQ3@no0`kdL|#wVNPQUd#x2@(Q$VJ1V3yeK8#)&`&mUqc$Ok#P0ayeJrBVdiSS@=7_nAHtveq(SOHUK>r~3{S?b1 zIT8J@Ce7`)iM{(|`J-+w8`=MdG}}$1*Bc-ITO2bv!FqAv{1eM7A+PP_w&QrUiZ6_HEDP29RHJLACey8f89ZAv?7BcGmGnmJ*dA;K9n->oJ zGs`Jb`^@vVR`06LYS9o^iOdj|s4t0%54^3qm#Dn4eo;3?d&2sotT9eL>7F@9;$BQ@ zt2HT8KB_DzBNezSatKI+##2E?b!}e34%_=(N%t4nh}tdBSC2XO zX141=@uJT{v$fy9J^Z0JQ0ju=&6T^tO+620B>8+wo4Tk`PH@wa{2u-r5tWQKnl2sL z^F)@i8VzRO;>Z24~XX*&C*LRmw0->BUh%YXROySOt)U7HqZ%nn|1LP>Mw zo`@^?`voWRr+rdX3od$`v@CtsDI-@kU{ZWKR5k&C3;a$ z>r}_l&=8i;usw-yGB>9_{QiFbzf(8Vv@a>Ftp9QR?)v@z3ZK7UqW$VRG*=* zClU9TY2CZ?A66fIDkd7ks&6*a=i&Ot6Q+g==FfYkc;~fB4IfvSsAJ63&jR`SOYZaS z|8!sO|LNwqO|35rWI+i2$`uv55 zf;IO3e~u*c#A$giTCiqa+L}kF6Tg>TZGU9q|DdisPBL@{n`g`P*6g*9Rc@seoOLyw zdqlPQZb%qoP5c(_Nx1>8+Q+}{Z|r6DkAKAdVO7t^^Lw65+HlFP8p&+atI1am7dZ$2S{~Hngu*vau@+du0E^ zT`V{3&%&qK=4Qa;KRV~|D_*^ZidE%bj!i1Mx6y$AL%Dbj z??WwDktLr$O#E38zk&Ctl6=($?uwclnmb+=g}GTq@7rM1zW9oTsd3@wPpcn(|9bjo zh1as@8$2o}K0PR`m$NPLsojaGt{ZBvUr(I&%(1bWGrreelP>PZ zpq@UCNGV*lJ^ zJ}>zA^ zmPY)??lM0V%T+_3T`_L{AKPyGd|grFd2Z(H zl`|XaoBqz)KOtK0@9zoLdhdl>w#~cKvSZI<87;Pju3PV{Tg!Z+S@2p{l6$4#o@b)T zm6593FMij!6IQrw<~y~?-UYlHE-q?$8Y$GSe`()a$^B~ayVk|ejawamH}BMo+h(^~ zE_%g13yX96EotRe+VlGFx;vZh#HG*9c>il3cUO+aHlN*pN?+IbG@oks|FnK%M~q%- z&aoygUiDTzF~g7Z!yG@Jdo?d#;aOtppZgQD8`ev2zIKQN~a-#1K%Vyy-<%-%0fuGs^^`5Co2-OIx-_<-;>F@a1SVe=CCH4D5%{iaW z9c~bRl-cd;&G<^}%(PQGQw(x$Wc=9u)XZ;H#oO#0%yuLok1s!i8L&OXn@AJ?7)r|=?>QXYmPx~_Vam}s<$1ybUrn4dF3=UCe_>vc8 z{yS}EDrbG|`vZC`C(RzM(5Q0U)@EF3__m~V?c@~~K3f0ywR}y*L0O6Et0(<0D_iZv zQt;opr+Kq`_-Xs6$Jxw&drZI2vf$|YX4ikOYMxZx;n;5?GlOfJLwyJ5KIb&ql)}_E z=N7$BJW|fPN8^Uk={2i1Nk!Wo7Ega^RZ{$H+tYIw(~hUk`}pak`k6}yf>y@5Wn4^U z=Ezap@bBHjiI=KoX79XvcIlyyk~tf6_UujF{Z)?VGFwyVHow(d-yW(7e0ccBS!2y+=c`|fwRe%?l4`UqI4v(!wDera1EG)Kdi|$+`b}m&ec--D^U5-& z-*0cY+%o*(sw_R{%qJ$@BX-*R9@!n+vMuf%>*Z^F?;ob{Z#pa-`b>J0f8WbZ9|S^b z8)WYMPGmTdyl~On`Nt+WFN+9U@PXr;+Xf${{LQ}80|WW2yIc}8w`?iz*!_8V`)aT1 z4M7(^eK@x+JJz{d@A8JDysu9^wD+la*jmG|CR@->{71UYehJnFTZ6@yI(fXUmHdtO z$h7;2>|tYBpWS_bch|Jr>aRD1-0pXOKjX?K)nD9WHFGj7-Y1qiGr(oS zI*v&lhkqL>i5_XawEgqe>DKSrR^OB`yI_4v`zPz4cw^Z~e}1m{cldnzmS}^UFV4rL zoHCukZV_s4s2s4)`RZ29zxP-5@H1OfrO#kpp2E82C!X7%xpLiEWx*lwJIs^0ANN10oa$`zC17)ao#=YErKz2>U)xID3KoZXXMxN%NM`Lp?ts&fz8H{>tAD!J!qd7t+BgSTq;$%SoM zzt22`Rkm%Ta+RyiZ_7!*lBN|8ZOsOJ+T%`|4xpMf1Di zN56a$V=`Uq?fhkT_^BL;)o<>f*dW>S+Om1Odd!KQl^l(%IZ5lT9#AfvtXY2ju_g27 z%I;~O9~NG6y_9*`t?b^e4yEIVOJrAV;*nBVrPPq#ArN<{M_QTNWRu5F&E+nN&J%Kl zRhS|xoT}LE>Qrn_YD!F2jL*J<> zdk)&KH`(VaJnMMt$M??PAH;6nx>98gZ>vT49BCD2@gH7($x(;aUb?p=rr|}>oDW$A zjC)Xi(sh}KWuq|g{xw`sA}*+1vH>K`YU9u#=Ua7xOr|1S5Lu(Xqx zHQ5zr{WN6xClQ%d_;SYbyEpHcvzMf;DPuB!!tCX=DsryFMj8H^4U72Kbt|N-{-Jp+ zmb+T%7n^uykcg1Yyk@VugSR42I@+KmO7Dox*T^4See%t6k$0C>LgPT%9H*^2u{&e|;behdJ zms4Up@)9-fW^Fy9rlnM=5XRor;wld_`-TEKd&(_r!u075-TdTvo;Fu++zmfaI+r=(z%x#mJ*SOe!VL9H< zxJXGOC%<3N{Hl=`oK{6(5=ki*Awk$ z6ONuueXbCrp*`WZU;SU}O(spti!Mg8W=-x+x$~|lA~ovGCe>TgXWlv~1?w$Rjp>(P zChQs~_wCFP=}Obp2`>*h%yB7JUBak(T2Zr8;qf;GuG(80WOJ6BO4|LJ^91L#$Zn0h zQr)5(ZX}kd7qd*BwXxe|=X8&bfahP%N_X$L*4vbo|JcHK-*li8`^L=yYxLzgVZIiD>%-QWHih~!4KWaXltkUs3 z;Hr*?!rC8uPkgw$_F~V4Ydn)RG!z)+y5%|T4q2UK>Q34bbI(sD)J^EIdD_3g_cazJ z%qjXhXST1>37pv*vAiRgcgfMXg3Zjx&uD88^XLf(u`JNSl?q3)a?HSWF zOQTyKUDotEzSS+xbk(M_X{8r+)>yxA_Fo|Wv~AwET^$c1-YDH;ak42`UwMW9`?>9m zixOkSkALIeSJ?k}&y_5dZ|rA6!ahjJ2z4H;=oPZMIVsZPiG!{{!TGl(!m+#k<9;;W z7OH*KqaUF5e``_f#tQn};PoOkoEhE5Te z51ZCFQR}Z~z*M464^24!; zyRQ9lYMJ%xuFR?>!fPi)O#1Ue*j}#M`=9k~4$G+Z9(W z5==Hc`W6|?8CzvE{ZmY?pVK3Chccfi7OCEkC2TT(n5)=tu^(J!eDR+^vXqe3w%8cS zb$tA%id?$XZUyYf^4bvPX!Q70$%RUT8uy3I##}#rw(CF1oW;fY&7lfQp*J+%2hkA7+O_=h3*iD%@Q_}ta zl2G}SN{)q%6EA$|dwgpL*PQ^7i*o1YAK%S%#;i4ScJP&V{uZr0Ck2+i*_5}xVEUWa zTX`3^{FVv3t@Pq)j~f^B|0G3az4)*4(sx+iC~9rbEHRL{AaVSUfUV1f&@~pK!I_5+ z_I}vlw2M1yLCe+I`JZx4&F#~!{Lwrj@FQM%)yrMWFFg5vr@d|;kaC`GzzUR}D8 z;f2E43l8#Uen#G-! z1^+&b)el{2b~x<;$0oiVjVnH^n>_3M{X++JEGv$$ko_lcwlwUay5+OtXKPn$O!T?l z`OJso-QoHJ3b9|!KOB%2-G8~^(>r-dnVs5;gyM_66t5kb^>xF&cW0Kw`*KODUVBr& zJ-}z`QGO;@HP-Mohi400$FqOxwRy_^c)H(CuBGn_g#@SQyPKtbj^NE(eQP6cm))1P zr-y|so)n6jpR0f1Dl&WCjCqSKjLNT7yB&}@>2WVumbo_fi&WdsQwJw~c;)mXk4sIe z+*I|K(QWwz54pP&t1_?Oi_S0I<5;oMa_PU-E4Usl`4SLw`s0&q3t90t@4a=8pZ~S{ zZ?Wms(mxmb)fSjH?AU!!Rc~9wv?UY2 zBW%C1O4ZAd?aImWJQhwXJ07y#y|!13dD+&P2ef+*teX64*Hwn**=dI=N|#%6%~cb< zc<|v`_S6%*Rn}}utvPY65ACL`ET1 z8@giOT;^*BE0jRyUS0n8@2mDRYc`8X`wkvd=FpwDXw&Tl+S`l$ z!)(76oy+#0-uh$}pW5WdhF)K`yTopp`aby8GUhW1HtJj-k{WLosLqs=mz#g;tlgcv z@9mB~w{u~vjCqz=w72U}int2P*)D^J&i`0Hd+{2+5d31LaH8tNG|xw(mR};@tyQ_W z$4Ft_R-syXz55HFyDi|c?PT9)+Z%GWTqbs1Y&`GE4}9Bf1#jGq_{3gmUMITB$uO>9 zX8prituCBdrl@#$mN!lmb2TY0x+f}q^Yz9pIm{Z~1vG~_&- z!*BAg)1x=!%Bq}~juO3sy^k%JofCh|I5AEB68GW-4mR&Do4zjCB=P>*!J?T;$vw&! z*7_Zs_t|6ZGnT+}Gx++P7fuR$C*^ZTX%~|3^ckPw0ecv zWZvN{OVvGGa9feZt@5zt;sc3Aao(4MzCHbGU?QM%HODGVTj#;NYv)Q;KdP~|-c<9u z<>^-T=wjt{hZ${i?yX6VX*R4m+xH}86Q8d5D(&zWG9jfOHq`WeD`)DA4H4h4_u<0t zL19fT^4G2`crt_gYRiQU%*T($SM~}T+*=)_Inz?@>Ac(T{f%B-SkiENt3hAmGM;Ab z4ZfLnN>kN#9+>sv{lV(zuJU^NTW&N*7wY=I%FVqsH{;{hEz{VXU$5$%=s9^M=VU$J z%m4F)z4skbmyPrF9t?atXt@LGl=Xbx9 znQg2Vzk2Scg62rx&N)tEojbP0ELe7DS!TeVin)e-R@w#2S6mRzSFwEWx5|*GC~2qe zFL6QH!fB7y12qk+CVA}mdvg{0@!bE%?@#5M;w{E6lG2{-L; zIN9$!!WG%VyK3T_!iYa^U#DF#vN1T(<@)DKOr^a_b`q)IP29W#cj_+e_FqMY;u<=&U<(0`Lum8eq6gBHD=A&dSbnM z*pZah;IA8`)~@9an%W@ZH?`*2^TkR3`PHRt8XRT_Z|@cP@LAZf1`ocGUCf-a~zH(_P z?~dRjp3A=_7%H+hzp^RPEt_>gOEJ|uE-XtWO6%+|`~Tk!9%W83;#eva()&&~qF-ur z(QKEF*7i$QHvE-(3x5ga1&V0hT&7#}H>J(a;^aJqkN#nSA8)JL3e|XSKHem$6Tz9V z*2UbZxNieDFPG=KMJ1jp*RRYx_%eVo_RfXXtJIgyW7EwIew356*zHpJEGzzHtSyC0 zPJjA(!S(Kc{*&1fRRUZ^p@)sF4u~f^Y1S=%CvkAnQs%qsq-rC*giD-b5^pr-XP)(A zm%b?VBug(pO#5QL^9R0)3|*&(N7_pHxQSJCU4P? z)zyJ%HjFy^kNw=Y#EmaCKC(r2+KPnRGp=5(XS?^1|Mc8AF?-+F@0x7g@9#c;I<$GQ zk;B{UlPk(re~sE`oR)UihjZ8B)6c7Y_q@?dc+!!z^Y1e=ziM;si=i*}-wke?c-&Nf z&CY#)-YtBPws^vJ$GNfFY7$fXlC`%<-_TQh+10!}qWjD&F1x1PZIs){03HQL6joO(!+;WvmVSd96A~TzcY{*nn&o+`HG5RGw(R47pU_bd79*MjMtpM{OCvdeaq(XeQfV}yduf^ zZPL=s4^mcb;!TXq;+l6L_Rz-qNLKwHWtPrf!m2NFe@jl=x%ud{>XwW35M$e1>3#rfKIKOe_^vTZgR{eH~HNMb7 zJZSl+rE3;V>EoA82%NOUI%!5#sK8pel-0%iTBX*@mVDdUm&m>QyI*Ghbh|fG&qoGI zHs>E}QXLU`0cs8 zCc*yy(QEu$U(~E`_AKCvRlXtDV8D9fw#CNdR~2+FYM9P{qEMk!WWS-QqF>@f2G7Do zAt{}|?Y+q_B;Wli)8<|Hfupb><()>=yMxpE1$TWfld4+uRFU`8`efhhJzHL7tXkHs zaYi8U(%SzSR`XKs=-+?&VAhX-Ev(ADdrM^s1=Wu#T0Wnd!nA(vO?OK^4S`mz*J<5; zR!xi@^Ve_7?DH3K(|SCWxhVD>fA#4ba>|-#v_6TSl+fLteN@7B&CL{y{cco?U}h>a7Nmu{$rkr@{YlauN;~nos%zae#$%DxnHJGRmJ_k z(2G-(Im30e429Sw-z5L2-M>ombW3@YXy@s4rm_tW-7{1!nc8PYzDnHJD)H-i>E_vH@{hTSYq$nr)6seGu_XJ&VErGVVzX@GdTKn zogc@PHw_kz`4a-xUkGcqt+>eC+4s#QcGBKFiJME;g}X=TUHPNf;<7i&eCOG1mF6$3?=deVw=jO}DRhfqtHAP-u_Ni)C&ane76J94BWp64e5`M|hsivv3Wku$3 z-MPH^Q$NO8g^K;SUaxF0-|c2kZqJjP)M+-;<=CciGuHk+8k)#)RKWFnnY(IaNWO`; zdVBhHiCvk?^q!>zhzCozq|Ls_$2)t8X5WL#6#}6Fox0Z#FK4~|Xv>;_qe|+D2OXxY zS+(hSuwiGZfry5t*7j>VDh_vd&E@S#`M7(={l6(I7`^VhTsB%AD|@6Z$k+9I-mJ7b z-Aj*O-Cks}JWnysdE1J{mybR^e%yF&PP5m+y!JD>|0XOtnPBn%ce8z%`=0WwYZ)^p zx-VelEs?#WI_Jm9Rkh1Jmn8)BUzr*8{OsjaExyie(IskE6*qlrl(y8E@;U6Zm)~m% z4b>BSulX`I zPd)3J8o2da^jQ%ZvGyOcV$81ZT(L3>yg*?4@n?s<4hVagMqc$QmvYLTlsj+3s^jkG zW0rhOo7Xg#G2J$G+9`>?vyGiueMNIpy^jC* zY4<-gLw5JO65nU-Zr2ZMN2T6QE!y;fX|pxg;>s!NT`R+mY@S_ay;^Dh)|vY^+0I-a z^>$DH`-M+dHy>6hahi6q@4le;SJTojPA|*1-EI3aZC2?g;nzl=oLDxpaMnEWa)_Jj zn$)%Wt6%>L$=g#ro{9*rttwuy>_)oDal{#zLW|cyw)CK#aSe^$B#+muJg^<#EPT72Q?OT z{74LqTX=>|~hMW!b#0T%Pzl!I!z-x3AFtfBbdA`HFXc&^&RkNSy@Soi*wVJ{Pt&B>C0{Ce{dNn@vithPuXlOkHtYG( zTdY5KrXLPovGvK44whdl&M&%fCE30(Q~rFw32QS(aYmkriP}7RsWz^Q*(9IH|8cbZ z+BUa4(sz+u&wYnKpAzRKPS(FQWlHxx&yVr$eG@kB$~8F?bR9;q~3vFpZs)QavX;Iq!IWLqlUj(Tb=f zdBdavwO`6!KTqF-1~!9ZEXBzunT4ew47J}XtBrPPk&$Knb^rMV$3E7 z$v#i!o@Lf2!@}p1IMs6gW!L@#%DN?4Y)Z43MO7mO>TVxv<$d;c-JRWwFYP+%6BBaq zd3#xFyWrl5-&3Q?S~A`WInUo0Dx47O|9`E}Q89IqoyI37m;0toNR8FI@cU9uA){;O z-v%irpKa}@bd@&0uzM7tp?CUILg~xQPyX`^`CeQNaaUxjynN{8{i{OE+8UchDa92ki0?0Unw}N2VEsSYqPRZ>X4N}#V?Gont#fcTUcf(BMpddn*_HXmF?^X zzsSDp^Eaw~+n@e7`eVrBqW1Ib&!3;NliM%%py=q5FY7|)yu6h!BBNirFphD>LEAfv z4|=)fB?KpFvl*~vqQ@M{r{w9^Tuvp#mrH;d2ceW{*4T+?JG`vteP`n z^=pswOVf=?rXST3`CSW7K-rP28E71GJC*8zU^5LI!_1abMe(BlB)}(7_dw-R&wtRI?CG5rGm4BDI z`|2I$KhZ2Mxs+?OqJCB6yTvCGGH<;5yt-(2%lQWv{id6wZ4Y)?a%-c|*RS@Pnf-jP zc7~hRm9;Kk=V6eqyS$+l`A8>hgBcf0+L%Rfu7=B|$pmfBG0w?JY`@``)jDkry^P4w9JWu^@O>nN_L zfqVW>xD>Kr!VkI6pM;~#pJ?#EXa&b=!y3L7kudTVd=N#Db|ttWGKwv(=2 z;fX%)omM{K@1;JezhJHEpJjG2bk&TL3lH9OR{wb5rN9cg>Ax=+hs=LFec9q~7F#=vix3Os^3r6w1eqr<~t1ajDn%h~AwyJH4R?CY0to!9g zXG39Lu%Etol}~XU=?X>XPMR>rm@4#cT1cxol=rJ{*^= zm6?69^_CsytJl-NN|{~$D3|qv_x$aBGTE0*JsGDL?)24ov|ixquBWZH4A*WHcVErx zu`k6rYj5S^Wac}}v1@#P9GJ5%%hme*(;zvZzA#d&YchZ(%>Zy4-m2$#lw-+Z#e@r09u+{3}ZOT;cJM)6Wb)e-YifO4_?I>Gg-h*;68qP42Q1Vb%}( zc<#TR&lF9wW1(-($truq`QMi~eDsCO8K0AGNmopN&I(oysMFp2(Q&0;Aa}IMvDv$o zjOLiGc=0DUYn=UN;0)noY!_54NOCx4F8xY*aQEO41c)NKB zTUvhkEzof(=V# z9AP#&kL-)PdwFH%_TF&V`=ow~;j=6GzL`s>MMqw7b~vniu0eYJgGFZ*vz7M>T@9Uc zc-N8YF3)?`=QS3r__uF+KL0#X!RZP*Pi>b*6{V+sY0EU*`-(4V?yFDh{x00RmbCyL=cr5({bl|3wdK32 z_dVC899A(M=kC*)a@&NL>xlogB!-rwhvQDUaO~k)%(+G4P)@H<^yY0h+3J{AS0>#R zsn_N`X+3|Zo+a7)#vZNcFf!5ySCws z|F4IJ;t7fdf1mhmpQo_QqG(5^Xz4QWr32DYkKUARqV{Tx9Mmnr4*(}yQ>5mPT@TNktZ?m{eQ-{E9&>d&rSKo z$^Zt8V3L8MV$Rgy+j-K80#ECeq*YffvJ0urxaudr|Dl65c0U z;-eB5GA+Eq=<{vjrdvXOPgiVg%32Y9@?c=>@$@vc13Vj_pAEX>o%(Lg%^6)6%f2=H zIY{vJmTMkQD(dfcZkOD8^u9sRxnR*RS{d9@t@FNK*#Ao8{S-5iTu1Y8L92Tjn`G{s zxOu5hI7K#d)`oZA&p9l3Qf9CiM7&uy8_rzg8N z@d*eY*YTL4yjrv%sqTwktBkcwtk|-^q}7``blkE>kT=6xYxg?94qzxzzv zcNeI-NF+M3FaEUfa=;?p6S`43yf-?;kH$upM8{N34z>QZQ|e=crrT16XJ@v~UUU7Y z5FclW3AgG4mSrLDSC%WkY5tO`kume21xnOVDtC!E$%Zqc`zM5Zk zKK$3U?oUP2&ME5NS{i<;(229R6;NSuLzVIzokIibH3&gDjOn12WEF3Z1>dXx`s|I8S0|UcW5Dhj9&ELpo1u&Ii zHOrkF>~4^A8LI+(z_G|a8^o1{#bpKq12_yof|kq-450J?31=_3+ri-swhtQ43C#YC zTznSpd)l;tA3=BRD3=AnC`xqD)jxa*~1dcB^+~HTi zRD;z(4{mV&+yXUE9v(&oC}9Nh>l|ptdkYUEH&9;k<5OT-2niS$J`Pt%S~>w$%Lg(S z>^5v^2^zN!Olu)-!-!f2Q2rGGClCgPH=yuy;uGit<;Px7e(Yg!LFLUKka-LY4C1hK4NDU){mgwV9=)tRY|ZS<-xxs&!;2eI zHX1;~N){IOJZu8Z>}^avY`v^~Ed9(N_ey{YPzDBuy&yZC_yl^H-1#J+?sehQXlC`} zGhoVr_|_5TTqj6egh2Ja1Gx=nTtLf+0HzCA%QGi#a2dP+Y8I4Y0J&`olrshHHaEE2 z96@e#;WMZ}bD9e`1Gs$Ffre!gEFHtb%L5c%py2XoW@i=$hZiXAgX)q5sGfB=!V8o? zTA*r#VDW&{-{3Up&NqP(M=|2a4YKnJ)I4XHoqQ7*kuwOWF51He3IGNMbr1!vi=x2k z0>s6Ib(ui<_v3$T^332`6H|tn0aW^96NlBJsB+8Ck>Oo~VNNO2aoRvWU>OfFE0uqPRw>%7LAPy3~3TE>#NP%etaSP1k0hi@qCX~1j zrg<1F!8C$+0=3rw>LhSk&cMJR&j@iR%zdD86r{@u6wnMj4Bj9P5_X4*haic8m_AVP zL=XoF2SUX&k;FjEaHx1Lh=YVU-ZnIP#<4Jr;QuVAvw z;1(&22chM_>S3*JXxYWUz+lD%DF+H5%HaJ=5SN(&R11PwsF)cecR}Qt8KfZ$G?JMC zmP=42m>CpN1)w};24yGHrpQWYmNc6$YIh^v9b z!G1<|B?E&oNE}rN%yYmY9>NT9=K-)PXy1r|fuRhC`WhVKEjYv%!OVvSJh;Eaz`$?_ zD*gZ}4(=~8Ffd%jVa`9OdIM;E4emEFFff4Hkl4agj|Ji{^m;0p1$#J8hpG>N*7e}N z5(5LnI;c2$eRP(EfkBZ;6&h*`@S6K24)Z_b5a(mX?j9)|;u<)_J#mPG+Bew3ClQDG z0#-=41%MjVuznK*14A2BTmaf60QZX+7#Kk9Mr`K4gQ`cbPvzJk=06aJ1RbcK17g{* zVGjpisQL|(AXN+u;64fi14AJW^<6l`7emci0BtCM`!5U(4ELbo8=yrQxG%!M!0-nu zz5vv4VqjnZ_a_(_7$n&t?l*uIWzgmVgDF(p0V)paCxBcW%Z}Y&jZpOopg{vz`=5b< zVHH$d0h+YHZF>d=h6_+}0Z@kxI_?58|1&$Nd_&Y<;I=vg1A`?8c6%Lgh`ZwuPvO9B z{wfYgI4D5f18V1k+;aejIX7{Lt8?OTCl2v29O6kh#LGD$?wkNEFhKnVkUP6^sNaf1 z{45S}hWMx`KO=W%6OYuy0^^d5RM#?Bi_E;@lEl2^REGE{_b@!tdOpqu4DkpBCb@}4 z*{%V(0p7Vm!6jy8smUezMVi*gbRT!VrQ;`NgAb5aPYK{8Fx$Jv-c&&SyaM3{gGQ>boBkmKS@Qj1Gm zaXZcktK$q!!Ftn*@^j;h^7BiIA%29oP0z>K9Au9Lh_D0^h6Z5L5KMv{VhDDVp($7d z>?%VuFdMAX2&~cwtkMXg7h;YD)al^JF;C9V$w^HvarFz1H#ByJaQq8OGV}9X;Vv-( z8*T*iGpfcigfg)0Mqno!St8qFnwXQ5pX{0oQ5x^=rhJwy9TM8fa(ET zWLjLFnhGflkcF|76$~!ndPS*edhzk;6&3LXsYS*4d5JlhC6)1IpkgYx#3VVt6r5Uv z^DX0j<1_P$Q;SMG1H8*zU4w%2L%>NcIN!LSv;>mIg7Zz&a!QLcAYp=>7!8f%eIcna z9v~_1aSnoBuXqvO@S2{0l@~~w24rNS*m~x z1(z)F^krxUN?@?s6f6&_Q9-UJqjWYxE1io=igHr(KxJ5RK_%FyhL$j&=H#bmCZm*K zWLRj3W+75L10LvQu)-KrX(g7V#-~;!r-G|Qh%XI|i%RoKGILWQj&U}04f6IQ-7VmP zGPnfIG#5za65@#=19cU+JcqKuQGwz*SY*O#T#$>6+?@%Rlc4IuFSx`aGru@KDX}=! z#4|6m#2Mlk3~{g{k=om!E;p#l3K|y%wIgADADH-`{}7-Jk_3+_g2qJ|7+~T?XyPz) ztf1nc?k#960;V1`zXXy3iG#*`VB-EDK?Vi}Ed~Y#2T*?nV(tG}s5rs?};Ryfh6vQBz^&h_$817q3%Ie z{}4&s9?6{VIK)Ljfs4hQKqPTwcQ)Y=Ujr2fSpyo?g2nGfs5r>KpfPEf_)#Qr< zpsRO75=VCDJ|uBu^FJbqBb#5x4oO((=1)WtM~?SnNaD!x_y;PE9$$>m`3;cy$nj-} zB#vy34OASI-@}l?!51nHGAA5Kybeh`0!h3LNjwrsJRX#opz(|BubD{V$lyVB!m*L$DzCBge~eBynW(zaWVthYu@syb5GaG?Kq~pyKG^ zF9;O}sYed~HY9Omdv_v)a_Fj(oDLPC z;vjpG(@#Ih^U!>OoIY0|i6h6aEyy!i)Q2I7BdgCw5=S<_3P~JU{UjuDWc90&#F5n> z!6AMHNgUan?a(PBP&goqA43vHHvb-yII{ZhNaD!qc|@_7tI|l~$m-pY#F5PpMG{9= zzY$3sxqNtxLtIh};T~l5UO2?dafo+8#X;#ARMf%Jb3arZ6rRZC%myTJWP9)65a)xA zmxIhfR_}sCJP10K2U3q5J`0e2@9W>AP%&CK@MjzXh#fW zFLL;JB8emWHxNl2xgA)HBo68`!t9+66$iNo#Ds~@0dcUn=OmIivU~m@i6gs*1-gI( zIk;IYXWj$0J6b>LJEF89j zI9S5r5t2Bve_tVqBm4I^R2*bJXzCGWJ~N1e#e6L!ab)vdki?Pw8x9pm_iqVQ96fy6 zq2lQ3XF$b4>XFm=Y9w*wbbc5r4l)NhJkLYLLH-3LZJ2+rL&ZVnBd2pF=+Y99IC8o& zMG{922U{d@h9u0xAv)2juk0 z0v#{`*^8`R0xFKK-WW+7IXvy5;vj#4k`l~c?oe@%`N;k%LlQ@Je;txIa=6Waii6At zMG?&W1yFHx^RFO@Bm3(GR2!op!TR2<|Uh(ZrxGGOk=-K;6$hCQ(h4(Q2`Y|mzAlnDviWgH;>hVI4M`k1{VYck zM{YOXM-oSFe=0(khJoCJ-2Mzj5=TxaIZ$y>d?Dwr8BlSMe?eBk{JQ`u4l*A(e0D&^ zLFz$FnEC@C4wiEG22>oR9<-zbrv3p`9NqkHNaD!jRO}$lQ1j!E(x*6*crcQUM{b9gK*d4+0h{E4@n$3eI7#+M^2v_pg@7f z7qYlEc(FKW4LAb>vbYtJIC6Rpz#*QCB#vy(DkO1acizS!&I%oP2gM_D|C9?V4hkRS zewhoBICA*-Ac-T7gDpl9M|RI0BynW-|3?x>PPbgpbvhvTAg6OtByr??p@k%l9G+=N z;>h`{5J?<4Uz8zFe;g_f3TNbU?<0~paz6cuB#xXd<4EGj@%S4_9621sbrAJhDU!bwk;Kc8#C4(Kp!BbYByIr} z2f3#NN!%Gpyc|h91xXy)oq0&&$mypADh{$2Ip1|c#XQEen5LV zVCkw8WGGY|**!|oacPjfASO(`I*0>J4OdPrVuLB7};{~)<0T#~4>kU9z z4JHoTD-1Fpl$K!PAU?<_P`(3AeS_KrAU?F10jFn>T`={qojjoMsYh}rwAcXeOhI0E z0d3}k%|Twz0I~ywLBWB%2MCr=LDQU|{mURVAj}6M7#P4i{y=*(H{O8=z}y2;kG!W1 zG!_j~0TYK#Z^3u$fW*xh7#M<}kJGGC(*?1K!ZRG3=9v@#9{7vjwXI56e1u2@g6wbK;iQk)TjaNgGUpe z25Pi|_Ftiit3m_D9!-44DTw(VXyT8OAmSlt;+voa8!X?!!Yu*15e=5_VB&?JAm-$v znbYk85idg%KMpNu>(Rt-figD(149Rz`1YF+b3kW2fLJhlVd`g~sec4bKa0@BB|wXw z7#JAVpoyzq0htOt(*P+wv_dw1GMqqDzndK*a2rCwGtfFTao58Tb9SJK z_d)aHAvAF{XtJ}amYM~WAid-&1BVeXMc6NkA+8Co&G(!+FU z`J;^{{_HWt-k;EQL@@Oep$CDmLf8Mm#8*OhgbSgGdon^2nmn2~OuZVKxFU2Tt{s~A zdQfK+bp8mMcsH~lj6f4lfiAdH1U}i zAmIku?*w9@tKW#GJ{Ic!lW5{F^FjNgkj?RiR`@S)sDF8D*XoDpTO?)S`9?3%!j|FuW85kH!(Zr39fqc)v z(1#}e7TPbGiY6`uZJ4h^6Tbkhf48EEJAfK%3=9nS(ZuiVhS>WIO?=*Zi1=4D@f*-` zo(bA-g@xy4Xg=aW6ZdY1m?MEE9s+7ifzE+J6WZws1u)fbX#O=u6NiPfHJW$;^f09eG;t$nd76MG zo&fc4F`D=*Xgs!}iRUbWxU&~coEMr;7odr!LDTIDH1VC#_U%bD@yF11%Ox~%d#L+w zp@~ld4Yn~bFuX+*SAn+c-b2SLK+>Rgpar!2VT5)hVB+e~{L6dVMr;@jnoA+|k6Hp!F7P9U#m-iylJM7oe%ERrj_{18Bdmf^R&wd0Ee}N{xA9`TKZ!~e3dM0Sc2j<_u&~Y3o zG;vrt4_gNaQ~wCsp|M3%e*)T3bU_nu0S%@yFfhcRiNnG_8BJUt)QMzZU}!)ShlO)H zn)vn}NH{D*6SskO)Hb7u!{YG(nt0s?h&jj6#Aknlh~GvNhpB&rCO#Y5PWyu<4pYwz zO)s$Ul-vX{Um8surd|n6JPX>swMP?&#g`kJ_;P4_J_$|S6gtq7k0uW5CpMyq--EVe zJJ7@vq4{Mwns^Xs(*^?r!#*_e642l@0|UcRH1R&r# zCLVho;+`}#aYtx}J{L{=FSHzJMHBA^4a$P{-J^-W0uA4C$IxxTpT7->M&*nnQJw7z?h0uCO6ir+bIv`$GB7Yiqlxc>_REUV#LqzMqiQtq^~{id$7D3|)zEg-0yOcw^N{da zfhPVJI*4@uO?(HmoqPgKd?RSEkb!~WA)5HB$q@5jqKV(y0TE|{uDgb%b69(r3r&3f zOo)1AG;vt_M;lF?7jiHZLlBxcY&~uinz$=;oS_Cy9M(Q;K@-o09>BB^O&q3vC7Sp= zXuIeFnmA1T4K#5V=sp=v=(=uL_`uW)qKT(N`;U5P;xP4QXyV4{knoH}6Njl!MH7#N zZWx=0CLYBENpCaJ#NR;&dbgp8!_@CX6R$rDanEfuahUqYXyP)^b~WtiCRq4zK_@ym zpzUjz_%;`cQOnXnz>CUjt?@Onp6?dOPT3%Q7@^nEG{S;yWM*Br;q;6Q2uORLH=< za05+T8yYXa(8OWtnV|C_Fn2zOVqjo+ftXQ%Glw5d zyb`pCm4Sgl2TeQ$IuB@tCVmq-Zf1uj?gAZ;3Pux$rNewQ@yF2g(10d>3fi9OK@)d^ zw*O)KbYT91rNd=t>J$4R@d!&7F!e_}AmTgG)Sp}k5kG?_egQfjbs0^(AKK1@?dyS= z|LP*doWE%5Vd5;%1tKu@rOA4W`AT;r_ z(0VEhP5k>Bi26b_@dwcHkWMslnE4aX#9u(iy_chjuZ6as)}e{pKo3GViY5-rUzgCt zVdmUK6F)r%;{Fe4;&RY_(+@Q9&Cqc$0cd)M#mjYQ`&Ph=;F|HHW5wy4rp;7=-gN|@ng{Zz7b7a1UlZb z6HWa7dq{X*LlcM93op>beW3GtU(m$&LC4j9qlvpf$A5&N^NO(WhpCrD6aUu?agPC- zxCC_JgE^Y`N$5PjADZ|k(Bc%(d8ugPbD{BDh9=o1+*Rb8BIL?3nYAapyO4r@cal`1Oz%K6ixghwBFZ6 z6Sw&dF~<~5yc0U!;)fcrtXHyar7iW=;#5xW*ZXd*-5v!^SgL zp^3xH*@Pwzn@2f~CJs}78BKfzw7>iYO&r!f{DLMPcMalB9%#7&3;%o2aRU)F@x9Rb zTpcv=jy8xnCTQY5eGu_zH1V)m5bFb)=;F!lUs;&#w-zz9torrruoJOz4C zXcC$@Onnxb_!Vfst`|)lrhY1#coTHL#5y!_nEGvK;_lG)9BjWBx_|GWsrQ49KmS4# zhndd=UC#nD=Obv-9%#N8O`H+5xEM4ZjwYS~ns^?xKRyjj+#Nb@ zwirzuHb1f&P232&e&#TmIBcHf0-89?oEvE3JE7)$Kof_}v;064UkU9;3qTi)g1ir! zM~11FKoe(!hNl6VIBdSj0!{oSbe(ztnmBB}DFRJ=KXksk08Jb=?^A&$z5!a#PCyff z&HKRi-@*LVG#yfIZ$MKIoA-h3zk{h4ht6kRKvNH!_kr!dgQ<6ct`qx!rXJQW`hg~% z4V}jkfQA#yocqvrjs%+c0cg9?3{4!S-VRNCKeRs{jwbE{ZEwV*iSL58yNc1oFG9y% ztI@=5pa=R-MibXv4GHJjXyQ!J@xU!;;xP4l(8O0k)n7mp7lN*nxq&9m1MSzpK@*3~ zqrvv^!NNIr3B;W|(0T(d4y~7A`}knuuz55^H1+eL{T(|raosHt^S#l;Vdey*iBDbu zQD258z5%)be+HWP!p{)(ThPQ|^K^UA#Lq&mQDeA*CJs}72Tgnm^umlUXyUMWy+3H; zdC>NR2y}lUEZkt~WzfW7=jEB8iBE@)JK3O#?}5%oN1}Q|$wPlwhYXVJuA>aU`SKivfh&rfLL zq0n;a7n=BT=s2Dtv|fd|2c}*VO+4%d#C&fwahUpGH1X5W{!1yEI81#lnz%A(QxpRO z!%8%9nEH)q;%d-O`Hk3j-mifd^dF5X%d<^O#Li0aot}Kd$*&B!_>p}=fd2%54!H< zA)5Ly=zPRWG;tMZyW%gJ_;P6aWQC4D!OY(ettWKQ#9``9(8Rw$$M;gv#9``l(ZmZN z&2xsCXyP#S3(>?6KrfCufhG=9e*sNg8_NF!rD6Vpsb>Lg_CrcPA<%x4Hkvq0y)l}& z1ZWdB0|P@mnm9~-I+}O{blerTZx`J?uzi{^@r%%Q=^-?8VCJ7f6BmP~&u?hrF!le? z#2-M%L$sjtCop?q>W$FE&7tK^9GW;xeHxnhT4+0Y5}G(n{VX)`N6>c5K{WBpQ1KIJ z;%A}jKR=_1PlV>9UufbC(C}A z*!@PVQ2)Wg?Gm&ekwp`Stpia-6Ayu|fA&EWhp7)i6EBDE(0 z(ZpfuL(#I#e&~`v5nmBA-Vl0}t4|HE%6`D9qeG{7aJ!n5= zC7L)){YEr#JLvlJM`+?O^{>#xZJ_&V*`e!?VBrH(&yOZP0lIGA3{4!S9=47NW=e);o`48q_7U+H%Wi)Y^dTlgu7pVI^(8RN$`(^ym#NR^a>toQww@rh%qY6#@ zj4wpI2~E8H1VnrRnmBBI)JimQ*!rkVXyOl{>kST}iBE#=Cq0iQ4x4|xgC_0+tw&y> ziNn^Jd_xn5t@~nz?uUkj|5oTaH!d`Be&{@lI+{3a9@7L(9A=I+ns_aAJkSqK95!wo ziYC4UI>#51vGnOAnfOHFW%c1)4Z)-}hEDaVO|{<3niT z!O(q4C(*<`p!?>Yp^3xPzeN+D39a|Jpyd`UoMGw((Zma(^Tm2-;xP55XyX5&<$MsD zI81#cns_m^94hqX8A(ZpfxjZQT2AJFibgeG1H-ET4rO}qoT|7$IpI4oXvqlrI- z?&Cg;CN2aW|9OEX{tkLh!Ur_*-=IUA7#J9Mq3u~%_{01wgC;&1y1qygP5c*h|EU3* zI5V_gV}&Np2OSUbMHh#bhv{hICQ$K4H1Xfiah};|;xW*DG+WWc6QT2E=h4J(K+S)N zCawh)XNH;w3!hTxypJ@RxDRx{mN7MH82W=HDM^;xP69(ZoZc^_nOPpDnt{9?W3T;$LKEkN_S0XXiNos6k7(i{(EP#+9e;w^3)@F8f+n5@Jx@mmO&k{f#%SX8 z&~cjpG;vrshogxuqlv@T4F&Vc`r52M#pxr(K{{3j>29nmBBoj3%160CZiq z4VpM?Ux^EvI5%`WC>%{3wyz`wO&qp=qzFy?4|Kg^J({=@v|ZhUCVn2;ub+t~z7RTZ zz6?#g5IV278BH8!{w_4}dC>EA&Z3FK)L%gpUj{w6?hTqa3v}M|Gn)7<=y(S=v|NG3 zqcL=xQ3y@k5<1STgC-73w-#vPywLpUk3&2RO}rkuo;DLr9A-`dn)r9nA(5bS;n2ik z>if~er$fuzGd6Nk;q_@arkLEWE%CSC_^pJ$6wt(B>NU{BKSAfkT+zf~>V46~XF|^l%R&odF1#Cf6R z_6#)fsJoDIcs`o=Tj>6#-Du)`(DSkmqlv$P?(=$pCe97*f4x8xf3OE)FBfz@7c87% z&q^bk$_B6OUS1G@hP7M`$jMhZ#}^ `_~(8NWcf+#d`U+8*{ zax`(6`g%0+80db$IcVZA^-Ivi%b@329z+v|tb=6MqUlKZgU_ zo`QuZY@S6FO&m7wAd4pM1l{LuiY5-5A8|qxhneGrCjK7UF3Lm`e+nHxY)2FS0v%7D zhb9i&H?bN`9Jb$KGn)8v=y>&MG;!Fzi5qC*FmoQDiR(bm{rQ0=4%-L80PWYp!kG^` z4lIEt4pXmyCawS-C$~TohwYniKod`a*6$H$;;?-a325RgpzYoYG;!Fzi3T+Bv(WMC z8EE3LeG?1N#9u)9JD@Zy9ANWb2hhZ`q3cL*pozo!cMs6SVdvldKof`UYhZwmqrmL7 zfsVIGqKU)QE24>ifzIdJqlv@zLAaxdYeLuGM5Bqr_CdhTGlRM30d&1YHJWD$Xf~QSY#+oTG;uTNKCfM9;;{V%$I--L`wPyaiPu2;t#8o8VdsYZL=%UZ!w4Pk zg!$JTdcL3 zMiYmr*G3cH4;?pjMiYmvtM^6|_khNG3Ys`feGZ!VjIR*)w4#Z_)&uvViO+`auV08J z4qF$!0!>^Ix80+(Z-a zhW67RqKTVA*T4No6F&(Zr(%cABQY>AfVwEG(0MBbH1UXI7ZRmWB zADTETbR4x1O*{>{&%F{&yc>G%)g(0Wc4&WL7Ml12==mX=(8OJ#>1G$2cs#T{a0gA? z13J(C1Wo)Gbbf&idcHL*y-kG1J0F^OBec9QKokE7jSn+4@ek1S=7%Q!9=d-g1Wo)l z)P3n_;wI4jpZRFwx1r(OfhG>y=iZMdei^#nW(}G+O#Nmw@psVv;8iqnQRukDT{Q8j z(Dehq(8OWtnV{z!z{2?^G(BjbiNnSd%+bXCq2~p8pozyp_nZ5oi9@@s3_)n($DsUh zC=GLuGj#oGGMe~%=saBpn)o_sd#n^qd^)rp)rckz8z1OJ6Nj}2W}%6DLf6kMM-zw5 zL#;y-hux2O5KSDW{sfx17Bu}oKof_}BRoeFZ-%Z{=LB6UhO}M+)*lx`6Nk+s$fAkY zLDQiXnmBCU$`MU`7jzwXI-2-0X#2bhO&m6F)rcm(6FS~91x*~Lem0u;QRsNuW;AhF z|8Wo44Xc6Mq1m-%&slhm9}kqKU)i zt*p?*k3suUPH5u$pyNUzXyWIg<59(E;`PvWdo`LkA9Q{1Of>OZ(0sHIP5dNuoP9l- zILzMjXyV?`am71m;;?zHmuTX!dADz9;;?x)X6U{>Sop){-2~9YVdjgYiSt9xz12b! zhp9J26R(2KYj~oG!{*%r(8OJ#PLwqxu zI3x7DvSVoCFmukLi8DdRMW3RH!_>b)6R(7xYs~^J=V0*yQ_qbio&a5Mtc)fOQ?G?4 z-UwY^>VYPH7rIW~2Tgni^gMw?G;!GYc@dg8Y~HOBO`HL`zHtJYI86O?H1Xrm_Rl&r zaag%`08Jb=Pj?(m+zpzq@1cpq=9QkHi7Ph00QOQHSc7&LL1`Xn@QM(FtfRcPWc^-XBvGSK}Ov(Ut0>KCDjpM{PO z>_-!asXvY;z81Q^@d=tZY@Y57n)oB=xGM{EUnVR(Ve@oCXyUMWI!QF~C(wPPrfA}@ zc{*D(@gV5F*C;e`*gRbln)oE>I`9@Waag;0GMe}c=z9JIXyUMWx;1Fxuz9*|XySa( zdAk2-;;?x)cIdf!uyCt^_7kMg#9``{(8SxI>l{qc#9{MvwrJuJ(DL66O&nI<2BV3? z=GUUp#GgXfIX9t+!^)W{XyPz)=AenUK-Y~QMiYn4)15{WPlVPNZ_&hI^Dke}#ABfS z5q79PSUAJf^P!1XLfa2&XyUMP%mPguW{y3YxF>YKLkyZYti6|qCJr;F3{6}Q+K-!w zCJt*ytws}vnX?&9+#EWNbOucvrv5UTcn-9m1>4Vo9&Vq})XPBU!3ClF@6pvuqKV5u z*OywOiNoCEj3#aZ9T!SP6NjnKMH62PJ?95Du8;1X$!O|-K2{)t|AyB4 zm(avv{h*s@;v1p;=x=D^F!le?#1})yJ*1)aJk0$t^~z}CYoYtH9ni#K^KKq!;ziK& z5Yo`ZVe0eH#4Dlm^sxILVeWy=(@jBB51U_`gC@QMx-Mu7nmBBp?jV{t%$$>G;tJ6D z>=$U_Pod|pu|d}l!rZwRx*tszO&m5)r-ddCn_n|R6R(EO1A3u}!{+J2(Zpfq#G{GB z&POOm6Nk;a)uV|kLFXB#qlv@R&qotCgtjZTqlv@j>Gq?EPloRIzm6sjo2R>vCcYCo z{`MVB95zq)A5Ap|x$pP`AHK+nx!f{ts#!VNa> z#)T%H0o@;`geDGCuZ1R_2wi{ZgeDG~ck@CMmxj7O2~8ZPJ_}8p4|;Ax6Ph?|-mMEw z{66&j|3zrxF!ig@#4keY>qBVbuz9yrXyWP6d6vg$;xP5E(Zpv!%X1d!xx%pUht1RR zpo#NC_kAm%iNof_)X~IapzHlS(Zpfu1JT4^L+h1dG;x^vYBcfp&~pjqqKU)QFGUk? zhMt#x22C6`?{)=ETmYJXKcb1l)c-^iPl3*}OGDS0!om|aPp6C~o(7$#vq2Mw&C|J{ ziAzD-KM`o+uz9)!H1TWD`=jg7#9{MvZD`^g(Du@NG;!EG-EuVXf6)5tD4IBIp6)D~ zxIc8?=m#`$*gV}2G;tefzd{gtjx{ViVe@p7XyVhM>xT`|#9{MvmT2Oup!|AwA}y&g>*Hcz(|O?*1EUO9^<4x6XDj3(|2Js0a4nmBBp z?j4%=eCW9`?9lZ`u<(SXm5X zF!haS;&IUZ2J_IwzeDTsWoY6Hq4TX<(8OWm#&^)fVdE07(Zpf%eSgrz|3b%wIHBtq zVc`aApNpZ1!_F&EMiYniPYuw-VdoXtqKU)K8E`=pKMtLzNJJBdwe$1P#9`)?qKUge z_px@MiNo4~{b=H`(DgIR(Zpf>h;?YY#})g`T5mh9+JDUB}{#CJu9_ zKbp8Kw7d#K6EBADf6PP^zXkPYDVlgBbpK-=n)qz!xN!%X_%-N!#1u4f*tqCwH1R&@ zI{Y1I;xK<5K@*4h>ol791n54aduZY?f4xEzhxzL>nmEi~f6>H?pyA00J?9=4?_JRK z-hyc2+0b!tb2M=g=>8^0G;vqxK3{J%@jmE!yihdpThMYZ5ltNCo=i0HSduX!_iQCO!{(e$;j}@q5tqOMB47lc4c<5KTM{dT-7NH1Ubh z^FywqiNA)9cilr1{{tO&eTydU4?TbQ8=5$*eft+pTp2n}B?`TN1C}0kLi4W-ns_;M zqnZhtIBcK3BbqpD-@PZA_zLL$h%_|ulhE<@Tr}}C==#Z4G;!EI{XR5t*trCA(Zt)K z>-LwRi5o)i)!K+A4l{ojnmEk-%V^^Nq49MeO}r9XFFZjLKMg&X<0YE70d&6OGn%*q zbY0djH1Txk`d%sMx(rx6!pu=b6W4(5cd$ScuYisl*rSOrhOUbUMH7d$>+;dWE1~`R zay0Sf(D9rWG;vt|-GC-u0NwAl15NxU^gj2aXyUMX=O&tX9rPZWhiKxjpy#x_LlcL& zM+&-L5*D5hKnw;31|>A{6VP)N^wGp&?y*1n+cqi9d#pi{3;Nhxzvfnz$--J=q5|@ha## zlfP)uBP((EWq=(Zpq-{jxV`;;?X&fc6hy z;dTJJpF#mmdQ{6xlp8y@-euX9uEB9ES^*k(` z+o9z!51P0b^d1vQG;vsbxuS_5h3=2@MH7Dm-4_srCJqaSOf>O@&~qCK(ZtiB`KS&} z9F||&(Zpf-1=c==`4^U7)}g5vg`UH|6;0d-dcMImH1Vy_ap}8g;=<7NpRdrwe?!X) zX6U>(%smaz^FX-K#G9e#Hi)2!!^R&p(8Rl-{Rn+D@x##ZRd+P;m(Y0xKQ!?}&~rSa z(ZpfloPs6}3+Gxi@h8yrbuDP(H=yTNOhglhnLi6n9A^GzH1T+7{kI!Ud@J)ifH2Vq4QH3XyPo;{hOv};=0g%TP|qgU!nD&H=4Kz zw7ngICJqaS3^ehp&~sDs(ZqK`$C+!;#9`q)0Zp6-y1r{Vn)oK@IGV`#|fd05oxPX#1)VO?)b}KU0Y&-VeREq76+P)}HT26Nk0u z=b?!|g{GfnXyUMa9qZA=Vc~xfO`HQdk9Gr1d^@y1@(@iN7Qe61#9`t84^3Pf8lG&> z@ncv##zX60VKi}AILM%h!@@xuP5dmh{xe1sZ-uTma6l7>nG=F0{u-LUqS3@%q5a=N zG;vtD0h@1u`D-C`9()p-`b_9}>?$(KSO8_~oqq4!IkL=#^H4Yvzu;+vrBY+s;> zuZFtkJ(@T-)IChle1`6RPBihQ(0;BWnz%8vzSck!=Y!@)2Q+a>=sG|TH1W&O^LYZ% z#5Y3EV~j)--v_J>Y8sljiz%cYT!|*01|9F(fF?c{dM@GxH1PuHJj+cqaeJuyAE1eQLdUT` zqlv@P?O!x;J!m^qAG!`57XCk>{a-UQ@ypQpO;0rOH_-l00GfC`bf0eunz$-7zht9{ zn?T34O3=jlq5Hh5(Zm-+&tGjp6JHJ8$J&i1&Ixtr6g2VA(EL6dO}rC&pVSgG@$b;} zx2w^_H$(diThPQ|>rRiNiNnV8FQSRV?qR=+CJvite2FFwn}7L=CJtLK#0Xt~2aDg; z&~p;`(8O0k*Zr%YiNpFedT8R;q3u6wH1QH>yWIs%d?9qc)dx*H6nbt_0-88XeL9-B z6LkEr9!(q;4n1h%3!(Mh6g2TTXt}xuO&k_4JJG}^LG$TBG;wWcy>b&xToc+pd59+7 z3*E2x6HOeZp0Ny4e!$}EFmzpz9GduL=zM`1n)qhudUZQAahQ5HH1YG$awZu~9Ja13 z8%ni7>iTgs++b%Tm)zJ7lgeL9*?eE`56K{vc%X2jGC(!lG zEYNlnEIhYD&F4WAkA|MprHLlq13lls5KVj%bRVTBnmBCyBnV9$Hr|zpCcYlJt~d`( z9F~vD(Zpf-q8?5BAGF;#8BH9feioW|K6HKBCNyzaKH85a4$DWdbqcWXWP#9``9(8L9y<8^^(;;?)Xi6$-# zJ)gD^O&q4a5>5OpbbZ1!G;vrynujJn4|+bpZZvUNK01Le4$Vgw(8T9M?@4-#CJxI- zU(v(`pzU^{O4M=&mXD;+#HT^mQJbTQ!}5_mn)q4hIZ82T;;?*_f+p?>Z3ot%iNo?y zE1EbgA5B3MzYJZUdJIh*)}A?wCawj&xAy^>IIKPM98KH@I#2W)O&r#qVS=__VCmKb zI!IhYBJabM{9X7|y=Vd|fuiPu8+AN@lUhlK+-v>ygbC$Mr=7)|^Uv|iIj z6NiPf1)4alTy;PbH-e4_Mxcqq%E<&Y@$1le{|Yp5nED1Zac*e&GZ#%9R!%NO6W0`i zlskLT#9``>qKUgh%dbah;;?e{6`Hs|bU!9LbRGZ}&aiS-1YI0juF9Z^S3vuBmT2Oz za@7${+!VUbCk{;HGMVd30~CJrlaC!&cjf|e&M(Zpfp=SDQ~y`aSi3=9k>(ZpfuVf#p6;qwN1 z|Ij-$^|12u8=Cl5=z2Up==c!K9GH4BH1XF^zA==BsfU%f)@b4;(0*Gjth}9sCcYUup0FNG99G_LM-yj&?l-xDCJrla@1Tjlg^vIHL=%UV zw~Ww!8!UY0LdQ!b(ZpfvUDeRUVdbzsnmDW+wnG!IhRz>(qlv@vR|uLoEPutIiC>5A zBPc)m-^uEPq`@6W;`Ff4@W% zhvk=#XyO9Ubzhv&`UDnVF!h3H;_IRFM|x=Du>4|%CcXrE@0A~#I81#Qn)q$#yhbsa zI4plvqls^Y&L7P{6NlxmrRd_&{IwQM9JYVv6q-0Je_cWoe*-n=J(@Tye|<+2w}bAF z6M^;{VBrkQUovRoZr>p7Kua`nSpITE6W4>zcSNFzAA+uzPDB%b4ZZI#A59!KU)+o) z4$F@{XyUN^I2%p8_!PwbE6~JY`EetfI4pndL=%4mT_1ZEO&q5F3Yxe%bUy11nm8;! z{zMapI4nQvp^0}v^OqZ%I4pnpp^3Xe&m&7i6NjnK zLleINJ>R1nO&pfLCZmZjgP!NP8ciIgelwal8&v%TG;vsdyn!apxDXQWU(v*2`H=~_ zp9vPu)1mo@3r+kKbX-v#O&pdV_0hyHLBrVxO&pdVL(s(ULeoJZnm8;!R-%dfL)QaO zLlcMP$9ZVtuzORsp^3xt(E&7ZSUx(9CO#25pLH2c{2+85?E#uN%>0*V;xP07qKR`r z*Bh`x`ya4)iGuDw5<(M)nJYoC7+(?}8={Gv60Y9AEr@*-!2!Lco1~_O$<%^0d)LI7EOFMbX-COO`IFL4_6aSd_Q!a!X8b08nm4m zgeHCvx-K*lO*|iZzHSnlxHoiMHyceHw!gX+O|=`{mQd_D9&qY^anc<8>81~l;;=sK1jG;!GY?@ToDS`o`=R}ya5V92Q1Lu8 z@yXEffvsrbm!R`9XVAo(p!?chpoud<*MGA>*Tcg66#`wqr-de72MteeH1Rvoe4UFX zz6Ba?jcDShq3g~1(8MdD>3ad1xFfV)JAfu$4;6oaCJvjQV}PzNhWRTCn%>0G#M7YT zM7C(+P0(?VNHlRj=)UYyG;uj-{ndjeJ{dZ$xCTx95wspWgC_0)_1AMW@f@f*Oi+Ko z{M8O!$IFim>})#95*1hpo`W)u8L-?a{<9L(`Q9n)n3h z{Dd!>_#fzc_ZT$sS&Wm^-`B#9N@{ z>P$58^U!@U%h1GO?p%!~z8Pxo7Bq2~J9naqFNUrcJcK3=bLVk1@o7^b;cyL2ycsI~ z7)>1J&KGFnjL>r@Kcb1l-1!Yn+#1?{{EsFMb0-V5{R>OC=b-0$7@&!(L)ZJ-p@}m? z*A*n8iC=<_XJ+CMZ^I$pi$i=Bnm7-1KH?~v_&4afjXP-K70~?q15I29I&UNa-5(DN zhn>*#1Lbjuo8u6-!yz7qCe8-kM;3=eybOnU9S-qnXyWP6`g$G?@ohN7_u&w~h9>?5 zT5sONA^r`A_&*%t;?Q+Eu<*Bl?x#>j6MqD42k4@SPlbw`qlpVZ+eMCO;-{haGWej0 z|Aw~PW6;Dcq5aT&G;uTNJ?qtI;$NWaD>~4`BcS_7rlN`eg|4?*j3z!|Ii%cJk0xFU zJ^%awn)p{}zw!*4cqX*oxrrt|3A%sw8JhS~==%T9XySjM^T-U)^T}ZGbst)e@uG=) z&VjgJ3Qas8+Rj%;6Ss$+J7j_;UIp!UJEDo7h4w4`(8TMZ>s6xB#6Lp!S7xAz`$FsM zQZ(^oX#2JaP5eJ}ooYXt_-SarV-A}5b!dF8L=#^OEoZi&iN`?8rNe0AJkb5-7tq9| zp!L^XG;v4h`RA|D#6zL;%iqz&o1pDO7U;fASp0TF+XI4V;?>Y}D~Beo2yK^YqlwRf zo||ETCY}#HXWJD``~`GeJs3@V5%fH_cr@`G=sZptn)pI!|8WwUxbAaE`rM2r-Ul7m zI*%q^3{8ix(Zpk+^Y84FAm+isZ4R^@u7W0R3*B$7gC_0?okw#;6JHA*2Z%)zUk6=h zn1v?Z32oO+Kof_Z8?_Bhd?vKLehE!{H?&;+izaRc&F_-X_65wp@1XUX0h+iIG@S*Z ziC=||14p5W$3oZb6r+i=L)Y8)qlwEy+qYZM#6LmH^Sx-|zo7eMZ=s1tLC4J)pft>1 z4$$#f4m9x>(DuJ7n)m_eIJ_g8_#)`IhbNl2KeXSPh$h|%&0kGu;@QyiZRVnh_d@$? zJJ7@rK+BoSXyT8d{(pxi?hnn6oX~iNg+mB5-8!O)i$UGvhbBG?I?fP{CawV8$C`mA z&I~OdO3}oRL&LubP5ckEzUxO5zYX=*95nHX&~&~MO?(FQ+@5V{;ug^Q;xL-{7wEqJ zYiQzv(DBb9kWTE-XBQq3ghP(8M*N^EWdOm|8nz$Eqzh@wt_#9;tkO9`81k%E_D3!4Vw5QXgXwp?(>7W-vOE*dC#3B9@hd2W? zUBlu9W{w1!ct7+UPI(;SHaNtcafm0NiHkz-8LdGRp95`2%|#P$g0_qHqls%l*M*8e z-3#;A5or5g0ZrT=I?khmCSD2M&u)PxE(a}#UC_iUq2V8ZCawvcmybac&xY0)8EE1q z&~dgBbaCjoWdoY{L1_KegC>3(x_@m3ns^g*{oxWc@y*cj(hX?hi=h3NJ!s;+(02X_ zH1V@gcV0mg7locH@&HXd78(w3(8NQb^}-J{@pS0@3oOuj5*EJ)pzU4(H1T85c_l?O z@qB1MT^CI}99k|}qKQL?FBsg=#1o+Vi-OU_pF_t*6VSvbLHFtBqKTh@o`Y9~CcX#S z&uvE&e+6~W6f|)QXu4g9CjJK6j$MZ)4jaeZjV2xm-CuSBO?(kFonJ*0zXDy?{s>LH z9vZ*z(ZpXs&%yhHCVmH+UpS%tS6KXpL+cSSH1P=N`60?^;*+7}f&rSiIkcT`izfaI z+K=!;6L*H5Hy(~A-U02Wr=W?SgRT!RL=)G9&Lh;LiSL2-TW6t(=Rxx|JM{cQSU7M& z+fgED;uX;JtcWJA1zqQ_k0$O6&DS<);)&3H4eY#Fn7xOg{>ng8e-@hFiqOOzp!>di z(8P{g)avaZ~7gVkeq7%=`&x;+D{T$7|8VVd}S_iO+|g3v&id z9H#yf*XnnzjCe8rurwE{l+d{)# z3{Ct#w0|XoCT<9g7$r3E8tC|>2AX&dv>&90CLRtQmoPySZ-ky_;(#Vz1lj_sh z@%0*zeC>lKE(C2qr=W>%FoLMhMiV~;ov&#@6E}d4w|Aq7dqdAfpN}Sf2f9uJR<6Us z0Vci~O}#es{Ip|e;_=XW|16p~H}qWYw`k(?q3i3up^1Nn&POmWh4>rhp83%7iVIEL z5xVYL5l!3(TK{UGiDy8^;T_P#U7+nEcQo-z=(v+Fnz$UaJ_d3`bISIAJF#LG&J#CXuEVSnz#t`+?B;>;&Y($_*>A#Z-WAyfq`Kcns_g? zJ$3+191=?m49C#KmqGbwpft!>PM4F z(EI_j_aJoKUJ^}wFZ3J$H8gQp`DTnJUI(3ba6l7pg|27zMH9ab6^}v_XZ{5VhjcXY zc4+$~4^4a?v>qu(6TbjmuU>~H&JSJhJrPa(Ff@P7Koi%4_H#F&i8nywYdf0wALw}L zWi;{C(DQt5p^4vwt{?b>Ce96QNBu+-Z-DNX7lh82!s4+Gx?W2HO*{*F&XpCqIJ8~r zh$j9BI{y)gCO#dS-xJWpGojp~(Dq_Inz%i*oLq<|?g{NjtUwcA4sEv|K@XF(8P~G%k$r8;`Y#UO$DLrhG5|)01Z!dG;tf~ zIU#}2{Rc4hEzow|KQwW7XuZr0+keBrzyPZ6Y@p)|l4#=1&~&ASCJs~Yk0!1KJ%20? zOxC$wJ<3x6GGya=F)yFk;q3Ys`fy*8S-CbXSwg(eQGzkJce6`}QJ z5}NpS=(tuHnz$x(yt)c14(g{vyFlQIe<}{~`A~6?e?eO^?4kXI?ND);InZG$h6`xo z(C$9NT_kbj@qu?xagh0-^tlqcf8+<6c&{$lnGCGZdIqNcH*`J)R{y}n7eMy{wy?cnEA`m#9`)dK@*3ipSNh@u=C`;%NL<&;;`~C4ow`EUpmmlVeXlVCJuAYA~bQBd)A|g z!_wg%G;!FvI4vVj7G;vsbrK5?%;;S7^ z99Hk|LKBC%^9q`HJG5W$4NV-D&V``$3CzDRcgmxQ!`!KZCJu9_3z|4A9(~coVey!X zCJqbFJT!4wc$TAy!^&saI1sw~d(qUx+&>FV9OnMzXyUMZ@exh@7PMdX4^7+~I*%U@ z-3JeI56u0wIK1Q#TxC(UKU_F}nM(Fz0V`$4CJxK*foS5edMye~+#EVjnvNze0xh?j z(ZpfyS%E|R5Sq9>bR6#qnmEjSKInR6n15m6DUBu$3s2a+f-v>4@N_{_4|8V>4)Jm{ z@z>CCsJUq3Fmn#!5Wj{d4s-uwG;x^wKcI=j-2WF%99Hg0Lif?a{0noB9S-qmG;vrx zm4zk_%cuQl;;{RV_M(Zy?7fI44$Bv}(8OWk@C;2H77oVHb$sal3PBT>fR0}!qKV5w z#VgUoVfnWSO&sQ)J~VNddsd=}!~A;?hxjQp@fPSj_%k$dm^p&bed_4`l|mD5f{r7r zp^0CHo~z}ECJr+{8cqBVbbx6$nmA1T1vGJI=y?lT&~Y-DJ7M8zj3y3?cULrVSU3lv ziNnG<9!(sU{u|K5VeXuPLwo}c@f&F3?$CKLDd_q;n7?4=8{rVQMiW;r z4DC;DKof_>%T6?LSiBrU6Nkmic{FiYyu3yehlLLxbo?6@&aiNZMiYmH^K>+E*!?UE z(8OW)UadqEw}#GNA4L;~x#txQ@y}@Du=S!`(Dg?!_rvnL44ODBziXn2!}7ZqnmEio zNjSu(powpTriZy`;xKcTp^4W)=Y2MziBE=>1BcPXbD;Obo<|eUfR4}H#UcI>O*{p< zFP;;+Zxt49FmnXZ#P2}eBZnpq^Oq@_xFvMn%LYx{5V~K<3r!qmP6V3xdg!{xBs6g; z=sN9UG;w!m`)~r9_)_S3eGAaU)u8JrPOCJs}-5r_Cy9OA!lh|8UX*aLGv z%zS4Y;?X$7%h1HDq3LrDnmEk-rD)=?`s*N?IIMm=g(eO&=P8=_YiKxsLKBCXBLMAp z!u$(sUrC~g!|LlWG;x@{c{s!;;}BnsL;L~`@h@oNu=0}wdOifq{d=J6q6MJhpm|T| zR46!NwV~o5^`IkTpvoEa(Zr$C;|#F#Ct&KK$F4Bgps9y0YhrLk6NhfIWAH>1hZZLc zu~2cCJEwqM$-t0@Bo1vlgJo)w#F704yLS}iPSE`C7U=ql8Bp~gagcwZ-Cl+{XyVXe z8HQz0ahQ9c-5Q1sP;rnsAoGtv%|D1F4l*CgWjG3DfYgJ;p~;Wo9GWgNa7%WtpFLwz`*bbO?(bi{56{R zC#d*)H1T&(@gHd7T+n&yKWO4?P;o}+IwN#+^Gju&xa;12Njorii4a13LogQ z3kEf)IL!R7&~PwA5(k-|3N^OtZl_j^Olxr!$42o=AFCSD2^e}pEU z4;6onCO!=+{vJ)d4=VlxDh_i$bU2oQ3A#QSFp@aP{oA1Ch@**bfr=}j zi64cEtDuP=hKlQ=iC=+=8={F{f{L3##bNG;9yh`ejV2ClrZJ@A5U+!ZgZvBf*JG&p zO=#i|q2k?W;-8@6{b=GJpyIQk;xKoD)>?roe%Lqx$X-x5+d;#5D^xv59ONEG=zP;o zH1YpX^ADkk3qaK$LlftNil2vyqr2xO4)JeLahQALq2~NT6PJaGGeggNfT`DminF7M z>p;Z?q2e(2K(CKxkcNtb%mIauA2fV)kipREhj^PeX=vhJQ1L>jILv(L@fZxS^OMlUr$g1l%uj%tGaF4j4l2GBDh@Lz0hD+c7#P+= z#X;tP!Y2+IKKqfxLGCYsnsXRUya+0O22H#fDt-Y?yb&sX6HR_U4AY?EAoD@t&baS`aa zFUVd{nGNd~%c66NkBTCYm^G zTy8mzCa4%BWU68dx?)wiC{w8SRv!UzK9nr*L=eGu+ zi9dzzdyPdCUjjW(CJjwo1A2}`KAL!24#YjJP;pQ>2I^WUK=&8Sfr`WY3k%OBNaCP! zEDl=!tUwcwf{L$25(kw_-OzdA9Z2FJa~h!P_n?WFLB$UuiG$36#p4+yagaINpz1H6 ziEn_4UquoJ)fbzf`=g&DiG$3!16BVTP5cs6`~#9W$egQCbABR;gWL&=FP5v2@CJn^ z$b3F%zUDv^=YWdyB8h{{QGk|T5=i18a}1#BWzfX6pyG;1;vjdvhPqP=NgQOpWfa7H zrbyx-^I`WsSfYuCK+U&95(k-c8@j*96G)a zko$R{=Mj}5iG$3)3N@z+P5d%cycsHvZhkLR9A>@})cnOr;vn;%LCsl?CjJB}z5yzZ zZvHN)ILv$tsQIUm#6jkNhnjN^P5diV{5qOAJ9NJ6HkvpqRQw549Nj(daEJ>-?>$CW zFAEiix!(ioeqAJSko%>f_8OvzOG3r1pyKG}yFkU!%@0Hp2br$}H768JTnj3m3KfT$ zzaN@@@^OfFL&ZV%g3Pyrn$wRaZUYsc0To9#e-RGx-B59u`TkII_M?gWLdDNR#nH{b zi9`G=R2*i0BGjCpXyWluaVF?JHZb*tP;oXi@qDN_KU5suJ(4)Y?Qn>D;1JKpAzq0? zd?60;)i}h@Ld9YJZHM~nBAR$JRQwj2_(G`oJv8yTQ1RzbarE%{h(nwoI-vk_&u*wW z!f4{#q2e-V;#Z;K3TWaNq2iiQadh_>;}8#oio@LV9%@b~n)qv|cpREICkLdyNJ0~5 zg^FjRi7P|J^U=iRq2eV_ahUs0LG$la9OCnFh#$fseg=p5E2uau96X`!d50$M4i*0n z6-Rd`BXs{ay0{jaIILbX!66<96^FSe7HV%Ons_u+JPs-jvlnK51`hE?s5s30Jg7OX zXyQ3g@u^U8bo1xq5Z?n8hnZgwHRk}Dcr8@?Bvc&T{L47R-$2D-=1+i{^8rn~4=T<8 zo!~<^p9_b$E)H>X9OAKP;_IO4HXSMsawn+W5&^9@E0DxN_0B@5J8RIy=R?I?(Zn}E z#XHf&*FnW6p^5K@icdom-wPFA02N0MpH(=-k3+>l{sOuG9MqiCXyRv};y0n<=;lAh zA^ry{4m1A|)Eoxry?HS42T*Zts5s30YtZl)g^GjJgTg-#8vbfX;vo0`gPNm-CjJE~ zZj2`G1G~o%P2348?f?~sx#t1YJzhA()1l%ZcY@s03^gYkO}r5*UVP=8tA5D$flgUkW>D+cPGNHp;%sCWug9A-WrXmJ4p14Aj2IJ9U6XWUjKanShH zJE(j5afq*hio@Jf0JV1mns^>md?!>K<{p^&hjEDCfr`V-Z-koj08P9eD*gc~j&A-h zs5ryapW~+!`tlv-b(q9D6kJM^JGOH1Qu$aUV4CZ&2}Ys5s0$jL>jSgo=ag z1*KanXu2vw5(mXEA9P=B8Jaj3RJ$ehf{#2r7OBO}q~(egjRs3o8B)Dvs{{ z*HCegJCVcx2a-6*oy(x+{6Q061Qln6?lSP8Vo8(L@pl+4}{mUKdUL9aP*1Dh>+=eP}uiK@;bOipN34LH+{S8v?aAA4wc! zuN*(5JTFEQmx7Adpo!Z;#T(GXt)b$Rq2e%i!rU_#Dvs`+RY>9>_k=>tS%)Sb2o>Ls zCSC#+-;E|-1QkCA6-Rf^4X8M}d!8bRgWS^tHRmOocn4Jc6PoyHsQ5QD@s&_<9_V>; z=Q%%JHo5{Gy>R2<}AkiV>;=2xSMTR_EI(8N8V;vHz>?ojcGP;qqk z%*G+U6DkgK59~bry=dYQQ1g$WiDyE^PoasYL&Yyc#nIh!7l-&)s5s0$RZw$&qKQ{P z#o3|fH^bC-L&dq##59w0~NQzAs!ADhuJ#|YJN1D_zb9c3Yz#j zsCWjN_!_8q9#kCW&PmYmkTx{&7f|sDP;roZKTvMXyTqwaYHomc&NB3ns_W!+yN>MbB`0WUFwBHJO_t( z84mH;IK-Di#XZ>acBG;w#RI1}_7R#5nW+>;9x zXG0Uugo^W{iT6Xrh0(;Dq2e-7aag>=&Zkm?ii7M0h0lFx_}CzcgWPiiYK{Y%_!X$Q z7m_%#IT28CbbFJa;xK!^LG7)Cio?{WLDOe54)HlqagaG6cQQfO?JPhOXMl=tgo?w= zuZEhx8;AH^9OBP$i1R@A*P@#*1{DXn6BIsd(ESwZNa7&(OF-SJjV3Mv6*ol^M>fX} zDh{*vI<&sX;5)=^~;gOLH=rkx_>pAcnef~ zD^wh2{(Y!BFQJKdK;!EU4)LE*agcjJ_D+ME{})Ys3RIj8danpf{VJ$97n=AAsJH}F z9Oh1#dz5g9TSLWR=I?`=V~-}j2P*D?CVmMj?t>K*d4s0om&b zwKoY#9Axh@sQGDV;)|f-l~8e*y)g5eq2lP~Pel?3nST*#&P+7%vrzFhP;qqgw?W0x z%|C%84l@4_)SNSD;y<9`kD%h{=D&f8!_1F{hR;tVagh0%qLB97Uo>%Ls5sjTh&;#~ zkop9uI2W3D6jWRUNgNa}MNoTXq2e%i`a|Pa9ZlRFD((suhuPZ*HQy6WycQ}R4i!f? zKM^VpG6&?I7N~oQk;Fm%nh7rAXo+^EX1xS&1gT7An3D zDh@M01R4(K(8ML6>Hh`}@vl&Ekb6M(9*3I$6HWXmRGb~UaTsPV%zQx{;#yE~nEAJ% z=IEh`--L==LdDU|cZQ0C%mKyA6llDJAc=$A{~l^i1e*9;sCXipI3x6)Mq-F!bB;@MDf znE7E)bMn!|L!jcdP;qqg+i{4m!6Cj4Dh{$2ls=b0)8}C%aZq|lgW7u>O*{oEegRFq z0xEt5O}q>$eitf^?*8XE#F?SzErHw#a!)7J9CkGEcBr@jR2~v!Ldf zqlwRein~L_(ajIUA)X5rhnc?yYEB`V_$sJ)6`J@SsCXTk_%5h;J5(Iz9vNu)IT45W zHZ*ZXsQLpq#P2}GVeY>Gwf6y<_&KQfOQ<-^Juve>;}GY8-eU$c{~^>I0W|UZP;mvQ zIJ)^-IKjwa3s6;FVQqq`>yhj>2@@tHWp58x0# zg+u%k4)H%Y#3kRNwtvK-{*px#7ln$ep^0lk#kJ7HRiWa>XyVRLadR|rd#JbrR2)4# zy>N&pL&ah78x1ul9ZftEDqeslo(mN(K@-n}ir1ovw?oAn(Zrjf;$2X2boWoeA-)zW z4s-u}s5u+a#OFfAccF=Igo^J&6JHAzKaM7T8Y+GoP5d}i{0f@*Q>ge2H1UT}@w-rQ zn16Mk<;g!B;vCR>d(hQu;}AE+As!4BhlLwA^gy3*G;vO-cmh-$-QFx5;#1JXtD)o4 z^Kgi7hl<18BM-HAH=4LCRQw239OfRF`R8zmKZlCL%r}6V^BPTD4=Vl#Dh@N>4C;P1 z=>29Ob3pa}QRu!TVI*--J?jiLM;uMu9x5&e6-PJU98Ej{x)0Y6Dh{$2v|kCfuPqEo z9As|>)chzk@dT)NJd!xb9N2!eEF^J|In$u(^U%cmpyDM^ahUt}K;7916^FSKwvTKI zk~qlxeNb~|po#B-iqAz72e}irPjD%cILMsqQ1vU(#4kg|*CC06%z^DI+>Ry=+gEr5 zDvs{2b2!9bL&ZV<1-a)7)ZX`K;-8@6KcM31<}-bO)FbHP(ok`j`K-``f#lJ|nW5tP zP;qo~EOCg3LB(O_i$TqaLK7E(iYG(G(aq1rA>IZRhncSqHKz+rToo!l4Jr;Z|2{Nb ztw$4w<%^wAagh0-{1^t!kEf8tLGfY%HUAu%xEWOZ22>noZ#UH5_ekQP^?RBi1q=)f z%pXzX3#OhIDh_i`4%9s=P;roU(0V_ZdOfH(x_W!4I86O)sCzu2;xP5KQ1j!F#6kWI zg8C~NP23MEo&yy}H@^%j4l{ou)ckfNagh1BP;HoL^|-TcG01pCIW3rv4aIoE=U42vnR0Dh_kc52$-o(8PtI;pu=Tz8$LG3x{|* zR2=4>t5AEh(Znx9#S5U~F!#X9`8qW5El_(Gpotqm*WYf3ii7M0mBX<5Yd?}WC_JA* z?LCYp{s=050!bWX&Kzq<_+Ca52bset1rfiFCjJ*{&K)FikU6k=@Hvt=$Q&uCIj_;g zC7|LTpyIIbf$fv!{0y-lCcXfA&x-<796cN~kiZs`59%+T{E zVCH{?n$L?vTooz~G6xhsi=gh*L=#^C6*q#4qnmGoLp&5J4l{ov)SO5(@%2#gBsB3u zQ1LW0@dHrtd^GV(Q1N0k@e5G#8Z_~TQ1J#d@%vEmPN+D#e@2%L1Ce8pA-v<>(ch3o^IJ$eTAc=$ABMdd?2Aa4aRQw^D zxC&JKDVn$vRQv-}9Nj&?pyDw1tb>LRJM{irkT}RaCQx&@(Zr3Q;v#6`E>Lj^G;t@W zxFS>>-96e+age>B_}T|`k2#V!$UUJ@bF9(CgQ4OsXyU0*aSt@{WTW z2~csEd(J`KQ-~xEa!)nXoKiILN~m}}R2<#>PN+D{{3lTJXCaA$% zDh@NB4eI`bXyTku@zYRon7v=1_C7=s2idy@*)cw*>agaHnbixfi-(Ckv9Ay3rs5u5`;!mLBmT2NU z&~UIt6X$@6yFta#-4g&6hq*@y>YhX-agck|pys5aiK{@xv!LQI^L3!@oEkK7MQAv* zLB(PAnn3NHj3f@S*Bom8bTn~esQ3aj@nER<5;SptsQ6l_ILw_Fpzhg@L;M0%9OO=r zd$OVCTtO3u-Oqj(O}rYa{vn!pB~<(wR2=4>8&LQBLlgfF6_@&s+K#e;imTudcZ7<= z+}{PY*A-2?11jzX6^FUU5o&$}nz$uYya-JkroIL$4zd@N&fTE#+lwR)3eVY4dncla zPlt-nhKj@769Tn&DO4P0egxF~ZAjuE^LIhb*@Y&)11f$5Dh@M08EXD*BymuC33~iL z!z(0lPf>7}uG;w~Y z_*AGkx_{?G#X;w4aV6*Tc8sJJdv9Nj(UP;r=h7C_ZIBZ-6D(+U-LM-y*`iU**HPlbwy zpove0iYGzEVeaXK=EoeUILtj8pz3Rp#6j*^4Ha)h6JH4x?}mz_n?DsQ4m1B4RQ)m} zagh0YpyI30#CJi(w?M^V=J!F}e-=%AB2@f3R2*jSHK;jnk;Fmv-h_&OL=(RZ75@bl zhuI4=pXC>7x`LT6fFuqw|0mQO5j647P;ptPIL!P7Q1`1t#bNG$4pnc0Bn~oP9NG`H zKob{+iaVl-TSCQM(Zo%m;(kzZboWHy5HE#_gWL&nPY~3cN;L5RsCY9}9A^GXsDFE* z;vjQC<=79Xe`g_ygUnBcnllegJRT~(98J6yD!v*`yb>zD1u7164+C_(aUTxx>rio! zJ3;Q53^nIAn)pPh_!Bho#Zd7VXyOZ@;%}kiF!yjk-NOpKzZxd43>8;K6JG)q*M*9M z+zAR#4ygGaP;r`P;r?0!_fH3g^I(}t3u7MLlOst4{RK%2~B(hRDBOr z9A^F&sQafu#bM^d(&ri^agh0kq2_Er6Wi!>4agaHn@OOo(XZ?dHH$djUfr@jYiNAn~3!#a_`iWv_;!MzZk%x-I z+`|Cvk7(i$cY=z8+zE1z4AdMqG;t}YxIdb>4pclCO0Xn{<4iyKv2Q;4oo1fB05(mXQBh+8UXyRX? z?zBJ>2blw#S8_%Y2btplHOC!I+yW}@3l)dCGZfn2OoEET+zDG>k&7e_GCv(^P9d6j zGE}?_NgU)(*!qe(Byo^Abx`$9XyP?c@pdF}kU6mR6%)|JVe2dALdDVjwH$}|5vVxG zzaaPYL+w3*Cf*AbzX%maH~%&c@h?zunE4B!=KMetp9dA^fSy;4ZoUu>aeb&b%>0c| zbBxi%*F(i^pyKG}yWtRzhl<0@KLj-=8BP2ER6HLl4l}{Ds=fzz8ydfdMA|8!FBT6$i9!Gaoj;KO0S4 z4{H8$s5s1geQ3HmfF=%`M>vH;{5ez{X0H>}{MTsW4p8y0P;r>Om!ReRe;nd6Odyqr z_zi}dqktwJ2o=|Yii324;{7eud`Bd4P<;fOcMe4oM^+yX6$kkX)c#opoyV+#io?w3 zgyz#09O84J;vjQC={6hc&IM@VnNabSP;qqgH{%dL0~LpvUj;Si0-AUQRQx8IcsEr1 zE}D2JRQws5_-v^7D>U($Q1Q=b;;W$I-_gWZK*brL_aUJBmkTNm@)s!lcS6Ho8c7@! zp1Yvt$fJqxfQoCNiJyjw>!69Bgo>L&#nIhk4;4puk2jJy$US$U=J=zD--3!qpozbQ zipQXdzlMsZL&eeEQwSA@x#uJ_eCm+ILGJkrHKz$p{5Mp*8%>-Sy8pc&O`IDlJ_9O_ z?w&ILtjS zq3(HsBo1;9?EIxSXyQ&#^S?pG(amRI0f|7$B~beO4>ey9NgQN;DAXKLH1S}lxI9!G zWE!aak%GG40!>^ND((aohxv;iTE0afiG%Ddgqk0NCY}uyPlbxZ?1h=14;4o@zZyv# zWd0K86-Rf^ai}=VJ+@Hy+&~fsx#vC9oI7aZZ=vE3q2e&}=Ro^4pV7okq2cfsDh{*P zA8Icb^rBUeILKZG=>9c6H1R)Bd&SYjWuWS%(ZnU7;wn&am^&Sy^}Zesad)UV%snPh zbG*^SjiBNoXyPtV@dz|=C#ZNVR2=3W52$-e(ZtiB;uF!t1EAqK8;AG~s5s31!BBhm zpos@U#ScQoVeWzT@6Mx%`$Fw~i6#!4Kl+SAT!0N^GNjx9#cvYSUJ*3$1gN+iR2-xW zR6gv6hJz`RIH)}X8}IT&5=T}a3>6231E{=8gr>JVs5rX$6;N?>^_@_0nEKOD_e_S0 z!_*f;&0mQm4)Sje)L(1S#4DiU+o0m;<{!WzeiteZvKM6jRH!)*(ZnZ1#a~0kVdh_f zy8kOw9ApkCd|IIHXM$dc3=#*KzYJ;)8=Ckcs5n2G_(7<+Fq-&YsJIMN9OfPeXt|+= zL);!J4s*{9s5#DP;@6eiNAz~=VTn> z8=&Ga_kV}ly9G@gcF*rls5s0$@1W)%M-zVr6@Q2(UIWdiuW^WTaDYrkdTAas zaTch!7*rgj3zWYmLd{ozii7+GNBkUB9F%^pozowvpj-|!`yQMnjhal#bNG&t;76_Bo1;92Xwy)BNxa7M7m{z zigQE7L9(Fq2{T_5Dh@OMAJo5UNa7&#C86eMp^1w_#Z92%F!Rqs-S3Mg4qGP{4i$&l z%Li4TizE)R7q+jn5KY_wYHt-(9A+=f{1&JX-nGais zwj3%BGhYGf{vAl-AoI(h=IlWeFM^66MH8O|6+ek4J`E~<2`Y~6o;x_ie?rAU?gY7K z3)GyyXyTio;_TcYlNrFHte|xA0_rb8s5r>mbHY>v`CDKqesK9VV^<6^FS;9cr%znz$-d+z2WTG7S`8?9le1Cz3d*-2$5jj6f1c zR-XhF2iXfsZ!XaERtptJH@_V!j;?+NR2-%rwk~TCR2-&08fyLyBymvsafJG751P0w zRQxDZ9Nql$IKtx$0#H1S5LxHeQAWIHIn3ZU*W#Ubto6^HqEHq@LTH1U~G@n|&h z)ll(xH1U;C@f4^y%ssI62{mZqlc4ULfhKMY6<-7u2e}gzp0IWDn~}sp;kgTH?{+lt z9Z>PTP;r=h^q}TnMH9D!ia$XUKLD+N|DuV*_M?gLflP+PJ7|6lHV-a?Bo1=td8m67 z(8P~J#Z{5SLFRPkLFU~JkiU1P=kbAPB_RdBV&xDFEfr_J>zYZ#nZvJj0agg~{P;>U9iB~|y&qKvw=EL?I z-ozpP4Jr<@7i4}X)SO>v;_XmzW`2;#he(r)pJP|4mGaq(eOe&iAa;W+FP;r>~PoU;c#vwizDh@Iql%9E^>enHOgTn0~ z)cj3o;`^cEd!XVld%r-sHq2e%m6`<-rAc=$Qy$Ch`3z|6W9NoWY;;*6V z83jNtfs`8{bDl%R*`VSeSy1?ML){~bBo3;tDYhk6aY3m1STu2dsCW`o9Oiy;sQatY#9{Lbtx$28I~}0zoP;C}a;E~+ z{Ap<7a!~R4XyO)7@x^H3W>E1JP;r<$wW03Zi6jmRXK1m?a1Kcv6wU@v^*5m6F!u*Q z-Txjc4l^I7{wGu%T|Ji|NF^d)J3!4Bfr`V_CqvEGLJ|jsk2lm`dT8RVP;qmpILH=| z`(frgLd9X`mqE=BLJ|j=pA9u93{5;8Djp3Lhnc?)>i%3baaX8#IaC~GZyVI!79??y zz0FYbJJ7`Iq2d$K#OFfAr=p3^go@9Dio@Jl0Cmp_9O4I|;vjc|+_M>K&QUb+jZpD( zXyS*V;+N3G4?@MSL&ah4seroYJ(~C=s5rL}NF^ej#6!hJq2eHSg38Hh(C}145(l~e z64YKTH1P{iaRaD0$QDpK35S~RfhL{{6;DPJ-vDiIR6)f-?g7>Nuy#=sk~qjckD>Oq zp^4vzigzQ4gUo@g-Fn=I7*`;f#z z<|{$XKZGW(02Mz26^EIB1!~S?BymuA;tg>o!*?WcP&mWXGYW%DfYb{h_ZUOX5ke9N zxyK4>uNa!R1yo!CDh@IYWd41qIhJVRAEDyTP;po|xIx83ki z4i#q?0oe#iCm{8kq2k~E>O5hLfxZ|Bn}GaL})l$BZ(uccZG_>++PND ze;ATD$UP^a_C}$JABT!3qlw>yil?KAUx$k4K*eG1SB1L26;0d(D&7wjhq)7W4$=Z7 zagaM-K+Ru*CjJa6z7|cKNedD{8_~r7LDg@Aio@J#19i_?BymtUXF`l&c!(qp3TK%5 z*HCeo`=>#}`7e?<$o*1K_b`frY(%67F{n5fR2(FWY`zFo9Nl~cByo`WMo@E9(8Tqi z;<`|AnEBpN|C&R^Vdk%dy59py9Av%^)Epl)aW|-VD4KW$R6G(*yaXzq1QkbjPYzTZ z=AJ!J_tYYZgWNL-YEC1Xcpp@}4Jr;Ze=gL&Gtk6g?Z8D)ahSblp!Tju5(nA43Tpml zH1TCn@jYnbN1);d(8Lcw#ZN-TVeTw|y7Mv)@i$O$kUK%{xdk=n1Df~^sQ6Db@mEms zzi8qwpyEtoAeSK8EfrArNTG>OhKie^iDyB@9iZYMcY^B2JJ9e9L=p$N|0mSmP&D!H zQ1NJ}ILK9?e31k-zZgv%7H%C-ahSampy!cJMiK|LPu%(-8G9a*ILJMG+7R(YXyR;8 z@hxcLc2MyhXyOJ?@qI|*AbX?NLd-vhBn}FnWl(oMLJ|kLryFX{Gc@sfsQ7!RI4pcR zq31FFgo?w$;Q-WpE^&}bMEP?ZY7QTo_+hBHIGXq?sJJwm_%o=u3RE0q3n;!|=W6QV z5ch_PgWL)7FS`yTeEiYGS)t+)XyVdP@fb95NvL=#nz$BJJQGb^11eqw6-Re}4G!_C zP;r?1ZJ_4NL=(4yiZ4PF4}gj zDO4QY{P#G-IV3l|C`YCX^bQeN)N42 zbIj4i8=>M3XyU7&;x1_7OQ7PuXyO;4;(=)5XQAR@Na7%OzJaAV0&N15>0#;RJ;~Vd>d4}4Nd$KRJ;pK{2Ww#GMe}&sQ7d=@pn-1 z1!&>|dJy+7K@(?#im!!=!{U7_G~I58io@dlKQuf~Ac=#*(;aHg88mTcsQ6Vh@pP#8 zO*HXjsQ4o^@ySr}XK3R6Q1RDD;-Gkkx$`Gf9Nk~ck{}UCz5uBggZftrDh`qbrT?o? zaTOfmj!_<+J;Ez~`(XyU7(;sH=`nEBJ8^=u-NIH(;9i7f_(LL_mJdtO1^Q;kD> z22>p8o`X<(=b(x2hl($Sio@IkGk-k}@e@#SnE98X=A1zjzX%n-0~JR%{~1&qWDY3& z)u8_RjwB8W&zDehexr#$hKjRDflP+PBS`&BeMrc0povd~it{3gBikzm6$hCH3g>ia zyeL4$VeW*T*KLF(4zhPE)O<5E@y$?id#E_N`JPa5nE4LSaEL|{2bq5yYEC?w_)(~M z22>o~{3570y7_fT;vn;HLd|JH6Tc1>??w}U4HfT46MqR6p9vL*xhEeQp4-sGze4?c z0EhTps5r>|Ab0+Tn*R_@{3lfW6`DA|0VF-VLlftPihoBFSB8rJMiW62t3Y2btLc`M+Dh{$2l+J^p z;&Djgpzw@`nv;Yk9t{=GMiZ}visz$=S3<=r(8Q-h#cR;SCql(r(Zshw#XHf&H$lZG zLB-MiI|nL`?%$P2;voN?gPOAzP5cy8d>fkh8>sj$H1QWu@xy51Y=)5Zb{tKd0V;k0 zO|)YR(TdaZ9K;qYTJoMEMyF6=y{g4~L5L zp^2A5#f8ws^P%F>XyQ|#;__(X6QJTMNaCP$8w*Xhx=7+6f31S5H$)R(0Tnlcii3Oy z$`?A&@+SgK9CluP5>y-(p1Dwai;=`Z_U?z8Uydfe8!Fy_CjJO2-hw864=Ub^CeCXF zNk0?O#5tkjv(Ut0>gS<}!_+T_io?PI=HHD_adiLgLlOu1R|{(IAvAF{sQ76#abKwT zc{FiPsQ3*u@d~K;9W?P0sQ6PfahUp-XyP#SpP=IC{`~_LNB1wMEJ!6H{ZED3%ZnyH z5h^Z*CcXnIE`=t(1uCwLCjJ;Iu8t;tA1ZEuCJs|?f+h}A?*J7C`2v*AVe#t)6^Hq^ z7Mh;Jk;Fmq%U}#iZ_#Mtf1vJ3K@-=9s?R_Z*M^E0qKUgh#Y@q|ouT4YNaCRUJ{juH zW~eyKU-r=a+Y1$k`D-pz{d^>GkiSx)<}XGQPlSrEK@+crif=#@uY`*4go>lP=P*

~pP}Y#MHBxB72gjPM>qc@4)JGDahUn6 zCXjsh3Qe3DD*hQwTpTL?9Zg&mD$XDeatR`SHK5`wXyR&6aXzRxNEax+VBsTyL);K5 z4s*Xb)ErYZaZ{+c9aJ3Md=IEN$Q)39KLCy2NF;Gk{CYyoiA584hl;16i6=tEv(Uuj zq2k48;ssFgay0QgsCW&MII=riq2e%qc|+ab4;6>`>jG4K4w5*?UrkW+7odqZK*d+0 ziO+(HuSFA|0TthdCcY9Xz6(u!IaK^GR2<#?XQATg?!Sd34s!o)s5$r0#CJl)pQDLi zhKj#N6Tb)*|AHp|2rB*qP5c2=oKXSfazy_N7XI8&adh`fBZ-6D{{?D}Jev3?sJI52 zI2%Y40|SE&nm7wo+!Re*4k~VmCN2XNw}*;@d;!XLVbF9Ef?6_%f(C%zS&OIjhjbZK2}Zq2eI(xfvK3px2==9E6I4%mL-2 z2T=cBLJ|iV5eOm}7#OahiTgvv??c65<~u-&PllIJahUmx(0b<=k~qkSWDvo?!0-=E zJP|6+t_U(2lCD7R_kfx&h(lZtDh{$2WJD>5U|?V{LK82Bid&)_l3GY9*1}ZR2=61l~8kP(8QNR#aq$D_dvxv(ZqK_#V4VO zpN5K0LlZv<6`v0kM|b~99O8$d;xPB$g_?5=P5d@g{5+cY2dMaEH1T&(@jGbZ|Doa! z(8T{j#a}|j(cS+Uhd8$qNF}1a76fGu1_lOxG;w~YxCENGGE`g!Op{gqt^%c>AZYq=#v$&DLp%*C4vQC8sQFoF;?7X^?GmBymuBh=QgE zKd3m!{mAp?AoQ5P0%351Nniv=uW}%6%hKkQe z5(k-691d~lDkO1`IiI2G*P)3&hl+1T5(k+BJ1=n`k~qj58*_;HhtR|gpyJ1o#6jjf zfYwKskiO2bnVwdN0K@Byo^ATcPS-p^2}Dihn>72bt3io!?|p z0mV3^z5~U3BlLVEKBzb-enCMq9~xisNa7%SuR_gNMiajb71xD|gKPnrKObto3z9f! zp6e(iI2j_4#6jv0L)9nY5U+=dgWL&n&s(Uy&1mAUq2j$zahQ8x=TmJ&6MqJ^cQ;fV zWIiYyVCQz8K@tbq%L)oq1_p);XyVLJ@mo-Fn7yB%=6^&I2ZaOl8Vd$iRgg+Vyuj4+ zL&ah4ft@d{fFurbk1W()6*O^asJI?f9Apb9oMGo>`J#z)K+oF=hl<1OJr7L}8A#$F zdv&1Z=b(veLB&ha#9g4`m1yElQ1LpbILw`}bGqiBi3>s9xeSN+VW>FB{UCP+L(M;q zCLRbCzX%nF*{cRM{{@mbD88V}$Qk}1iG#uurk+g=WC9`{VdBbAahQ9uq4uhyiDyE^ z4WZ&7(?I4MLfsR9CT;>1kAjMW%m=00`_T9*KoSRqLj%1#8aW+ zxgCf26{tAO{i~t&-ar#y2^GH!6^FSe3u^vrH1Q;;II9LoB_e)d>iMDKAbUai)DRlK z3P|Fh@Z1NrR|QRc2UJ`aP5cE^+z?It5mej?Dh_fLD1Kq?als*;2o(pp6XYI2D@Z;{ zMHAKAwCT%4l`c~YR)V)aRsROVyHN}`D<~AABBp;%r}Oba}rJ55GsBN zDvoac9US6cq2e&}U7+UtL=$&{inBv6Zbmm>5Qn%XR2*i0DAXKXH1S}lxII)H-F#0R z;%QKEnE7c?bF$FHQ=sA{P;r>~CD3$U2NegI14_@H(DXb7NgR}Z>Y?V$Koc*8iZ4VH zKLHhAiY9&tD!vXXj_#fvP;r=hGNJA{ha?Vi&j+YEm(axDLB(%F#nH`wibI@D3#1a! zk7I&%IJwZoVFP5sP;rnhP=17krz{R}E2ucgUm*93K+U&96BmMtdqTz0%@2l(gUkWN zS0yxj;*rEb=Bq)?Nk$V_fr{rr#bM?*K+{77R2*hL?7pW~Byo`W4p4JC(ZtQ5;*-$C zJE7v!(8Qae;`5>6=>=U7+*;bH6H7 z9Nl~)Byo`Y?V;wFp^4i<#oeId=;jAN#bM_EgStNvNgQN;0MwjRG;u$ucpjQ~5>&hh zO*{cA-U<~*cTYc59Nj&0ki1{FtlzcZ3J$o$JtbKKFyFG9tmpyKG}r$EKg%`Zd} z2buo}YECJd_yeeT9h&$@sCW~a_WsH#BiOsQ7<0aet^dvmVGsNV)}?;|mq%K@*RMiVL8L$3n$Lk;Fm%5`^9x zB8ManGCv=xUI|S+7b>m}6$iNrl>Q$>>nR^Jaaj2rhC{p(hj=p%@i|a&P&k9!*$#Ej z0yObfsQ7BAILw^_&~byUIK(eO#bM^pgqm{=O?*03{6171-Taq0#M$&gDiQIx8fp#~ zn)phnxCm4nqze?zB2f3s;Sjfmio@K$7ix|@n)q(0xCff}d8oJ#n)q3$cqp3q1E_c; zn)p4acrsKR-Tk>Z#M_|aF!#TQn$v|Q{uU}e87hu${#>Xy$Q)2QSA?eXbx7i%^uuTm zDaSUUiT{V1zZ*?l5~_Ybnz%Sr`~;e~22}hEnz$NN{34P#vO8}<#bN%EgvR?5s5s1D zhERWfL=p%2%L;1#S2S@8sQ5oL@gS%;lL5#^MEVSXigTlhCql*f(Zu7S;u27CkZGWF z3v<5`R2<#?`bgp+_ZLIWF-8+Fgo@jsiFZTA9ni!(q2ius;?GmW@5lG^od7pQXVuK+ENgSkp15|w( z4)MuQahQ7)q4rKk6PJgIFNBK2+;aqK{thH@kb9m$-E#&>9ORx0Q1#bvh<}EP!`x#D zwf8%kxH(ju(Fo)cMEE~}nlFJQ4sy?JsC#sf#F5tzm_fxs_JYbiM`$_bjwB9BZ-G#I zz0t(|q2eJ>ageK!&5y$&UJVro*$Xm18EQ^Fns_2qyb~%8Gd~XMugN&XH$cT<=9fav z*@7ls3>DvtCf*JeKZqvY3Kc(vCO!iyehy818dUrSR2<#?k8p_phKj@7zZ`1Le>Cx> zP;m}pkjaqr01E$9X!r=>5Z8x_!_40aHOClDd^=R!22K17RNMhg{1jB&6HWX!RNNO$ z{3cX93@Q%t1<3tbQ1>U`5U+%a!`%NCYECVh_-m+m8=5$SBgBF(H1U5>^^?)W`Jw8k zqlxoE#TP)u(cQlahxlQrIL!TuP;-u>iOWO9FQAE=K*g`1i5o%1@1lu2L&YDWi915Y zUqQvu-TwuLIFAWPC8B*23N=RnO*|MXE{P_d4i%S06HkSTtD%WkLB+Mu#4DiU`cQF@ zt3c@|9}>L`E;z*faEPZv#bNQ%2{k_(O}rf{UIG<5_%x_E%>3C!z+j6c4sxe9)O<%YaZRYWH&h&CJ1897q2?zciG$iF(Bp_0%86F!uyO-Lnr(92Pz&aEL#Jii4a1 zvNs57{!29R0I2w9s5s2tGN`>=<{%MBynw<1dVC{;9FjOF9AN4-pyD8VLE)ebVlXf; zSR#po+>-^h*A`7Y11jzg6$jZ4GQSz>o&+@UKB#yWR2*a-$X;U*1GKLJNgQNv71aEC zH1P_kcn6yJB&c`~n)n2$_(Z5U%$<{=?pcpRd?ya^Yfy2JvqA1$2sQr}n)rOE_!Fo& z%--ctdw(N|gW?Oie1n1C0;CcWkD%~`sh7kdZUz;Hxo0QTUMn>5?ND(Ss5ra{fKLJp4*wMs&pyE7GagZ)hJgV|S z+%JbFei9lE8c=bNbs&2yK@0{422&()P&i~j&9_7oPl1X%p@}y^#of@v>!9NPP;r<$ ze?Z+6i9@^yDh_fU$UQTl=9Hm{PlJlrqlvG8iZ`Q)FN2DAK*eG1VSt9)0yJ@HsQ4Z< z@#j$YAA^d6+zATLP7s5Ef#EumILQ6mq4wTJ6WKWkULL7-D80!egrCRizE&*2i7j~KoSR; z^B=0-2TlAVR6Gz#9Au7v5yYJ_Na7%KCb&Sv6VSw+pyGLG;QM1=Byo_v z?9h8~n~=mo_O6AhZ$lHG3l;B15(k;n9t*K|8j?83oX=48v(UspLdEAJiG$)Rg&ktf z3M6rm`MZT7;+v7gLFRKnH?VC-6K8;m??Dm=ndAEpV$N|SagaF{Q1z$L#C4$J7m&n3 z=FIklm~$IR9Ar)hRQ-K4@fxW36C`nvId;(V9^WI0gUq=GRsR`H{0vn54^$kK3qa-G zVNm7Cz`(#}4H7}*3z)bvR2-BqK<0Bm-LH-&&IT1XfQo}mLpI+Ehj=(t9A>@@)SPHE zaVe;H3RE23{5%}u?ND);`36vPy3xe-pyIQk;^^it#UZ{ADh@N>1!~SAG;t@W_ywpq zy7{+oh%?xLR3hT#1T?<5aEPlz#bNFVf!eE$CLRP8H$f9mhKgIDi6=tEouJ|%SApX9 z3DiA4P;rpGp#0bX&5w~t;-K_X1vMuYO}q#yo`xpA3o4$4CcX(OUJMn7x#um^J+(N* zXFXyTus;>*#*IlLhGcQu+g8&rG?nz%SrdzgL^SaaQ1MhW@i$QMJT!4GA4s|?LKA0$idUnF>p;cp(Zn^N z;vHz>UQqEKG;s&0_*AGkDE2}58W!*Kq2jQ3-vN#H4M^gk@T`KGvjt7O3@W}CO?)0y z{2-e6EU5S?H1ShV@pEY6$Drbuk;Fmq4s+*2s5rX6UgHqwvjeF_q<>S8#~BzHByfnE zLd8MKK;iHN>K;op@kdZ`7pOSM7Em~gf(GXp7#Kp4#GyqPI62RQv~;_${dTA2ji6P;o|kkV_!_L}YuppyD7|P&j`8 zIgEjUK?F_w1ytM!Dh}d;-1!G;z8RYMFQ~XZR2fj$6;yl|nz$KM{4kn0 z%)iIc#9{uufF>RUHRlSNxF1yfE>s-dzt5rK=>GkJBo6X#9@Ly4XyRE=aYjdw$&m68 zq<#WaoE1&H2P)2oCJytj5Slp5ztU*pE1>4cqlqtpimM=rgVHSvv@+C15(l~S7*xF> zn)m^zxEWL&mlQXyTus;!SAc zvH_6v)`li72^H^06L*A)Pev2Bg^JHX6Njl^fF=%8zY;1A3kR5gH$%nI{d)jO9OU0P zsJ%zf#G|0%XVJu4q2d?O#2caFx6s5_LdEZ)i7$nUKSvXXseg?o4paXHDvs{oe^7CB z|8hHlR3g&m@5-PqENgR~k zN}%cO5Ry1(JQj98;8`SbkozN{=3GP*_l1gILlOs>1H13|9+Ei7oT*UtkI=+>q2kYx z#6jl3?mPZ~CJwvr_%Bo(7H)FT^$+YWAQ43S7ACF&6^Dh}Rj9ohXyTWl;)YOhkZGXw z05iuLhj<879A^GYs5ud6;?JSt8BlR_^NVnZ_d~^D=KqD7GZ{_%H&lEMR2<#>WjMt5 zL&ag{3kE~V`NL@9{7~`pP;r>~$L5_vAvwLH2_3(G=+XS{;%&D4n}O z&1pgtcY%s`qlrgB#rx63BcS3lpyKH6Sp*e_xn~X3J)4olLGH5MdXQ=pLs5rWN&O*h}-E$L39ONF(P)NCY7fqZUD*g;jTox++3Qb%ZD*hQw zTo)?-9Zg&tD*gv54s*XLw0x6r2Z0z9AcqLSPJ(_qqRD1`Tcn4H`51M!zRQxDZ9Nqorq2lQ7zk?(Wa{nBtISxgNlDa6Njn)fhG=9&*BO4DQ3Fm!y&E? z6^HpZ0&1@|ns^vg+yqTL2P$rXCY}WqcSIAfhKjqQiC03!{m{f=>Vwe4Vd|ry;viom zr{`20;&o7Qn18#W_BNr3cS6Ox(ZuIN#rx63=R(D2poy=8iqAn4Ujr3iiY5+IzY2Neg&g5noeUrXQ+H-w7A{QD7VuPK`Nd#Jb_R2~ ztk83MQ_;kkq2gswahUnA^0omg4l)N+Uq6S|*AtP%LG_Cy)SRhk;^I*8`A~6~`GL^( zz(zE2n7zAkh~I#UgWLnMR}*Uf9W-%usQ6Q;ILuy{`R{Rv^LT?)BI4H;YK{P!xHVK< z5-JYT1&Vi=`N}xNZJ^>X_Xk4FaX=IIhl&S4#nH`=!XaJ^6^EIh3N@!3O*|PY-U<~* zH@_c;_*OLW5NJH^hl+#j1*Mbk&~$PYNgNbk^-z0nqKU)Kk$wafhq(u4{u`(`y7@nl z#6jlohMNBeO?*96oYexG7W|=6*$}do0n!<)PwsP;rngpmfp&HQxtKya_6vh9(YEUjP*c*$c|2p3wMh zL=p#urxDcNRy1)vsCYkA9OfPdXgJKoA-)YN4zd?yejwDGU1;L|Q1QcP;;B&a<7nc^ zQ1J^;adh|G!Xf?{Dh_i`8PuHbXyPSMaRxt-$%uNP3o6cnCf)%R7lMj|bb;av7Ctgi zage>B@Q0OeI!NN6@RbpL;vn~ALCvW`6HkMRH$%nI&F_VZ!_40Z zHGdY8ILQ1-P;=&?iFZN8m!pYago>|56F&_V--0Io0V=)&P5cd1d@qtXC>&t!JO&kq z`Ku6`4lh8(Vg5P-_19e_age{nq9OI#Lo{&#sQ4>1aaXALJ2Y`esQ7m@@o1>{Z#3~p zs5nai$mNK75axb9s5rX&rIExz?k|R#BabGY3l-Nu6JG=s*Fh7X2NgF(6W;+9w?q@) z1{HULii3Os%11Ew`#{Cf-5-G@4s!n)s5voc;-{eEsc7O)pyHWm;`gB9MQGx}F_8Ez zLlftRidRF$VeapRrk}}3;-DrVY(Mf`s5s1D*P-cZ9g;Z6Uz$+!H=&8EL&bMP#Xfe7z;vn+_q2@3J zf=ob^tNu`NZZz=}s5n2GcoI}x0!_RWDlUU2UJMmiL=p$(cbGf1pyD7`fx?Xs61@y2 zP;r>QRH6QILlOu1s~c**7n*oGR6H0>d@)o!98G*7R6GGHj_#f;s5s0$_E7iKAc=$A zvlD7g1Dg0&sCXxu_(iCAFPivysQ5IfIJ$clK*iDBvj#~Vq!!tB-acDe#z#+~T1Tq0qPJ-ecrd|SvxCNRxEdM&;5RZq7 zgTe7~Xs5r<~Aosw`FUKK10V)nNUma@B6f|*FsQ4l@acijfGBj~Z zsQ6l_ILtlJV}Kb>Ld8M$g4U(L_Rl^+6aTmf5&>MnAQK?@9a+5+4sk0S;vQ(?GLIqV zXQGM2+*6Jw&UFl;eg>L2O#L!6@r}^)MvkM2!_;3z6TdkfV*YP5ahQ6R5Y%vh?H3k8 z6Nl}eRX`Jmtw*wkii1o8)sF$tah@QkIC{K9A&G<1p&vAU1Jq_%tDjgUp!&Ro{jtJ_Rb?jU)~-2NpilkiI4oWoq49DGDh`Sl zkiE@Ndv7C&gUr`~9=LWNO zc2IFaH1SlZxG0)(Zp+^;z4NQlcC~a zXyOy0;weyZbob=p5O0Ty!`!n7YECzr_yVZ-6g2T|Q1KaP;#;8Ni=pB$_xy*3&srSf z=W&SN#3B9#0h9nM3|56E%@L7c>E(R6ff+UV?&LOBc zy1i$h;xK!6L+yPG6^E%;hPv}D4sot@gE;z)~aEKS+5TA-ed_Ghh7Cxt;;j;lr92756P=9Sf6Ay!m??Vy? z#S6@w<4|!}I2?ug>mpPfX77Edy)U5R=;}W~#bN5-L)CLefK(##HOzcrs5rWM6(n(x zzm7rOuYo3h1S)O>6$jY@ikDMR_xq!XJ3z%Fq2e%mnV{uc7Lqu~-WyQ!^U%bvK*h_^ z#Q#9WtI@=NK*c+u;xKo@+%p*}j_#fXNa7&(C?tZDA;S_haT%!iS~PJNsQ5-SaR;dQ z9;i6XJ?_x(IR+Jnxkm;XK6jABLGHZ z2qa&F(k;wA;z;5k_iTllBaJ4$9xAShCVm4du8Ssq0V-|=6$jZ4N>{M(ae#`Whfffa zILJK=Ns#yoLlgf6H9rMSTp6l915I2SDxQlZ4hjcLXuOmmiG%F*gsQJX6L*D**F(i& z{%V58`(iZlK&bdys5s2Oeo%W4BZ-6T&4ikN98EkODt-$p4zm|#{u8J;y7}Lb#6jlQ zL(TbxCSD5_=ZylHj3{Sd=8Hqc(aqOH5(k+-6>5$yn)qa>xHD87WD6)gz|8lBio?v0 zgN9EOk~qlx^-y!-(8O0l#naKmpFqX4(ZugT#Y>UILFpk6YHuA>9OlkmXgqe{5MKrr z2e}{Q&i_#JSD}gjg^KThildu<2#5Fss5s1gzGO(gc!DO*0~P-S6-PJ!4-Rp;Xpl-s z`2cdiEYut&G;wLDxH?oEqze>}Q=#Ewk0!nf8lIjw#M7YSFn{Sl&Cfy;*Mf>yK*eG9 z!pv{NAwC-_4l~~YYR-H#aXYB^DyTTR`CD*^UxbRo%nyN@a}`ZI2r7OLO*|DU{s>Jx z87lr7Dvs`+uQUa;W%0s5rX$ zr*VkCfQrM+-vu@24Vw54sQ53aIJ)^Pu^#huZ_MWEvDXyO7; z@c=Y&U8r~nnz$xZJQhvd9V(uPChiOsPlJlX{Cfymp0wi-pNKH1RB`_)Dlbx;sDP5SL5@sYK+{uTX!Pqlv@jQyih?u^P&>H+ z>Ygw(@j9q@JX9QHJ1G6Y%+G|1qnlrbBn~ovBGjBJH1U3@co$S0W_}jbUsIssF!N)e z?q7%`4l;ik)SRVg;tQbS>!9N3=I?-tqnm#eNgQPUb*MQf(Znx8#UDb&Vdf{WKa98FvnDz1Sh z9t{=OK@$&#iW?${gY1o73vs74k~qlTcBp!LH1T?mcl z2f2qAdVll;Byo^AI_VJer=W?eLB(exiG$qp8S0)zNa7&#Ve@)xki^4l>8_1jIf2k;FmfG(*)NMiZ}uil0Cd2bptyH^iJvNa7%Kwn5cjLla*I6~B!n z4l-vk^!&+ZNa7%KUO?5qLKD9O75@ws2jwPExl{lxAO1qcLHQ08o*dBp$d?RKiO6>f z84&jip^3{t#ih~2ZK2}wXyTSoaSf*#Z?uSHBM`4pZL;Reugi9OV8>P=Llb`u6=zEUnT)8f8=&b^04feMe+kt6`cQF@E>QY`skelRqpJ^vileKK zhl<10?}eIQfFurbzd$A={g=d-FXEnj_%HfNa7%OHbBjPiY8tI z75|JTJ_{=T9Zh^1RQwN;II=t0Qb8_6q@Px3`cXj>=YY1CJki8q>Vu);Fn?WxriU!3 zILH=IdV{Gifr_K6Z$lCXg~JZ0`@7J@w?M@wL&ed}p9>X7H-9Ho9Ht(Y{trXNVd`H% z-G3QL9ORz+PA_9xC1r6-PIJB2*mR{CP;?AoClb<}5-JuYrnh zf{LS?zXvJ~GhYVk{V6p{agh1fq2?%{iC>0_>p{gqwt&(D%zO)|IJ)^kP;qqi zF;H=sdK;*Fa*@PA?qSJ>)Gvi-;tWvndZ;+M`JGU4bn~YniG$47hMF@AOwXG;-K`i z5PE-NAd)!9UYPqMk;Fmab_E(fv1sDQpyEkL;vjQi{q7tjagaGmIS}_0povRB#Y>UI zLFT~jJ*-C(2bmKMRo{#z9taihKoSR;Gw~b5-bqN}AakZe)lWkc?}v)dK@ta<)2#zB zXFXIL6l3XyVVI;w?~dbo2Xgh_8o=gX{&F{~Kz~W;F4iQ1Lxbadh*K;Shfe6^EJ6 zn+M5{&(XxWq2iyQ;^^l8fr^970mT=qD#RR)9FR&xdXR^j!-FO+3l$fKii324(nAe2 zJt#uOVdjfM&DTQ`2ZfJ0)Epx;aeb(`HJW%4RNNj-JO?W70ToAgPY_fb<{k^Ed*YGA zLGD=qH76NOd!9K=clJQTtph3!b7u@x{Zu4z zkULqS7e&uR6K8~qFG3Snhl(#l6IX_cuZN1GyJsg<9Nj&~kiBn~qF8`PX0H1RJ`@i|a&bn}-%#bM?*LfyX|NgQN8 zdjTXIcB6^2LdB0j#nH__2Ng#*|2C31$b1Q?Irq`T#h~Kvq2lP~|AdOe%%2E#KUW?| zB_jQ3Le1er6IX|di=&BKL&c@h#4VxXdQfqYEui!Ri!TePIJ$dWk;Fm%^@5t?i6-s= z6^}p?2bD`OezX%n# zKodU?6?cS+gM5LUZoQ%6=ZE*Bo1#473;;?l4ABVV7 z0muZ*bgqL#+!ZPg3TKcz!=di+L=z8%iibeOLAHR>p(M1Pjl&^c1r>*xp9wXm4oy5A zD&7tiM>l^W4)JwRahUnlP;)k+iC03!_dvyA=F39ee+-BCW2iXH{9dRz&(XxYq2eFV z#OFiBzo3cFg^K@06W;(8XDkG{5K#}VgNk!Q#X+*5@Q1ly6oggDk13sWd3WYIc#X+FQMWBP;rnhkomkI1_J|w6b^B7 zs5r=9AoKr1&9O!k{|yy)K@;bPj{ke0iSt6m1JT44pyHuu;&M>&c&IqY*~sqC#39}U z6^FTBA8Jk;nz$}hydNqKGhYP6U|?XFi9>uFR2*i$Bh;K-XyW!z@xy51AyDz-XyQRo z@e63;$x!htXyS=b@w-rQkh4MIBMD+KFfcsFALd}_uCVm?#z5q@9Jyd)Nn)q9&_*yh^ zrV>cMV08$-nt zq2lP~XX6lWhKj??cY&JIjwbE|6`uqZhnc?|5{(RVaER}Kio?tghMKbnO*{}PeiSN> zZvJ^3;%}hhF!Ph3=6paCPk@U5go>k^&s+u)LBuc2UkXrhnE8cJb5zj8^P%FpP;roH zp!kKEV~#^S1S$?QzX57a1e$mqR6GeP4l{o>H2iaLh_^z;VdnQk&FMrF?}ds_fr`V- z-vTv%9uD#CP;r>~3!vugMiZX{6+eO|z8xxl0!@4?RQw`T9Nj&)q2eHWLG7Gx(00xX zBymtX;S|)IH)!HVpyFTA#NR;0f1-)Mf{HVhgIt1W=lq6>v!RLqgo^V+#X-72=>Zm= zl2CDU_p2d^gWS(o3W)$MG;t27xG|cz0aV-^O~YEbj9Ac=#_{{c1U2AcRcsQ4qOIJ)_7aEP;3f>a{PC9X0^ zxN)M1b3nyKpyD81p!j_bQO+QTL);uH4)Pbs{c=!qtkJ}!pyDoQ;-*k>4>WOOsCXb$ z9Nj(9P;rpGp!8q{4bKcDagckwq2}bEiMv9@OVPx0q2iTj;@ME~CN%LHsCXNicokH< zA1aRS{+Up5boVbq5(l||64abkXyQFk@y%%BTcG0G(Zn}F#Sfr~ABKt_K@&d+6+a6V zM|b~qs5rX&pCgHb+UnE4J+bJn1V+d;)QLB&DlgT}`^pz{~|(ZmCw;%CsrnW5up z-_gYRpyHy{Ad?~W6v%woyn`{CcotN>7n*n#R6HC>92CE8(D=OsXp z@da8Z30wbZfg}z}he6QzvOyCMfQmap#bM^3gqk0PCVl|w{z9lY%wE{~)k-9BkiE%J z^J~$>VV_3thuagaH8q3ZXciC>3`A4U=fnFHO9$#4cq9OO>ee$Q)2;vnmioSBHxCLB&DVA&1Wls5s0$+8_lC3=Auf#6j+{f||1i zP22)1z7Sza(^7u zUVb$37^t`eR2-xW**!{7agaHn^aC?rA4wc!em>M3V>IzxsJJs!9A-ZBSO5lJ9O9W! zageg@wHHKbo0045Wfr+hnc?w zYR+{u@kLPa2WaA3pyE%^#5Y03-$KRF-SZuXxJ*4rC8C`G3x72n;=VYy9!bsenAuGgo^(~6PJOCGd6&1MAR1&P;o9aaWkkmADXxkR9qY?4l)hd z{faomt)SvC_xnN3u|pI0fr`7MiN{05z0t&@q2eKE;+0VG2sH6hsCXip_++SfDw=pd zR6GkR4)ZT`*)2mi4)Lit#CPBjKZHa40aP3oZabmwd4eXs9V-47Dvs{X?>NL28bK-% z`4m=`KU5su{F6AuA3?=o<}*}7^64`)@qbYBzd^;(&1Yx= ziD1TyBvc$`z97_mSu}BesJJ#%9Ap}D_?zMok46)RUUSBf3Ka+03#yl)*K{(JB8h|Q zO%15Mm1yE>Q1K=-adW768=AN&RJ;Dn1t~j_%*(IK&S_#X2-fQrM+&xD%u2TeR3D$d>vG8qx?(BVM_L8v&$98mbf>I+3A zagh64q2{QfiC06#_0YsGL&c5I#7{!St)b!|SAo(G)Y%NKIK-2n;vjc|+{0A^N&jhR z;v7)%d^B-6sCY4&xC~Uh22ETSD&Bx5t_>CMgo>lPe=-j7HBfPw`|Y6SY(NvYfr{@$ z6Ayxl??n?2fQp}hio@I!3kp;Q28K&G#NR{3VeUzUn)4Y=JRU0k2P%$kK3fY&1d*;_ z_R2%WVdfV>%~3`ZFMx_0L&ZU+ft(IA#}+CMG6$4C+d&E#7#O^e#6jty3u=xZns^gb zJRD8@Bvd>aP5dBKJOxdhu@;ivGSI|-Le=LYiG$p^9O}+8Byo^CjiBaKp^582#hcN@ zUqHp%(ZruX#V4SNGu1)dIR#DpA5{HZG;sx}`h{rXGEnhVXyQ&#@pWk8c2M!{XyQpw z@!e?R5m50XP;pRjf#N+8L@+QgoP&zP;{7;C0RscWeI#*Ec+Q5J^B7HhI#m1(n)ptr z_y;uctx)k_NaCP)gxSl{3UL641UV7rP9dl`%$<)x3K$p|G@;@kE=YYNh+tq~FvcMs z02K$B1M=5nsCz=t#2-S%0_i=&C3hlMyNQt`MpTuAoB&G=1)Wu=ZA{VLK9bliqAt6SAdGIfQrN16ABH_qiEubq5eIO zL;MX?9OQnGJB^^`e?SvAfQtV_6L*7(|3wpbfr_(1D<+uvQBZL%H1P4<}aB0 zWpRj`LB(O_XG6`gLKDw~iaVo;*F(kK(Zp+^;z3Yxn0r=0!!rgd4zd@NZgrvJxk%!m z@SF-Yrw~niB2>HzO?)F%ybeu#EmXV*P5dNOd;*&IQK7P;qqkEJYFrx#teloRw(eH=yF1(8Pa3#kZk}|AdO4go>lP z=Q30r-8~PG#6j*6Zi1xGCurjQQ1Q2D;zm&Mk7(isP;vH7kV_E#0$BJ6Ld9Y335Uj) z9FjQ5Jw8x#l+eW8pyJwS;*C&oeKhfEsJI21_yVZ74Vw5YsJJ7NI4C`*L*3~G6$kka zBy<-~E{=b+*}P;qqkOv53*1u716 z&qJs=JJ7`ML&XoGiGP5KA4L;?2NgdD6-Rf^4IJVhpyDw1Fg8Qd;TJUV|4{Rpx!Ie{M-yKQ6@P&yei$nL22K1R zRQwlI9OMip1_lP0dswnx)Eq@L@e5FKEj00GP;osp@h4DmOQ<-= zc945sffx)749+;jQ*nsr;}D;MLwp`o9ON%hdYA>WoPmL1HIg_e{C`8;xgJgYGgN#B znz(5TBtPy!6E}v6A43uc*}DyD?|CF~ki8yI^_S7aU7+H3(8PB@#UG%FZ-I)xLleIQ z75{`Lehw=B8%_KRRQx}h_y?#sM-L?8K;a2;zgR0I9C*;gxuD{rP;rnhP!PNWF&G#a zc0cF!g*;@fsZBQ=#G@b3pFwgt})Yns_@@d=*q2X1+4i{4F@dui+4XfJ2 z3=9lcafp9{ii6w(vR4*r{x>vnX{h*rG;u?yICCG!C5U=lA1W>g6$imZl?}UoCp^3Lb#rvV+=0_|3DM}2o?W>CjJ&G&e#uf2_#*C z;zbJ@FI-6CAbYvnA>}zAnm9XDTo@`2G7S{v5>Ruj(ZroWk_-$Cu26B9e{G=Zqmjfx z_Ub~-k4F>Ngo+nI#bNfs%&&opqnqD{Bn~n^0&31AH1QCq_)@4iy7}v&;^^idL=p#? z-wZY9D4KXZRQxtn9Nqk~e$epwgd`3!e*@HkRJHxR+Vz@UI8{thZ`2NegoA7nm92PFMCp^39V#RH(? z=;lX3#X;tP+*1y9PY#ke$b1E;IR$9qGEnh4s5rX$9Z+#}^XDOngUq*pnzIN^+ypAV z94Zbo|2H%oj-!bm04ZQ#V7Q1w{4G=*~Nl~ccA8^p^4vuikCpe(ao>JA-))g_*$qq$X-zToDNN&yO6{| z>EScf-hF7|AEDyM(ZpFgA?4U{`1Qaco&ptznQs9#Cj(8~3@ToTChh?h zFGUk~gNoNd#bNF_0%9;QFm&J$UyCMw5~_YX4)M!SahUsKp!Qxz6OV$5KY)sZj0J@c z%=}k4#F?Q3DKPVMq2{ooiDyH_#i8Qp<}2b5w}pzs%&&)<V zLdCLwo`b@$ERo58@Dii9`G|4sn60AeSTBIg6qG5cvKojSMiZ?>V(cRyTLwpHT9Oiyas5vXp#MPnV8_~qApyFH6#Lb}M z`_RNgpyG$n!~>w>r_sdopyKDz#IvB{SD@lB|6Tzx7#JA7;t>CjLtJSZL?eg<#XHO# z9US6bP;pqeO@X?{4^4a$R6HCij&6P;4)Ja@aVd~S1_p+yIK($X#bNGQ0kwB4n)ouP z_&zl8?NISUXyRL;;%A`ZAZLKWM;63jU|_h0L;M|79Oj-AP;)+^i64WC|AvZ#j72t| zbvj4{QJ=!>m4k}I%)bdWM+r^*I#k>kDh@IYWd1csHe#@aii6AnwL^A5#XXV4LG}I{ zs5!o9;xC}$Ay9F2^YftMF!SA@`?xES#6kPZVEYG~k;Fmv>UTpN)Q%?32^H@_5(k+B z+dnuBNgQO(BdGdWXyP}Z;`5QjLFT~juUv^F4l+lq2jZT!XyRN@@l8nLAalgyAnNxZ ziG$3EfT}-$Chi6mKZ+y{GH2oyh&ktx#6jlFgQ~xbCO!=+eg`TJi> zK;z{bk~qlxLr`;mp@|=WiZjmunT)8vE<(lG(ZtU~#RbsBA3()L(8TXS#pR&lAX`A` zHXG`G4X8NG{Y6msTOf&p-2WMBjt!dlTd24znz(8&B%D3b#O0ylK~Qm+dn%#siNPUW z2^9yq6XYH*s5!N0;vP`(HZ<`#sCXBecnnm0GMacURD3#`cs5jg0aP5_{i|?@ABKv< z++PPZ=Qx^p4OILBn)oEB_!Ttq2~hF-P;r=h474HP{}P8d+f0y3M0#5YHHQmLd_GiM z7%C3Z1xi0K^JQ^}n?c24{@nyM#|lk+1614#DvoY`2vi(o4yau1gr?6#BymuBI1V)@ z6;1pgR6Gw&{0~&T2u=JGRJ{;+N3GOQ7Pnq2jQ3H-VYjx-#P>nPVeXNK+It91Tox*R z8Y&KR56t|lIKg{Ldj z97Qy7d#Jb;n)pwsxE`ALSE#r#k~p%xHc)YpYeC`s3mVRDP;r<$-$LCPfg}!cr^rM| zyvLx43qi$Gq2lP~=R?I|=KqD7--sj*GG7&HPAi(YGE}?|Dvoac45&D|`Ad+*LFSu5 z%~^paZUPnGh$ik172k>`?g|y(4;6>G=RY(&@1ThnK*gWo5NDnPG67KzghS0|M-vZ) ziVL8LXG6tB(8M#L;<9Ms^-ys|H1S%fxE53#}7Mq~{c|)io@IqbI*3D zIJ$d|Ac=$ABQY70-cF#2i$KLMqKR8V#jm1?n?l83K*iDB^9d@B?w- z9OPe+zht2HPDK-!f{M>W6W4}{FG3U7go>|*ile({D^wh0FUb8-Q1>545(l}*25Qb} zG;u4a_!Ts9Z>abUG;vR;_(P~Tx_e$j#nIjK9Z4MIo*1Y(ztO~_pyHhKK_(;8XD(En z7fn1HDlP;S2k8Q(!_&}s(MA*B03ClY#UUOD6$iN=5r-h1x>;=VR7Bn8$L&ed}-w72*SAPmB4pV;%YW@|dI81## z)cjXS;voOdfconln)oEB_;;u{y7`O?Kq8R%0=a(*)O;Z%agh1Dpyr67iEo37OGCv$ zrh&p|612agizfaU>MwJsILu$mp!T{TiG%FD0yWJP=L%9aKCNP5c#9JPs-j zb0-Hhy=CAKZ-k12+zE0I%T!2$Xhjoef{OQ{iHktRC!vW8LB*#-#bNFdfVyWrnz%Mp z{4|>Q4`_H^#UcI)Dh_kMGSuF0XyS@c@!wE!n0x+0&F5SQ5<&FuzCy*7(ZtPR@s2~> z6DkgKj}g>fUo>$8sCXDu9ArBvUBS#xz#(1%6^EJc2sNh$P23(T-VPOqnePsD|3s)b z$Q)3<*al6X3z5V@=^+Ga&QdgSKdAURs5rX$J8+0!g^Gjh1({z3HRmRpcnMVe5mX%A z{5LqnITwLcLh?Jv{5eo_c+tdXLB++O;vik1@P~zu0uFIos5s31tD)vNqKU7BihD!F zVdncl!#@;~QBd>SafmN~io?u54K-&8n)q?3_*yja zM^N#NXyOl`;=7>Y=FpwtI4HipLe05~CjK5Oeh*Dtd>W*@dW0q} z3Kf5iCawk*e~%`v0u}!O6-ReJ(_)YaBwZo9pC3saashfq~%-R2*auDE-`qrvE=k;vo0m zhML2$1fmh79wdGfD$WTN2g!om4>MmFDh^T)GXDeAd=(^dkU4Lm=4haazlMq%LdDU| zw}y(t%x8t3C+veH4l@5g)SLh`@xM^dmnE6sr^GlG#LFNlWFI=fW6X%DD zH$lZ=<~xEI3=9lCIK-Di#XxIR=I(Zt_C#iyW& zv&?|hcQeq$|3TF+L=#tos$YsGt^yTb4HbvEKN7@XU|=|aL;MsD@yAeckbgn`GKHG| z98KI9D*gc~4zdmu?=X9R;Sd*E22zPgx9(7L#L&cDq2fwVagZ*M`LOyz2Zy)^R2=61 zNT@kJXyV~e@i3@3%zT*p6L5&vK*eF^XG6_tKoie|inl?+Jv8z4FCiMR%Bw@mWxD zS*SQj7swnQuqg}->Nv!mq2eI-gTnbd)Esv-@v~6z0H`>+`B6B;%c0^h^B+LXsYVmO z2NiFHio?tofV#gQhxi((IL!QyP;)k*iNA-6??e-4nhCLBFPb<5RQwp4xG+@w6q>jo zRQw859Nqo*aEO10io@Km1U2V3nz#Z~oMjcrWXO09D1Kq#!v_@ynFDGU!Qx#WNgNcv z#!z#V(Zmg*;yP&J-cWG^G;vR;xFwo+6ja<6O*{fB?t~`rf}ILLP(e~Ch(g&`Cw z4)d1`R6Geu9OSQTsQGDV;+atKd^GW9sCY4&cq3H222FetRJ;LAd;(Ow6Dp4G{>e~r zboVbn5(l||G1QzTXyOZ@;%m{wcSFTDqKWT>itj=bKLr)vhbDdkDt;U)j_&@8P;qqk zKSUA-x&JoQoTq5wH=*M1(8S+B#Xq5mzk-VYMiXb51&R3oXyQyzan{u!mm~6pB1AcZ z6b^9}9OAZ6agcvO{t||o?}#QY2o?8&ii2zirCXT2AvnZypyDv|RiNe+pouF%#cQGB z=;pUW#X;tP@)5L|z%U(29OQm$s5!II#EqfiOQ7QD=C8vcei|wcvKM52Ce)nsXyWNm z@taU_nEBA_5E&lh5NB8eQi-VVs-Whupov#N#d*=hyP@KOXyTnvaVa$M*-&vgH1U~G zaSf(T!=U1gXySfQ@iruJP&mNc*$)+m`3u^t zW|#>Thxsc8;v9x$Na7%WbwJHug(ltv72k{|z85OK9Zh^URQv#%_&KQf5j62rQ1P=+ zadh`zhl-=S{|S;f$o=o3=Da`?e+d=;h$gNAy&&o`g!u-wGAaM-!KUCaf|vabakGZ5f)l&@YJjtDxc_*Fw9LV2Nu` zaaejda2G7ha0@C9QV;51Lqr)EzM_dcK_&j<5SQKvG6B;50ht3+uL>0h*$XP4bD-v! zB8h|Y`%Y-SvqTf$4i$HTii2zcnGdaA7<{1OF!Q0u`ZB~IiG$3)2sI}GP5eAmJQFI8 zZhkRT9Nqi|Byo`WFQMkNpou?+iuXdr(aoO@6-PIJ36eO-d`4)zuRs(34>f-yR2<#> z-B59u`Os|5a2iP*WWFTS{PSqy;!yFMP;qqgAL9`J4HXC33o_pjYR-Q&aeb&b$0m@; zi1Y)CUm+agT2OJA`JPa7^w7lJq2e}BagZ&@>BkL+coI|`W_}{noHR7?c&K zN*v;opyDv|E1~90LlZBDiqD6Nqnp1Hhxj3=IL!QsP;-uUk)|@8j?83{4Y>*ZlQ^PfQmncildwV7AlTz{x2kPkols}4E7IA zTo5YGw-sbEB7MTbM*=DiGk-hO{i;afAoDGt=4hgcn?S|Qq2eH0Kc>eVl?sXQ1MzMagaG{pysq8iG$2}1XbUKCVmAfJ{e71eF4P3)6v8wq2ddm z;xK>tLc?bj4)Nnqagg&s?n!`}a~e%N4k~^HDvoacJsje{q2e&}^P%SaM-$J5igRoS znT$veF!u}L5Z8u^!_2RPnxl^s5s0$tx)qHL&ZVnfYRq)5QBk% z;R}*DC_U_en)3rqd<|5baRaQ#vkguB8&rHhnz+akNO&Gb6BmGr zpG6W!w)Zwv9NnEyq2e%iYC+xk2PzIzKLMH_*>-_M5a}Eyt_&3inFI2d9n?MQXyP_d zaU-ZW$TU#6O%{Xr%Na==w9W@2%D@neBo0!)6zZN>9O6|_ahQ98p!U|Gi3dQ%+o9qx z_rT1bh(ml8R2*i0BGjC9XyWlu@qJKnbn{O@#X;tP;>!ve{x^}tLE%{fHRmpxcpg;z z8Jf7}Qb@?XLK9boioZt^N4EC|R2=5cwa^6wOuIoMhCLRkFuS65igNoOpiRVDY+o9qx_iTlR+Y&VK&Cv9`4u|+@s5r>|Aa~Y5%|DMO zUIP`sfhIl)Dt-q|d;(PbDVq2)sQ61X@g-34Pf&4~zhLhFgF{?&4@f1VeYF*8jwG7+ zW~jIln)pemxEh-Haj3W5OkR6G_<{3}#E8%P;roJLFscjG<{m4iO+|MheO3d z{so1zFVy^KG;vR;cnX?$GE_VRO*|1QUI-OOcTY7`9Aq!Z{hOiT+>0a*a!(1=oQY`S z1yJ!>XyRQ^@p)+C9Z>P*P;qqkY=nxVyJs(wILJLSq2?S!6Q2$hKaVE93MzgXO?(+t z{03AU=AJdsc=-Vphq>o4GR1Aom}F+N+8tz7Hy{ zk0cI?m;X?6ERe)O<~)U}w?PxX4Hb7q6PH;DN&lW`;sQ|dAgDOVcc64T2kNgF9O9Kw zagcvO?(u_~Q;R0<0~K$Bildu90f+cns5s30Sg1K0(Zr*n;=7>Y=;j~6A$}Js4l_Ro zYR*G6@hqtLN2oZu`M+_9i$E`8fSF$lHAezXyc#O51{Fs)-vEbr7@GJ3XnZB$5U+)b z!`#ygwYL#Xyc;Us4HbvE=LppNsZeo{IiU2Z2b~vKh9nM34@;ottU?o?1r^_nCjJR3 zz8y{c1yuY1R2=4>b5Qr3!Xf?~Dh_fd$UX9_AnE@#nz$@f{0o}6F;x5qnz$iUobe#Y zC5ZaS2`bKtChh5EL#0{b1F!u*S%`rt2_lJtxp^2wL#huW^lcD0i zP;r=hB%llQ!*Ph0K*eG1DS?_(fhJxA6>o%!qnqE2LwpHT9A4E8H6*>gMH4rL zihn{9M|S6LByo^C)1m7BqlqU%#W@avLI9BtrPo00kCDFtUq2fwt z;^9znH8k;HsJK3wcqLTa7)`tsDsF=&J`*bLfF|A#759XSgM1CjN3e7o3>AmPdp0!Q zQ;@_#;dupWP6nFz1*mu-n)o}Ycqy9rE2wxqk~k!9K= z^%l_lxC4jyMW{H)9FV^x)^R)cg-P#CZ>cR3g%q4%8e$G;uAc zxD-?zqze=;F!NP#h}%NNVeYqvn&XHjZV43+go>k^9}N`;nF9*{Nzm}jK@tarj~~>W z0yJ?CsCXrsIMX^vc-Eqc|AVS;LJ~)|w;L)BbLS)Ic+^y=ILw_Zq3&FcBo1#nH|Gj3f>+-vVmR zcQkP`s5k@kVi%A(AocE0aTYXjSEx82R2=4>=g{!fMiY;Qre{+e;z3Yxn7!dp^TW`@ zL!sjFXyVyW@nkgdOsIGcns_}_yZ}wS7Ajr|6^Ho?=Kf|J;&Y(lF!%RC%~^mZ-UAh1 zi6*`XD!vv?d;wH^2UHy9o_J_@9)gO4>;mlWX5}LR$R9qWP+z=|Rk0!1Q6}LbW_k@bupozOf#a+?FW1!-mXyOr2@gS%;$k(9q z8Rp*@s5rWRGm*qW{w;%=lZz%^1Qjns6Q2MTuR;^=fr>YyiLZc)x1)(KgNjc;6WHRNNU&+!-qF z0~JSiPZ$pIJg7L#Jt0tYiqOP^pyCZ^;>l3)7BulhsCXw-9Oj-A(D+&j6$jZ1ieF`D z{BDPe!_;4ciXViE!_>z?#V;X=gW|UYYVS2P@dBv$10->fy?Ib`ULuKu%$W&Q{}xTW z7b^Y@P5dTQ{1=+|X{b2!36PHv<<)Jdy}UTYwV>i4|AO2jvp{gALB-L{UxP#Z zC{!F~z9ZC}lW5}hQ1R*J$z92 zRO1kz0TlP;=&>iT{9#FGUmQ+YIsVN;GjEsQ4x{aapMNHZ*Z*sQ7-UIJ)~! z;t+oX6^FTB2WrkUG;uAc_d;GP6Vb$XL&ayIiNAx2&qEV`0u^73B#!LPHAvzhcgk;p zq{9tp;*wDDooM2hq2hbd#Lq*;kD-abg^Hg-6MqR6zluBQ4Q1J(7;@VL0 zCuriTQ1Q2D;vrD+k7(i^Q1M?-arAg+ISmqlw0}V1`57ATqDbPP@SF=ZM-okZCRAJr zO?*34Tn$ZpGgRCFNgUZ;JE%CwRmkbz11b(npIp##EFLNjQ@;V4A2V@?H$lZg=79Y5 z5bB;bH1YdT@##=;nE6Mc<}bt{z7Hx6Gyf~poI_~hpP}NXq2lP~U&SH*4k`{apJf{) zU423mXM&0|odKDQD3@UF=YfiY%mIbJ6f`_#k;FmaBMvo35lvhWDz1elei|yShbDd; zDsGGhX4k|8#CT;>1S3nat zf{JURiF-iBb+C}2OQ#&P;pTBgWMkuH76ELJQOOPh9;g370*Hw z&xDGXLd9Y3xd9E&dZ;+aUQoJngr=(rNa7&(G(ydpf+k)I6`zYHJ{u~&5KVkKRD3;} z_*SU+W;F4QQ1Lxbadh_|gNmcO|1y#|$o=P`=3GY;KMfUsfF}MDD*gmb{3%rY6Ph?P z^a9#%XyX5&>izDKv3OsJJqkxH(i@9ZlRADsGA< z9tah;L=*RgirXQHgWTy2O(*V1;vjeCLe+btiKj!w1EAs{UxV_6BeXwWfhPV8nm(JL z;;{IQh1xqANgQPFEU5X@(Zr`g#TTH7Z-R~6_-L2cZP}^K*d3}fZ`DrK2}h1n0xY}@#T&r4suTk)EsX#@jR$_2%7k6sCWdL z_)@5NBAWO)sCX)x_z9?Z7Lqt9JvTz#Sqv42`70EfK5Nm$eWBvBq2eI_g8cO!YW{pQ z@z+rC6=>qDyCCth22Gq9D!vsej_#iQP;rpGAoov(y8j}QILJL>P;;)Li3>r+@1cq7 zK*b-SiEBZ{Uqi*w-SZVHj_w}D3m}zGP zF!xwN?LCSnZUGfP4;6>G#};b-O{h4?98mfUgr?6|NaCRM5DYcv9h$g1RQx-d_E2?P;qqg&*Kn(0TqXt?+!KR4Vt(sRQwNA9Nm1j z%ODX*eE~|J<jVpyCQ>;#;8NDrn+MpyIk{;(~i2>A?_9oE<7| zh9r*cPJ1MAkUO2A>YdTVZJ^>lXyV_X;sI#lpP=HAXyQWqAnuGs6X$`7r=f`(LB+Gs z#Py)!#c1MTQ1Nm!@c^iJ1Dbd(RJ;XEycjCp3l#^&GAJLx((QDpI4J#q!gB^R-d7-r zgTiwM)SNYF;#;8NThYWXLB)5XiJyatA4U>Kw)Y}b9NnF_q2e%iu7|qw6I2|gUIUsR z|KJc8y#i7RN#`Jc{eiki5>5OUR9p)x4$=h*H(RLrCOE_cq2eHSg3K4#4@oDXXySZO z@i?eBy7?J6#2caFF!SZ1=Cq=T%RLyei=FV$ScfLjv2f6bf)cp5o;(wsx zKcM31<}+Odi9pf=$UV=X=8GVSgUshW0EtHlG;waIxFS>>WEv=)z}&A56^FSWX1+O+ zILLe%s5#bX;!;p?7c_BgsJI83xF%FQ2r3S9k1RAi^U=h;q3O92hxjz8ILQ4VcUnWu zpM@rF2^C+AChiXvUydg33l-mhCY}rx--0Hd2o>K86^Ho?=KkY2#2-M#VeT)2n)3ur zyZ|cx7EQbjD*h2oyag)$2PzJ8k3Td#*{*>^5b5eCG+l`!iG#v(4%8fJH1QcwaTPT2 zZBTIyH1SPPaYHomb5Lye$O!#mlp*My3J8Dv z3!&mxXyUt};&y1_>!ITAP;rniKaRc?;(1VUQ22n{^B!tW5t{g0sCYG09Nqj@ z9O8?h;xP07LCsl)CjJL1z8)%$ZvIXj;+LS}F!OnjK=RQwG;waI_%oorw z!`xE_HNOig4l)OnKA%F<=WHZ#kbm8w=FCSEw}y(ZKoegK6<>oUJ{>B)6)FyMPXp9F z`*Dchfr^9N33AVMs5uYN#IHidU!sY>hKj#M6MqR6|Ar?13o8B#P5cK`ocT7$<%sqP z%>BGL#MPkUF!ysFg``g{G;wyQxG|czEL7YaO`P-r5Aag+JlN;)c60g ze}jtuMHAm}43bV5?|?!EQU0ufigTffpMr|>p@|=Zii@L(KY@x%qlrI&imRZBa~y}b zM*~fq2`X-gCT<87H$@Xyg^Jrj#X-J9PPZOVaag?TK;u0UNgNcORZw$c(ZtK3;%R8& zQ=sBmXyOx~;w4Dppm>DY+XNLycV`b&9Oh1Es5=)!#bN3nK*iVM5I+VL2blx%*FLCw zPN9kKfr{UTio?wR3N`;J4soWtAeD&pa|vn=8=Ck9s5n1V9Ha{rFEH~Zaflm1#bNG$ z2sOtHP5eGo+zl#@Zhin%9ApkC{DYzXN<Uko!UIJODL+4Vw5qsQ6Z>IJ)`!q2eHOK<>$c zhQmc9agh1vq2^pg6F&7@6;vGNFPQsVaEQ-^io@J*0ySqLnz#{Ed=;9w2UL6=nz$QO zd?!>K<{l1ccpip|gX{&Rt14)^x`HGQ3ePyGIXBS6qoCps(ZtK4;!n}Ui=pD5(ZnY} z#lNG8_dvxN?t@&8XkWqH&jl4ncfUB2ILQ4gq2@@Vi7$nUtDuP=f{JUPiSL7oo1ux{ zhKgIEiC>3`J43}mz5u0jnEQR9;^^*=LJ|kL{|nTdI5hDOQ1Ns$ao$sq^qh?*&IuK- zL=#toir1ovD?!DZkijRJoqxWFC?0o0)75sUILu$Gpy}`+n)o89_B{4Z2oA1V&A9h44X;bRFE2ZaMDJYnu}MG^!I<|02PP1=QcEa`k>-4^&QZ0h8a+Cn0i5|IV+LGLGCw)+PfA_+!!jp z9Z4J%4vJ874j_qx%!z@jKY}J602M!rCO!))ei2Q)4=R2ODh~74M5w=>;1Fkg1X2k} zKOpyo+&%zOzP;-*k>P5OzRNM(Fj&8mW4)Ii| zIL!PvP;)ZT#9u+hE1}}(<~QRIp92+#ng17R&H^;?-%#;&P;qqgci<4ehbBH18ecDP zh_gNhnT&`p-m{Q=#EB-(4HXxLii324;%hzBd|9YC$X}rJ84gXKdPw4+_)>$KV}vFy z1r@hO6K{fw+oOq>LB&0w;xPB@gt{jPhj>0z9OO=rd$vK%DMl0D0u`@86F&tNZ$J}2 z0Tu5=6Tb-+??n^84i%pU6-Rgf0vzHyq2e(2zkr&v7ft*bRQwp4_#deFDKzn4Q1Po! zahQ7^LgVp14)H%wahQ9!&q2};!xNARh;+pX73YMCgJePJ2WGx74sji*ILv%0s5u5` z;u27C2dFr@`Cd?QkU60ASqt@7IFdLhJs3mHiAEFGgo>x2iMK<=Gtk7#q2h&T;!mLB zrD)=}pyE|X;>hl7MiK|PQ}jF}oZHdF`Jv(y(8Nzd#iyW&ABBp~MH7Dt6<>%Zejh5n z3Qe5#0>nM*(8L*`;@i>0HKF3W(ZrRZ;z!WL1EAt3(8S%K;uoRf=<$9VDh`YHdC+)& zgCq_L&u*wWAJD|xq2fQ$#Fs+F|DuU6go?921-S&0{z35wvsV-<4w6Mq|MF0Am^-&Z z-Dw6DhpA^2hJ>>N4)I8+ILI83zs^J56N@H(7Al?x6^EHG1~tC|hxk;eIL!RVP;+LY zi9dvjFM^7ro4*E!_)(}h%=}MKb55d(e}IbLgo>k^{}?I`G6xj?N1@^Q1xXwfKCBlZ z;rRni{6Exu#%CatA@K-OzZ0sS6-|6ARGbS*9NAuBs5rio@J_2kK6J zByo_v7op}Gqluq~irYZN(am>*io?u*12sPaNgQPU1E@JMXyW&v;;B$^bo29};^^jA zBZ-5|e-AaM9!>l$RJ;RC{2x@j2TlABRD2p#9OfP&Xn1Z$6IX$z=e;<@Z$ZUD?gzP( z?-C?l?xBhEK*gVMauq1uYCyx&3n~t>7nIKbL(^3>k~kvJE7t^XyUC<@lrJLg;4QIH1YXR@g_9!El}|`H1Q2k@qVZ{x_@Uv#nJt{ z3`rd1-*ZrNR-uWXf{JfO6Mq2}-;O5!1S)<2O`PE}Bz+!16aNQQe-=$#7^?mvnm9jH z{1#Lk-M>$u;^_YUh$Ig3uP)S_uV~_$Q1O3g;_gs!rWYU^5#_2gRGb@4JRT~}k0u@q z6_-F0FM^88po!-}#TAjnLFtwgnx3_g#6kY*gR0j<6YqeE8$-oGz5wNm-6D{92}Kh( zgPI=?6^DhVG*r9*NgQPFZm9VsXyV(U;_HP}hl-zvile*dCR7~VJ_ZcO4HZ9*CjJL1ei}{u7gYQT zR2m+C#-*>JLK4Jv^b}F!eo9^-)OTp!n5>+8c)^t_~H?KoSSpI|ph`A(A-A zoB*i$QZ#WFsCXTk_ynkU6PkDvRJwxNk1hl=lq zildu<5{LLRs5s308&Gpzp^0CEihqWRqnrO1hq%~lkV-^4c@8y43QhbeR9p)x4$=iq zC(!UQ!6EJo6^FV12h^NEH1Tgx@pz~>y7`$n#QV|2&q3WY6NmUVs5s0$9M>TEXcw9| z8&v!VR2=4>FHrN(LB&DlfYRqJX!^X5Bo0asicoVNqlt?`#owTb*FwcVpotek#eYJ@ zVea_{br16!kO-n4fr%?X#X;@_xo0EP92GS2^-ytLH1VTQaYHom!%%T6H1R7?aXU2e zOHgrls5r>Ap!5TCXCMyoET}ll{g0vMA=iGPQRSEGr4g^IU9#bNFVg2v+n z9O7%C;xPBHU5BKfjcDR5Q1M+*adh*K;1ItH6^EHG3N_~;nz%4j{3BEx-TdEBagaHn z^vM7%&pF`oIT zaZtLw232o?CVl}b?uaJdbpsMFu4v+IP;oyr@g-34AT;p>Q1NIq@qJM7cr@`{Q1J{j z@kdbc95nGeQ1MbUaqgQC_gA8c|A(q?f{KG;6O@l&>9z+d4vTk1XuQuw5(kB62-N(A zXyO4-@l|Nzc~J3nXyRE=@f}Fwpm>DYdkiX$?#>HPahN+TpzeGQ6^E%Wg67AMIK;W$ zfm9;W^9-na_|U|sLB-{v;vik1aBGK}uZct44Jr5OBRD2Vfc+)LN zI^2dPUI!K5jU)+0yiC=(q2VBkBn~ovCDa^AH1Xw7aV4lY$TUzofw^A?Dh_fdviTNB;vn;PK+Um1 z6W<0EcSRFF4i)!A6F&+S4~B}v-17h$ZUt!KQ=#d(3WxY~s5r>|Aa`Denm-#&{3=v@ z37Yt8sQ3yr@t08XjcDTkq2gQ7#Q#FY_d&&B{(`yx1P<|sP;r?1`EEnf=TkIs9;o;` zG;t-U_$M@R1*rI6s5s0$v!LP0{sAO{NLTsLbR~f#4hl~Ts5vrd;wDgWRW$J+sJJGY zxF1y998Ek2DsGJ?o&gnifr^7%3re>z_xnM`LE#2Uw=nldBZ-6D-v%`&9!9r z9EOh|5kxzG1vGtfLB(O=(+yQGjU*1THxO#RJes&KR9pj1JP#_agC?E@6}N|qgIonl zZ!q_GLdDVD6NV%Xa?ebtIZS*GNpyCE-;(MUtCTQZjpyIYraggnxbO>{gJ5(HGFUb7|q3(%95(l~G zEYzG>H1U&A@ia8?$58PsH1UT}@nWbrx_fG&;^^+_L=p$N=M&VNUNrF!Q1RJl;>`CT z>0~~d_x~n0hwoc^!A4;xP4W(0ke5B8h|CFAa6i zM>KJ9sQ7OraZtR7LCs%H9rw54l)OnKE0vovj|BXlpel8 z%_&0@e*+b-M-z9s56P#^XyR5-@gAr+%su8%_e{efz8NYGawo_=g-~<0qlxE3#Sfr~ zw?f5_poup_#m}ONPl1YGL=&F`6~6@)M|b}d9O8eW;xP9whML3p6=VXU99Rey=RyV^DKk(8P~G#eJdT=;nvx5HEm=!_2=5 zHKznk{4!L$1uBkiejijEWDY2O=0MZuY$S0|dUyjhXFi(v6R7wKG;xy$ko36*OZ=i{1Ld74ViFZQ9 zpQ4F3L&e{riLZo;e?k*q3Kjp2CVmzw{vS>JI8>bD8z=@5>G=y(oCi((6;xalDh|?x zoNncz;;?w{fX2H4k~k*>e*(>qEjYyILd8Mmfc#YqbgH$5oeHzppUNrG3P;ptPI7k;L-eK-nhl+#T2@3!9 z(D1ZC5(kCPN~k$DXyS{Z;;v}ov5z6?#1l)e z?kq+U2f4EpYJNGIcrjGG0VH1R5^_)#?R3aI!Es5s1> zF!wxyile*dJ(4)cJ(Hm3d`1)RgNpw_6JHAzXZQuO5s_|JL&b%m;viX2dV{$~7AlVJ z9xWtskb90o&Cx>>KL`~!M-zVl6}LtczXuf$go>lPCmJdabB{PQzA})+LGJklH75s6 z{0mgP6iwXl86-VdqKRum#hcK?L!jbqXySfQ@opq>PX;6K{fwpG6aIfQny(ile*d0S@thP;r=hCPK|&`VBGxk*@lo z;@oKB3!visXyWsr;u27CkZGWF2n!!29O70`ahQA7L(Q>66JHAz_dyfi2Ne%M6W;?B z4~2@u+#?T-uTrQu$X-zVT0`Tv87dA_Zx0>!=!J^I)Tcq!&qERi#qUL^y^GMqPeaAm zAc=$Qt%I7g6-gXq4%>4`dftg9{tar*AvEzMsQP1Q;z3aH^H6b^zdWG+x`{*l8&n+R zUyyq?K+XAuCcX|T&in^tGNK&_GoKfSxE53#X8wMtIeKW~d!gdyP;rngpmYT@-w}s+ z6jU5${yC^QacJUapyGK@adh)5aEMQYio?vm4>e~hn)qF)_+qFyy7_Byh+jq%_kqUO zT^!=SpyDw1yocKR4^8|nRGi~4$R&vQdIL3I2r3RT2b4ZnLer-*k~kP^tZBcS58P;ro}K=Jzx>K=C-;weyZkUK%{nE^E?15JDyRJ;&Pd<|5* z6is{;RJ;yNd^c3Q2~B(_RJs5z== z;=iEcrciN^X`u7~Gshk(4l)OnKF>qbrw@`iC_RY2grv^^G;waIcqE#5B2+vUO*|4R zo`xnq11g?{Cf)}X&qoqRc4q~WILMtRq3UbU#1BKoThYYpUP1iTi6&kJ6`zDAJ_9N~ z4NZIsRD3>~_!g-6Vl?p$Q1LZr;y0k;8_>irLB)5Xi8H>2xPLF2_*baDY%k>}RLdnzaP-uQM#Ubto6$hCE@>d_!Jwa&VJy7vvs5s30EU5XpIK;c4;xO|U zLCxty6JG!opAHpAH-8}x@m)}HnE4x_=IlcgUk?>O2Ng#*{{~bXWDY3&#i8N(5=k5s zK1ZPDyhRh=2NnN@CSLglk`8~NiI+mf|09Vb+snZKiakWUuYsmRAvEzNP;mpOILQ4V zcTR+wZ-OS?4;8nCio?PIX1+UA9Apm2J$le^h(r0;o8; z`87!5AoJHl&1parUkerQL=)c!74Jn8-vbq&4i$&FXA3mkwxEf_)-UbDA$}Vw4st)p zo#&wD-$xTa0~LRPCjJO2{sv9_0aW}en)o-U_)j$PFHmtNM$~iyb3YFbaaE`|%>Ary zA?Z^SO`I7jZiFT-2^BX(6BmbyJ3_@_;am$XAH1RBAbUaS$_|>YVvxi^;i(TbCjm`d z8!DcOChiFp&qWh=g^E|Bi6=wF>(RvHq2e7-adh`jf{LTNe?F2p$o;iYa~7kCS3hbF!eDt-t}d@WS`G*lej{a2yl=+NBSKk-HM}$i$cX^ zpyIG_@PhWoUC_i~>jwRx;vjc|?2Uq^&v+zpki8yI^OMoUU7+GQXyU0*@d7mQM5uT( zR2=3`n0tDm;^^*~g(MDg&jhGB^U%b5pyJEX#MeT_SEGrqgo^Kjile*d1XLW|Jy(&$ zLGHN$HRmRp_!X%5BQ)`^Q1NGI;vb>nf1u*%?qOp_q$^N- z0~J?56OV+7tDuPoL&bH`#A~49hG^ntP;oOPagaOfpzgGXio^UB2u+`!IKB%1h~PKY_NIK-3C#H9lv>eJA~{{}(CB_R|8D10=aY!DR=A{Zd;SY+`@IK-jX zZDN=MJ)RFP&IZ*F^)`k$w3~+^{u8PX=1!P793TNCcf!QQafqwo5VuDYSBKiyi6$-& z6<>)a4pR?Z9td|oOq?5%3^By@afqj(iR(h`EkYA7fr>YyiNnY14#4n{Xe1&6o~4)HP^;?r@6 zZ$}dcg$2kZ$8d;W#UcI#P23k`2m=GdXB^^8ED!}S|ANXCkcc1-aRnUW`Z&bx(8O&( zhBGiQ_~H;xL=$&{s?ULnqsMzGR2=61D5&}t9O6@Oh|hC*s*xIGSWKOExmNaCO*ub>KXMiz&6;z>Bfi*Sh7LdDVD*#Q-Yxf5pZA{^p-aEM>SA^rh}I2Q+Mc*5*e z!6EL2CVmPUKA})?n7?*F_hrXH#bN$}#aBKK@dg~?6LE+yLK9yHbSdu$X-}@W}=C&gf^_JaEN!~5TAoX zd<~j7Ec~}a#bN%1rNaYIahQK$>aXAse~Lr=15_N{{GU*9bo2S4=jg!18KL2zjYHfS zhj=s&@p2sE{W!#z;}AcLL;N-l@vk_<<)QQZF#mEx{R`Xw1QXYXire8(ABICb1x*}g zPAQr=%-&uc;Y@d=oJVdhw)iJL*g!3&3YG!F4B9OBhD z#Cvdv&qfoMfx2fIR2-Jhe?ZTdTMre7`3t801e*8@Xnl7TDvoZ>103RSaESlFAnSrhxjZU;>&P|uZN1m+yk@s5Sn;3)ICPfb8unmVd6eG#PiU^JD}!Fz#)DUP23Ht z{uz=uay|GBhd48IUk=QjX;5?cpyIIbbb+p;mV}DK)WiG*JHH1eejS=GrlYBc`D+nW z9A-W&zpRFe!_0xH-;YE56jU7DoXb#gbaP&!iT6VN%M6_lgsF##%i<6>#~~hwLp&RY zcqYqc!(ba!|ileJ%g3iOEiwolr zSHU4}ibLEDhj=&+@pK&Gl{mz^aEQ;wA-)!e_+A|1C!pf6@Z1L-*uDrAhlQIWG`=3; z5dVThoCP``g>DW%R2cw%0Yv2&KL=%U(-vvn=RG(^sEMj0_2u2bI_2Xtk z-I<3&yd6z^0aX1$9OB#2#NR{JAIBkn4NZJIRQ+=_aRcc59g`F!en8#A0l|c<3n7BF)aSJqYMW{I;IK*?%#Lq(2*WeKEMiaMzs-J@c)*5fHyIK(%hiJyk5 zKZHa4BAR$DRQ&@q@u^Vp*GS?Ze{F^OiwPyn*Zz3#6zLt z6L5$x#38;3hxlO};@8l`#i9Ab3RL|e z9O5_8#OaqagcxaK-Jsh z5D&m14(o@(+ygTwABXyS9O4sjh%dw;z6po;AsphDaEL#~A^sVMI486}4fF2_Xt+t? z5I08?zW`MaTSo&k2PR&Qrv5%u{cIfKTXBdVLlb`iHRlly@n2}-dC>I61s%75xf3QX zi6#zf2Wy~-e}7XHck&SUmTh*qLI{t(kDzj2TfcCs=f_}_#8CxJgE9L zIK+3Oi5o-JUqBOI0PBB3$4z1Ghl%T;iC=-LcSIA1sn5Y7UX4S%3r&0@)clz^#8;t- z!`!nKNgNa}xsc+T;SiEIDEyy5&A)^u&IYaD?;?qV%&CBy^9D&AWDZO{6KK&V(z*+7 zs5wG7#1+xR)u8Hiki^{;V=|3VYbf~x1&Mh%At&~b2k9OA`D;-Do())4IsJxJo9c+`ZB zBcDJM?}Un9g^I(*&##GrVuFF;0S@ukP;rndkohokICLNmfQk1(%@>A>qnj@S6-QUE zjYHfPhqwn+9Nqjts5rX$325T0q3$fgA>M{Vd@@uV-QIaP#8*SbVeWz1dkKg5XEgCw zP8Lri60XvHBu z1xXx~u3+Y`LleIWwRa~}92Wj}B|ssZD``@ z&~o?$4)I$!#NXf$|AQtD3x9S4hKLs5s1>F!d@p#LaMsJ3__L&G&+eqnn?A zCjJu|FLgM?XW$Uujzj!B4)M1*#MuoY;RACg%spy2#O-j1$KVhz!y!Huhxlq7;s?;g znW5?DJes%(RQxfTI86OFG;x@EJ|om{fT@>46NjnSMiYmrw?Y$#srN$@hpA6Q6Njm< zL=%UpZ$%S_sh@@>4pYArO&q3vCz?1+{TVcInEEGZ;xP3e(8OWt89|F;k=oTT^LqZ9 zYvK^Mz#;C1Lp%wGcp(n)W;AhcsJ~|85MPBud=C!sD>%d-;}HLfL!2G7sTe7}!Q3g2 zLtGC{JPhhD2OQ!-NaD!t#uPMh2S~Isl%a`xK*c+8h|jQiL(wn*Y2^{{z`G$e6k^|eUiAob6n z?pcf^j;wwgk~m1c5Of^;8k%?`)SQP%;-GfsQHZk{-XV#D%sC8I{}V|Zq#icD!3N#P z3Gy#UJafqAX5O>8P9)?3a9fx=W zns^D+{U>pVf5aiq3@un-@dYzS6og z^Zjv%=i?Bch(mlM4)KdP#NXl&=e0#mC+DEi9vtGcafq+QA-*4n_;noO&(OqGq5k@TL!1lRFoTt2Jy7+cNaCP+8M+LaK?zA5 zl)qL&)$1aOgVaN}n=n`*iG$RigsOK%5(lY=owpK%B#xY~Q*elvp^3*qk_STv4)K{d z#8==D--RZg3N`;M4)HrU#NVNbXF<(jbc8TK;ScgJOk4nmxDpO=Qyk(hIK;znh-css zuf`$Xg(jX4@eacr9O4_0#6jsn0J_ii44Sw-RQx%b_++R!EA(IxP`H82f$awtKoSR~ zD_FZ!7D*ggy$+f<%wBUOagaICX$=M!Byo^A?ojsxqlqU$#p95~LFPcG?HIC=#6jki zLDg5IiT6Rp+mOUT=D_?l8A%*u4ov+bG;vtCtwjdkS82jURVL=!&=HK!Se_)IkMk5Kh1aft6g6Mqg>e;Q3(02D|J z3=EHu#6kHK;!6ew1{Vkm=3kh4GbC|j^%IfALE#Kj|H2Jn4zhYXcZ4{y`Uyzl$m-W2 ziG$SZLf!ubO-{27c3KfUh`xfe71}{kb!t90l zmlGO;}QWkDJl7#NbE;vg<)NEl{L zE)MZZ9OA7w#AiUoVeWz1`viyhN2oZ=J+N^2gF~DHx?lrcy$B9*MW{H;Jpmw%3=9m{ zafpA!ATlx^e*qOoH|Glu@xM@UnE4+-8W|WEIQ&4NhdAE`=6*q_ zIJ$Zns5nSFD12b*RiWbO>J6ac=;|$@;^^u<(ZpftEd(kKGY6KhW1-?Ob71NVafsJI z#bM^a+}{cnM>l5zR2-%rX75a>IJ)}vXyQpAjSLJ7d!XVVE^@dX!y$eVDh@LrX3ldo z@obQR3=9l^(ZpfuCH*1si*Ak@R2-xo**yk0#I2#?=;j3D5YNXUUIP_Jx3>+4_(Z5U zy1grLh#$ux{vAy`599y_1_q`8Nce!b$l<^N6^Gfo0i=L|fk7B54&oxKmxGGK)Wgg- zL=%UZ! zhpFF&CJs}798Dai{t{Fi-90y;;xPBX%y|qIM_2z2Dh^W*GoKN99xY59W{wb=I8419 znmA0oKAJd8y&IZ1OnnlXI81#V4)JcNIJ&>4;t*c|6^HrjFi0Z<1H%p+;)kK)AZ5tu z_8e3k-JEAQ#6LpC(are<6-PIR6*}RFu3i8tj;>w&9Q-s!_0xHcZZ6j ztB-<;!_*r=`%R5V;-LN)bXyt2G$e6Qy$|bWErE)oo4)~v_#PbMhoIsh_aNJQ7AlTz z{xzsLNIkN99zw;@)xUy@qpSZ46-QV94=RqXo--JGIVl7cM^`Tk6-PH;4Jr;(59=?R z;ShI66E}c1`huY1F!Rfx{jzANILv&Q`ZTCGOg*gL&xeYmtFMBJ!_>pfZ-$DatDlNP zd;wG(W)95Wl~8eXbB^N>=YcN32B`<76G&_@FlZo&gVKW!G<*_~#F5pPA&DcaZ^9wo zk3)POnm8<+*WnP~2^B{VheJ?tkiS6gfthm&hxlEnIJ!B{pyKG}e8VBm7zznNbaS|% z;^^jxLdDV5%R$A_)$8F9x5FXs2^B{-KL{$0ZhkCO99?}HR2-%rmL3YB;xP5F^jrlM zM_1p8LwpKU9A*wIJ;;xKby_FjRCqnq;>hxlh4 z;{TxH=;pJBLDC7j`C>T4)o_R#LdDU|w}OhJo9~H3JQ9a^3RE23{9LFwy7@IY#Cvdv zPlt-5o4)`mj&A;X9OCl3;8WE`Z0wx}ZL%bPHJO^sdW*p*o(Zr8J+iA>^sP@9dmC(dnq2?Q-iFZN8 z9nr+ML&by8#J@wuW1-?0;S3drg)>ZjIS%nAs5rVg-B59KbLQX>UyDP02UHwpK8GL3 zLtaZtM&Hvel16-PJU4k`{Z z2U)!*R2*G>5L6td9=Z&hAr*&s84mGAs5rX$Jy3C&`OssK8J6G>Uk?>WH)j`A9NnBt zIK=Nl#nH`q1{Fs)=Oa`cUHu=ZIJ$a~SVVjwhqF9X9NioZs5s0VSUeg-#nIK+yk<=5h`v06^FUMECi&2 zfx#In4&s5-Plc)vfQrM^FNdm+#vz^t6-PIx0Zn{9)ckI!IJ)^$pyDudVCom+5MKus zM>l6XR2~FmpKL5$O#So)*x1HOg^_PrxC*5l!3y zYR*+0;?fDI_A*1&Yaoe3n=D|37C6LRk;FmnSB9Ds02POY&$=*>&lwn^q2eGONIlHI z$I--(Le05}CJyu0GpIPsd{}z>ghTuleheLcD4)L2f#2J&o(F4DC0A{`l4skCW;#p|oflzlg;1HjNLwo}c@uxV%8In=m z-wU;uABVUc4sl&H@m0`#Y5^68#Urd7bA*b+;tQtU2P%%PJ`^gBu09QicsUO74jke$ zafq+NA-)@j_$3_Tk8y~9!6D9?f*LQd@DW23Uk43mH5}rGP;ppzy2pY-kb%JpDh}d- z%7N`rbG&hg$KVjp!69A_6-T$X0VtG^5thpC5|e;-X8X3hsR zahUplXyP#Sg3tqAVCFYK{iTgV+!Kd*G7j-Z9OAQai0?!bZ-u(&2vi&vJ_)HH7c(%N zf{KH9pz!2?=Etj0adh<$pyDv~F#oz^+ZzcLM^~Q$6^E&ZrH2AEaaek2L=%Up??n@bsh@`?4pYAh zO&q3vH<~z1{c$vLnED%N;xP4Z(8OWtS+lX14+2neSojnrfkK3VK@2Jm;(^i+%p66i zIJ$Zrs5neL%su8%adh>zP;r=gnE4)1adh>;P;r=gSh*UHChi8!7X@hIF!eQP;xP5S zXyP#SGttCh>Q|wO!_@CU6Njn4iYBfA9Z>j%Bn}#vfSr@3oP!!)-ca?fNaD!qW01r_ z@f8nM--INNtbPWPI7od4RQ*;YagcgWP=GTqFq}XVM^^s{hqyHK;5d+WWc4~Y#BFhi z`{59e$01&TL%bbLya4LoLpa1=;Sm3WL!2)UHNIfxE8q~fKohTlx~CY2_(B}wcW{Wa zK{w{W!oLShqwa{@dzB^S!m*t(DV3eaESMziOWLOFTf$b5r_Bz9O9R7h`+)i{u75dcM)nh zD?#0WAhqwz4@faN9**L^&aftWh5MPc%d>fiL?A*x{IK*!ui6iHuH#o%qp^5W? z3OWV`27zKkc!JDL0CAz{40wl{sp3pK_7>>BM$Lk zBymuC<|H%3pcFLm0}x?`HXP!6(8RAn)!)M*&H(KYf&2xs_XkwH77p=BG;u?aMg|6k z4QS%wQ1S0L#5pP<7J-z3?1ib9#38PQL);pNxHk^*FsL}J|C?V6asdNFJX9RSLv~LA z4)G>5@kEeD1_p-7IK-FY5Z{VJ`~XxO-JK_);vnll?u6NU3y1g@9O67xsNoMYM;3>; zISz4u9O4N$#H(3X#s^G1H%ufIEV*Q3iB^#J@#;r z!y$eJhxi9H@c?LhfUyD9e3-Zp4sm51;>Kv=u<*Boio^U1D+k=6;xPZh)JNkG&%q&H z4i!f?zX2+aZvHeh@fD!JW?*30ghTuk4)I4g#Q)(C7lU4y1#=I~UOgP*UO2>)aERC7 z5MPESz6t8zEokD`pyEf-#9`|1;t+q0CJr;_51Kg49FZo}^ac}GLKBCXV~i#aQ}2sI zya|W+LLB0U(8TXT!{H(h@kcnsKjIK)YDV=h%zR-S;!0@ZhoSD#g^I({`DtiCwfkOBqdrc7{UwJc4s*XIR2*hL zEWa2*#bM^d)Vtvj4}^-Nn-c{UM>nScP23dZ2?hp+E*#=ZaER~2A$|jg_$M6VJng9A z26K-dnz%F6osMYY63}ptL=%Up&p{K1sc%6OhpC^ACJs}-5ltMX{sj(k&JI+6eS^AR z5r?=X4sm}p@x7o3Wnf^4f{Mf99o9cehKhrffvkk7&x4Ait1pL&qpR=0AwCm__$nOY zyK#u0!6AMZhxiv9;;fyh;SBSy7!GlD9O9NZ#659{hd{+);kk7ZCxDvoaN5~w)HI%Ipd;t)TNL;N`o@gF$Eg}P9~ALd^z9OBkE z#6xk2=i?BciY9&q0~E(=wE3y1hy zG;!ECsML=p#$+p9tCeT*aya{o@Kdhs4qa}Gkqt&qf#&51-3 z2buF8s(wD2crx@}uES{JF;MYKIK&^~5dVTEo((mJu@~ZgSbQCs4)HKA4sl5w;%ZQF zkZzE_VCH+HiNo$c3xkTI+ZzuRhnWLYpNB)d9*1}rR2<#>$xv~0^B19s8$jC1PaNVIXyOG> z^BZx9A3+m0fvSImL;O9GIC8u3KMrx838?-GftoK46^DgC_bgCIF)%1V#X&q!`hK1{buGug{hZB6Njl+M-zvsw?Y$#srN+_hpA6R6NjlUMiYmr zZ$lG@sh^1^4pYAwO&q5F84hvgDX8H9Q!k4qeheC(Iyl5_aftii5Rb(no`*xc7EOFP zv_9=X5(f!EuZLrpi6jmxe{O*!LE{)W#IK@>KZdG*k3*aldeJ#7Ke9l>M-+#+3Yz#2 zsQJcd;^xqMADwWBhoXtQL)B*>i6ggvs*%J&;Q&+Lha`@yelC(YvidbR#CM~K`#{}u z22DH)D*hOU_%|Hl64OxAC(Imm9O70u#A9%XXX6mB!Xe&^Lwr3B@qI|*$l-hzhxi>d zaT`zqV_;x-heMnJx)2DY3}ik`y$}v@6*O^2kVXau1`9NCZ>YFG4)IhR;_W!Zr{NG^ zgG2lr4)MD<#NXo(XPtpaKcMh|`AZ##xEY#wBs3g6aEM2tiNpFYIcVZAbDEIELHX+= zbUbG%k~nk;KG@+G(8Qs~t}{HuA^r(XTmWne0|WC+2m|CDkohoi5gg*mIK)kGi2L9W zkH#UMgC;HtaUMep4)Mu2#FyX@--AQ^G!F4QIK-hC=b*X=X1*B?@lYJ%WjMrF;}GA4Bo4~I&}$tSjv|SJva|xkc?_43#6jwz!OL(L zNgSjedff@bD;>hZ^ zB8elbKZGQXto|&LII{X%NaD!qpCXAPtN(!{4pJWgs>B!=7}V#X#yd9TUns@`$ zoE{wFi_ygQLe+0W6Ni~|1xdrDW@r6+F*=XVhybyQq!6AMEO*{jt{xO<(AXHpq0mM95zK(&4 zC!&e_Ld6Skh}Yu~pMXPr0h&0>Jv-6FTcP$IgNnn(D>9TpE@oi3ghTuu4)Iqw#J}MX zXIcmeA9Q;~q2eG{fbt8>ot|jo{ZRLZK*iC`iG_;8%z>%T!69CaL%a zd1&GV{1AVx#UXwShxlcvIJ&*}afrXhA^shQIP)TiyU@)Sf{MfZ1#`bA4)H29@ug7z z>Mw?v4>JcQ?ukP@6^D2yn)qg@`I~Tv|3(vsxnFb%s(WDKN=V|! z)IDBMaaedB-wE_XaLp%Y8cs>sC zdNgrZ_;*3YVg7}c8K+(Zr`i>%sGA;@hC&&(OpdK*eQOqK3n2 zsJK6x_#CKs91ihZ9O892#QV_1VeVOqCVm8J?II4~jVkhJ851PvH>1hC}=j z4)M=Wagc4GavSCzg;l8Gb`I)JZKyc9J58YCFmqt)opFc<;Si67ildvK1{Fs)zZ6Ye z2s&WYfJFM6ZeJsOJ)sfyuidQ zaEM3X5U)ZLkA|8*3y1hsG;x^w-{TPfgCvgJ-r!k_a6huRB$7BN9a=!$qXHF&#Y^QO zP)IQ_=t9LoJdk==IN0D2_s1d5ybj?WWOJm^#2-Q18(KKTEpdo@;1G{M6NiO=GE^Mq zUsySi0~Lq)7pA@ehj>2@@mWxDbn_QO#nH{*i6$NojhD+f#9!kO|A#|dVm)g3!^}6r zA?}4kJQjy|IS%oOIK)@t5Z{AC{00tj)(xos%7uoTAe#6MA&5E!G;x@E3moDuXyPz) zg3-ib=49g#FGmxHnbU?Q4l`!~4)NPH!Qs!fQEwx4smlF;%+#^Lve_w z;1DlG6Tb$n?;6p>ze2@lp^4vzir+#Le+3m6-h}Gk+fZ>O9O8yJ#GP=62ce0>+>?za z&H_E?xdJK(;1FMdLwpMk@#9c&kSjptFwC95(ZupRQDvoY`0GfCwG{48=5U;=?-U<~*w|62A@wqs} zSK<)gibMPmR2=3nnET)35LbX6TmVyl6zbnAIKd9jEpUhj;SkTmAwC;T z{2A20%hALgq4ntwG;x^v(`e!_^^eiSVd~$biNn-0>_iO*n0jF}ahQ5-G;x@Eb2M?7 zdJi;lnEGfmahUp2G;x^vH8{l2;}HLVCLRh6PqtmC{)LH);}F-yA#Q_1+!u#q(PA>M^1t_)Rw0!>^GD*gveTplXUy&KiPFmWjy;@UXGtE?w}sl92o;Bw z11%RoIiG3+8^Iy{O>^6L&@vw}txmI}UN-eW>QZ)Enav4@VRChMHf8LwqNiILw`wafm-a z5=U;Ie83_87fBqHJ~g23;n)xH7c9Q^UIv9A1A`z`9K-{uhxu0lhqy5g@#i?i|D%aZ zK-(vL(1U|u_QJ$vafs{S5Vt`ShlRg8R2=4CSh*1Z6^GdiQ=fuEycmag9aJ3M{C21~ zy7_a_#QmZ1vK@!`c^u-8aESlGAua|z$P4Bkn7w*9#2s;nN8=DL#Ub8{Lwo@a@jW=i zU!sY}Lc{GVns`36US>H2N#`*C!qm&)5Z6ExhnZuJCJr;lABT7}nmEjyEHrVLIW0KE zcjFMhheP}?ns^yB9C!|+h67Ao8i%+R4slBy;vP7}BhkeDq4i)Y4)HoP@ffK3J!swYi$lB; zhj=Rv@rgLZmq5iqt^k$iFn8WS6K{aJ|1ne?-TiN%;xKby>VM-9=Q@fS&M@_&P;qqg z<)Gr|=If$~Z-eG{8yw=HIK-2n;^_9~;SjIFA>M{Vd=d`v`A~6~zhLe^gG2l;n)p|! ze>WaO4NsW(X&mBDafovsM>U5TT0R)z5U)lPhq-?$4)H}u;>hijO*q8&BZ-63=L4vJ zPeH|D@s)Q66oL#4m!aYy9!Nbb93J5i|B6F=u}jK*iC`_k@b0n;(xR&H+s)6*$Bv;t*ej zL;Nrf@jE!gzv2+*I|T_hnEPSwRL3FighMb6!OY>uA+CT!+yYI!16mKd;1G{R6Q2rIKO0Sa0aW}vn)pPh z_&prrZ*hqK!y(Rh7Bw7T?ome*Uk|m{1S$?I2TnW$62t0#u&E+_@c1d?(cXhoIu|flzUD^P`~R=;jxoiEBXPr3;7nA{^pdafqMCA^sAFIOAp1 zaD%x=1c$gD4sj10;t4p!i*bne;}GA2CT<1|w-adMyG0=WxsE0dQ~w@^_-{0Em^oZm zAm+j15oV4O4sks+ahN%_XyPz)!f}ZA;Sk@5L;M1o_#tRG+{YpQ4u|+(9O67zQNsad zzBCST9W?QS(0b4UP5cQ|JP=L%98`QFn)pqq_$f5;Q&91nIK*Gz5dVoooD+Jm5-i?f z?omP${{ppFA1V$j2P&Zl7h2;GcgG6KTZbB3P2X+5ms5rX& zk3q#@=D^fn#UcI#hxmJ_IJ)^ipyKG}vtLI|Z$Z%fE`~!~ABVUNR2{5^I_tlXyP#U z=i?BsK@vx9pY-4mpNS+6YHt)l-LnKL4vVi%Z$Tl*z_1o74&s5-!@^+?4)OCi#G7xS z`WI%-Y&7v3(D9R1IK+425I=!K{05phESw)h#bN%1l^buM;xPZh)HB>hbw5m;ABVUU zR2<@r5|VcjFMhibMQ84sp&qsNn;1zbX##AT;q6 zQ2)lEi9dqYr}=2&F!fDn;xP5I(8OWtm!XNn)Ne-CJs~o2u&QO{vDb)O#Oc} zahQ6cyQtv?Q?G+24pX0uL%a=#_;NJyZ_x1Ei$nYz4)G^A#6RN@XMtX<154*Hdu7nX z*`WKdG;oO9qlpVc)t8`&%R$8#qKWfE#W&y(-;YE50uJ#9XyP#Ud`A=4h1$z<9}>T? za)9SEC`1?-1aOGU;1JiqA#Q?0+!ZPgvJF&j!`xGZCT*-{KJe1rF^2Ezx7aYSiHD?1NoeRp#v%o;(^q|!eKfN@l`m);~t~>3uaCknz%D`Jfsze z_!J!Ci*bl=MiYmH|30WV%)hX5;5bwq=3kil+c?Bu;Sm1{6-PJ!A5NBad?^m`9XP}<;Shg=L!9L)cK?dw5I4plo`5DU2@SU#G;smw zKCfytahUqaIK=0piNnlUhb9g)=NJz0OK9RSa~`6J!_4`OL)_>YYPiAFhvE<~K@%5; zhC?$B@kuzu7vd1#fJ1yg4)IH9;`Y$`?j8>DS7_pCQ1$H43-Vz3$OkH(j3yoe72k*^ z?g14)fJ6K|4)F&##6O^k!`#F90yVzgKy}v;|VPH_gA+Co*+zN-d8xHXx z9O9`^agZxO++7glaOhKj@d3se6chdA3?RDZ$L3qr-w&6k3TqnmGlCSD7T7cU&*DLBOIaEQ;q zA-)NR_!%7H&v1w{yh9BKnEPdLh0Id0wxYSe-R`OJ+cif1v?)aB+ddB zfe^6s7eV5z5Fs!b045p0=4(LNASwYwFhIm%W`cyE+mFHOLFT~RCkv8W-2qb$Q zK!-sxFfd5t5Z6N!huvdnfhN8d%J+cMAnQR)*!_JGAP$nfF!2l=;uUD(u>0d?qlrVO z9~riziNo$MyNpBp6%O%VXyUN@$ONI`1oKxJl&=V-VdAj+wzSd2t)S-GqKU)qz4FH) zo`yrb0!{oK)cg)K@dF@-F)%R9z#+Z@O?)=A&^mxa{1%${a;W+*XyW^z;+#+#K;MHy{0y471yub5H1Um4@eeq}nW6T>-0uKYFN-Gb4i&dT6Ze6N`=f~mLdD~8 zi09)FuSXLXfOc-Wki?PO1F-OexnBsXel3!EP`-ePAH^Yl15MlkYR(HZaZ{-H4>a)* zs5n2=-!S(iL&eo_h{NIyralL%-V05A7gRhIP5dxayb(?OHdK58nz#U{0S3D75{LL@ zH1Pna`lo2(FQDRI(ZrLW;;c~nVg5>kii@I&=Rw6)afn;v5O+lrKMXY|6iu9g6OxZo zafp|qiOWINx1ot=K*i_a5Z{DD{3x1uA=I23XyS^{MEwX!94Z9%z*{77Pcx=6k=3gqi6fhDiX@J#-T_G*S-n4!II{Y9Byo^>*m>9aXyUN*s2gyI z&p;E0oeRAJhxiU0;wR9=Vdq8PMicLXdg3FRxES;z2Nr0$gN3suR9pm2+#M>ef+k)D z6*oZ>Z-$DypowpViie|#AAyQz;SjGv6F&)6--Rar94bBwO&oSU_F6P?*!k7_(8OWq zHors@hn>624-HpXxWUA=afn-^iNnsn4MG=(cFdB{#J5AoU31XH_dvz#(8OWqg2K`l z%$+dtML5)NK@*=3-OqIdO&oS^=La0(4A6Lh*$X>|Qy)znb}nTAnz#hCe%*C6@f4^#U!sY_&Q<%3LtF^jQHQx7rd|b2 z9Clt=JPz@EG;!GZV{6gGVdrjLMiZX^b^jL};@r@6kuZ0{)Jvm@!_Gl6LKC-xj*B{> ziNns-@j(;63w2K%nmFvdmjWE(O*q7-po#lJ_jfEo6NjC<@)?IXGc=#U!U1+(N)Vbj z?EH`lG;t1SKAMR`d;<>g18Cy5P;;)MiE}{1`8f{pUufd6a|2kQ;SKXw2-JKrG;!EI zcMTlkRyf3c(8OW;$0yjVd`P~ zNwd+^XG6oe8ciIwZ?P3koEMtjrlE<$_TR0*A-)TT_!%_uMNsqapozow!NKf-`3okl z1l0!NKof`U=c+>!hwamuk3)PL4)J4X;$qPCCwI}r|3bt0Ee>%8s6LqcVf!_> z(8P72d>JSWQxDsBpoc@;0f#tj{V&WM*n0k6H1#m?xoG0B_4&8a#9`~w8KLtDF!N#d zDd7;e#3Am9CJtNQn}8;M0UFK)XyUN-qE%?(^P%qUK@*3qhn$B)d;<<~*!~Haf8RmX zU4qguaoD;4g_}Y4!XD&4)r!@;;{7?={Use(ZpfvC|03~ z!`2VL(ihAPaL=$g-ir+#L-vAYVizdDm zD$W3Z${gT#^JmkDY=NE{UY zF!jPn;vn^~`9C=%agh2AP`(M2hM98(%6Es-F!B3PemIndiGPFg)1fp>oJk52kL76M zl2Gw>G;vj^_;fUJ8>sjyG;wdJ_+A|1XVJt1pz80UiDyB@-=c{xfQtXaAZ zP5doXd>5KHrwqjXr*Meh!Xf?&P5dL&d-H1R!9@sl{jZ{iSti6*`T zYR-Q&@s&_uwHmJB7n)qR;xEY%G7U%*QH#G5`Q1LJ{ac`)2 z2AX&@RJ;;RJOwJ=g(mI*UEnemNgP!FMnRGZ!vZ96Q2pBoRlfmE{1#OF0GjwGsQ3jm z@xM^<2Wa9ZN)U^`qlr61#rdG&2McGIxB{BE4^+Jons^pe+zU;-1S+0|L%a%yco&*@ z1JsgG@fDM0~1$56Bkj2gtHNvxFl5E z2~FHz1)|;uNgO$ygd>TA(n$hTeJ+}KH&nb1O?);~d=d`v#c1LSpz1fHiJL(eW*x&J zehp1L0jmBDns_TzoEMr-Vc|IoDz1z}+!BYlCz|*=s5y~n;>)1o`Do(TpyE@}#J8$J z;$WG(;t=18B#yie^C+4)bXf(%RWxzv z@GQeKG;yeN7`~y2!`5Z8LGwK*oI&=&#Kmxk>!67nLy|3nJ({=$R2){$!OXXTipQg= zhpjiw$06Q?CY}j3XA+t?Y(3~ABymvrsQ~gE0|UcaBymuATLCp^Cz3cweFjwhH8k-8 zsQ5P=;%w0T0rD@%9GH4BH1Qg!IhHuYozcV_pz34M#CxFPMQGy7q2f(w;_IN|lhDLB zLB&_#5Z{d^E~^O%xYKCjN>K6JXyR2+@ux`Q$l?DTO&ogd3j;ee-+;msq#k;F2ZJ~c zadjNx=4j&3?NkizNaCRQngDfY5Ry2^Uf4R`SR`?f`cUXXfk~ng_pFt7_ zg=Z90{T(#%Nl@`;Na7%KVC%L&B8h{{fvNwEB#x|}4Vo`u@d8sXfFzErUK&Xp*?d(b zab)!dXyV==ix?Of9FWA3*Z&72iG$3Cgc<`w9FjQ5e3*D9k~nn9Dp;x*NgTTL5-eVe zBo1YQ#XF!Jkn@n;18qKl_f1$bFff>dRWmR^lQ~>G5h@Oiez!@>zBeibU7g=P-)m_vqqG;!E^_!2a6=(bdb zN;GjUXyU3v6BmPuH=~KGLB%`J#Py-#y=dZgQ1MA<;;{V#)6v9(q3Y+Li6=qDq1VX6 z(^U~v9Ja3n7H(}&ap*OzaP@sqap<*&aPe7Cap<*RaPg&3ap?6saPcirap*M~aPh-X zap-aEaPf;!aoBzqm^&Xq#i7T1!qvZqibId_gNuKMibIdTf{Qal*X2Wxje(2vK*gcQ zIl#pgpyIIl8Ri~cs5o@HAzZyFRQw}ayukJ|d_xlthpPXLCLRwJhwamW*_#d(XN9JB zn0P)^oC{4Hwl9MpO}q`NUIb0N4=N5T4`Aj`gNnKO@L&e?D#6LpCVf75moPSX905tVH&`Ki| zODK*clB#Dk#Xd1&G}Q1N0k@mi=jY=0HZUu{tFS~T^r zeIre1;?tq(+tI`qLdAQ~#8*MZC!&dOf{IT=6F&eIpN%Gd2`at-P5dELd?}jvC#d); zG;wBVWe%%PVBx?672krUUK}dE6HQzJD!va*Tn{RK7){&?Dh}JH2D8^0Dt;DCeIQi) z5}J4fRQx)ccmh-$dd&d5{K&V?o^aLMe6Bo0*y7I%V{6Cm|aC1CM=&;bybIBZ``7}~l8*t&XowE0Ka`fUb7 zuyNpO0AxOF{x=2M5QLe(0XnbNX^*O20osp!>W(T7>sQY6Mu>yj$uPeO`Xj`lOP>?t%{K0|@3=FV+t{`!cdf57z8jt{zJ7MVu z*3JS+gRlTd69WUo0}uyEJuF@6K*Iwh4Z^T>JFxZ(NDO3zGt@yfNa{iEgt?~`NgSje z*6v?`Bn~nQwyxt0nm8;yOF+XLq!xr>=^0kPfy6)mhYCJsfYEGcOZ!) z=dUkF;$U;2l7ErJLGCGn#)}4Y02ZVcTb$*Bb;@g<2#IjL|>@lk%kCFb$* z$rTlbhK5E-iN%@8@x>)YnR)4+$-yOthRGR;Me!v?iJ2wEp2@DkiJr->uFgiD!N&2f zt^wZ3LEgc}@er#mkgcYQxo}q&mlPT5p_pG>l2}wyS^%{&GcU6wKC!4Mu@WkflA2VS z9-o<)md~IEVJ9Xf6{Ug#3l#hip`85WoXp~qViY}zMTvRosi!_@P?TSgT2un_WokxzT2W$dDuZ5nQGRIw zG!auk6)-U{K&x^TQ()`YpxgNvK*MaHxddo&!T_Uj>Gyz|2Fg1iCP+VMtOlkJM&r^C zt0$55gUV!>J{XNlKWtnDSwE;AgXx3Op!yqBr9rbb$f;lq3))2>hl52R1avzCgabN9 zfq?-W7O?PwNeD!OOl4qzttS8(11jQR;R#({2p%^Bsf1P=FzpONu!$kK2!sJr3t>S> zkhvf;(e*1p^%p{v!AX#R;T#4AaPtdfCL5@*M3R8%M>iMU|KZR!5xRZ@sQs| z3!@uh?uSUj$qUc{N?1P?CV}Qmh8i64F9GeC!rDI|_k*@%p}T(q)P8hxEuobQ^g3^t z_270goWsDtun4Lj-TyzJ`q9N<_QU-D2dW<<{-EvhDae*FFu>2pfeC+y`5(;#1yv9m zVD&Y~|DbXPWzk@GyNa zaZvjmtP&;xwI~5gT_a&xxWBuMZV~QZQu@Sq28sxkn&2 zy8aGJkSGH~Hd?uat{*fG15(M1rtXI|NEFk*F#S;HFo4E)z~PUk|3L=C|FC!lg+FMh z0;V4(4mv*wWD_)+V8${qKnH%I%U|K*AhjS4j0VlCz}O&h7?y$Rhw))Fx>`Rb1_scP z8EDRDP=M-3cNfh4F!R!wAmul@{s5?c*f}OJ_2~LR;{f3BgDHU0KcL~q0g{BKAJAMP zOg}9AK>k6u8)SrrGf0Mk0k&@))Eoe{U(xk*GB7YeN;r@%1lI6}=zj`QfDp#0e?fH` SHvJ5_koYf0a~#A}gn Date: Tue, 28 Mar 2023 15:36:08 +0200 Subject: [PATCH 208/372] Added a variable lookup. --- src/Codegen/Codegen.hs | 34 +++++++++++++++++----------------- src/Codegen/LlvmIr.hs | 32 ++++++++++++++++---------------- 2 files changed, 33 insertions(+), 33 deletions(-) diff --git a/src/Codegen/Codegen.hs b/src/Codegen/Codegen.hs index 6dd9c2a..7f01d6b 100644 --- a/src/Codegen/Codegen.hs +++ b/src/Codegen/Codegen.hs @@ -13,6 +13,8 @@ import Data.Coerce (coerce) import Data.Map (Map) import qualified Data.Map as Map import Data.Maybe (fromJust, fromMaybe) +import Data.Set (Set) +import qualified Data.Set as Set import Data.Tuple.Extra (dupe, first, second) import Grammar.ErrM (Err) import Monomorphizer.MonomorphizerIr as MIR @@ -22,6 +24,7 @@ import qualified TypeChecker.TypeCheckerIr as TIR data CodeGenerator = CodeGenerator { instructions :: [LLVMIr] , functions :: Map MIR.Id FunctionInfo + , customTypes :: Set LLVMType , constructors :: Map TIR.Ident ConstructorInfo , variableCount :: Integer , labelCount :: Integer @@ -88,28 +91,24 @@ createArgs xs = fst $ foldl (\(acc, l) t -> (acc ++ [(TIR.Ident ("arg_" <> show getConstructors :: [MIR.Def] -> Map TIR.Ident ConstructorInfo getConstructors bs = Map.fromList $ go bs where - go [] = [] - go (MIR.DData (MIR.Data t cons) : xs) = - fst - ( foldl - ( \(acc, i) (Inj id xs) -> - ( ( id - , ConstructorInfo + go [] = [] + go (MIR.DData (MIR.Data t cons) : xs) = fst + (foldl (\(acc, i) (Inj id xs) -> + (( id, ConstructorInfo { numArgsCI = length (init . flattenType $ xs) , argumentsCI = createArgs (init . flattenType $ xs) , numCI = i , returnTypeCI = t --last . flattenType $ xs } - ) - : acc - , i + 1 - ) - ) - ([], 0) - cons - ) - <> go xs - go (_ : xs) = go xs + ) : acc, i + 1)) ([], 0) cons) <> go xs + go (_ : xs) = go xs + +getTypes :: [MIR.Def] -> Set LLVMType +getTypes bs = Set.fromList $ go bs + where + go [] = [] + go (MIR.DData (MIR.Data t _) : xs) = type2LlvmType t : go xs + go (_:xs) = go xs initCodeGenerator :: [MIR.Def] -> CodeGenerator initCodeGenerator scs = @@ -117,6 +116,7 @@ initCodeGenerator scs = { instructions = defaultStart , functions = getFunctions scs , constructors = getConstructors scs + , customTypes = getTypes scs , variableCount = 0 , labelCount = 0 } diff --git a/src/Codegen/LlvmIr.hs b/src/Codegen/LlvmIr.hs index 59850b6..15bdc01 100644 --- a/src/Codegen/LlvmIr.hs +++ b/src/Codegen/LlvmIr.hs @@ -11,15 +11,15 @@ module Codegen.LlvmIr ( ToIr (..), ) where -import Data.List (intercalate) -import TypeChecker.TypeCheckerIr (Ident (..)) +import Data.List (intercalate) +import TypeChecker.TypeCheckerIr (Ident (..)) -data CallingConvention = TailCC | FastCC | CCC | ColdCC deriving (Show) +data CallingConvention = TailCC | FastCC | CCC | ColdCC deriving (Show, Eq, Ord) instance ToIr CallingConvention where toIr :: CallingConvention -> String toIr TailCC = "tailcc" toIr FastCC = "fastcc" - toIr CCC = "ccc" + toIr CCC = "ccc" toIr ColdCC = "coldcc" -- | A datatype which represents some basic LLVM types @@ -33,7 +33,7 @@ data LLVMType | Function LLVMType [LLVMType] | Array Integer LLVMType | CustomType Ident - deriving (Show) + deriving (Show, Eq, Ord) class ToIr a where toIr :: a -> String @@ -62,7 +62,7 @@ data LLVMComp | LLSge | LLSlt | LLSle - deriving (Show) + deriving (Show, Eq, Ord) instance ToIr LLVMComp where toIr :: LLVMComp -> String toIr = \case @@ -77,10 +77,10 @@ instance ToIr LLVMComp where LLSlt -> "slt" LLSle -> "sle" -data Visibility = Local | Global deriving (Show) +data Visibility = Local | Global deriving (Show, Eq, Ord) instance ToIr Visibility where toIr :: Visibility -> String - toIr Local = "%" + toIr Local = "%" toIr Global = "@" {- | Represents a LLVM "value", as in an integer, a register variable, @@ -92,16 +92,16 @@ data LLVMValue | VIdent Ident LLVMType | VConstant String | VFunction Ident Visibility LLVMType - deriving (Show) + deriving (Show, Eq, Ord) instance ToIr LLVMValue where toIr :: LLVMValue -> String toIr v = case v of - VInteger i -> show i - VChar i -> show i - VIdent (Ident n) _ -> "%" <> n + VInteger i -> show i + VChar i -> show i + VIdent (Ident n) _ -> "%" <> n VFunction (Ident n) vis _ -> toIr vis <> n - VConstant s -> "c" <> show s + VConstant s -> "c" <> show s type Params = [(Ident, LLVMType)] type Args = [(LLVMType, LLVMValue)] @@ -136,7 +136,7 @@ data LLVMIr | Comment String | UnsafeRaw String -- This should generally be avoided, and proper -- instructions should be used in its place - deriving (Show) + deriving (Show, Eq, Ord) -- | Converts a list of LLVMIr instructions to a string llvmIrToString :: [LLVMIr] -> String @@ -146,9 +146,9 @@ llvmIrToString = go 0 go _ [] = mempty go i (x : xs) = do let (i', n) = case x of - Define{} -> (i + 1, 0) + Define{} -> (i + 1, 0) DefineEnd -> (i - 1, 0) - _ -> (i, i) + _ -> (i, i) insToString n x <> go i' xs -- \| Converts a LLVM inststruction to a String, allowing for printing etc. From 43a863c153fd11923862e28dbe8c4ab3e1b3320a Mon Sep 17 00:00:00 2001 From: sebastianselander Date: Tue, 28 Mar 2023 15:44:03 +0200 Subject: [PATCH 209/372] fixed coerce type error --- src/TypeChecker/RemoveTEVar.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/TypeChecker/RemoveTEVar.hs b/src/TypeChecker/RemoveTEVar.hs index bfa06ba..e709456 100644 --- a/src/TypeChecker/RemoveTEVar.hs +++ b/src/TypeChecker/RemoveTEVar.hs @@ -64,8 +64,8 @@ instance RemoveTEVar a b => RemoveTEVar [a] [b] where instance RemoveTEVar Type T.Type where rmTEVar = \case TLit lit -> pure $ T.TLit (coerce lit) - TVar tvar -> pure $ T.TVar (coerce tvar) + TVar (MkTVar i) -> pure $ T.TVar (T.MkTVar $ coerce i) TData name typs -> T.TData (coerce name) <$> rmTEVar typs TFun t1 t2 -> liftA2 T.TFun (rmTEVar t1) (rmTEVar t2) - TAll tvar t -> T.TAll (coerce tvar) <$> rmTEVar t + TAll (MkTVar i) t -> T.TAll (T.MkTVar $ coerce i) <$> rmTEVar t TEVar _ -> throwError "NewType TEVar!" From a7401f0ee3e9b465cf985fc0ad8f0fb1f87451b5 Mon Sep 17 00:00:00 2001 From: Rakarake Date: Tue, 28 Mar 2023 15:55:06 +0200 Subject: [PATCH 210/372] Monomorphizer main fix --- src/Monomorphizer/Monomorphizer.hs | 13 ++++++++----- 1 file changed, 8 insertions(+), 5 deletions(-) diff --git a/src/Monomorphizer/Monomorphizer.hs b/src/Monomorphizer/Monomorphizer.hs index 17994c0..49b3871 100644 --- a/src/Monomorphizer/Monomorphizer.hs +++ b/src/Monomorphizer/Monomorphizer.hs @@ -183,11 +183,14 @@ 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) - where - newName' :: M.Type -> String - newName' (M.TLit (Ident str)) = str - newName' (M.TFun t1 t2) = newName' t1 ++ "_" ++ newName' t2 +newName t (T.Bind (Ident bindName, _) _ _) = + if bindName == "main" then + Ident bindName + else Ident (bindName ++ "$" ++ newName' t) + where + newName' :: M.Type -> String + newName' (M.TLit (Ident str)) = str + newName' (M.TFun t1 t2) = newName' t1 ++ "_" ++ newName' t2 -- Monomorphization step monomorphize :: T.Program -> M.Program From cf12c3443d7aeab9785bf884d817f09dcb9d872a Mon Sep 17 00:00:00 2001 From: Rakarake Date: Tue, 28 Mar 2023 15:57:35 +0200 Subject: [PATCH 211/372] Main had a weird look --- src/Main.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Main.hs b/src/Main.hs index 1864a17..4208137 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -103,7 +103,7 @@ main' opts s = do --let lifted = lambdaLift typechecked --printToErr $ printTree lifted - printToErr "\n -- Compiler --" + printToErr "\n -- Monomorphizer --" let monomorphized = monomorphize typechecked printToErr $ show monomorphized From ba832ba288780c893f068bdb53ab9b0d19fc2b5e Mon Sep 17 00:00:00 2001 From: sebastianselander Date: Tue, 28 Mar 2023 16:07:39 +0200 Subject: [PATCH 212/372] added printTree for monomorphizer --- src/Main.hs | 105 ++++++++++------------ src/Monomorphizer/MonomorphizerIr.hs | 128 +++++++++++++++++++++++++++ test_program.crf | 21 +---- 3 files changed, 178 insertions(+), 76 deletions(-) diff --git a/src/Main.hs b/src/Main.hs index 4208137..84e109a 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -1,34 +1,44 @@ {-# LANGUAGE OverloadedRecordDot #-} + module Main where -import Control.Monad (when) -import Data.Bool (bool) -import Data.List.Extra (isSuffixOf) -import Data.Maybe (fromJust, isNothing) -import GHC.IO.Handle.Text (hPutStrLn) -import System.Console.GetOpt (ArgDescr (NoArg, ReqArg), - ArgOrder (RequireOrder), - OptDescr (Option), getOpt, - usageInfo) -import System.Directory (createDirectory, doesPathExist, - getDirectoryContents, - removeDirectoryRecursive, - setCurrentDirectory) -import System.Environment (getArgs) -import System.Exit (ExitCode (ExitFailure), - exitFailure, exitSuccess, - exitWith) -import System.IO (stderr) -import Codegen.Codegen (generateCode) -import Compiler (compile) -import Grammar.ErrM (Err) -import Grammar.Par (myLexer, pProgram) -import Grammar.Print (printTree) -import LambdaLifter (lambdaLift) -import Monomorphizer.Monomorphizer (monomorphize) -import Renamer.Renamer (rename) -import System.Process (spawnCommand, waitForProcess) -import TypeChecker.TypeChecker (TypeChecker (Bi, Hm), typecheck) +import Codegen.Codegen (generateCode) +import Compiler (compile) +import Control.Monad (when) +import Data.Bool (bool) +import Data.List.Extra (isSuffixOf) +import Data.Maybe (fromJust, isNothing) +import GHC.IO.Handle.Text (hPutStrLn) +import Grammar.ErrM (Err) +import Grammar.Par (myLexer, pProgram) +import Grammar.Print (printTree) +import LambdaLifter (lambdaLift) +import Monomorphizer.Monomorphizer (monomorphize) +import Renamer.Renamer (rename) +import System.Console.GetOpt ( + ArgDescr (NoArg, ReqArg), + ArgOrder (RequireOrder), + OptDescr (Option), + getOpt, + usageInfo, + ) +import System.Directory ( + createDirectory, + doesPathExist, + getDirectoryContents, + removeDirectoryRecursive, + setCurrentDirectory, + ) +import System.Environment (getArgs) +import System.Exit ( + ExitCode (ExitFailure), + exitFailure, + exitSuccess, + exitWith, + ) +import System.IO (stderr) +import System.Process (spawnCommand, waitForProcess) +import TypeChecker.TypeChecker (TypeChecker (Bi, Hm), typecheck) main :: IO () main = getArgs >>= parseArgs >>= uncurry main' @@ -75,11 +85,11 @@ chooseTypechecker s options = options{typechecker = tc} tc = case s of "hm" -> pure Hm "bi" -> pure Bi - _ -> Nothing + _ -> Nothing data Options = Options - { help :: Bool - , debug :: Bool + { help :: Bool + , debug :: Bool , typechecker :: Maybe TypeChecker } @@ -100,46 +110,25 @@ main' opts s = do bool (printToErr $ printTree typechecked) (printToErr $ show typechecked) opts.debug printToErr "\n-- Lambda Lifter --" - --let lifted = lambdaLift typechecked - --printToErr $ printTree lifted + let lifted = lambdaLift typechecked + printToErr $ printTree lifted printToErr "\n -- Monomorphizer --" - let monomorphized = monomorphize typechecked - printToErr $ show monomorphized + let monomorphized = monomorphize lifted + printToErr $ printTree monomorphized - -- printToErr "\n-- Lambda Lifter --" - -- let lifted = lambdaLift typechecked - -- printToErr $ printTree lifted - -- printToErr "\n -- Compiler --" generatedCode <- fromCompilerErr $ generateCode (monomorphize typechecked) - -- putStrLn generatedCode check <- doesPathExist "output" when check (removeDirectoryRecursive "output") createDirectory "output" when opts.debug $ do - _ <- writeFile "output/llvm.ll" generatedCode + writeFile "output/llvm.ll" generatedCode debugDotViz compile generatedCode - spawnWait "./output/hello_world" - --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 - - --compile generatedCode - --spawnWait "./hello_world" - -- interpred <- fromInterpreterErr $ interpret lifted - -- putStrLn "\n-- interpret" - -- print interpred + spawnWait "./hello_world" exitSuccess diff --git a/src/Monomorphizer/MonomorphizerIr.hs b/src/Monomorphizer/MonomorphizerIr.hs index 66888c0..052cdc1 100644 --- a/src/Monomorphizer/MonomorphizerIr.hs +++ b/src/Monomorphizer/MonomorphizerIr.hs @@ -1,5 +1,8 @@ +{-# LANGUAGE LambdaCase #-} + module Monomorphizer.MonomorphizerIr (module Monomorphizer.MonomorphizerIr) where +import Grammar.Print import TypeChecker.TypeCheckerIr qualified as TIR (Ident (..)) type Id = (TIR.Ident, Type) @@ -52,3 +55,128 @@ data Type = TLit TIR.Ident | TFun Type Type flattenType :: Type -> [Type] flattenType (TFun t1 t2) = t1 : flattenType t2 flattenType x = [x] + +instance Print Program where + prt i (Program sc) = prPrec i 0 $ prt 0 sc + +instance Print (Bind) where + prt i (Bind sig@(name, _) parms rhs) = + prPrec i 0 $ + concatD + [ prtSig sig + , prt 0 name + , prtIdPs 0 parms + , doc $ showString "=" + , prt 0 rhs + ] + +prtSig :: Id -> Doc +prtSig (name, t) = + concatD + [ prt 0 name + , doc $ showString ":" + , prt 0 t + , doc $ showString ";" + ] + +instance Print (ExpT) where + prt i (e, t) = + concatD + [ doc $ showString "(" + , prt i e + , doc $ showString "," + , prt i t + , doc $ showString ")" + ] + +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 (prt i) + +instance Print Exp where + prt i = \case + EVar name -> prPrec i 3 $ prt 0 name + ELit lit -> prPrec i 3 $ prt 0 lit + ELet b e -> + prPrec i 3 $ + concatD + [ doc $ showString "let" + , prt 0 b + , doc $ showString "in" + , prt 0 e + ] + EApp e1 e2 -> + prPrec i 2 $ + concatD + [ prt 2 e1 + , prt 3 e2 + ] + EAdd e1 e2 -> + prPrec i 1 $ + concatD + [ prt 1 e1 + , doc $ showString "+" + , prt 2 e2 + ] + ECase e branches -> + prPrec i 0 $ + concatD + [ doc $ showString "case" + , prt 0 e + , doc $ showString "of" + , doc $ showString "{" + , prt 0 branches + , doc $ showString "}" + ] + +instance Print Branch where + prt i (Branch (pattern_, t) exp) = prPrec i 0 (concatD [doc (showString "("), prt 0 pattern_, doc (showString " : "), prt 0 t, doc (showString ")"), doc (showString "=>"), prt 0 exp]) + +instance Print [Branch] where + prt _ [] = concatD [] + prt _ [x] = concatD [prt 0 x] + prt _ (x : xs) = concatD [prt 0 x, doc (showString ";"), prt 0 xs] + +instance Print Def where + prt i = \case + DBind bind -> prPrec i 0 (concatD [prt 0 bind]) + DData data_ -> prPrec i 0 (concatD [prt 0 data_]) + +instance Print Data where + prt i = \case + Data type_ injs -> prPrec i 0 (concatD [doc (showString "data"), prt 0 type_, doc (showString "where"), doc (showString "{"), prt 0 injs, doc (showString "}")]) + +instance Print Inj where + prt i = \case + Inj uident type_ -> prPrec i 0 (concatD [prt 0 uident, doc (showString ":"), prt 0 type_]) + +instance Print Pattern where + prt i = \case + PVar name -> prPrec i 1 (concatD [prt 0 name]) + PLit (lit, _) -> prPrec i 1 (concatD [prt 0 lit]) + PCatch -> prPrec i 1 (concatD [doc (showString "_")]) + PEnum name -> prPrec i 1 (concatD [prt 0 name]) + PInj uident patterns -> prPrec i 0 (concatD [prt 0 uident, prt 1 patterns]) + +instance Print [Def] where + prt _ [] = concatD [] + prt _ [x] = concatD [prt 0 x] + prt _ (x : xs) = concatD [prt 0 x, doc (showString ";"), prt 0 xs] + +instance Print [Type] where + prt _ [] = concatD [] + prt _ (x : xs) = concatD [prt 0 x, doc (showString " "), prt 0 xs] + +instance Print Type where + prt i = \case + TLit uident -> prPrec i 1 (concatD [prt 0 uident]) + TFun type_1 type_2 -> prPrec i 0 (concatD [prt 1 type_1, doc (showString "->"), prt 0 type_2]) + +instance Print Lit where + prt i = \case + LInt int -> prt i int + LChar char -> prt i char diff --git a/test_program.crf b/test_program.crf index 4771d93..8cee923 100644 --- a/test_program.crf +++ b/test_program.crf @@ -1,20 +1,5 @@ -data List () where { - Nil : List () - Cons : Int -> List () -> List () -}; +id x = x; -main = case Nil of { - Nil => 0 ; - Cons a _ => a ; -}; +const x y = x ; --- length : List () -> Int ; --- length xs = case xs of { --- Nil => 0; --- Cons _ xs => 1 + length xs ; --- }; - ---sum xs = case xs of { --- Nil => 0 ; --- Cons a xs => a + main xs ; ---}; \ No newline at end of file +main = const (id 0) (id 'a') ; From 4809cad1cbf97e9afce615b7b38033f731eeb717 Mon Sep 17 00:00:00 2001 From: Samuel Hammersberg Date: Tue, 28 Mar 2023 16:54:11 +0200 Subject: [PATCH 213/372] Fixed chars. --- src/Codegen/Codegen.hs | 52 ++++++++++++++---------------------------- src/Codegen/LlvmIr.hs | 2 +- 2 files changed, 18 insertions(+), 36 deletions(-) diff --git a/src/Codegen/Codegen.hs b/src/Codegen/Codegen.hs index 7f01d6b..0cb08a8 100644 --- a/src/Codegen/Codegen.hs +++ b/src/Codegen/Codegen.hs @@ -6,9 +6,11 @@ module Codegen.Codegen (generateCode) where import Auxiliary (snoc) import Codegen.LlvmIr as LIR import Control.Applicative ((<|>)) +import Control.Monad (when) import Control.Monad.State (StateT, execStateT, foldM_, gets, modify) import qualified Data.Bifunctor as BI +import Data.Char (ord) import Data.Coerce (coerce) import Data.Map (Map) import qualified Data.Map as Map @@ -243,9 +245,10 @@ compileScs (MIR.DBind (MIR.Bind (name, _t) args exp) : xs) = do emit . Comment $ show name <> ": " <> show exp let args' = map (second type2LlvmType) args emit $ Define FastCC I64 {-(type2LlvmType t_return)-} name args' + when (name == "main") (mapM_ emit firstMainContent) functionBody <- exprToValue exp if name == "main" - then mapM_ emit $ mainContent functionBody + then mapM_ emit $ lastMainContent functionBody else emit $ Ret I64 functionBody emit DefineEnd modify $ \s -> s{variableCount = 0} @@ -262,39 +265,15 @@ compileScs (MIR.DData (MIR.Data typ ts) : xs) = do ts compileScs xs -mainContent :: LLVMValue -> [LLVMIr] -mainContent var = +firstMainContent :: [LLVMIr] +firstMainContent = + [ UnsafeRaw "call void @_ZN2GC4Heap4initEv()\n" + ] +lastMainContent :: LLVMValue -> [LLVMIr] +lastMainContent var = [ UnsafeRaw $ - -- "%2 = alloca %Craig\n" <> - -- " store %Craig %1, ptr %2\n" <> - -- " %3 = bitcast %Craig* %2 to i72*\n" <> - -- " %4 = load i72, ptr %3\n" <> - -- " call i32 (ptr, ...) @printf(ptr noundef @.str, i72 noundef %4)\n" - - -- "%2 = alloca %Craig\n" <> - -- " store %Craig %1, ptr %2\n" <> - -- " %3 = bitcast %Craig* %2 to i72*\n" <> - -- " %4 = load i72, ptr %3\n" <> - -- " call i32 (ptr, ...) @printf(ptr noundef @.str, i72 noundef %4)\n" - - -- "%2 = alloca %Craig\n" <> - -- " store %Craig %1, ptr %2\n" <> - -- " %3 = bitcast %Craig* %2 to i72*\n" <> - -- " %4 = load i72, ptr %3\n" <> - -- " call i32 (ptr, ...) @printf(ptr noundef @.str, i72 noundef %4)\n" "call i32 (ptr, ...) @printf(ptr noundef @.str, i64 noundef " <> toIr var <> ")\n" - , -- , SetVariable (TIR.Ident "p") (Icmp LLEq I64 (VInteger 2) (VInteger 2)) - -- , BrCond (VIdent (TIR.Ident "p")) (TIR.Ident "b_1") (TIR.Ident "b_2") - -- , Label (TIR.Ident "b_1") - -- , UnsafeRaw - -- "call i32 (ptr, ...) @printf(ptr noundef @.str, i64 noundef 1)\n" - -- , Br (TIR.Ident "end") - -- , Label (TIR.Ident "b_2") - -- , UnsafeRaw - -- "call i32 (ptr, ...) @printf(ptr noundef @.str, i64 noundef 2)\n" - -- , Br (TIR.Ident "end") - -- , Label (TIR.Ident "end") - Ret I64 (VInteger 0) + , Ret I64 (VInteger 0) ] defaultStart :: [LLVMIr] @@ -305,6 +284,9 @@ defaultStart = , UnsafeRaw "@.non_exhaustive_patterns = private unnamed_addr constant [41 x i8] c\"Non-exhaustive patterns in case at %i:%i\n\"\n" , UnsafeRaw "declare i32 @printf(ptr noalias nocapture, ...)\n" , UnsafeRaw "declare i32 @exit(i32 noundef)\n" + , UnsafeRaw "declare i32 @_ZN2GC4Heap4initEv()\n" + , UnsafeRaw "declare i32 @_ZN2GC4Heap5allocEm()\n" + , UnsafeRaw "declare i32 @_ZN2GC4Heap7disposeEv()\n" ] compileExp :: ExpT -> CompilerState () @@ -398,7 +380,7 @@ emitECased t e cases = do emit $ Comment "Plit" let i' = case i of (MIR.LInt i, _) -> VInteger i - (MIR.LChar i, _) -> VChar i + (MIR.LChar i, _) -> VChar (ord i) ns <- getNewVar lbl_failPos <- (\x -> TIR.Ident $ "failed_" <> show x) <$> getNewLabel lbl_succPos <- (\x -> TIR.Ident $ "success_" <> show x) <$> getNewLabel @@ -485,7 +467,7 @@ emitLit i = do -- !!this should never happen!! let (i', t) = case i of (MIR.LInt i'') -> (VInteger i'', I64) - (MIR.LChar i'') -> (VChar i'', I8) + (MIR.LChar i'') -> (VChar $ ord i'', I8) varCount <- getNewVar emit $ Comment "This should not have happened!" emit $ SetVariable varCount (Add t i' (VInteger 0)) @@ -508,7 +490,7 @@ exprToValue :: ExpT -> CompilerState LLVMValue exprToValue = \case (MIR.ELit i, t) -> pure $ case i of (MIR.LInt i) -> VInteger i - (MIR.LChar i) -> VChar i + (MIR.LChar i) -> VChar $ ord i (MIR.EVar name, t) -> do funcs <- gets functions cons <- gets constructors diff --git a/src/Codegen/LlvmIr.hs b/src/Codegen/LlvmIr.hs index 15bdc01..5c04e11 100644 --- a/src/Codegen/LlvmIr.hs +++ b/src/Codegen/LlvmIr.hs @@ -88,7 +88,7 @@ or a string contstant -} data LLVMValue = VInteger Integer - | VChar Char + | VChar Int | VIdent Ident LLVMType | VConstant String | VFunction Ident Visibility LLVMType From 92a2ff323565385a06652af12e4edfa81bbdc0bf Mon Sep 17 00:00:00 2001 From: Samuel Hammersberg Date: Tue, 28 Mar 2023 17:13:38 +0200 Subject: [PATCH 214/372] Fixed a broken path. --- src/Main.hs | 73 +++++++++++++++++++++++------------------------------ 1 file changed, 32 insertions(+), 41 deletions(-) diff --git a/src/Main.hs b/src/Main.hs index 84e109a..1b02c09 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -2,43 +2,34 @@ module Main where -import Codegen.Codegen (generateCode) -import Compiler (compile) -import Control.Monad (when) -import Data.Bool (bool) -import Data.List.Extra (isSuffixOf) -import Data.Maybe (fromJust, isNothing) -import GHC.IO.Handle.Text (hPutStrLn) -import Grammar.ErrM (Err) -import Grammar.Par (myLexer, pProgram) -import Grammar.Print (printTree) -import LambdaLifter (lambdaLift) -import Monomorphizer.Monomorphizer (monomorphize) -import Renamer.Renamer (rename) -import System.Console.GetOpt ( - ArgDescr (NoArg, ReqArg), - ArgOrder (RequireOrder), - OptDescr (Option), - getOpt, - usageInfo, - ) -import System.Directory ( - createDirectory, - doesPathExist, - getDirectoryContents, - removeDirectoryRecursive, - setCurrentDirectory, - ) -import System.Environment (getArgs) -import System.Exit ( - ExitCode (ExitFailure), - exitFailure, - exitSuccess, - exitWith, - ) -import System.IO (stderr) -import System.Process (spawnCommand, waitForProcess) -import TypeChecker.TypeChecker (TypeChecker (Bi, Hm), typecheck) +import Codegen.Codegen (generateCode) +import Compiler (compile) +import Control.Monad (when) +import Data.Bool (bool) +import Data.List.Extra (isSuffixOf) +import Data.Maybe (fromJust, isNothing) +import GHC.IO.Handle.Text (hPutStrLn) +import Grammar.ErrM (Err) +import Grammar.Par (myLexer, pProgram) +import Grammar.Print (printTree) +import LambdaLifter (lambdaLift) +import Monomorphizer.Monomorphizer (monomorphize) +import Renamer.Renamer (rename) +import System.Console.GetOpt (ArgDescr (NoArg, ReqArg), + ArgOrder (RequireOrder), + OptDescr (Option), getOpt, + usageInfo) +import System.Directory (createDirectory, doesPathExist, + getDirectoryContents, + removeDirectoryRecursive, + setCurrentDirectory) +import System.Environment (getArgs) +import System.Exit (ExitCode (ExitFailure), + exitFailure, exitSuccess, + exitWith) +import System.IO (stderr) +import System.Process (spawnCommand, waitForProcess) +import TypeChecker.TypeChecker (TypeChecker (Bi, Hm), typecheck) main :: IO () main = getArgs >>= parseArgs >>= uncurry main' @@ -85,11 +76,11 @@ chooseTypechecker s options = options{typechecker = tc} tc = case s of "hm" -> pure Hm "bi" -> pure Bi - _ -> Nothing + _ -> Nothing data Options = Options - { help :: Bool - , debug :: Bool + { help :: Bool + , debug :: Bool , typechecker :: Maybe TypeChecker } @@ -128,7 +119,7 @@ main' opts s = do debugDotViz compile generatedCode - spawnWait "./hello_world" + spawnWait "./output/hello_world" exitSuccess From 91d6332dc5096ad29d68cf51434380f12b59eb29 Mon Sep 17 00:00:00 2001 From: Rakarake Date: Tue, 28 Mar 2023 17:14:55 +0200 Subject: [PATCH 215/372] Fixed removed args in tree after monomorphizer --- src/Monomorphizer/Monomorphizer.hs | 25 ++++++++++++++++++++++++- 1 file changed, 24 insertions(+), 1 deletion(-) diff --git a/src/Monomorphizer/Monomorphizer.hs b/src/Monomorphizer/Monomorphizer.hs index 49b3871..317ecf6 100644 --- a/src/Monomorphizer/Monomorphizer.hs +++ b/src/Monomorphizer/Monomorphizer.hs @@ -134,10 +134,16 @@ morphBind expectedType b@(T.Bind (Ident _, btype) args (exp, t)) = -- function calls markBind (coerce name') exp' <- morphExp expectedType exp + -- Get monomorphic type sof args + args' <- mapM convertArg args addOutputBind $ M.Bind (coerce name', expectedType) - [] (exp', expectedType) + args' (exp', expectedType) return name' +convertArg :: (Ident, T.Type) -> EnvM (Ident, M.Type) +convertArg (ident, t) = do t' <- getMonoFromPoly t + return (ident, t') + -- Morphs function applications, such as EApp and EAdd morphApp :: M.Type -> T.ExpT -> T.ExpT -> EnvM M.Exp morphApp expectedType (e1, t1) (e2, t2)= do @@ -153,9 +159,20 @@ convertLit :: T.Lit -> M.Lit convertLit (T.LInt v) = M.LInt v convertLit (T.LChar v) = M.LChar v +-- | Conv +--data Pattern' t +-- = PVar (Id' t) -- TODO should be Ident +-- | PLit (Lit, t) -- TODO should be Lit +-- | PCatch +-- | PEnum Ident +-- | PInj Ident [Pattern' t] -- TODO should be (Pattern' t, t) +-- deriving (C.Eq, C.Ord, C.Show, C.Read) + morphExp :: M.Type -> T.Exp -> EnvM M.Exp morphExp expectedType exp = case exp of T.ELit lit -> return $ M.ELit (convertLit lit) + T.EInj ident -> do + return $ M.EVar ident T.EApp e1 e2 -> do morphApp expectedType e1 e2 T.EAdd e1 e2 -> do @@ -163,6 +180,12 @@ morphExp expectedType exp = case exp of T.EAbs ident (exp, t) -> local (\env -> env { locals = Set.insert ident (locals env) }) $ do t' <- getMonoFromPoly t morphExp t' exp +-- T.ECase (exp, t) bs -> do +-- t' <- getMonoFromPoly t +-- exp' <- morphExp t' exp +-- return M.ECase (exp', t') +--data Branch' t = Branch (Pattern' t, t) (ExpT' t) +-- deriving (C.Eq, C.Ord, C.Show, C.Read) T.EVar ident@(Ident str) -> do isLocal <- localExists ident if isLocal then do From 8910d8adc01eff7051fb89aa9c910d8de3ef1797 Mon Sep 17 00:00:00 2001 From: sebastianselander Date: Tue, 28 Mar 2023 17:13:51 +0200 Subject: [PATCH 216/372] temporary commit incase of breakage --- Grammar.cf | 1 + language.cabal | 3 +- src/Desugar/Desugar.hs | 32 +++++++++++++ src/Main.hs | 78 +++++++++++++++++++------------- src/TypeChecker/TypeCheckerHm.hs | 44 +++++++++++++++--- test_program.crf | 5 +- 6 files changed, 118 insertions(+), 45 deletions(-) create mode 100644 src/Desugar/Desugar.hs diff --git a/Grammar.cf b/Grammar.cf index 55763f4..9ca0db6 100644 --- a/Grammar.cf +++ b/Grammar.cf @@ -48,6 +48,7 @@ EVar. Exp3 ::= LIdent; EInj. Exp3 ::= UIdent; ELit. Exp3 ::= Lit; EApp. Exp2 ::= Exp2 Exp3; +EAppInf. Exp2 ::= Exp3 "`" Exp3 "`"; EAdd. Exp1 ::= Exp1 "+" Exp2; ELet. Exp ::= "let" Bind "in" Exp; EAbs. Exp ::= "\\" LIdent "." Exp; diff --git a/language.cabal b/language.cabal index 9785d75..922f873 100644 --- a/language.cabal +++ b/language.cabal @@ -44,9 +44,8 @@ executable language Codegen.LlvmIr Compiler Renamer.Renamer - --Codegen.Codegen - --Codegen.LlvmIr TreeConverter + Desugar.Desugar hs-source-dirs: src diff --git a/src/Desugar/Desugar.hs b/src/Desugar/Desugar.hs new file mode 100644 index 0000000..f67fa05 --- /dev/null +++ b/src/Desugar/Desugar.hs @@ -0,0 +1,32 @@ +{-# LANGUAGE LambdaCase #-} + +module Desugar.Desugar where + +import Data.Function (on) +import Grammar.Abs + +desugar :: Program -> Program +desugar (Program defs) = Program (map desugarDef defs) + +desugarDef :: Def -> Def +desugarDef = \case + DBind b -> DBind (desugarBind b) + DSig sig -> DSig sig + DData d -> DData d + +desugarBind :: Bind -> Bind +desugarBind (Bind name args e) = Bind name args (desugarExp e) + +desugarExp :: Exp -> Exp +desugarExp = \case + EAppInf e2 e1 -> (EApp `on` desugarExp) e1 e2 + EApp e1 e2 -> (EApp `on` desugarExp) e1 e2 + EAdd e1 e2 -> (EAdd `on` desugarExp) e1 e2 + EAbs i e -> EAbs i (desugarExp e) + ELet b e -> ELet (desugarBind b) (desugarExp e) + ECase e br -> ECase (desugarExp e) (map desugarBranch br) + EAnn e t -> EAnn (desugarExp e) t + e -> e + +desugarBranch :: Branch -> Branch +desugarBranch (Branch p e) = Branch p (desugarExp e) diff --git a/src/Main.hs b/src/Main.hs index 1b02c09..32f4443 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -2,34 +2,44 @@ module Main where -import Codegen.Codegen (generateCode) -import Compiler (compile) -import Control.Monad (when) -import Data.Bool (bool) -import Data.List.Extra (isSuffixOf) -import Data.Maybe (fromJust, isNothing) -import GHC.IO.Handle.Text (hPutStrLn) -import Grammar.ErrM (Err) -import Grammar.Par (myLexer, pProgram) -import Grammar.Print (printTree) -import LambdaLifter (lambdaLift) -import Monomorphizer.Monomorphizer (monomorphize) -import Renamer.Renamer (rename) -import System.Console.GetOpt (ArgDescr (NoArg, ReqArg), - ArgOrder (RequireOrder), - OptDescr (Option), getOpt, - usageInfo) -import System.Directory (createDirectory, doesPathExist, - getDirectoryContents, - removeDirectoryRecursive, - setCurrentDirectory) -import System.Environment (getArgs) -import System.Exit (ExitCode (ExitFailure), - exitFailure, exitSuccess, - exitWith) -import System.IO (stderr) -import System.Process (spawnCommand, waitForProcess) -import TypeChecker.TypeChecker (TypeChecker (Bi, Hm), typecheck) +import Codegen.Codegen (generateCode) +import Compiler (compile) +import Control.Monad (when) +import Data.Bool (bool) +import Data.List.Extra (isSuffixOf) +import Data.Maybe (fromJust, isNothing) +import Desugar.Desugar (desugar) +import GHC.IO.Handle.Text (hPutStrLn) +import Grammar.ErrM (Err) +import Grammar.Par (myLexer, pProgram) +import Grammar.Print (printTree) +import LambdaLifter (lambdaLift) +import Monomorphizer.Monomorphizer (monomorphize) +import Renamer.Renamer (rename) +import System.Console.GetOpt ( + ArgDescr (NoArg, ReqArg), + ArgOrder (RequireOrder), + OptDescr (Option), + getOpt, + usageInfo, + ) +import System.Directory ( + createDirectory, + doesPathExist, + getDirectoryContents, + removeDirectoryRecursive, + setCurrentDirectory, + ) +import System.Environment (getArgs) +import System.Exit ( + ExitCode (ExitFailure), + exitFailure, + exitSuccess, + exitWith, + ) +import System.IO (stderr) +import System.Process (spawnCommand, waitForProcess) +import TypeChecker.TypeChecker (TypeChecker (Bi, Hm), typecheck) main :: IO () main = getArgs >>= parseArgs >>= uncurry main' @@ -76,11 +86,11 @@ chooseTypechecker s options = options{typechecker = tc} tc = case s of "hm" -> pure Hm "bi" -> pure Bi - _ -> Nothing + _ -> Nothing data Options = Options - { help :: Bool - , debug :: Bool + { help :: Bool + , debug :: Bool , typechecker :: Maybe TypeChecker } @@ -92,8 +102,12 @@ main' opts s = do parsed <- fromSyntaxErr . pProgram $ myLexer file bool (printToErr $ printTree parsed) (printToErr $ show parsed) opts.debug + printToErr "-- Desugar --" + let desugared = desugar parsed + bool (printToErr $ printTree desugared) (printToErr $ show desugared) opts.debug + printToErr "\n-- Renamer --" - renamed <- fromRenamerErr . rename $ parsed + renamed <- fromRenamerErr . rename $ desugared bool (printToErr $ printTree renamed) (printToErr $ show renamed) opts.debug printToErr "\n-- TypeChecker --" diff --git a/src/TypeChecker/TypeCheckerHm.hs b/src/TypeChecker/TypeCheckerHm.hs index 0cb8a4a..13716cd 100644 --- a/src/TypeChecker/TypeCheckerHm.hs +++ b/src/TypeChecker/TypeCheckerHm.hs @@ -21,6 +21,7 @@ import Data.Map qualified as M import Data.Maybe (fromJust) import Data.Set (Set) import Data.Set qualified as S +import Debug.Trace (trace) import Grammar.Abs import Grammar.Print (printTree) import TypeChecker.TypeCheckerIr qualified as T @@ -96,7 +97,8 @@ checkBind (Bind name args e) = do s <- gets sigs case M.lookup (coerce name) s of Just (Just t') -> do - let fsig = apply sub0 t' + sab <- unify t' lambda_t + let fsig = apply (sab `compose` sub0) t' sub1 <- liftEither $ runIdentity $ runExceptT $ execStateT (typeEq fsig lambda_t) mempty sub2 <- liftEither $ runIdentity $ runExceptT $ execStateT (typeEq lambda_t fsig) mempty unless @@ -314,6 +316,7 @@ algoW = \case (subst, injs, ret_t) <- checkCase t injs let comp = subst `compose` sub return (comp, apply comp (T.ECase (e', t) injs, ret_t)) + EAppInf{} -> error "desugar phase failed" checkCase :: Type -> [Branch] -> Infer (Subst, [T.Branch' Type], Type) checkCase _ [] = catchableErr "Atleast one case required" @@ -687,15 +690,42 @@ typeEq (TVar (MkTVar a)) t@(TVar _) = do st <- get case M.lookup (coerce a) st of Nothing -> put $ M.insert (coerce a) t st - Just t' -> unless (t == t') (catchableErr "TYPE MISMATCH") + Just t' -> + unless + (t == t') + ( catchableErr $ Aux.do + quote $ printTree t + "does not match with" + quote $ printTree t' + ) typeEq (TFun l r) (TFun l' r') = typeEq l l' *> typeEq r r' typeEq (TAll _ l) (TAll _ r) = typeEq l r -typeEq (TLit a) (TLit b) = unless (a == b) (catchableErr "TYPE MISMATCH") -typeEq (TData nameL tL) (TData nameR tR) = do - unless (nameL == nameR) (catchableErr "TYPE MISMATCH") +typeEq t@(TLit a) t'@(TLit b) = + unless + (a == b) + ( catchableErr $ Aux.do + quote $ printTree t + "does not match with" + quote $ printTree t' + ) +typeEq t@(TData nameL tL) t'@(TData nameR tR) = do + unless + (nameL == nameR) + ( catchableErr $ Aux.do + quote $ printTree t + "does not match with" + quote $ printTree t' + ) zipWithM_ typeEq tL tR -typeEq (TEVar _) (TEVar _) = catchableErr "TYPE MISMATCH" -typeEq _ _ = catchableErr "TYPE MISMATCH" +typeEq t@(TEVar _) t'@(TEVar _) = + catchableErr $ Aux.do + quote $ printTree t + "does not match with" + quote $ printTree t' +typeEq t t' = catchableErr $ Aux.do + quote $ printTree t + "does not match with" + quote $ printTree t' {- | Catch an error if possible and add the given expression as addition to the error message diff --git a/test_program.crf b/test_program.crf index 8cee923..bdce08c 100644 --- a/test_program.crf +++ b/test_program.crf @@ -1,5 +1,2 @@ -id x = x; - +main = const 1 2 ; const x y = x ; - -main = const (id 0) (id 'a') ; From e87e2d3870fd5edfc54dd1cfc23ae2b2252d9d2a Mon Sep 17 00:00:00 2001 From: sebastianselander Date: Tue, 28 Mar 2023 17:33:14 +0200 Subject: [PATCH 217/372] sneaky buggy fixy --- src/Main.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Main.hs b/src/Main.hs index 32f4443..f5793be 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -116,14 +116,14 @@ main' opts s = do printToErr "\n-- Lambda Lifter --" let lifted = lambdaLift typechecked - printToErr $ printTree lifted + bool (printToErr $ printTree lifted) (printToErr $ show lifted) opts.debug printToErr "\n -- Monomorphizer --" let monomorphized = monomorphize lifted - printToErr $ printTree monomorphized + bool (printToErr $ printTree monomorphized) (printToErr $ show monomorphized) opts.debug printToErr "\n -- Compiler --" - generatedCode <- fromCompilerErr $ generateCode (monomorphize typechecked) + generatedCode <- fromCompilerErr $ generateCode monomorphized check <- doesPathExist "output" when check (removeDirectoryRecursive "output") From 230a205965854266c2c38d5421866d2d6934846d Mon Sep 17 00:00:00 2001 From: Samuel Hammersberg Date: Tue, 28 Mar 2023 17:37:29 +0200 Subject: [PATCH 218/372] Fixed wrongly typed functions in the code generator. --- src/Codegen/Codegen.hs | 235 +++++++++++++++++++++++------------------ src/Compiler.hs | 5 +- 2 files changed, 135 insertions(+), 105 deletions(-) diff --git a/src/Codegen/Codegen.hs b/src/Codegen/Codegen.hs index 0cb08a8..ffe1f91 100644 --- a/src/Codegen/Codegen.hs +++ b/src/Codegen/Codegen.hs @@ -1,49 +1,55 @@ -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} module Codegen.Codegen (generateCode) where -import Auxiliary (snoc) -import Codegen.LlvmIr as LIR -import Control.Applicative ((<|>)) -import Control.Monad (when) -import Control.Monad.State (StateT, execStateT, foldM_, - gets, modify) -import qualified Data.Bifunctor as BI -import Data.Char (ord) -import Data.Coerce (coerce) -import Data.Map (Map) -import qualified Data.Map as Map -import Data.Maybe (fromJust, fromMaybe) -import Data.Set (Set) -import qualified Data.Set as Set -import Data.Tuple.Extra (dupe, first, second) -import Grammar.ErrM (Err) -import Monomorphizer.MonomorphizerIr as MIR -import qualified TypeChecker.TypeCheckerIr as TIR +import Auxiliary (snoc) +import Codegen.LlvmIr as LIR +import Control.Applicative ((<|>)) +import Control.Monad (when) +import Control.Monad.State ( + StateT, + execStateT, + foldM_, + gets, + modify, + ) +import Data.Bifunctor qualified as BI +import Data.Char (ord) +import Data.Coerce (coerce) +import Data.Map (Map) +import Data.Map qualified as Map +import Data.Maybe (fromJust, fromMaybe) +import Data.Set (Set) +import Data.Set qualified as Set +import Data.Tuple.Extra (dupe, first, second) +import Debug.Trace (trace) +import Grammar.ErrM (Err) +import Monomorphizer.MonomorphizerIr as MIR +import TypeChecker.TypeCheckerIr qualified as TIR -- | The record used as the code generator state data CodeGenerator = CodeGenerator - { instructions :: [LLVMIr] - , functions :: Map MIR.Id FunctionInfo - , customTypes :: Set LLVMType - , constructors :: Map TIR.Ident ConstructorInfo + { instructions :: [LLVMIr] + , functions :: Map MIR.Id FunctionInfo + , customTypes :: Set LLVMType + , constructors :: Map TIR.Ident ConstructorInfo , variableCount :: Integer - , labelCount :: Integer + , labelCount :: Integer } -- | A state type synonym type CompilerState a = StateT CodeGenerator Err a data FunctionInfo = FunctionInfo - { numArgs :: Int + { numArgs :: Int , arguments :: [Id] } deriving (Show) data ConstructorInfo = ConstructorInfo - { numArgsCI :: Int - , argumentsCI :: [Id] - , numCI :: Integer + { numArgsCI :: Int + , argumentsCI :: [Id] + , numCI :: Integer , returnTypeCI :: MIR.Type } deriving (Show) @@ -55,7 +61,7 @@ emit l = modify $ \t -> t{instructions = Auxiliary.snoc l $ instructions t} -- | Increases the variable counter in the CodeGenerator state increaseVarCount :: CompilerState () increaseVarCount = do - gets variableCount >>= \s -> emit.Comment $ "increase: " <> show (s + 1) + gets variableCount >>= \s -> emit . Comment $ "increase: " <> show (s + 1) modify $ \t -> t{variableCount = variableCount t + 1} -- | Returns the variable count from the CodeGenerator state @@ -94,23 +100,34 @@ getConstructors :: [MIR.Def] -> Map TIR.Ident ConstructorInfo getConstructors bs = Map.fromList $ go bs where go [] = [] - go (MIR.DData (MIR.Data t cons) : xs) = fst - (foldl (\(acc, i) (Inj id xs) -> - (( id, ConstructorInfo - { numArgsCI = length (init . flattenType $ xs) - , argumentsCI = createArgs (init . flattenType $ xs) - , numCI = i - , returnTypeCI = t --last . flattenType $ xs - } - ) : acc, i + 1)) ([], 0) cons) <> go xs + go (MIR.DData (MIR.Data t cons) : xs) = + fst + ( foldl + ( \(acc, i) (Inj id xs) -> + ( ( id + , ConstructorInfo + { numArgsCI = length (init . flattenType $ xs) + , argumentsCI = createArgs (init . flattenType $ xs) + , numCI = i + , returnTypeCI = t -- last . flattenType $ xs + } + ) + : acc + , i + 1 + ) + ) + ([], 0) + cons + ) + <> go xs go (_ : xs) = go xs getTypes :: [MIR.Def] -> Set LLVMType getTypes bs = Set.fromList $ go bs where - go [] = [] + go [] = [] go (MIR.DData (MIR.Data t _) : xs) = type2LlvmType t : go xs - go (_:xs) = go xs + go (_ : xs) = go xs initCodeGenerator :: [MIR.Def] -> CodeGenerator initCodeGenerator scs = @@ -165,6 +182,7 @@ test v = eCaseInt x xs = (ECase (MIR.TLit (MIR.Ident "_Int")) x xs, MIR.TLit (MIR.Ident "_Int")) int x = (ELit (LInt x), MIR.TLit (MIR.Ident "_Int")) -} + {- | Compiles an AST and produces a LLVM Ir string. An easy way to actually "compile" this output is to Simply pipe it to LLI @@ -172,7 +190,7 @@ test v = generateCode :: MIR.Program -> Err String generateCode (MIR.Program scs) = do let codegen = initCodeGenerator scs - llvmIrToString . instructions <$> execStateT (compileScs scs) codegen + llvmIrToString . instructions <$> execStateT (compileScs (trace (show scs) scs)) codegen compileScs :: [MIR.Def] -> CompilerState () compileScs [] = do @@ -240,16 +258,17 @@ compileScs [] = do modify $ \s -> s{variableCount = 0} ) c -compileScs (MIR.DBind (MIR.Bind (name, _t) args exp) : xs) = do +compileScs (MIR.DBind (MIR.Bind (name, t) args exp) : xs) = do + let t_return = type2LlvmType . last . flattenType $ t emit $ UnsafeRaw "\n" emit . Comment $ show name <> ": " <> show exp let args' = map (second type2LlvmType) args - emit $ Define FastCC I64 {-(type2LlvmType t_return)-} name args' + emit $ Define FastCC t_return name args' when (name == "main") (mapM_ emit firstMainContent) functionBody <- exprToValue exp if name == "main" then mapM_ emit $ lastMainContent functionBody - else emit $ Ret I64 functionBody + else emit $ Ret t_return functionBody emit DefineEnd modify $ \s -> s{variableCount = 0} compileScs xs @@ -267,8 +286,10 @@ compileScs (MIR.DData (MIR.Data typ ts) : xs) = do firstMainContent :: [LLVMIr] firstMainContent = - [ UnsafeRaw "call void @_ZN2GC4Heap4initEv()\n" - ] + [] + +-- UnsafeRaw "call void @_ZN2GC4Heap4initEv()\n" + lastMainContent :: LLVMValue -> [LLVMIr] lastMainContent var = [ UnsafeRaw $ @@ -284,20 +305,21 @@ defaultStart = , UnsafeRaw "@.non_exhaustive_patterns = private unnamed_addr constant [41 x i8] c\"Non-exhaustive patterns in case at %i:%i\n\"\n" , UnsafeRaw "declare i32 @printf(ptr noalias nocapture, ...)\n" , UnsafeRaw "declare i32 @exit(i32 noundef)\n" - , UnsafeRaw "declare i32 @_ZN2GC4Heap4initEv()\n" - , UnsafeRaw "declare i32 @_ZN2GC4Heap5allocEm()\n" - , UnsafeRaw "declare i32 @_ZN2GC4Heap7disposeEv()\n" + , UnsafeRaw "declare ptr @malloc(i32 noundef)\n" + , UnsafeRaw "declare void @_ZN2GC4Heap4initEv()\n" + , UnsafeRaw "declare void @_ZN2GC4Heap5allocEm()\n" + , UnsafeRaw "declare void @_ZN2GC4Heap7disposeEv()\n" ] compileExp :: ExpT -> CompilerState () -compileExp (MIR.ELit lit,t) = emitLit lit -compileExp (MIR.EAdd e1 e2,t) = emitAdd t e1 e2 +compileExp (MIR.ELit lit, t) = emitLit lit +compileExp (MIR.EAdd e1 e2, t) = emitAdd t e1 e2 -- compileExp (ESub t e1 e2) = emitSub t e1 e2 -compileExp (MIR.EVar name, t) = emitIdent name -compileExp (MIR.EApp e1 e2,t) = emitApp t e1 e2 +compileExp (MIR.EVar name, t) = emitIdent name +compileExp (MIR.EApp e1 e2, t) = emitApp t e1 e2 -- compileExp (EAbs t ti e) = emitAbs t ti e -compileExp (MIR.ELet binds e,t) = undefined -- emitLet binds (fst e) -compileExp (MIR.ECase e cs,t) = emitECased t e (map (t,) cs) +compileExp (MIR.ELet binds e, t) = undefined -- emitLet binds (fst e) +compileExp (MIR.ECase e cs, t) = emitECased t e (map (t,) cs) -- go (EMul e1 e2) = emitMul e1 e2 -- go (EDiv e1 e2) = emitDiv e1 e2 @@ -319,7 +341,7 @@ emitECased t e cases = do -- emit $ Label crashLbl emit . UnsafeRaw $ "call i32 (ptr, ...) @printf(ptr noundef @.non_exhaustive_patterns, i64 noundef 6, i64 noundef 6)\n" emit . UnsafeRaw $ "call i32 @exit(i32 noundef 1)\n" - mapM_ (const increaseVarCount) [0..1] + mapM_ (const increaseVarCount) [0 .. 1] emit $ Br label emit $ Label label res <- getNewVar @@ -349,28 +371,28 @@ emitECased t e cases = do emit $ SetVariable casted (Load (CustomType (coerce consId)) Ptr castPtr) val <- exprToValue exp enumerateOneM_ - (\i c -> do + ( \i c -> do case c of - PVar x -> do + PVar x -> do emit . Comment $ "ident " <> show x emit $ SetVariable (fst x) (ExtractValue (CustomType (coerce consId)) (VIdent casted Ptr) i) PLit (l, t) -> undefined - PInj id ps -> undefined - PCatch -> pure() - PEnum id -> undefined - --case c of - -- CIdent x -> do - -- emit . Comment $ "ident " <> show x - -- emit $ SetVariable x (ExtractValue (CustomType (fst consId)) (VIdent casted Ptr) i) - -- emit $ Store ty val Ptr stackPtr - -- CCons x cs -> error "nested constructor" - -- CLit l -> do - -- testVar <- getNewVar - -- emit $ SetVariable testVar (ExtractValue (CustomType (fst consId)) (VIdent casted Ptr) i) - -- case l of - -- LInt l -> emit $ Icmp LLEq I64 (VIdent testVar Ptr) (VInteger l) - -- LChar c -> emit $ Icmp LLEq I8 (VIdent testVar Ptr) (VChar c) - -- CCatch -> emit . Comment $ "Catch all" + PInj id ps -> undefined + PCatch -> pure () + PEnum id -> undefined + -- case c of + -- CIdent x -> do + -- emit . Comment $ "ident " <> show x + -- emit $ SetVariable x (ExtractValue (CustomType (fst consId)) (VIdent casted Ptr) i) + -- emit $ Store ty val Ptr stackPtr + -- CCons x cs -> error "nested constructor" + -- CLit l -> do + -- testVar <- getNewVar + -- emit $ SetVariable testVar (ExtractValue (CustomType (fst consId)) (VIdent casted Ptr) i) + -- case l of + -- LInt l -> emit $ Icmp LLEq I64 (VIdent testVar Ptr) (VInteger l) + -- LChar c -> emit $ Icmp LLEq I8 (VIdent testVar Ptr) (VChar c) + -- CCatch -> emit . Comment $ "Catch all" ) cs emit $ Store ty val Ptr stackPtr @@ -379,7 +401,7 @@ emitECased t e cases = do emitCases rt ty label stackPtr vs (Branch (MIR.PLit i, _) exp) = do emit $ Comment "Plit" let i' = case i of - (MIR.LInt i, _) -> VInteger i + (MIR.LInt i, _) -> VInteger i (MIR.LChar i, _) -> VChar (ord i) ns <- getNewVar lbl_failPos <- (\x -> TIR.Ident $ "failed_" <> show x) <$> getNewLabel @@ -391,7 +413,7 @@ emitECased t e cases = do emit $ Store ty val Ptr stackPtr emit $ Br label emit $ Label lbl_failPos - emitCases rt ty label stackPtr vs (Branch (MIR.PVar (id,_), _) exp) = do + emitCases rt ty label stackPtr vs (Branch (MIR.PVar (id, _), _) exp) = do emit $ Comment "Pvar" -- //TODO this is pretty disgusting and would heavily benefit from a rewrite valPtr <- getNewVar @@ -418,7 +440,7 @@ emitECased t e cases = do lbl_failPos <- (\x -> TIR.Ident $ "failed_" <> show x) <$> getNewLabel emit $ Label lbl_failPos ---emitLet :: Bind -> Exp -> CompilerState () +-- emitLet :: Bind -> Exp -> CompilerState () emitLet xs e = do emit $ Comment $ @@ -446,8 +468,7 @@ emitApp rt e1 e2 = appEmitter e1 e2 [] let visibility = fromMaybe Local $ Global <$ Map.lookup name consts - <|> - Global <$ Map.lookup (name, t) funcs + <|> Global <$ Map.lookup (name, t) funcs -- this piece of code could probably be improved, i.e remove the double `const Global` args' = map (first valueGetType . dupe) args call = Call FastCC (type2LlvmType rt) visibility name args' @@ -466,7 +487,7 @@ emitLit :: MIR.Lit -> CompilerState () emitLit i = do -- !!this should never happen!! let (i', t) = case i of - (MIR.LInt i'') -> (VInteger i'', I64) + (MIR.LInt i'') -> (VInteger i'', I64) (MIR.LChar i'') -> (VChar $ ord i'', I8) varCount <- getNewVar emit $ Comment "This should not have happened!" @@ -489,16 +510,20 @@ emitSub t e1 e2 = do exprToValue :: ExpT -> CompilerState LLVMValue exprToValue = \case (MIR.ELit i, t) -> pure $ case i of - (MIR.LInt i) -> VInteger i + (MIR.LInt i) -> VInteger i (MIR.LChar i) -> VChar $ ord i (MIR.EVar name, t) -> do funcs <- gets functions cons <- gets constructors - let res = Map.lookup (name, t) funcs - <|> - (\c -> FunctionInfo { numArgs = numArgsCI c - , arguments = argumentsCI c} ) - <$> Map.lookup name cons + let res = + Map.lookup (name, t) funcs + <|> ( \c -> + FunctionInfo + { numArgs = numArgsCI c + , arguments = argumentsCI c + } + ) + <$> Map.lookup name cons case res of Just fi -> do if numArgs fi == 0 @@ -519,40 +544,42 @@ exprToValue = \case type2LlvmType :: MIR.Type -> LLVMType type2LlvmType (MIR.TLit id@(TIR.Ident name)) = case name of "Int" -> I64 - _ -> CustomType id -type2LlvmType (MIR.TFun t xs) = do + "Char" -> I8 + _ -> CustomType id +type2LlvmType (MIR.TFun t xs) = do let (t', xs') = function2LLVMType xs [type2LlvmType t] Function t' xs' where function2LLVMType :: Type -> [LLVMType] -> (LLVMType, [LLVMType]) function2LLVMType (TFun t xs) s = function2LLVMType xs (type2LlvmType t : s) - function2LLVMType x s = (type2LlvmType x, s) + function2LLVMType x s = (type2LlvmType x, s) getType :: ExpT -> LLVMType -getType (_, t) = type2LlvmType t +getType (_, t) = type2LlvmType t extractTypeName :: MIR.Type -> TIR.Ident extractTypeName (MIR.TLit id) = id -extractTypeName (MIR.TFun t xs) = let (TIR.Ident i) = extractTypeName t - (TIR.Ident is) = extractTypeName xs - in TIR.Ident $ i <> "_$_" <> is +extractTypeName (MIR.TFun t xs) = + let (TIR.Ident i) = extractTypeName t + (TIR.Ident is) = extractTypeName xs + in TIR.Ident $ i <> "_$_" <> is valueGetType :: LLVMValue -> LLVMType -valueGetType (VInteger _) = I64 -valueGetType (VChar _) = I8 -valueGetType (VIdent _ t) = t -valueGetType (VConstant s) = Array (fromIntegral $ length s) I8 +valueGetType (VInteger _) = I64 +valueGetType (VChar _) = I8 +valueGetType (VIdent _ t) = t +valueGetType (VConstant s) = Array (fromIntegral $ length s) I8 valueGetType (VFunction _ _ t) = t typeByteSize :: LLVMType -> Integer -typeByteSize I1 = 1 -typeByteSize I8 = 1 -typeByteSize I32 = 4 -typeByteSize I64 = 8 -typeByteSize Ptr = 8 -typeByteSize (Ref _) = 8 +typeByteSize I1 = 1 +typeByteSize I8 = 1 +typeByteSize I32 = 4 +typeByteSize I64 = 8 +typeByteSize Ptr = 8 +typeByteSize (Ref _) = 8 typeByteSize (Function _ _) = 8 -typeByteSize (Array n t) = n * typeByteSize t +typeByteSize (Array n t) = n * typeByteSize t typeByteSize (CustomType _) = 8 enumerateOneM_ :: Monad m => (Integer -> a -> m b) -> [a] -> m () diff --git a/src/Compiler.hs b/src/Compiler.hs index 180914f..a10a642 100644 --- a/src/Compiler.hs +++ b/src/Compiler.hs @@ -16,7 +16,10 @@ optimize :: String -> IO String optimize = readCreateProcess (shell "opt --O3 -S") compileClang :: String -> IO String -compileClang = readCreateProcess (shell "clang -x ir -o output/hello_world -") +compileClang = readCreateProcess . shell + $ unwords ["clang++"--, "-Lsrc/GC/lib/", "-l:libgcoll.a" + , "-fno-exceptions -x", "ir" ,"-o" ,"output/hello_world" + , "-"] compile :: String -> IO String compile s = optimize s >>= compileClang From c77139dfa8eb7921a8bc60639cc65bb8e2145a7e Mon Sep 17 00:00:00 2001 From: Samuel Hammersberg Date: Tue, 28 Mar 2023 17:47:43 +0200 Subject: [PATCH 219/372] Added a Malloc instruction. --- src/Codegen/LlvmIr.hs | 27 +++++++++++++++------------ test_program | 6 ------ test_program.crf | 13 ++++++++++++- 3 files changed, 27 insertions(+), 19 deletions(-) delete mode 100644 test_program diff --git a/src/Codegen/LlvmIr.hs b/src/Codegen/LlvmIr.hs index 5c04e11..4a309c7 100644 --- a/src/Codegen/LlvmIr.hs +++ b/src/Codegen/LlvmIr.hs @@ -11,15 +11,15 @@ module Codegen.LlvmIr ( ToIr (..), ) where -import Data.List (intercalate) -import TypeChecker.TypeCheckerIr (Ident (..)) +import Data.List (intercalate) +import TypeChecker.TypeCheckerIr (Ident (..)) data CallingConvention = TailCC | FastCC | CCC | ColdCC deriving (Show, Eq, Ord) instance ToIr CallingConvention where toIr :: CallingConvention -> String toIr TailCC = "tailcc" toIr FastCC = "fastcc" - toIr CCC = "ccc" + toIr CCC = "ccc" toIr ColdCC = "coldcc" -- | A datatype which represents some basic LLVM types @@ -80,7 +80,7 @@ instance ToIr LLVMComp where data Visibility = Local | Global deriving (Show, Eq, Ord) instance ToIr Visibility where toIr :: Visibility -> String - toIr Local = "%" + toIr Local = "%" toIr Global = "@" {- | Represents a LLVM "value", as in an integer, a register variable, @@ -97,11 +97,11 @@ data LLVMValue instance ToIr LLVMValue where toIr :: LLVMValue -> String toIr v = case v of - VInteger i -> show i - VChar i -> show i - VIdent (Ident n) _ -> "%" <> n + VInteger i -> show i + VChar i -> show i + VIdent (Ident n) _ -> "%" <> n VFunction (Ident n) vis _ -> toIr vis <> n - VConstant s -> "c" <> show s + VConstant s -> "c" <> show s type Params = [(Ident, LLVMType)] type Args = [(LLVMType, LLVMValue)] @@ -114,8 +114,7 @@ data LLVMIr | Declare LLVMType Ident Params | SetVariable Ident LLVMIr | Variable Ident - | -- extractvalue , {, }* - ExtractValue LLVMType LLVMValue Integer + | ExtractValue LLVMType LLVMValue Integer | GetElementPtr LLVMType LLVMType LLVMValue LLVMType LLVMValue LLVMType LLVMValue | GetElementPtrInbounds LLVMType LLVMType LLVMValue LLVMType LLVMValue LLVMType LLVMValue | Add LLVMType LLVMValue LLVMValue @@ -134,6 +133,7 @@ data LLVMIr | Bitcast LLVMType LLVMValue LLVMType | Ret LLVMType LLVMValue | Comment String + | Malloca Integer | UnsafeRaw String -- This should generally be avoided, and proper -- instructions should be used in its place deriving (Show, Eq, Ord) @@ -146,9 +146,9 @@ llvmIrToString = go 0 go _ [] = mempty go i (x : xs) = do let (i', n) = case x of - Define{} -> (i + 1, 0) + Define{} -> (i + 1, 0) DefineEnd -> (i - 1, 0) - _ -> (i, i) + _ -> (i, i) insToString n x <> go i' xs -- \| Converts a LLVM inststruction to a String, allowing for printing etc. @@ -223,6 +223,9 @@ llvmIrToString = go 0 , ")\n" ] (Alloca t) -> unwords ["alloca", toIr t, "\n"] + (Malloca t) -> + concat + [ "call ptr @malloc(i32 ", show t, ")"] (Store t1 val t2 (Ident id2)) -> concat [ "store ", toIr t1, " ", toIr val diff --git a/test_program b/test_program deleted file mode 100644 index 751a976..0000000 --- a/test_program +++ /dev/null @@ -1,6 +0,0 @@ -main : _Int ; -main = double 3 ; - -double : _Int -> _Int ; -double x = x + x ; - diff --git a/test_program.crf b/test_program.crf index bdce08c..64aa2e7 100644 --- a/test_program.crf +++ b/test_program.crf @@ -1,2 +1,13 @@ -main = const 1 2 ; +id x = x; + const x y = x ; + +data Maybe () where { + Just : Int -> Maybe () + Nothing : Maybe () +}; + +main = case (Just 5) of { + Just a => 10 ; + Nothing => 0 ; +}; --const (id 0) (id 'a') ; From d8a75d66437510c110c502428d7fdfbfeb929eb9 Mon Sep 17 00:00:00 2001 From: Samuel Hammersberg Date: Tue, 28 Mar 2023 17:49:47 +0200 Subject: [PATCH 220/372] =?UTF-8?q?Solved=2030+=20WARNINGS!!=20?= =?UTF-8?q?=F0=9F=98=8E?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- src/Codegen/Codegen.hs | 39 ++++++++++----------------------------- src/Compiler.hs | 29 +++++++++++++++-------------- 2 files changed, 25 insertions(+), 43 deletions(-) diff --git a/src/Codegen/Codegen.hs b/src/Codegen/Codegen.hs index ffe1f91..9827571 100644 --- a/src/Codegen/Codegen.hs +++ b/src/Codegen/Codegen.hs @@ -312,13 +312,13 @@ defaultStart = ] compileExp :: ExpT -> CompilerState () -compileExp (MIR.ELit lit, t) = emitLit lit +compileExp (MIR.ELit lit, _t) = emitLit lit compileExp (MIR.EAdd e1 e2, t) = emitAdd t e1 e2 -- compileExp (ESub t e1 e2) = emitSub t e1 e2 -compileExp (MIR.EVar name, t) = emitIdent name +compileExp (MIR.EVar name, _t) = emitIdent name compileExp (MIR.EApp e1 e2, t) = emitApp t e1 e2 -- compileExp (EAbs t ti e) = emitAbs t ti e -compileExp (MIR.ELet binds e, t) = undefined -- emitLet binds (fst e) +compileExp (MIR.ELet _binds _e, _t) = undefined -- emitLet binds (fst e) compileExp (MIR.ECase e cs, t) = emitECased t e (map (t,) cs) -- go (EMul e1 e2) = emitMul e1 e2 @@ -348,7 +348,7 @@ emitECased t e cases = do emit $ SetVariable res (Load ty Ptr stackPtr) where emitCases :: LLVMType -> LLVMType -> TIR.Ident -> TIR.Ident -> LLVMValue -> Branch -> CompilerState () - emitCases rt ty label stackPtr vs (Branch (MIR.PInj consId cs, t) exp) = do + emitCases rt ty label stackPtr vs (Branch (MIR.PInj consId cs, _t) exp) = do emit $ Comment "Inj" cons <- gets constructors let r = fromJust $ Map.lookup consId cons @@ -376,10 +376,10 @@ emitECased t e cases = do PVar x -> do emit . Comment $ "ident " <> show x emit $ SetVariable (fst x) (ExtractValue (CustomType (coerce consId)) (VIdent casted Ptr) i) - PLit (l, t) -> undefined - PInj id ps -> undefined + PLit (_l, _t) -> undefined + PInj _id _ps -> undefined PCatch -> pure () - PEnum id -> undefined + PEnum _id -> undefined -- case c of -- CIdent x -> do -- emit . Comment $ "ident " <> show x @@ -398,7 +398,7 @@ emitECased t e cases = do emit $ Store ty val Ptr stackPtr emit $ Br label emit $ Label lbl_failPos - emitCases rt ty label stackPtr vs (Branch (MIR.PLit i, _) exp) = do + emitCases _rt ty label stackPtr vs (Branch (MIR.PLit i, _) exp) = do emit $ Comment "Plit" let i' = case i of (MIR.LInt i, _) -> VInteger i @@ -425,7 +425,7 @@ emitECased t e cases = do emit $ Br label lbl_failPos <- (\x -> TIR.Ident $ "failed_" <> show x) <$> getNewLabel emit $ Label lbl_failPos - emitCases rt ty label stackPtr vs (Branch (MIR.PEnum id, _) exp) = do + emitCases _rt ty label stackPtr _vs (Branch (MIR.PEnum _id, _) exp) = do emit $ Comment "Penum" val <- exprToValue exp emit $ Store ty val Ptr stackPtr @@ -440,18 +440,6 @@ emitECased t e cases = do lbl_failPos <- (\x -> TIR.Ident $ "failed_" <> show x) <$> getNewLabel emit $ Label lbl_failPos --- emitLet :: Bind -> Exp -> CompilerState () -emitLet xs e = do - emit $ - Comment $ - concat - [ "ELet (" - , show xs - , " = " - , show e - , ") is not implemented!" - ] - emitApp :: MIR.Type -> ExpT -> ExpT -> CompilerState () emitApp rt e1 e2 = appEmitter e1 e2 [] where @@ -500,16 +488,9 @@ emitAdd t e1 e2 = do v <- getNewVar emit $ SetVariable v (Add (type2LlvmType t) v1 v2) -emitSub :: MIR.Type -> ExpT -> ExpT -> CompilerState () -emitSub t e1 e2 = do - v1 <- exprToValue e1 - v2 <- exprToValue e2 - v <- getNewVar - emit $ SetVariable v (Sub (type2LlvmType t) v1 v2) - exprToValue :: ExpT -> CompilerState LLVMValue exprToValue = \case - (MIR.ELit i, t) -> pure $ case i of + (MIR.ELit i, _t) -> pure $ case i of (MIR.LInt i) -> VInteger i (MIR.LChar i) -> VChar $ ord i (MIR.EVar name, t) -> do diff --git a/src/Compiler.hs b/src/Compiler.hs index a10a642..0b34936 100644 --- a/src/Compiler.hs +++ b/src/Compiler.hs @@ -1,25 +1,26 @@ module Compiler (compile) where -import Grammar.ErrM (Err) -import System.Exit (exitFailure, exitSuccess) -import System.IO (BufferMode (NoBuffering), hClose, hFlush, - hGetContents, hPutStr, hPutStrLn, - hSetBuffering, stderr) -import System.Process.Extra (CreateProcess (..), - StdStream (CreatePipe), createProcess, - proc, readCreateProcess, shell, - spawnCommand, waitForProcess) +import System.Process.Extra ( + readCreateProcess, + shell, + ) ---spawnWait s = spawnCommand s >>= \s >>= waitForProcess +-- spawnWait s = spawnCommand s >>= \s >>= waitForProcess optimize :: String -> IO String optimize = readCreateProcess (shell "opt --O3 -S") compileClang :: String -> IO String -compileClang = readCreateProcess . shell - $ unwords ["clang++"--, "-Lsrc/GC/lib/", "-l:libgcoll.a" - , "-fno-exceptions -x", "ir" ,"-o" ,"output/hello_world" - , "-"] +compileClang = + readCreateProcess . shell $ + unwords + [ "clang++" -- , "-Lsrc/GC/lib/", "-l:libgcoll.a" + , "-fno-exceptions -x" + , "ir" + , "-o" + , "output/hello_world" + , "-" + ] compile :: String -> IO String compile s = optimize s >>= compileClang From 9e6fe454ce8fde57a6b123a1d951f4eb690db738 Mon Sep 17 00:00:00 2001 From: sebastianselander Date: Tue, 28 Mar 2023 17:57:44 +0200 Subject: [PATCH 221/372] reverted back to most close to correct version --- src/TypeChecker/TypeCheckerHm.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/TypeChecker/TypeCheckerHm.hs b/src/TypeChecker/TypeCheckerHm.hs index 13716cd..5208e7a 100644 --- a/src/TypeChecker/TypeCheckerHm.hs +++ b/src/TypeChecker/TypeCheckerHm.hs @@ -97,8 +97,8 @@ checkBind (Bind name args e) = do s <- gets sigs case M.lookup (coerce name) s of Just (Just t') -> do - sab <- unify t' lambda_t - let fsig = apply (sab `compose` sub0) t' + -- \| TODO: Fix, this is not correct + let fsig = apply sub0 t' sub1 <- liftEither $ runIdentity $ runExceptT $ execStateT (typeEq fsig lambda_t) mempty sub2 <- liftEither $ runIdentity $ runExceptT $ execStateT (typeEq lambda_t fsig) mempty unless From 7c5041d2703df2d9fd729d8f0ab8aa500cf82e08 Mon Sep 17 00:00:00 2001 From: sebastian Date: Tue, 28 Mar 2023 21:52:09 +0200 Subject: [PATCH 222/372] added this stupid complex bug to Bugs.md --- src/TypeChecker/Bugs.md | 10 ++++++++++ 1 file changed, 10 insertions(+) diff --git a/src/TypeChecker/Bugs.md b/src/TypeChecker/Bugs.md index fb986a5..d1fd70d 100644 --- a/src/TypeChecker/Bugs.md +++ b/src/TypeChecker/Bugs.md @@ -36,3 +36,13 @@ main = case \x. x of { _ => 0; }; ``` + +# Inference should not depend on order + +This one is really tough, strangely +Spent many hours on this so far + +```hs +main = id 0 ; +id x = x; +``` From f20b80cab328fed5c1a35040f46493f0166a22a6 Mon Sep 17 00:00:00 2001 From: sebastian Date: Tue, 28 Mar 2023 23:19:04 +0200 Subject: [PATCH 223/372] added skomeliation on given type signatures --- src/TypeChecker/TypeCheckerHm.hs | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) diff --git a/src/TypeChecker/TypeCheckerHm.hs b/src/TypeChecker/TypeCheckerHm.hs index 5208e7a..3d1121e 100644 --- a/src/TypeChecker/TypeCheckerHm.hs +++ b/src/TypeChecker/TypeCheckerHm.hs @@ -66,7 +66,7 @@ preRun (x : xs) = case x of "Duplicate signatures for function" quote $ printTree n ) - insertSig (coerce n) (Just t) >> preRun xs + insertSig (coerce n) (Just $ skolemize t) >> preRun xs DBind (Bind n _ e) -> do collect (collectTVars e) s <- gets sigs @@ -538,6 +538,12 @@ fresh = do next 'z' = 'a' next a = succ a +skolemize :: Type -> Type +skolemize (TVar (MkTVar a)) = TEVar $ MkTEVar a +skolemize (TAll x t) = TAll x (skolemize t) +skolemize (TFun t1 t2) = (TFun `on` skolemize) t1 t2 +skolemize t = t + -- | A class for substitutions class SubstType t where -- | Apply a substitution to t From 528369c95ca0484f4adfcfd4650c57ba0820c7c1 Mon Sep 17 00:00:00 2001 From: Martin Fredin Date: Mon, 27 Mar 2023 23:55:04 +0200 Subject: [PATCH 224/372] Progress on new checkPattern --- src/TypeChecker/TypeCheckerBidir.hs | 130 ++++++++++++++++++++++------ 1 file changed, 105 insertions(+), 25 deletions(-) diff --git a/src/TypeChecker/TypeCheckerBidir.hs b/src/TypeChecker/TypeCheckerBidir.hs index 7cb0081..5ad5021 100644 --- a/src/TypeChecker/TypeCheckerBidir.hs +++ b/src/TypeChecker/TypeCheckerBidir.hs @@ -10,11 +10,12 @@ import Auxiliary (maybeToRightM, snoc) import Control.Applicative (Alternative, Applicative (liftA2), (<|>)) import Control.Monad.Except (ExceptT, MonadError (throwError), - runExceptT, unless, zipWithM, - zipWithM_) + liftEither, runExceptT, unless, + zipWithM, zipWithM_) import Control.Monad.State (MonadState (get, put), State, evalState, gets, modify) import Data.Coerce (coerce) +import Data.Either.Combinators (maybeToRight) import Data.Function (on) import Data.List (intercalate) import Data.Map (Map) @@ -45,11 +46,12 @@ type Env = Seq EnvElem -- | Ordered context -- Γ ::= ・| Γ, α | Γ, ά | Γ, ▶ ά | Γ, x:A data Cxt = Cxt - { env :: Env -- ^ Local scope context Γ - , sig :: Map LIdent Type -- ^ Top-level signatures x : A - , binds :: Map LIdent Exp -- ^ Top-level binds x : e - , next_tevar :: Int -- ^ Counter to distinguish ά - , data_injs :: Map UIdent Type -- ^ Data injections (constructors) K + { env :: Env -- ^ Local scope context Γ + , sig :: Map LIdent Type -- ^ Top-level signatures x : A + , binds :: Map LIdent Exp -- ^ Top-level binds x : e + , next_tevar :: Int -- ^ Counter to distinguish ά + , data_injs :: Map UIdent Type -- ^ Data injections (constructors) K/inj : A + , data_types :: Map UIdent [(UIdent, Type)] -- ^ Data types D : (K₁:A₁ + ‥ + Kₙ:Aₙ) } deriving (Show, Eq) newtype Tc a = Tc { runTc :: ExceptT String (State Cxt) a } @@ -69,16 +71,24 @@ typecheck (Program defs) = do | DBind' name vars rhs <- defs ] , next_tevar = 0 - , data_injs = Map.fromList [ (name, typ) - | Data _ injs <- datatypes - , Inj name typ <- injs - ] + , data_injs = Map.fromList [ (name, foldr ($) typ $ getForallsData typ) + | Data _ injs <- datatypes + , Inj name typ <- injs + ] + , data_types = Map.fromList [ let + TData name _ = getTData typ + kts = [(k,t) | Inj k t <- injs ] + in + (name, kts) + | Data typ injs <- datatypes + ] } binds' <- evalState (runExceptT (runTc $ mapM typecheckBind binds)) initCxt; pure . T.Program $ map T.DData (coerceData datatypes) ++ map T.DBind binds' where binds = [ b | DBind b <- defs ] + -- TODO this should happen in typecheckDataType coerceData = map (\(Data t injs) -> T.Data t $ map (\(Inj name typ) -> T.Inj (coerce name) typ) injs) @@ -138,8 +148,8 @@ typecheckInj (Inj inj_name inj_typ) name tvars | TData name' typs <- getReturn inj_typ , name' == name , Right tvars' <- mapM toTVar typs - , tvars' == tvars - = pure (Inj inj_name $ foldr TAll inj_typ tvars) + , all (`elem` tvars) tvars' + = pure (Inj inj_name inj_typ) | otherwise = throwError $ unwords ["Bad type constructor: ", show name @@ -216,6 +226,7 @@ subtype t1 t2 = case (t1, t2) of -- Γ[ά] ⊢ A <: ά ⊣ Δ (typ, TEVar tevar) | notElem tevar $ frees typ -> instantiateR typ tevar + (TData name1 typs1, TData name2 typs2) -- D₁ = D₂ @@ -542,33 +553,82 @@ checkBranch (Branch patt exp) t_patt t_exp = do pure (T.Branch patt' (exp, t_exp)) checkPattern :: Pattern -> Type -> Tc (T.Pattern' Type, Type) -checkPattern patt t_patt = case patt of +checkPattern patt t_patt = (, t_patt) <$> case patt of PVar x -> do insertEnv $ EnvVar x t_patt - pure (T.PVar (coerce x, dummy), dummy) -- TODO - PCatch -> pure (T.PCatch, dummy) -- TODO - PLit lit | inferLit lit == t_patt -> let - t = inferLit lit - in - pure (T.PLit (lit, t), t) + pure $ T.PVar (coerce x, t_patt) + PCatch -> pure T.PCatch + PLit lit | inferLit lit == t_patt -> pure $ T.PLit (lit, t_patt) | otherwise -> throwError "Literal in pattern have wrong type" PEnum name -> do t <- maybeToRightM ("Unknown constructor " ++ show name) =<< lookupInj name subtype t t_patt - pure (T.PEnum (coerce name), dummy) -- TODO + pure $ T.PEnum (coerce name) + + + -- Θ₁ ⊢ p₁ ↑ [Θ₁]B₁ ⊣ Θ₂ + -- Γ ⊢ (xₖ : B₁ → ‥ → Bₘ₊₁) ∈ Γ ... + -- Γ ⊢ B₁ → ‥ → Bₘ₊₁ <: A₁ + ‥ + Aₙ ⊣ Θ₁ Θₘ ⊢ pₘ ↑ [Θₘ₋₁]Bₘ ⊣ Δ + -- -------------------------------------------------------------- + -- Γ ⊢ injₖ xₖ. p₁ ‥ pₘ ↑ A₁ + ‥ + Aₙ ⊣ Δ PInj name ps -> do t <- maybeToRightM ("Unknown constructor " ++ show name) =<< lookupInj name + subtype t t_patt + + let (t_ps, t_return) = partitionTypeWithForall t unless (length ps == length t_ps) $ throwError "Wrong number of variables" - subtype t_return t_patt - ps' <- zipWithM (\p t -> checkPattern p =<< applyEnv t) ps t_ps - let ps'' = map fst ps' -- TODO - pure (T.PInj (coerce name) ps'', dummy) + + -- §ps' <- zipWithM (\p t -> checkPattern p =<< applyEnv t) ps t_ps + -- let ps'' = map fst ps' -- TODO + pure $ T.PInj (coerce name) [] + +subtypeData :: UIdent -> Type -> Tc () +subtypeData name_inj typ = do + injs <- maybeToRightM err1 =<< lookupDataType name_d + t_inj <- liftEither . maybeToRight err2 $ lookup name_k injs + (t_inj', typs')<- substituteTVars foralls t_inj data_t + subtype () + + undefined + where + substituteTVars fas t1 t2 = case fas of + [] -> pure (t1, t2) + fa:fas' -> do + (t1', t2') <- go fa (t1, t2) + substituteTVars fas' t1' t2' + where + go fa (t1, t2) = let TAll tvar _ = fa dummy in do + tevar <- fresh + insertEnv (EnvTEVar tevar) + pure $ on (,) (substitute tvar tevar) t1 t2 + + + + (foralls, data_t@(TData name_d typs)) = partitionData typ + err1 = unwords ["Unknown data type", show name_d] + err2 = unwords ["No", show name_k, "constructor for data type", show name_d] + + -- TAll tvar t -> do + -- tevar <- fresh + -- let -- env_marker = EnvMark tevar + -- env_tevar = EnvTEVar tevar + -- -- insertEnv env_marker + -- insertEnv env_tevar + -- let a' = substitute tvar tevar a + -- subtype a' b + -- -- dropTrailing env_marker + + -- TData name_d typs -> do + -- + -- subtype t_k typ + -- undefined + -- where --------------------------------------------------------------------------- -- * Auxiliary @@ -725,6 +785,7 @@ getReturn = snd . partitionType -- ([a, ∀c. c → c], b) -- -- Unsure if foralls should be added to the return type or not. +-- FIXME partitionType :: Type -> ([Type], Type) partitionType = go [] . skipForalls' where @@ -743,6 +804,22 @@ skipForalls = go [] TAll tvar t -> go (snoc (TAll tvar) acc) t _ -> (acc, typ) + +getForallsData :: Type -> [Type -> Type] +getForallsData = fst . partitionData + +getTData :: Type -> Type +getTData = snd . partitionData + +partitionData :: Type -> ([Type -> Type], Type) +partitionData = go . ([],) + where + go (acc, typ) = case typ of + TAll tvar t -> go (snoc (TAll tvar) acc, t) + TData {} -> (acc, typ) + _ -> error "Bad data type" + + partitionTypeWithForall :: Type -> ([Type], Type) partitionTypeWithForall typ = (t_vars', t_return') where @@ -798,6 +875,9 @@ insertEnv x = modifyEnv (:|> x) lookupBind :: LIdent -> Tc (Maybe Exp) lookupBind x = gets (Map.lookup x . binds) +lookupDataType :: UIdent -> Tc (Maybe [(UIdent, Type)]) +lookupDataType x = gets (Map.lookup x . data_types) + lookupSig :: LIdent -> Tc (Maybe Type) lookupSig x = gets (Map.lookup x . sig) From 133cc31e77d67677ae0454e6dff528f2da9eb1d7 Mon Sep 17 00:00:00 2001 From: Martin Fredin Date: Tue, 28 Mar 2023 14:36:43 +0200 Subject: [PATCH 225/372] Fix lambda lifter --- sample-programs/basic-0 | 4 +- sample-programs/basic-6.crf | 8 +-- src/TypeChecker/TypeCheckerBidir.hs | 78 +++++++++++++---------------- 3 files changed, 42 insertions(+), 48 deletions(-) diff --git a/sample-programs/basic-0 b/sample-programs/basic-0 index 4738fb6..5084527 100644 --- a/sample-programs/basic-0 +++ b/sample-programs/basic-0 @@ -5,7 +5,7 @@ data forall a. List (a) where { length : forall c. List (c) -> Int; length = \list. case list of { - Nil => 0; Cons x xs => 1 + length xs; - Cons x (Cons y Nil) => 2; +-- Nil => 0; +-- Cons x (Cons y Nil) => 2; }; diff --git a/sample-programs/basic-6.crf b/sample-programs/basic-6.crf index 3ed64a0..082cc6b 100644 --- a/sample-programs/basic-6.crf +++ b/sample-programs/basic-6.crf @@ -3,8 +3,8 @@ data Bool () where { False : Bool () }; -main : Bool () -> Int ; +main : Bool () -> a -> Int ; main b = case b of { - False => 0; - True => 0 -} + False => (\x. 1); + True => \x. 0; +}; diff --git a/src/TypeChecker/TypeCheckerBidir.hs b/src/TypeChecker/TypeCheckerBidir.hs index 5ad5021..78afe7c 100644 --- a/src/TypeChecker/TypeCheckerBidir.hs +++ b/src/TypeChecker/TypeCheckerBidir.hs @@ -46,12 +46,12 @@ type Env = Seq EnvElem -- | Ordered context -- Γ ::= ・| Γ, α | Γ, ά | Γ, ▶ ά | Γ, x:A data Cxt = Cxt - { env :: Env -- ^ Local scope context Γ - , sig :: Map LIdent Type -- ^ Top-level signatures x : A - , binds :: Map LIdent Exp -- ^ Top-level binds x : e - , next_tevar :: Int -- ^ Counter to distinguish ά - , data_injs :: Map UIdent Type -- ^ Data injections (constructors) K/inj : A - , data_types :: Map UIdent [(UIdent, Type)] -- ^ Data types D : (K₁:A₁ + ‥ + Kₙ:Aₙ) + { env :: Env -- ^ Local scope context Γ + , sig :: Map LIdent Type -- ^ Top-level signatures x : A + , binds :: Map LIdent Exp -- ^ Top-level binds x : e + , next_tevar :: Int -- ^ Counter to distinguish ά + , data_injs :: Map UIdent Type -- ^ Data injections (constructors) K/inj : A + , data_types :: Map UIdent (Type, [(UIdent, Type)]) -- ^ Data types (∀α. D (α), K₁:A₁ + ‥ + Kₙ:Aₙ) } deriving (Show, Eq) newtype Tc a = Tc { runTc :: ExceptT String (State Cxt) a } @@ -79,7 +79,7 @@ typecheck (Program defs) = do TData name _ = getTData typ kts = [(k,t) | Inj k t <- injs ] in - (name, kts) + (name, (typ, kts)) | Data typ injs <- datatypes ] } @@ -574,45 +574,39 @@ checkPattern patt t_patt = (, t_patt) <$> case patt of -- Γ ⊢ B₁ → ‥ → Bₘ₊₁ <: A₁ + ‥ + Aₙ ⊣ Θ₁ Θₘ ⊢ pₘ ↑ [Θₘ₋₁]Bₘ ⊣ Δ -- -------------------------------------------------------------- -- Γ ⊢ injₖ xₖ. p₁ ‥ pₘ ↑ A₁ + ‥ + Aₙ ⊣ Δ - PInj name ps -> do - t <- maybeToRightM ("Unknown constructor " ++ show name) - =<< lookupInj name - subtype t t_patt + PInj name ps -> undefined + -- injs <- maybeToRightM err1 =<< lookupDataType name_d + -- tinj <- liftEither . maybeToRight err2 $ lookup name injs + -- trace (show $ length foralls) pure () + -- (tinj', tdata) <- substituteTVars foralls tinj tdata + -- traceT "tinj'" tinj' + -- traceT "tdata" tdata + -- subtype (getTData $ getReturn tinj') tdata + -- t_inj'' <- applyEnv tinj' + -- tdata' <- applyEnv tdata + -- pure $ T.PInj (coerce name) [] + where + substituteTVars fas t1 t2 = case fas of + [] -> pure (t1, t2) + fa:fas' -> do + (t1', t2') <- go fa (t1, t2) + substituteTVars fas' t1' t2' + where + go fa (t1, t2) = let TAll tvar _ = fa dummy in do + tevar <- fresh + insertEnv (EnvTEVar tevar) + traceT "tevar:" (TEVar tevar) + pure $ on (,) (substitute tvar tevar) t1 t2 + (foralls, tdata@(TData name_d _)) = partitionData t_patt + err1 = unwords ["Unknown data type", show name_d] + err2 = unwords ["No", show name, "constructor for data type", show name_d] - let (t_ps, t_return) = partitionTypeWithForall t - unless (length ps == length t_ps) $ - throwError "Wrong number of variables" -- §ps' <- zipWithM (\p t -> checkPattern p =<< applyEnv t) ps t_ps -- let ps'' = map fst ps' -- TODO - pure $ T.PInj (coerce name) [] + -- pure $ T.PInj (coerce name) [] -subtypeData :: UIdent -> Type -> Tc () -subtypeData name_inj typ = do - injs <- maybeToRightM err1 =<< lookupDataType name_d - t_inj <- liftEither . maybeToRight err2 $ lookup name_k injs - (t_inj', typs')<- substituteTVars foralls t_inj data_t - subtype () - - undefined - where - substituteTVars fas t1 t2 = case fas of - [] -> pure (t1, t2) - fa:fas' -> do - (t1', t2') <- go fa (t1, t2) - substituteTVars fas' t1' t2' - where - go fa (t1, t2) = let TAll tvar _ = fa dummy in do - tevar <- fresh - insertEnv (EnvTEVar tevar) - pure $ on (,) (substitute tvar tevar) t1 t2 - - - - (foralls, data_t@(TData name_d typs)) = partitionData typ - err1 = unwords ["Unknown data type", show name_d] - err2 = unwords ["No", show name_k, "constructor for data type", show name_d] -- TAll tvar t -> do -- tevar <- fresh @@ -875,7 +869,7 @@ insertEnv x = modifyEnv (:|> x) lookupBind :: LIdent -> Tc (Maybe Exp) lookupBind x = gets (Map.lookup x . binds) -lookupDataType :: UIdent -> Tc (Maybe [(UIdent, Type)]) +lookupDataType :: UIdent -> Tc (Maybe (Type, [(UIdent, Type)])) lookupDataType x = gets (Map.lookup x . data_types) lookupSig :: LIdent -> Tc (Maybe Type) @@ -897,7 +891,7 @@ putEnv = modifyEnv . const modifyEnv :: (Env -> Env) -> Tc () modifyEnv f = - modify $ \cxt -> {- trace (ppEnv (f cxt.env)) -} cxt { env = f cxt.env } + modify $ \cxt -> trace (ppEnv (f cxt.env)) cxt { env = f cxt.env } pattern DBind' name vars exp = DBind (Bind name vars exp) pattern DSig' name typ = DSig (Sig name typ) From 76b1c55065cd9f62c782595edf1792af6c5384ec Mon Sep 17 00:00:00 2001 From: Martin Fredin Date: Tue, 28 Mar 2023 15:33:03 +0200 Subject: [PATCH 226/372] Progress --- sample-programs/basic-0 | 7 +++++- src/TypeChecker/TypeCheckerBidir.hs | 33 +++++++++++++++++------------ 2 files changed, 25 insertions(+), 15 deletions(-) diff --git a/sample-programs/basic-0 b/sample-programs/basic-0 index 5084527..7506d04 100644 --- a/sample-programs/basic-0 +++ b/sample-programs/basic-0 @@ -3,9 +3,14 @@ data forall a. List (a) where { Cons : a -> List (a) -> List (a) }; -length : forall c. List (c) -> Int; +length : List (Int) -> Int; length = \list. case list of { Cons x xs => 1 + length xs; -- Nil => 0; -- Cons x (Cons y Nil) => 2; }; + + + + + diff --git a/src/TypeChecker/TypeCheckerBidir.hs b/src/TypeChecker/TypeCheckerBidir.hs index 78afe7c..f82ef6d 100644 --- a/src/TypeChecker/TypeCheckerBidir.hs +++ b/src/TypeChecker/TypeCheckerBidir.hs @@ -246,6 +246,8 @@ subtype t1 t2 = case (t1, t2) of , t1:t1s <- typs1 , t2:t2s <- typs2 -> do + traceT "t1" (TData name1 typs1) + traceT "t2" (TData name2 typs2) subtype t1 t2 zipWithM_ go t1s t2s where @@ -574,17 +576,21 @@ checkPattern patt t_patt = (, t_patt) <$> case patt of -- Γ ⊢ B₁ → ‥ → Bₘ₊₁ <: A₁ + ‥ + Aₙ ⊣ Θ₁ Θₘ ⊢ pₘ ↑ [Θₘ₋₁]Bₘ ⊣ Δ -- -------------------------------------------------------------- -- Γ ⊢ injₖ xₖ. p₁ ‥ pₘ ↑ A₁ + ‥ + Aₙ ⊣ Δ - PInj name ps -> undefined - -- injs <- maybeToRightM err1 =<< lookupDataType name_d - -- tinj <- liftEither . maybeToRight err2 $ lookup name injs - -- trace (show $ length foralls) pure () - -- (tinj', tdata) <- substituteTVars foralls tinj tdata - -- traceT "tinj'" tinj' - -- traceT "tdata" tdata - -- subtype (getTData $ getReturn tinj') tdata - -- t_inj'' <- applyEnv tinj' - -- tdata' <- applyEnv tdata - -- pure $ T.PInj (coerce name) [] + PInj name ps -> do + traceT "t_patt :" t_patt + (tdata, injs) <- maybeToRightM err1 =<< lookupDataType name_d + tinj <- liftEither . maybeToRight err2 $ lookup name injs + let foralls = getForallsData tdata + (tinj', tdata) <- substituteTVars foralls tinj tdata + let t = getTData $ getReturn tinj' + traceT "t :" t + let super = getTData tdata + traceT "super" super + subtype t super + t_inj'' <- applyEnv tinj' + tdata' <- applyEnv tdata + pure $ T.PInj (coerce name) [] + -- §ps' <- zipWithM (\p t -> checkPattern p =<< applyEnv t) ps t_ps where substituteTVars fas t1 t2 = case fas of [] -> pure (t1, t2) @@ -595,10 +601,9 @@ checkPattern patt t_patt = (, t_patt) <$> case patt of go fa (t1, t2) = let TAll tvar _ = fa dummy in do tevar <- fresh insertEnv (EnvTEVar tevar) - traceT "tevar:" (TEVar tevar) pure $ on (,) (substitute tvar tevar) t1 t2 - (foralls, tdata@(TData name_d _)) = partitionData t_patt + TData name_d _ = getTData t_patt err1 = unwords ["Unknown data type", show name_d] err2 = unwords ["No", show name, "constructor for data type", show name_d] @@ -904,7 +909,7 @@ dummy = TLit "Int" traceEnv s = do env <- gets env - trace (s ++ " " ++ show env) pure () + trace (s ++ " " ++ ppEnv env) pure () traceD s x = trace (s ++ " " ++ show x) pure () From 52db1943bb6d6a422df9ecfeb35648acff790ded Mon Sep 17 00:00:00 2001 From: Martin Fredin Date: Wed, 29 Mar 2023 11:12:33 +0200 Subject: [PATCH 227/372] Finished new check pattern --- sample-programs/basic-0 | 2 +- src/TypeChecker/TypeCheckerBidir.hs | 110 +++++++++++----------------- 2 files changed, 42 insertions(+), 70 deletions(-) diff --git a/sample-programs/basic-0 b/sample-programs/basic-0 index 7506d04..88e4071 100644 --- a/sample-programs/basic-0 +++ b/sample-programs/basic-0 @@ -3,7 +3,7 @@ data forall a. List (a) where { Cons : a -> List (a) -> List (a) }; -length : List (Int) -> Int; +length : forall c. List (List (c)) -> Int; length = \list. case list of { Cons x xs => 1 + length xs; -- Nil => 0; diff --git a/src/TypeChecker/TypeCheckerBidir.hs b/src/TypeChecker/TypeCheckerBidir.hs index f82ef6d..9455851 100644 --- a/src/TypeChecker/TypeCheckerBidir.hs +++ b/src/TypeChecker/TypeCheckerBidir.hs @@ -10,12 +10,12 @@ import Auxiliary (maybeToRightM, snoc) import Control.Applicative (Alternative, Applicative (liftA2), (<|>)) import Control.Monad.Except (ExceptT, MonadError (throwError), - liftEither, runExceptT, unless, - zipWithM, zipWithM_) + runExceptT, unless, zipWithM, + zipWithM_) import Control.Monad.State (MonadState (get, put), State, evalState, gets, modify) import Data.Coerce (coerce) -import Data.Either.Combinators (maybeToRight) +import Data.Foldable (foldrM) import Data.Function (on) import Data.List (intercalate) import Data.Map (Map) @@ -33,6 +33,11 @@ import qualified TypeChecker.TypeCheckerIr as T -- Implementation is derived from the paper (Dunfield and Krishnaswami 2013) -- https://doi.org/10.1145/2500365.2500582 +-- +-- TODO +-- • Fix problems with types in Pattern/Branch in TypeCheckerIr +-- • Use applyEnvExp consistently +-- • Fix the different type getters functions (e.g. partitionType) functions data EnvElem = EnvVar LIdent Type -- ^ Term variable typing. x : A | EnvTVar TVar -- ^ Universal type variable. α @@ -51,7 +56,6 @@ data Cxt = Cxt , binds :: Map LIdent Exp -- ^ Top-level binds x : e , next_tevar :: Int -- ^ Counter to distinguish ά , data_injs :: Map UIdent Type -- ^ Data injections (constructors) K/inj : A - , data_types :: Map UIdent (Type, [(UIdent, Type)]) -- ^ Data types (∀α. D (α), K₁:A₁ + ‥ + Kₙ:Aₙ) } deriving (Show, Eq) newtype Tc a = Tc { runTc :: ExceptT String (State Cxt) a } @@ -71,17 +75,10 @@ typecheck (Program defs) = do | DBind' name vars rhs <- defs ] , next_tevar = 0 - , data_injs = Map.fromList [ (name, foldr ($) typ $ getForallsData typ) + , data_injs = Map.fromList [ (name, t) | Data _ injs <- datatypes - , Inj name typ <- injs + , Inj name t <- injs ] - , data_types = Map.fromList [ let - TData name _ = getTData typ - kts = [(k,t) | Inj k t <- injs ] - in - (name, (typ, kts)) - | Data typ injs <- datatypes - ] } binds' <- evalState (runExceptT (runTc $ mapM typecheckBind binds)) initCxt; @@ -149,7 +146,7 @@ typecheckInj (Inj inj_name inj_typ) name tvars , name' == name , Right tvars' <- mapM toTVar typs , all (`elem` tvars) tvars' - = pure (Inj inj_name inj_typ) + = pure (Inj inj_name $ foldr TAll inj_typ tvars') | otherwise = throwError $ unwords ["Bad type constructor: ", show name @@ -559,7 +556,9 @@ checkPattern patt t_patt = (, t_patt) <$> case patt of PVar x -> do insertEnv $ EnvVar x t_patt pure $ T.PVar (coerce x, t_patt) + PCatch -> pure T.PCatch + PLit lit | inferLit lit == t_patt -> pure $ T.PLit (lit, t_patt) | otherwise -> throwError "Literal in pattern have wrong type" @@ -570,64 +569,39 @@ checkPattern patt t_patt = (, t_patt) <$> case patt of pure $ T.PEnum (coerce name) - - -- Θ₁ ⊢ p₁ ↑ [Θ₁]B₁ ⊣ Θ₂ - -- Γ ⊢ (xₖ : B₁ → ‥ → Bₘ₊₁) ∈ Γ ... - -- Γ ⊢ B₁ → ‥ → Bₘ₊₁ <: A₁ + ‥ + Aₙ ⊣ Θ₁ Θₘ ⊢ pₘ ↑ [Θₘ₋₁]Bₘ ⊣ Δ - -- -------------------------------------------------------------- - -- Γ ⊢ injₖ xₖ. p₁ ‥ pₘ ↑ A₁ + ‥ + Aₙ ⊣ Δ PInj name ps -> do - traceT "t_patt :" t_patt - (tdata, injs) <- maybeToRightM err1 =<< lookupDataType name_d - tinj <- liftEither . maybeToRight err2 $ lookup name injs - let foralls = getForallsData tdata - (tinj', tdata) <- substituteTVars foralls tinj tdata - let t = getTData $ getReturn tinj' - traceT "t :" t - let super = getTData tdata - traceT "super" super - subtype t super - t_inj'' <- applyEnv tinj' - tdata' <- applyEnv tdata - pure $ T.PInj (coerce name) [] - -- §ps' <- zipWithM (\p t -> checkPattern p =<< applyEnv t) ps t_ps + t_inj <- maybeToRightM "unknown constructor" =<< lookupInj name + t_inj' <- foldrM substitute' t_inj $ getInitForalls t_inj + subtype (getDataId t_inj') t_patt + t_inj'' <- applyEnv t_inj' + let ts_inj = getParams t_inj'' + ps' <- zipWithM (\p t -> checkPattern p =<< applyEnv t) ps ts_inj + pure $ T.PInj (coerce name) (map fst ps') where - substituteTVars fas t1 t2 = case fas of - [] -> pure (t1, t2) - fa:fas' -> do - (t1', t2') <- go fa (t1, t2) - substituteTVars fas' t1' t2' + substitute' fa t = do + tevar <- fresh + pure $ substitute tvar tevar t where - go fa (t1, t2) = let TAll tvar _ = fa dummy in do - tevar <- fresh - insertEnv (EnvTEVar tevar) - pure $ on (,) (substitute tvar tevar) t1 t2 + TAll tvar _ = fa dummy - TData name_d _ = getTData t_patt - err1 = unwords ["Unknown data type", show name_d] - err2 = unwords ["No", show name, "constructor for data type", show name_d] + getParams = \case + TAll _ t -> getParams t + t -> go [] t + where + go acc = \case + TFun t1 t2 -> go (snoc t1 acc) t2 + _ -> acc + getDataId typ = case typ of + TAll _ t -> getDataId t + TFun _ t -> getDataId t + TData {} -> typ - -- §ps' <- zipWithM (\p t -> checkPattern p =<< applyEnv t) ps t_ps - -- let ps'' = map fst ps' -- TODO - -- pure $ T.PInj (coerce name) [] - - - -- TAll tvar t -> do - -- tevar <- fresh - -- let -- env_marker = EnvMark tevar - -- env_tevar = EnvTEVar tevar - -- -- insertEnv env_marker - -- insertEnv env_tevar - -- let a' = substitute tvar tevar a - -- subtype a' b - -- -- dropTrailing env_marker - - -- TData name_d typs -> do - -- - -- subtype t_k typ - -- undefined - -- where + getInitForalls = go [] + where + go acc = \case + TAll tvar t -> go (snoc (TAll tvar) acc) t + _ -> acc --------------------------------------------------------------------------- -- * Auxiliary @@ -816,6 +790,7 @@ partitionData = go . ([],) go (acc, typ) = case typ of TAll tvar t -> go (snoc (TAll tvar) acc, t) TData {} -> (acc, typ) + TFun _ t -> go (acc, t) _ -> error "Bad data type" @@ -874,9 +849,6 @@ insertEnv x = modifyEnv (:|> x) lookupBind :: LIdent -> Tc (Maybe Exp) lookupBind x = gets (Map.lookup x . binds) -lookupDataType :: UIdent -> Tc (Maybe (Type, [(UIdent, Type)])) -lookupDataType x = gets (Map.lookup x . data_types) - lookupSig :: LIdent -> Tc (Maybe Type) lookupSig x = gets (Map.lookup x . sig) From 4755f434fd5290f562d9c303b6e08da21ded13b4 Mon Sep 17 00:00:00 2001 From: Martin Fredin Date: Wed, 29 Mar 2023 11:25:45 +0200 Subject: [PATCH 228/372] Add test for pattern matching on recursive data types, and remove traces --- src/TypeChecker/TypeCheckerBidir.hs | 4 +- tests/TestTypeCheckerBidir.hs | 61 +++++++++++++++++++++++------ 2 files changed, 49 insertions(+), 16 deletions(-) diff --git a/src/TypeChecker/TypeCheckerBidir.hs b/src/TypeChecker/TypeCheckerBidir.hs index 9455851..9e1e12f 100644 --- a/src/TypeChecker/TypeCheckerBidir.hs +++ b/src/TypeChecker/TypeCheckerBidir.hs @@ -243,8 +243,6 @@ subtype t1 t2 = case (t1, t2) of , t1:t1s <- typs1 , t2:t2s <- typs2 -> do - traceT "t1" (TData name1 typs1) - traceT "t2" (TData name2 typs2) subtype t1 t2 zipWithM_ go t1s t2s where @@ -868,7 +866,7 @@ putEnv = modifyEnv . const modifyEnv :: (Env -> Env) -> Tc () modifyEnv f = - modify $ \cxt -> trace (ppEnv (f cxt.env)) cxt { env = f cxt.env } + modify $ \cxt -> {- trace (ppEnv (f cxt.env)) -} cxt { env = f cxt.env } pattern DBind' name vars exp = DBind (Bind name vars exp) pattern DSig' name typ = DSig (Sig name typ) diff --git a/tests/TestTypeCheckerBidir.hs b/tests/TestTypeCheckerBidir.hs index 1aaaf62..48bf230 100644 --- a/tests/TestTypeCheckerBidir.hs +++ b/tests/TestTypeCheckerBidir.hs @@ -1,20 +1,23 @@ -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE PatternSynonyms #-} {-# HLINT ignore "Use camelCase" #-} {-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} -module TestTypeCheckerBidir (testTypeCheckerBidir) where +module TestTypeCheckerBidir (test, testTypeCheckerBidir) where -import Test.Hspec +import Test.Hspec -import Control.Monad ((<=<)) -import Grammar.ErrM (Err, pattern Bad, pattern Ok) -import Grammar.Par (myLexer, pProgram) -import Renamer.Renamer (rename) -import TypeChecker.RemoveTEVar (RemoveTEVar (rmTEVar)) -import TypeChecker.TypeCheckerBidir (typecheck) -import TypeChecker.TypeCheckerIr qualified as T +import Control.Monad ((<=<)) +import Grammar.ErrM (Err, pattern Bad, pattern Ok) +import Grammar.Par (myLexer, pProgram) +import Renamer.Renamer (rename) +import TypeChecker.RemoveTEVar (RemoveTEVar (rmTEVar)) +import TypeChecker.TypeCheckerBidir (typecheck) +import qualified TypeChecker.TypeCheckerIr as T + + +test = hspec testTypeCheckerBidir testTypeCheckerBidir = describe "Bidirectional type checker test" $ do tc_id @@ -176,17 +179,23 @@ tc_mono_case = describe "Monomorphic pattern matching" $ do , "};" ] -tc_pol_case = describe "Polymophic pattern matching" $ do +tc_pol_case = describe "Polymophic and recursive pattern matching" $ do specify "First wrong case expression rejected" $ run (fs ++ wrong1) `shouldNotSatisfy` ok specify "Second wrong case expression rejected" $ run (fs ++ wrong2) `shouldNotSatisfy` ok specify "Third wrong case expression rejected" $ run (fs ++ wrong3) `shouldNotSatisfy` ok + specify "Forth wrong case expression rejected" $ + run (fs ++ wrong4) `shouldNotSatisfy` ok specify "First correct case expression accepted" $ run (fs ++ correct1) `shouldSatisfy` ok specify "Second correct case expression accepted" $ run (fs ++ correct2) `shouldSatisfy` ok + specify "Third correct case expression accepted" $ + run (fs ++ correct3) `shouldSatisfy` ok + specify "Forth correct case expression accepted" $ + run (fs ++ correct4) `shouldSatisfy` ok where fs = [ "data forall a. List (a) where {" @@ -215,6 +224,15 @@ tc_pol_case = describe "Polymophic pattern matching" $ do , " Cons x xs => 1 + length xs;" , "};" ] + wrong4 = + [ "elems : forall c. List (List(c)) -> Int;" + , "elems = \\list. case list of {" + , " Nil => 0;" + , " Cons Nil Nil => 0;" + , " Cons Nil xs => elems xs;" + , " Cons (Cons Nil ys) xs => 1 + elems (Cons ys xs);" + , "};" + ] correct1 = [ "length : forall c. List (c) -> Int;" , "length = \\list. case list of {" @@ -230,10 +248,27 @@ tc_pol_case = describe "Polymophic pattern matching" $ do , " non_empty => 1;" , "};" ] + correct3 = + [ "length : List (Int) -> Int;" + , "length = \\list. case list of {" + , " Nil => 0;" + , " Cons 1 Nil => 1;" + , " Cons x (Cons 2 xs) => 2 + length xs;" + , "};" + ] + correct4 = + [ "elems : forall c. List (List(c)) -> Int;" + , "elems = \\list. case list of {" + , " Nil => 0;" + , " Cons Nil Nil => 0;" + , " Cons Nil xs => elems xs;" + , " Cons (Cons _ ys) xs => 1 + elems (Cons ys xs);" + , "};" + ] run :: [String] -> Err T.Program run = rmTEVar <=< typecheck <=< pProgram . myLexer . unlines ok = \case - Ok _ -> True + Ok _ -> True Bad _ -> False From 2860d47f11cfcadca8a47c611a09a2d671f49e3b Mon Sep 17 00:00:00 2001 From: Rakarake Date: Wed, 29 Mar 2023 13:48:00 +0200 Subject: [PATCH 229/372] Case expressions implemented in monomorphizer --- src/Monomorphizer/Monomorphizer.hs | 31 +++++++++++++++++++++++------- 1 file changed, 24 insertions(+), 7 deletions(-) diff --git a/src/Monomorphizer/Monomorphizer.hs b/src/Monomorphizer/Monomorphizer.hs index 317ecf6..40dc901 100644 --- a/src/Monomorphizer/Monomorphizer.hs +++ b/src/Monomorphizer/Monomorphizer.hs @@ -180,12 +180,11 @@ morphExp expectedType exp = case exp of T.EAbs ident (exp, t) -> local (\env -> env { locals = Set.insert ident (locals env) }) $ do t' <- getMonoFromPoly t morphExp t' exp --- T.ECase (exp, t) bs -> do --- t' <- getMonoFromPoly t --- exp' <- morphExp t' exp --- return M.ECase (exp', t') ---data Branch' t = Branch (Pattern' t, t) (ExpT' t) --- deriving (C.Eq, C.Ord, C.Show, C.Read) + T.ECase (exp, t) bs -> do + t' <- getMonoFromPoly t + exp' <- morphExp t' exp + bs' <- mapM morphBranch bs + return $ M.ECase (exp', t') bs' T.EVar ident@(Ident str) -> do isLocal <- localExists ident if isLocal then do @@ -202,7 +201,25 @@ morphExp expectedType exp = case exp of T.ELet (T.Bind {}) _ -> error "lets not possible yet" - _ -> error "Not implemented yet" +-- Morphing case-of +morphBranch :: T.Branch -> EnvM M.Branch +morphBranch (T.Branch (p, pt) (e, et)) = do + pt' <- getMonoFromPoly pt + et' <- getMonoFromPoly et + e' <- morphExp et' e + p' <- morphPattern p + return $ M.Branch (p', pt') (e', et') + +morphPattern :: T.Pattern -> EnvM M.Pattern +morphPattern = \case + T.PVar (ident, t) -> do t' <- getMonoFromPoly t + return $ M.PVar (ident, t') + T.PLit (lit, t) -> do t' <- getMonoFromPoly t + return $ M.PLit (convertLit lit, t') + T.PCatch -> return M.PCatch + T.PEnum v -> return $ M.PEnum v + T.PInj ident ps -> do ps' <- mapM morphPattern ps + return $ M.PInj ident ps' -- Creates a new identifier for a function with an assigned type newName :: M.Type -> T.Bind -> Ident From 100b7b113a271192e14054da9dc558dd49531331 Mon Sep 17 00:00:00 2001 From: Samuel Hammersberg Date: Wed, 29 Mar 2023 14:31:24 +0200 Subject: [PATCH 230/372] We got pattern matching on data types! --- src/Codegen/Codegen.hs | 63 +++++++++++++++++++++++------------------- src/Codegen/LlvmIr.hs | 2 +- test_program.crf | 33 ++++++++++++++-------- 3 files changed, 58 insertions(+), 40 deletions(-) diff --git a/src/Codegen/Codegen.hs b/src/Codegen/Codegen.hs index 9827571..6cb510d 100644 --- a/src/Codegen/Codegen.hs +++ b/src/Codegen/Codegen.hs @@ -20,8 +20,6 @@ import Data.Coerce (coerce) import Data.Map (Map) import Data.Map qualified as Map import Data.Maybe (fromJust, fromMaybe) -import Data.Set (Set) -import Data.Set qualified as Set import Data.Tuple.Extra (dupe, first, second) import Debug.Trace (trace) import Grammar.ErrM (Err) @@ -32,7 +30,7 @@ import TypeChecker.TypeCheckerIr qualified as TIR data CodeGenerator = CodeGenerator { instructions :: [LLVMIr] , functions :: Map MIR.Id FunctionInfo - , customTypes :: Set LLVMType + , customTypes :: Map LLVMType Integer , constructors :: Map TIR.Ident ConstructorInfo , variableCount :: Integer , labelCount :: Integer @@ -60,9 +58,7 @@ emit l = modify $ \t -> t{instructions = Auxiliary.snoc l $ instructions t} -- | Increases the variable counter in the CodeGenerator state increaseVarCount :: CompilerState () -increaseVarCount = do - gets variableCount >>= \s -> emit . Comment $ "increase: " <> show (s + 1) - modify $ \t -> t{variableCount = variableCount t + 1} +increaseVarCount = modify $ \t -> t{variableCount = variableCount t + 1} -- | Returns the variable count from the CodeGenerator state getVarCount :: CompilerState Integer @@ -122,12 +118,14 @@ getConstructors bs = Map.fromList $ go bs <> go xs go (_ : xs) = go xs -getTypes :: [MIR.Def] -> Set LLVMType -getTypes bs = Set.fromList $ go bs +getTypes :: [MIR.Def] -> Map LLVMType Integer +getTypes bs = Map.fromList $ go bs where go [] = [] - go (MIR.DData (MIR.Data t _) : xs) = type2LlvmType t : go xs + go (MIR.DData (MIR.Data t ts) : xs) = (type2LlvmType t, biggestVariant ts) : go xs go (_ : xs) = go xs + variantTypes fi = init $ map type2LlvmType (flattenType fi) + biggestVariant ts = 8 + maximum (sum . (\(Inj _ fi) -> typeByteSize <$> variantTypes fi) <$> ts) initCodeGenerator :: [MIR.Def] -> CodeGenerator initCodeGenerator scs = @@ -225,6 +223,7 @@ compileScs [] = do -- get a pointer of the correct type ptr' <- getNewVar emit $ SetVariable ptr' (Bitcast (Ref t') (VIdent top Ptr) (Ref $ CustomType id)) + cTypes <- gets customTypes enumerateOneM_ ( \i (TIR.Ident arg_n, arg_t) -> do @@ -243,7 +242,16 @@ compileScs [] = do I32 (VInteger i) ) - emit $ Store arg_t' (VIdent (TIR.Ident arg_n) arg_t') Ptr elemPtr + case Map.lookup arg_t' cTypes of + Just s -> do + emit $ Comment "Malloc and store" + heapPtr <- getNewVar + emit $ SetVariable heapPtr (Malloca s) + emit $ Store arg_t' (VIdent (TIR.Ident arg_n) arg_t') Ptr heapPtr + emit $ Store (Ref arg_t') (VIdent heapPtr arg_t') Ptr elemPtr + Nothing -> do + emit $ Comment "Just store" + emit $ Store arg_t' (VIdent (TIR.Ident arg_n) arg_t') Ptr elemPtr ) (argumentsCI ci) @@ -274,12 +282,15 @@ compileScs (MIR.DBind (MIR.Bind (name, t) args exp) : xs) = do compileScs xs compileScs (MIR.DData (MIR.Data typ ts) : xs) = do let (TIR.Ident outer_id) = extractTypeName typ + -- //TODO this could be extracted from the customTypes map let variantTypes fi = init $ map type2LlvmType (flattenType fi) let biggestVariant = 7 + maximum (sum . (\(Inj _ fi) -> typeByteSize <$> variantTypes fi) <$> ts) emit $ LIR.Type (TIR.Ident outer_id) [I8, Array biggestVariant I8] + typeSets <- gets customTypes mapM_ ( \(Inj inner_id fi) -> do - emit $ LIR.Type inner_id (I8 : variantTypes fi) + let types = (\s -> if Map.member s typeSets then Ref s else s) <$> variantTypes fi + emit $ LIR.Type inner_id (I8 : types) ) ts compileScs xs @@ -369,32 +380,28 @@ emitECased t e cases = do emit $ SetVariable castPtr (Alloca rt) emit $ Store rt vs Ptr castPtr emit $ SetVariable casted (Load (CustomType (coerce consId)) Ptr castPtr) - val <- exprToValue exp enumerateOneM_ ( \i c -> do case c of - PVar x -> do - emit . Comment $ "ident " <> show x - emit $ SetVariable (fst x) (ExtractValue (CustomType (coerce consId)) (VIdent casted Ptr) i) + PVar (x, topT) -> do + let topT' = type2LlvmType topT + let botT' = CustomType (coerce consId) + emit . Comment $ "ident " <> toIr topT' + cTypes <- gets customTypes + if Map.member topT' cTypes + then do + emit . Comment $ "tjabatjena" + deref <- getNewVar + emit $ SetVariable deref (ExtractValue botT' (VIdent casted Ptr) i) + emit $ SetVariable x (Load topT' Ptr deref) + else emit $ SetVariable x (ExtractValue botT' (VIdent casted Ptr) i) PLit (_l, _t) -> undefined PInj _id _ps -> undefined PCatch -> pure () PEnum _id -> undefined - -- case c of - -- CIdent x -> do - -- emit . Comment $ "ident " <> show x - -- emit $ SetVariable x (ExtractValue (CustomType (fst consId)) (VIdent casted Ptr) i) - -- emit $ Store ty val Ptr stackPtr - -- CCons x cs -> error "nested constructor" - -- CLit l -> do - -- testVar <- getNewVar - -- emit $ SetVariable testVar (ExtractValue (CustomType (fst consId)) (VIdent casted Ptr) i) - -- case l of - -- LInt l -> emit $ Icmp LLEq I64 (VIdent testVar Ptr) (VInteger l) - -- LChar c -> emit $ Icmp LLEq I8 (VIdent testVar Ptr) (VChar c) - -- CCatch -> emit . Comment $ "Catch all" ) cs + val <- exprToValue exp emit $ Store ty val Ptr stackPtr emit $ Br label emit $ Label lbl_failPos diff --git a/src/Codegen/LlvmIr.hs b/src/Codegen/LlvmIr.hs index 4a309c7..0ef6ac0 100644 --- a/src/Codegen/LlvmIr.hs +++ b/src/Codegen/LlvmIr.hs @@ -225,7 +225,7 @@ llvmIrToString = go 0 (Alloca t) -> unwords ["alloca", toIr t, "\n"] (Malloca t) -> concat - [ "call ptr @malloc(i32 ", show t, ")"] + [ "call ptr @malloc(i32 ", show t, ")\n"] (Store t1 val t2 (Ident id2)) -> concat [ "store ", toIr t1, " ", toIr val diff --git a/test_program.crf b/test_program.crf index 64aa2e7..cf754ca 100644 --- a/test_program.crf +++ b/test_program.crf @@ -1,13 +1,24 @@ -id x = x; - -const x y = x ; - -data Maybe () where { - Just : Int -> Maybe () - Nothing : Maybe () +-- a simple list data type containing ints +data List () where { + Cons : Int -> List () -> List () + Nil : List () }; -main = case (Just 5) of { - Just a => 10 ; - Nothing => 0 ; -}; --const (id 0) (id 'a') ; +main = sumlength (Cons 1 (Cons 2 (Cons 3 (Cons 4 (Cons 5 Nil))))); + +-- take the length of a list +length : List () -> Int ; +length x = case x of { + Cons _ xs => 1 + length xs ; + Nil => 0 ; +}; +-- sum a list +sum : List () -> Int ; +sum x = case x of { + Cons a xs => a + sum xs ; + Nil => 0 ; +}; + +-- sum + length of a list +sumlength: List () -> Int ; +sumlength x = sum x + length x ; \ No newline at end of file From 82f1b38f1b51a78b2b085117576c99ffcf303cbb Mon Sep 17 00:00:00 2001 From: Samuel Hammersberg Date: Wed, 29 Mar 2023 14:41:52 +0200 Subject: [PATCH 231/372] Removed the Tjabatjena comment that the compiler generated. --- src/Codegen/Codegen.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/src/Codegen/Codegen.hs b/src/Codegen/Codegen.hs index 6cb510d..cfa75ab 100644 --- a/src/Codegen/Codegen.hs +++ b/src/Codegen/Codegen.hs @@ -390,7 +390,6 @@ emitECased t e cases = do cTypes <- gets customTypes if Map.member topT' cTypes then do - emit . Comment $ "tjabatjena" deref <- getNewVar emit $ SetVariable deref (ExtractValue botT' (VIdent casted Ptr) i) emit $ SetVariable x (Load topT' Ptr deref) From f69151a7ce6f1c435053557ba16f7fbba9aa80ef Mon Sep 17 00:00:00 2001 From: Samuel Hammersberg Date: Wed, 29 Mar 2023 15:12:33 +0200 Subject: [PATCH 232/372] Fixed a bug with pattern matching on literals. --- src/Codegen/Codegen.hs | 5 +++-- test_program.crf | 18 ++++++++++++++++-- 2 files changed, 19 insertions(+), 4 deletions(-) diff --git a/src/Codegen/Codegen.hs b/src/Codegen/Codegen.hs index cfa75ab..cd42184 100644 --- a/src/Codegen/Codegen.hs +++ b/src/Codegen/Codegen.hs @@ -404,7 +404,7 @@ emitECased t e cases = do emit $ Store ty val Ptr stackPtr emit $ Br label emit $ Label lbl_failPos - emitCases _rt ty label stackPtr vs (Branch (MIR.PLit i, _) exp) = do + emitCases _rt ty label stackPtr vs (Branch (MIR.PLit i, t) exp) = do emit $ Comment "Plit" let i' = case i of (MIR.LInt i, _) -> VInteger i @@ -412,7 +412,7 @@ emitECased t e cases = do ns <- getNewVar lbl_failPos <- (\x -> TIR.Ident $ "failed_" <> show x) <$> getNewLabel lbl_succPos <- (\x -> TIR.Ident $ "success_" <> show x) <$> getNewLabel - emit $ SetVariable ns (Icmp LLEq ty vs i') + emit $ SetVariable ns (Icmp LLEq (type2LlvmType t) vs i') emit $ BrCond (VIdent ns ty) lbl_succPos lbl_failPos emit $ Label lbl_succPos val <- exprToValue exp @@ -432,6 +432,7 @@ emitECased t e cases = do lbl_failPos <- (\x -> TIR.Ident $ "failed_" <> show x) <$> getNewLabel emit $ Label lbl_failPos emitCases _rt ty label stackPtr _vs (Branch (MIR.PEnum _id, _) exp) = do + -- //TODO Penum wrong, acts as a catch all emit $ Comment "Penum" val <- exprToValue exp emit $ Store ty val Ptr stackPtr diff --git a/test_program.crf b/test_program.crf index cf754ca..6bf593a 100644 --- a/test_program.crf +++ b/test_program.crf @@ -4,7 +4,21 @@ data List () where { Nil : List () }; -main = sumlength (Cons 1 (Cons 2 (Cons 3 (Cons 4 (Cons 5 Nil))))); +main = head (repeat 10 5); + +head : List () -> Int ; +head x = case x of { + Cons h _ => h ; +}; + +repeat : Int -> Int -> List () ; +repeat x n = case n of { + 0 => Nil ; + n => Cons x (repeat x (n + minusOne)) ; +}; + +minusOne : Int ; +minusOne = 9223372036854775807 + 9223372036854775807 + 1; -- take the length of a list length : List () -> Int ; @@ -13,7 +27,7 @@ length x = case x of { Nil => 0 ; }; -- sum a list -sum : List () -> Int ; +sum : List () -> Int ; sum x = case x of { Cons a xs => a + sum xs ; Nil => 0 ; From 2f12fdd7e224f94b5404ffc293b82c1e97c23ce7 Mon Sep 17 00:00:00 2001 From: Samuel Hammersberg Date: Wed, 29 Mar 2023 15:29:53 +0200 Subject: [PATCH 233/372] Removed a trace. --- src/Codegen/Codegen.hs | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/src/Codegen/Codegen.hs b/src/Codegen/Codegen.hs index cd42184..d368b85 100644 --- a/src/Codegen/Codegen.hs +++ b/src/Codegen/Codegen.hs @@ -21,7 +21,6 @@ import Data.Map (Map) import Data.Map qualified as Map import Data.Maybe (fromJust, fromMaybe) import Data.Tuple.Extra (dupe, first, second) -import Debug.Trace (trace) import Grammar.ErrM (Err) import Monomorphizer.MonomorphizerIr as MIR import TypeChecker.TypeCheckerIr qualified as TIR @@ -188,7 +187,7 @@ test v = generateCode :: MIR.Program -> Err String generateCode (MIR.Program scs) = do let codegen = initCodeGenerator scs - llvmIrToString . instructions <$> execStateT (compileScs (trace (show scs) scs)) codegen + llvmIrToString . instructions <$> execStateT (compileScs scs) codegen compileScs :: [MIR.Def] -> CompilerState () compileScs [] = do From c59cd02361f7371d1583b324e001fcf7849c059e Mon Sep 17 00:00:00 2001 From: Martin Fredin Date: Wed, 29 Mar 2023 16:37:52 +0200 Subject: [PATCH 234/372] Lift lambdas in the scrutinized expression --- src/LambdaLifter.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/LambdaLifter.hs b/src/LambdaLifter.hs index 5020fb6..d6d1945 100644 --- a/src/LambdaLifter.hs +++ b/src/LambdaLifter.hs @@ -234,9 +234,10 @@ collectScsExp expT@(exp, typ) = case exp of where (scs, e') = collectScsExp e - ECase e branches -> (scs, (ECase e branches', typ)) + ECase e branches -> (scs ++ scs_e, (ECase e' branches', typ)) where (scs, branches') = mapAccumL f [] branches + (scs_e, e') = collectScsExp e f acc b = (acc ++ acc', b') where (acc', b') = collectScsBranch b From d4115fd2f5ac5392601876365dd3a760ca80e880 Mon Sep 17 00:00:00 2001 From: Rakarake Date: Wed, 29 Mar 2023 16:45:30 +0200 Subject: [PATCH 235/372] Monomoprhizer handles new types --- src/Monomorphizer/Monomorphizer.hs | 43 ++++++++++++++++++------------ 1 file changed, 26 insertions(+), 17 deletions(-) diff --git a/src/Monomorphizer/Monomorphizer.hs b/src/Monomorphizer/Monomorphizer.hs index 40dc901..38abf33 100644 --- a/src/Monomorphizer/Monomorphizer.hs +++ b/src/Monomorphizer/Monomorphizer.hs @@ -55,18 +55,6 @@ data Env = Env { 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, - polys = Map.empty, - locals = Set.empty } - where - kvPairs :: [(Ident, T.Bind)] - kvPairs = map (\b@(T.Bind (ident, _) _ _) -> (ident, b)) binds - localExists :: Ident -> EnvM Bool localExists ident = asks (Set.member ident . locals) @@ -114,7 +102,10 @@ getMonoFromPoly t = do env <- ask Just concrete -> concrete Nothing -> error $ "type not found! type: " ++ show ident ++ ", error in previous compilation steps" - _ -> error "Not implemented" + -- This is pretty ugly, could use a new type + (T.TData (Ident str) args) -> let args' = map (getMono polys) args in + M.TLit $ Ident (str ++ "$" ++ show args') + (T.TAll _ t) -> getMono polys t -- | If ident not already in env's output, morphed bind to output -- (and all referenced binds within this bind). @@ -171,6 +162,7 @@ convertLit (T.LChar v) = M.LChar v morphExp :: M.Type -> T.Exp -> EnvM M.Exp morphExp expectedType exp = case exp of T.ELit lit -> return $ M.ELit (convertLit lit) + -- Constructor T.EInj ident -> do return $ M.EVar ident T.EApp e1 e2 -> do @@ -193,7 +185,8 @@ morphExp expectedType exp = case exp of bind <- getInputBind ident case bind of Nothing -> - error $ "bind of name: " ++ str ++ " not found, bug in previous compilation steps" + -- This is a constructor + return $ M.EVar ident Just bind' -> do -- New bind to process newBindName <- morphBind expectedType bind' @@ -235,7 +228,7 @@ newName t (T.Bind (Ident bindName, _) _ _) = -- Monomorphization step monomorphize :: T.Program -> M.Program monomorphize (T.Program defs) = M.Program $ (getDefsFromBinds . getBindsFromOutput) - (runEnvM Map.empty (createEnv $ getBindsFromDefs defs) monomorphize') + (runEnvM Map.empty (createEnv defs) monomorphize') where monomorphize' :: EnvM () monomorphize' = do @@ -243,6 +236,19 @@ monomorphize (T.Program defs) = M.Program $ (getDefsFromBinds . getBindsFromOutp morphBind (M.TLit $ Ident "Int") main return () +-- | Runs and gives the output binds +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.Def] -> Env +createEnv defs = Env { input = Map.fromList bindPairs, + polys = Map.empty, + locals = Set.empty } + where + bindPairs = (map (\b -> (getBindName b, b)) . getBindsFromDefs) defs + +-- Helper functions getBindsFromOutput :: Output -> [M.Bind] getBindsFromOutput outputMap = (map snd . Map.toList) $ fmap (\case @@ -253,8 +259,11 @@ getBindsFromOutput outputMap = (map snd . Map.toList) $ fmap getBindsFromDefs :: [T.Def] -> [T.Bind] getBindsFromDefs = foldl (\bs -> \case T.DBind b -> b:bs - T.DData _ -> bs - ) [] + T.DData _ -> bs) [] + getDefsFromBinds :: [M.Bind] -> [M.Def] getDefsFromBinds = foldl (\ds b -> M.DBind b : ds) [] +getBindName :: T.Bind -> Ident +getBindName (T.Bind (ident, _) _ _) = ident + From d26bde6a7fd95fb3c61d488471673a1f336ac7c0 Mon Sep 17 00:00:00 2001 From: Samuel Hammersberg Date: Wed, 29 Mar 2023 16:47:52 +0200 Subject: [PATCH 236/372] Added a fun Maybe example! --- src/Codegen/Codegen.hs | 13 +++++++- test_program.crf | 68 +++++++++++++++++++++++++++++++----------- 2 files changed, 63 insertions(+), 18 deletions(-) diff --git a/src/Codegen/Codegen.hs b/src/Codegen/Codegen.hs index d368b85..eaf8e25 100644 --- a/src/Codegen/Codegen.hs +++ b/src/Codegen/Codegen.hs @@ -328,7 +328,7 @@ compileExp (MIR.EAdd e1 e2, t) = emitAdd t e1 e2 compileExp (MIR.EVar name, _t) = emitIdent name compileExp (MIR.EApp e1 e2, t) = emitApp t e1 e2 -- compileExp (EAbs t ti e) = emitAbs t ti e -compileExp (MIR.ELet _binds _e, _t) = undefined -- emitLet binds (fst e) +compileExp (MIR.ELet bind e, _) = emitLet bind e compileExp (MIR.ECase e cs, t) = emitECased t e (map (t,) cs) -- go (EMul e1 e2) = emitMul e1 e2 @@ -336,6 +336,17 @@ compileExp (MIR.ECase e cs, t) = emitECased t e (map (t,) cs) -- go (EMod e1 e2) = emitMod e1 e2 --- aux functions --- +emitLet :: MIR.Bind -> ExpT -> CompilerState () +emitLet (MIR.Bind id [] innerExp) e = do + evaled <- exprToValue innerExp + tempVar <- getNewVar + let t = type2LlvmType . snd $ innerExp + emit $ SetVariable tempVar (Alloca t) + emit $ Store (type2LlvmType . snd $ innerExp) evaled Ptr tempVar + emit $ SetVariable (fst id) (Load t Ptr tempVar) + compileExp e +emitLet b _ = error $ "Non empty argument list in let-bind " <> show b + emitECased :: MIR.Type -> ExpT -> [(MIR.Type, Branch)] -> CompilerState () emitECased t e cases = do let cs = snd <$> cases diff --git a/test_program.crf b/test_program.crf index 6bf593a..c5b3f9d 100644 --- a/test_program.crf +++ b/test_program.crf @@ -1,31 +1,51 @@ +-- main = head (Cons (sum (repeat 10 5)) Nil); + +main = case (bind (fmap (\s . s + 1) (Just 5)) (\s . pure (s + 10))) of { + Just a => a ; + Nothing => minusOne ; +}; + +---- MAYBE MONAD ---- +data Maybe () where { + Just : Int -> Maybe () + Nothing : Maybe () +}; + +fmap : (Int -> Int) -> Maybe () -> Maybe () ; +fmap f m = case m of { + Just a => pure (f a) ; + Nothing => Nothing ; +}; + +pure : Int -> Maybe () ; +pure x = Just x; + +-- scombinator not working yet :) + +bind : Maybe () -> (Int -> Maybe ()) -> Maybe () ; +bind x f = case x of { + Just x => f x ; + Nothing => Nothing ; +}; + +-- represents minus one :) +minusOne : Int ; +minusOne = 9223372036854775807 + 9223372036854775807 + 1; +{- +---- LIST STUFF ---- -- a simple list data type containing ints data List () where { Cons : Int -> List () -> List () Nil : List () }; -main = head (repeat 10 5); - -head : List () -> Int ; -head x = case x of { - Cons h _ => h ; -}; - -repeat : Int -> Int -> List () ; -repeat x n = case n of { - 0 => Nil ; - n => Cons x (repeat x (n + minusOne)) ; -}; - -minusOne : Int ; -minusOne = 9223372036854775807 + 9223372036854775807 + 1; - -- take the length of a list length : List () -> Int ; length x = case x of { Cons _ xs => 1 + length xs ; Nil => 0 ; }; + -- sum a list sum : List () -> Int ; sum x = case x of { @@ -35,4 +55,18 @@ sum x = case x of { -- sum + length of a list sumlength: List () -> Int ; -sumlength x = sum x + length x ; \ No newline at end of file +sumlength x = sum x + length x ; + +-- take the head of a list +head : List () -> Int ; +head x = case x of { + Cons h _ => h ; +}; + +-- repeat an element n times +repeat : Int -> Int -> List () ; +repeat x n = case n of { + 0 => Nil ; + n => Cons x (repeat x (n + minusOne)) ; +}; +-} \ No newline at end of file From 53589e8d5071e8d067eec8b36b0b40ec8b449cec Mon Sep 17 00:00:00 2001 From: Samuel Hammersberg Date: Wed, 29 Mar 2023 16:54:30 +0200 Subject: [PATCH 237/372] Made the output from running the compiler a bit clearer. --- src/Main.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/Main.hs b/src/Main.hs index f5793be..97d75e8 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -133,6 +133,8 @@ main' opts s = do debugDotViz compile generatedCode + printToErr "Compilation done!" + printToErr "\n-- Program output --" spawnWait "./output/hello_world" exitSuccess From 29fcddf44c1222b07ea0e6e58358d4640ad55d54 Mon Sep 17 00:00:00 2001 From: Rakarake Date: Wed, 29 Mar 2023 17:05:56 +0200 Subject: [PATCH 238/372] Data defs in monomorphizer output environment --- src/Monomorphizer/Monomorphizer.hs | 25 +++++++------------------ 1 file changed, 7 insertions(+), 18 deletions(-) diff --git a/src/Monomorphizer/Monomorphizer.hs b/src/Monomorphizer/Monomorphizer.hs index 38abf33..0a98b00 100644 --- a/src/Monomorphizer/Monomorphizer.hs +++ b/src/Monomorphizer/Monomorphizer.hs @@ -43,7 +43,7 @@ newtype EnvM a = EnvM (StateT Output (Reader Env) a) 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 +data Outputted = Incomplete | Complete M.Bind | Data M.Data -- Static environment data Env = Env { @@ -150,15 +150,6 @@ convertLit :: T.Lit -> M.Lit convertLit (T.LInt v) = M.LInt v convertLit (T.LChar v) = M.LChar v --- | Conv ---data Pattern' t --- = PVar (Id' t) -- TODO should be Ident --- | PLit (Lit, t) -- TODO should be Lit --- | PCatch --- | PEnum Ident --- | PInj Ident [Pattern' t] -- TODO should be (Pattern' t, t) --- deriving (C.Eq, C.Ord, C.Show, C.Read) - morphExp :: M.Type -> T.Exp -> EnvM M.Exp morphExp expectedType exp = case exp of T.ELit lit -> return $ M.ELit (convertLit lit) @@ -214,7 +205,7 @@ morphPattern = \case T.PInj ident ps -> do ps' <- mapM morphPattern ps return $ M.PInj ident ps' --- Creates a new identifier for a function with an assigned type +-- | Creates a new identifier for a function with an assigned type newName :: M.Type -> T.Bind -> Ident newName t (T.Bind (Ident bindName, _) _ _) = if bindName == "main" then @@ -227,7 +218,7 @@ newName t (T.Bind (Ident bindName, _) _ _) = -- Monomorphization step monomorphize :: T.Program -> M.Program -monomorphize (T.Program defs) = M.Program $ (getDefsFromBinds . getBindsFromOutput) +monomorphize (T.Program defs) = M.Program $ getDefsFromOutput (runEnvM Map.empty (createEnv defs) monomorphize') where monomorphize' :: EnvM () @@ -249,11 +240,12 @@ createEnv defs = Env { input = Map.fromList bindPairs, bindPairs = (map (\b -> (getBindName b, b)) . getBindsFromDefs) defs -- Helper functions -getBindsFromOutput :: Output -> [M.Bind] -getBindsFromOutput outputMap = (map snd . Map.toList) $ fmap +getDefsFromOutput :: Output -> [M.Def] +getDefsFromOutput outputMap = (map snd . Map.toList) $ fmap (\case Incomplete -> error "Internal bug in monomorphizer" - Complete b -> b ) + Complete b -> M.DBind b + Data d -> M.DData d) outputMap getBindsFromDefs :: [T.Def] -> [T.Bind] @@ -261,9 +253,6 @@ getBindsFromDefs = foldl (\bs -> \case T.DBind b -> b:bs T.DData _ -> bs) [] -getDefsFromBinds :: [M.Bind] -> [M.Def] -getDefsFromBinds = foldl (\ds b -> M.DBind b : ds) [] - getBindName :: T.Bind -> Ident getBindName (T.Bind (ident, _) _ _) = ident From 4efe7cf9a2f47e386d229b4774d813c8f98ac3fa Mon Sep 17 00:00:00 2001 From: sebastianselander Date: Wed, 29 Mar 2023 17:30:31 +0200 Subject: [PATCH 239/372] inference does not depend on order. mutual recursion still not working correctly --- src/TypeChecker/TypeCheckerHm.hs | 139 ++++++++++----- tests/TestTypeChekerHm.hs/DoStrings.hs | 9 - tests/TestTypeChekerHm.hs/Tests.hs | 231 ------------------------- 3 files changed, 97 insertions(+), 282 deletions(-) delete mode 100644 tests/TestTypeChekerHm.hs/DoStrings.hs delete mode 100644 tests/TestTypeChekerHm.hs/Tests.hs diff --git a/src/TypeChecker/TypeCheckerHm.hs b/src/TypeChecker/TypeCheckerHm.hs index 3d1121e..ea819fc 100644 --- a/src/TypeChecker/TypeCheckerHm.hs +++ b/src/TypeChecker/TypeCheckerHm.hs @@ -12,6 +12,7 @@ import Control.Monad.Except import Control.Monad.Identity (Identity, runIdentity) import Control.Monad.Reader import Control.Monad.State +import Data.Bifunctor (first) import Data.Coerce (coerce) import Data.Function (on) import Data.List (foldl') @@ -27,7 +28,7 @@ import Grammar.Print (printTree) import TypeChecker.TypeCheckerIr qualified as T initCtx = Ctx mempty -initEnv = Env 0 'a' mempty mempty mempty +initEnv = Env 0 'a' mempty mempty mempty "" mempty mempty run :: Infer a -> Either Error a run = run' initEnv initCtx @@ -51,8 +52,20 @@ typecheck = onLeft msg . run . checkPrg checkPrg :: Program -> Infer (T.Program' Type) checkPrg (Program bs) = do preRun bs - bs' <- checkDef bs - return $ T.Program bs' + bs <- checkDef bs + sub <- solveUndecidable + dec <- gets toDecide + trace (printTree bs) pure () + bs <- mapM (mono sub) bs + return $ T.Program bs + +mono :: Subst -> T.Def' Type -> Infer (T.Def' Type) +mono s bind@(T.DBind (T.Bind (name, t) args e)) = do + b <- gets (S.member name . toDecide) + if b + then return $ T.DBind $ T.Bind (name, apply s t) (apply s args) (apply s e) + else return bind +mono _ (T.DData d) = return $ T.DData d preRun :: [Def] -> Infer () preRun [] = return () @@ -66,7 +79,7 @@ preRun (x : xs) = case x of "Duplicate signatures for function" quote $ printTree n ) - insertSig (coerce n) (Just $ skolemize t) >> preRun xs + insertSig (coerce n) (Just t) >> preRun xs DBind (Bind n _ e) -> do collect (collectTVars e) s <- gets sigs @@ -91,25 +104,15 @@ checkDef (x : xs) = case x of T.Data t $ map (\(Inj name typ) -> T.Inj (coerce name) typ) injs checkBind :: Bind -> Infer (T.Bind' Type) -checkBind (Bind name args e) = do +checkBind bind@(Bind name args e) = do + setCurrentBind $ coerce name let lambda = makeLambda e (reverse (coerce args)) - (sub0, (e, lambda_t)) <- inferExp lambda + (e, lambda_t) <- inferExp lambda s <- gets sigs case M.lookup (coerce name) s of Just (Just t') -> do - -- \| TODO: Fix, this is not correct - let fsig = apply sub0 t' - sub1 <- liftEither $ runIdentity $ runExceptT $ execStateT (typeEq fsig lambda_t) mempty - sub2 <- liftEither $ runIdentity $ runExceptT $ execStateT (typeEq lambda_t fsig) mempty - unless - (lambda_t == apply sub1 fsig && apply sub2 lambda_t == fsig) - ( uncatchableErr $ Aux.do - "Inferred type" - quote $ printTree lambda_t - "does not match specified type" - quote $ printTree t' - ) - return $ T.Bind (coerce name, lambda_t) [] (e, lambda_t) + sub1 <- bindErr (unify lambda_t (skolemize t')) bind + return $ T.Bind (coerce name, apply sub1 t') [] (e, lambda_t) _ -> do insertSig (coerce name) (Just lambda_t) return (T.Bind (coerce name, lambda_t) [] (e, lambda_t)) @@ -123,7 +126,7 @@ checkData err@(Data typ injs) = do TData name typs | Right tvars' <- mapM toTVar typs -> pure (name, tvars') - TAll _ _ -> uncatchableErr "Explicit foralls not allowed, for now" + TAll _ _ -> uncatchableErr "Explicit forall not allowed, for now" _ -> uncatchableErr $ unwords ["Bad data type definition: ", printTree typ] @@ -158,7 +161,7 @@ checkInj (Inj c inj_typ) name tvars where boundTVars :: [TVar] -> Type -> Either Error Bool boundTVars tvars' = \case - TAll{} -> uncatchableErr "Explicit foralls not allowed, for now" + TAll{} -> uncatchableErr "Explicit forall not allowed, for now" TFun t1 t2 -> do t1' <- boundTVars tvars t1 t2' <- boundTVars tvars t2 @@ -177,11 +180,12 @@ returnType :: Type -> Type returnType (TFun _ t2) = returnType t2 returnType a = a -inferExp :: Exp -> Infer (Subst, T.ExpT' Type) +inferExp :: Exp -> Infer (T.ExpT' Type) inferExp e = do (s, (e', t)) <- algoW e let subbed = apply s t - return (s, (e', subbed)) + modify (\st -> st{undecidedSigs = apply s st.undecidedSigs}) + return (e', subbed) class CollectTVars a where collectTVars :: a -> Set T.Ident @@ -225,7 +229,7 @@ algoW = \case -- \| x : σ ∈ Γ   τ = inst(σ) -- \| ---------------------- -- \| Γ ⊢ x : τ, ∅ - EVar i -> do + EVar (LIdent i) -> do var <- asks vars case M.lookup (coerce i) var of Just t -> @@ -237,7 +241,8 @@ algoW = \case Just (Just t) -> return (nullSubst, (T.EVar $ coerce i, t)) Just Nothing -> do fr <- fresh - insertSig (coerce i) (Just fr) + cb <- gets currentBind + modify (\st -> st{toDecide = S.insert cb st.toDecide, undecidedSigs = M.insert (coerce $ concat [[prefix], i, [delim], coerce cb]) fr st.undecidedSigs}) return (nullSubst, (T.EVar $ coerce i, fr)) Nothing -> uncatchableErr $ @@ -591,6 +596,9 @@ instance SubstType (Map T.Ident Type) where apply :: Subst -> Map T.Ident Type -> Map T.Ident Type apply = M.map . apply +instance SubstType (T.ExpT' Type) where + apply s (e, t) = (apply s e, apply s t) + instance SubstType (T.Exp' Type) where apply s = \case T.EVar i -> T.EVar i @@ -605,6 +613,11 @@ instance SubstType (T.Exp' Type) where T.ECase e brnch -> T.ECase (apply s e) (apply s brnch) T.EInj i -> T.EInj i +instance SubstType (T.Def' Type) where + apply s = \case + T.DBind (T.Bind name args e) -> T.DBind $ T.Bind (apply s name) (apply s args) (apply s e) + d -> d + instance SubstType (T.Branch' Type) where apply s (T.Branch (i, t) e) = T.Branch (apply s i, apply s t) (apply s e) @@ -616,18 +629,18 @@ instance SubstType (T.Pattern' Type) where T.PCatch -> T.PCatch T.PEnum i -> T.PEnum i +instance SubstType (T.Pattern' Type, Type) where + apply s (p, t) = (apply s p, apply s t) + instance SubstType a => SubstType [a] where apply s = map (apply s) -instance (SubstType a, SubstType b) => SubstType (a, b) where - apply s (a, b) = (apply s a, apply s b) - instance SubstType (T.Id' Type) where apply s (name, t) = (name, apply s t) -- | Represents the empty substition set nullSubst :: Subst -nullSubst = M.empty +nullSubst = mempty -- | Compose two substitution sets compose :: Subst -> Subst -> Subst @@ -676,6 +689,31 @@ with an equivalent name has been declared already existInj :: T.Ident -> Infer (Maybe Type) existInj n = gets (M.lookup n . injections) +setCurrentBind :: T.Ident -> Infer () +setCurrentBind i = modify (\st -> st{currentBind = i}) + +solveUndecidable :: Infer Subst +solveUndecidable = do + sigs <- gets sigs + undecided <- gets undecidedSigs + let xs = M.toList undecided + ys <- + maybeToRightM + (Error "SIGNATURE MISSING" False) + (mapM (tupSequence . first (join . flip M.lookup sigs . getOriginal)) xs) + composeAll <$> mapM (uncurry unify) ys + +tupSequence :: Monad m => (m a, b) -> m (a, b) +tupSequence (ma, b) = (,b) <$> ma + +getOriginal :: T.Ident -> T.Ident +getOriginal (T.Ident i) = coerce $ takeWhile (/= delim) $ drop 1 i + +delim :: Char +delim = '_' +prefix :: Char +prefix = '$' + flattenType :: Type -> [Type] flattenType (TFun a b) = flattenType a <> flattenType b flattenType a = [a] @@ -740,19 +778,30 @@ exprErr :: (Monad m, MonadError Error m) => m a -> Exp -> m a exprErr ma exp = catchError ma - ( \x -> - if x.catchable - then - throwError - ( x - { msg = - x.msg + ( \err -> if err.catchable + then throwError + ( err { msg = err.msg <> " in expression: \n" <> printTree exp , catchable = False } ) - else throwError x + else throwError err + ) + +bindErr :: (Monad m, MonadError Error m) => m a -> Bind -> m a +bindErr ma bind = + catchError + ma + ( \err -> if err.catchable + then throwError + ( err { msg = err.msg + <> " in function: \n" + <> printTree bind + , catchable = False + } + ) + else throwError err ) {- | Catch an error if possible and add the given @@ -762,18 +811,18 @@ dataErr :: Infer a -> Data -> Infer a dataErr ma d = catchError ma - ( \x -> - if x.catchable + ( \err -> + if err.catchable then throwError - ( x + ( err { msg = - x.msg + err.msg <> " in data: \n" <> printTree d } ) - else throwError (x{catchable = False}) + else throwError (err{catchable = False}) ) unzip4 :: [(a, b, c, d)] -> ([a], [b], [c], [d]) @@ -793,6 +842,9 @@ data Env = Env , sigs :: Map T.Ident (Maybe Type) , injections :: Map T.Ident Type , takenTypeVars :: Set T.Ident + , currentBind :: T.Ident + , undecidedSigs :: Map T.Ident Type + , toDecide :: Set T.Ident } deriving (Show) @@ -811,3 +863,6 @@ uncatchableErr msg = throwError $ Error msg False quote :: String -> String quote s = "'" ++ s ++ "'" + +ctrace :: (Monad m, Show a) => String -> a -> m () +ctrace str a = trace (str ++ ": " ++ show a) pure () diff --git a/tests/TestTypeChekerHm.hs/DoStrings.hs b/tests/TestTypeChekerHm.hs/DoStrings.hs deleted file mode 100644 index dabf5d6..0000000 --- a/tests/TestTypeChekerHm.hs/DoStrings.hs +++ /dev/null @@ -1,9 +0,0 @@ -module DoStrings where - -import Prelude hiding ((>>), (>>=)) - -(>>) :: String -> String -> String -(>>) str1 str2 = str1 ++ "\n" ++ str2 - -(>>=) :: String -> (String -> String) -> String -(>>=) str f = f str diff --git a/tests/TestTypeChekerHm.hs/Tests.hs b/tests/TestTypeChekerHm.hs/Tests.hs deleted file mode 100644 index b5d14c6..0000000 --- a/tests/TestTypeChekerHm.hs/Tests.hs +++ /dev/null @@ -1,231 +0,0 @@ -{-# LANGUAGE QualifiedDo #-} -{-# LANGUAGE NoImplicitPrelude #-} - -module Main where - -import Control.Monad ((<=<)) -import DoStrings qualified as D -import Grammar.Par (myLexer, pProgram) -import Test.Hspec -import Prelude (Bool (..), Either (..), IO, mapM_, not, ($), (.)) - --- import Test.QuickCheck -import TypeChecker.TypeChecker (typecheck) - -main :: IO () -main = do - mapM_ hspec goods - mapM_ hspec bads - mapM_ hspec bes - -goods = - [ testSatisfy - "Basic polymorphism with multiple type variables" - ( D.do - _const - "main = const 'a' 65 ;" - ) - ok - , testSatisfy - "Head with a correct signature is accepted" - ( D.do - _List - _headSig - _head - ) - ok - , testSatisfy - "Most simple inference possible" - ( D.do - _id - ) - ok - , testSatisfy - "Pattern matching on a nested list" - ( D.do - _List - "main : List (List (a)) -> Int ;" - "main xs = case xs of {" - " Cons Nil _ => 1 ;" - " _ => 0 ;" - "};" - ) - ok - ] - -bads = - [ testSatisfy - "Infinite type unification should not succeed" - ( D.do - "main = \\x. x x ;" - ) - bad - , testSatisfy - "Pattern matching using different types should not succeed" - ( D.do - _List - "bad xs = case xs of {" - " 1 => 0 ;" - " Nil => 0 ;" - "};" - ) - bad - , testSatisfy - "Using a concrete function (data type) on a skolem variable should not succeed" - ( D.do - _Bool - _not - "f : a -> Bool () ;" - "f x = not x ;" - ) - bad - , testSatisfy - "Using a concrete function (primitive type) on a skolem variable should not succeed" - ( D.do - "plusOne : Int -> Int ;" - "plusOne x = x + 1 ;" - "f : a -> Int ;" - "f x = plusOne x ;" - ) - bad - , testSatisfy - "A function without signature used in an incompatible context should not succeed" - ( D.do - "main = _id 1 2 ;" - "_id x = x ;" - ) - bad - , testSatisfy - "Pattern matching on literal and _List should not succeed" - ( D.do - _List - "length : List (c) -> Int;" - "length _List = case _List of {" - " 0 => 0;" - " Cons x xs => 1 + length xs;" - "};" - ) - bad - , testSatisfy - "List of function Int -> Int functions should not be usable on Char" - ( D.do - _List - "main : List (Int -> Int) -> Int ;" - "main xs = case xs of {" - " Cons f _ => f 'a' ;" - " Nil => 0 ;" - " };" - ) - bad - , testSatisfy - "id with incorrect signature" - ( D.do - "id : a -> b;" - "id x = x;" - ) - bad - , testSatisfy - "incorrect type signature on id lambda" - ( D.do - "id = ((\\x. x) : a -> b);" - ) - bad - ] - -bes = - [ testBe - "A basic arithmetic function should be able to be inferred" - ( D.do - "plusOne x = x + 1 ;" - "main x = plusOne x ;" - ) - ( D.do - "plusOne : Int -> Int ;" - "plusOne x = x + 1 ;" - "main : Int -> Int ;" - "main x = plusOne x ;" - ) - , testBe - "A basic arithmetic function should be able to be inferred" - ( D.do - "plusOne x = x + 1 ;" - ) - ( D.do - "plusOne : Int -> Int ;" - "plusOne x = x + 1 ;" - ) - , testBe - "List of function Int -> Int functions should be inferred corretly" - ( D.do - _List - "main xs = case xs of {" - " Cons f _ => f 1 ;" - " Nil => 0 ;" - " };" - ) - ( D.do - _List - "main : List (Int -> Int) -> Int ;" - "main xs = case xs of {" - " Cons f _ => f 1 ;" - " Nil => 0 ;" - " };" - ) - ] - -testSatisfy desc test satisfaction = specify desc $ run test `shouldSatisfy` satisfaction -testBe desc test shouldbe = specify desc $ run test `shouldBe` run shouldbe - -run = typecheck <=< pProgram . myLexer - -ok (Right _) = True -ok (Left _) = False - -bad = not . ok - --- FUNCTIONS - -_const = D.do - "const : a -> b -> a ;" - "const x y = x ;" -_List = D.do - "data List (a) where" - " {" - " Nil : List (a)" - " Cons : a -> List (a) -> List (a)" - " };" - -_headSig = D.do - "head : List (a) -> a ;" - -_head = D.do - "head xs = " - " case xs of {" - " Cons x xs => x ;" - " };" - -_Bool = D.do - "data Bool () where {" - " True : Bool ()" - " False : Bool ()" - "};" - -_not = D.do - "not : Bool () -> Bool () ;" - "not x = case x of {" - " True => False ;" - " False => True ;" - "};" -_id = "id x = x ;" - -_Maybe = D.do - "data Maybe (a) where {" - " Nothing : Maybe (a)" - " Just : a -> Maybe (a)" - " };" - -_fmap = D.do - "fmap f ma = case ma of {" - " Nothing => Nothing ;" - " Just a => Just (f a) ;" - "};" From 36b6a8f78171b376a78096f7f673c05905bb5186 Mon Sep 17 00:00:00 2001 From: sebastianselander Date: Wed, 29 Mar 2023 17:32:21 +0200 Subject: [PATCH 240/372] removed trace --- src/TypeChecker/TypeCheckerHm.hs | 22 ++++++++++++++-------- 1 file changed, 14 insertions(+), 8 deletions(-) diff --git a/src/TypeChecker/TypeCheckerHm.hs b/src/TypeChecker/TypeCheckerHm.hs index ea819fc..3ae6df2 100644 --- a/src/TypeChecker/TypeCheckerHm.hs +++ b/src/TypeChecker/TypeCheckerHm.hs @@ -54,8 +54,6 @@ checkPrg (Program bs) = do preRun bs bs <- checkDef bs sub <- solveUndecidable - dec <- gets toDecide - trace (printTree bs) pure () bs <- mapM (mono sub) bs return $ T.Program bs @@ -778,9 +776,13 @@ exprErr :: (Monad m, MonadError Error m) => m a -> Exp -> m a exprErr ma exp = catchError ma - ( \err -> if err.catchable - then throwError - ( err { msg = err.msg + ( \err -> + if err.catchable + then + throwError + ( err + { msg = + err.msg <> " in expression: \n" <> printTree exp , catchable = False @@ -793,9 +795,13 @@ bindErr :: (Monad m, MonadError Error m) => m a -> Bind -> m a bindErr ma bind = catchError ma - ( \err -> if err.catchable - then throwError - ( err { msg = err.msg + ( \err -> + if err.catchable + then + throwError + ( err + { msg = + err.msg <> " in function: \n" <> printTree bind , catchable = False From 61f364cd759d793926c2f7165264170398a6f622 Mon Sep 17 00:00:00 2001 From: Samuel Hammersberg Date: Wed, 29 Mar 2023 17:34:47 +0200 Subject: [PATCH 241/372] Splat up the codegenerator a bit. --- language.cabal | 3 + src/Codegen/Auxillary.hs | 50 +++ src/Codegen/Codegen.hs | 580 +---------------------------------- src/Codegen/CompilerState.hs | 141 +++++++++ src/Codegen/Emits.hs | 348 +++++++++++++++++++++ test_program.crf | 3 +- 6 files changed, 552 insertions(+), 573 deletions(-) create mode 100644 src/Codegen/Auxillary.hs create mode 100644 src/Codegen/CompilerState.hs create mode 100644 src/Codegen/Emits.hs diff --git a/language.cabal b/language.cabal index 922f873..ddf0fa0 100644 --- a/language.cabal +++ b/language.cabal @@ -42,6 +42,9 @@ executable language Monomorphizer.MonomorphizerIr Codegen.Codegen Codegen.LlvmIr + Codegen.Auxillary + Codegen.CompilerState + Codegen.Emits Compiler Renamer.Renamer TreeConverter diff --git a/src/Codegen/Auxillary.hs b/src/Codegen/Auxillary.hs new file mode 100644 index 0000000..c95f4cb --- /dev/null +++ b/src/Codegen/Auxillary.hs @@ -0,0 +1,50 @@ +module Codegen.Auxillary where + +import Codegen.LlvmIr (LLVMType (..), LLVMValue (..)) +import Control.Monad (foldM_) +import Monomorphizer.MonomorphizerIr as MIR (ExpT, Type (..)) +import TypeChecker.TypeCheckerIr qualified as TIR + +type2LlvmType :: MIR.Type -> LLVMType +type2LlvmType (MIR.TLit id@(TIR.Ident name)) = case name of + "Int" -> I64 + "Char" -> I8 + _ -> CustomType id +type2LlvmType (MIR.TFun t xs) = do + let (t', xs') = function2LLVMType xs [type2LlvmType t] + Function t' xs' + where + function2LLVMType :: Type -> [LLVMType] -> (LLVMType, [LLVMType]) + function2LLVMType (TFun t xs) s = function2LLVMType xs (type2LlvmType t : s) + function2LLVMType x s = (type2LlvmType x, s) + +getType :: ExpT -> LLVMType +getType (_, t) = type2LlvmType t + +extractTypeName :: MIR.Type -> TIR.Ident +extractTypeName (MIR.TLit id) = id +extractTypeName (MIR.TFun t xs) = + let (TIR.Ident i) = extractTypeName t + (TIR.Ident is) = extractTypeName xs + in TIR.Ident $ i <> "_$_" <> is + +valueGetType :: LLVMValue -> LLVMType +valueGetType (VInteger _) = I64 +valueGetType (VChar _) = I8 +valueGetType (VIdent _ t) = t +valueGetType (VConstant s) = Array (fromIntegral $ length s) I8 +valueGetType (VFunction _ _ t) = t + +typeByteSize :: LLVMType -> Integer +typeByteSize I1 = 1 +typeByteSize I8 = 1 +typeByteSize I32 = 4 +typeByteSize I64 = 8 +typeByteSize Ptr = 8 +typeByteSize (Ref _) = 8 +typeByteSize (Function _ _) = 8 +typeByteSize (Array n t) = n * typeByteSize t +typeByteSize (CustomType _) = 8 + +enumerateOneM_ :: Monad m => (Integer -> a -> m b) -> [a] -> m () +enumerateOneM_ f = foldM_ (\i a -> f i a >> pure (i + 1)) 1 diff --git a/src/Codegen/Codegen.hs b/src/Codegen/Codegen.hs index eaf8e25..bf35f4f 100644 --- a/src/Codegen/Codegen.hs +++ b/src/Codegen/Codegen.hs @@ -1,184 +1,16 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} - module Codegen.Codegen (generateCode) where -import Auxiliary (snoc) -import Codegen.LlvmIr as LIR -import Control.Applicative ((<|>)) -import Control.Monad (when) -import Control.Monad.State ( - StateT, - execStateT, - foldM_, - gets, - modify, +import Codegen.CompilerState ( + CodeGenerator (instructions), + initCodeGenerator, + ) +import Codegen.Emits (compileScs) +import Codegen.LlvmIr as LIR (llvmIrToString) +import Control.Monad.State ( + execStateT, ) -import Data.Bifunctor qualified as BI -import Data.Char (ord) -import Data.Coerce (coerce) -import Data.Map (Map) -import Data.Map qualified as Map -import Data.Maybe (fromJust, fromMaybe) -import Data.Tuple.Extra (dupe, first, second) import Grammar.ErrM (Err) -import Monomorphizer.MonomorphizerIr as MIR -import TypeChecker.TypeCheckerIr qualified as TIR - --- | The record used as the code generator state -data CodeGenerator = CodeGenerator - { instructions :: [LLVMIr] - , functions :: Map MIR.Id FunctionInfo - , customTypes :: Map LLVMType Integer - , constructors :: Map TIR.Ident ConstructorInfo - , variableCount :: Integer - , labelCount :: Integer - } - --- | A state type synonym -type CompilerState a = StateT CodeGenerator Err a - -data FunctionInfo = FunctionInfo - { numArgs :: Int - , arguments :: [Id] - } - deriving (Show) -data ConstructorInfo = ConstructorInfo - { numArgsCI :: Int - , argumentsCI :: [Id] - , numCI :: Integer - , returnTypeCI :: MIR.Type - } - deriving (Show) - --- | Adds a instruction to the CodeGenerator state -emit :: LLVMIr -> CompilerState () -emit l = modify $ \t -> t{instructions = Auxiliary.snoc l $ instructions t} - --- | Increases the variable counter in the CodeGenerator state -increaseVarCount :: CompilerState () -increaseVarCount = modify $ \t -> t{variableCount = variableCount t + 1} - --- | Returns the variable count from the CodeGenerator state -getVarCount :: CompilerState Integer -getVarCount = gets variableCount - --- | Increases the variable count and returns it from the CodeGenerator state -getNewVar :: CompilerState TIR.Ident -getNewVar = TIR.Ident . show <$> (increaseVarCount >> getVarCount) - --- | Increses the label count and returns a label from the CodeGenerator state -getNewLabel :: CompilerState Integer -getNewLabel = do - modify (\t -> t{labelCount = labelCount t + 1}) - gets labelCount - -{- | Produces a map of functions infos from a list of binds, - which contains useful data for code generation. --} -getFunctions :: [MIR.Def] -> Map Id FunctionInfo -getFunctions bs = Map.fromList $ go bs - where - go [] = [] - go (MIR.DBind (MIR.Bind id args _) : xs) = - (id, FunctionInfo{numArgs = length args, arguments = args}) - : go xs - go (_ : xs) = go xs - -createArgs :: [MIR.Type] -> [Id] -createArgs xs = fst $ foldl (\(acc, l) t -> (acc ++ [(TIR.Ident ("arg_" <> show l), t)], l + 1)) ([], 0) xs - -{- | Produces a map of functions infos from a list of binds, - which contains useful data for code generation. --} -getConstructors :: [MIR.Def] -> Map TIR.Ident ConstructorInfo -getConstructors bs = Map.fromList $ go bs - where - go [] = [] - go (MIR.DData (MIR.Data t cons) : xs) = - fst - ( foldl - ( \(acc, i) (Inj id xs) -> - ( ( id - , ConstructorInfo - { numArgsCI = length (init . flattenType $ xs) - , argumentsCI = createArgs (init . flattenType $ xs) - , numCI = i - , returnTypeCI = t -- last . flattenType $ xs - } - ) - : acc - , i + 1 - ) - ) - ([], 0) - cons - ) - <> go xs - go (_ : xs) = go xs - -getTypes :: [MIR.Def] -> Map LLVMType Integer -getTypes bs = Map.fromList $ go bs - where - go [] = [] - go (MIR.DData (MIR.Data t ts) : xs) = (type2LlvmType t, biggestVariant ts) : go xs - go (_ : xs) = go xs - variantTypes fi = init $ map type2LlvmType (flattenType fi) - biggestVariant ts = 8 + maximum (sum . (\(Inj _ fi) -> typeByteSize <$> variantTypes fi) <$> ts) - -initCodeGenerator :: [MIR.Def] -> CodeGenerator -initCodeGenerator scs = - CodeGenerator - { instructions = defaultStart - , functions = getFunctions scs - , constructors = getConstructors scs - , customTypes = getTypes scs - , variableCount = 0 - , labelCount = 0 - } - -{- -run :: Err String -> IO () -run s = do - let s' = case s of - Right s -> s - Left _ -> error "yo" - writeFile "output/llvm.ll" s' - putStrLn . trim =<< readCreateProcess (shell "lli") s' - -test :: Integer -> Program -test v = - Program - [ DataType - (TIR.Ident "Craig") - [ Constructor (TIR.Ident "Bob") [MIR.Type (TIR.Ident "_Int")] - , Constructor (TIR.Ident "Betty") [MIR.Type (TIR.Ident "_Int")] - ] - , DataType - (TIR.Ident "Alice") - [ Constructor (TIR.Ident "Eve") [MIR.Type (TIR.Ident "_Int")] -- , - -- (TIR.Ident "Alice", [TInt, TInt]) - ] - , Bind (TIR.Ident "fibonacci", MIR.Type (TIR.Ident "_Int")) [(TIR.Ident "x", MIR.Type (TIR.Ident "_Int"))] (EId ("x", MIR.Type (TIR.Ident "Craig")), MIR.Type (TIR.Ident "Craig")) - , Bind (TIR.Ident "main", MIR.Type (TIR.Ident "_Int")) [] - -- (EApp (MIR.Type (TIR.Ident "Craig")) (EId (TIR.Ident "Craig_Bob", MIR.Type (TIR.Ident "Craig")), MIR.Type (TIR.Ident "Craig")) (ELit (LInt v), MIR.Type (TIR.Ident "_Int")), MIR.Type (TIR.Ident "Craig"))-- (EInt 92) - $ - eCaseInt - (EApp (MIR.TLit (TIR.Ident "Craig")) (EId (TIR.Ident "Craig_Bob", MIR.TLit (TIR.Ident "Craig")), MIR.TLit (TIR.Ident "Craig")) (ELit (LInt v), MIR.Type (TIR.Ident "_Int")), MIR.Type (TIR.Ident "Craig")) - [ injectionCons "Craig_Bob" "Craig" [CIdent (TIR.Ident "x")] (EId (TIR.Ident "x", MIR.Type (TIR.Ident "_Int")), MIR.Type (TIR.Ident "_Int")) - , injectionCons "Craig_Betty" "Craig" [CLit (LInt 5)] (int 2) - , Injection (CIdent (TIR.Ident "z")) (int 3) - , -- , injectionInt 5 (int 6) - injectionCatchAll (int 10) - ] - ] - where - injectionCons x y xs = Injection (CCons (TIR.Ident x, MIR.Type (TIR.Ident y)) xs) - injectionInt x = Injection (CLit (LInt x)) - injectionCatchAll = Injection CatchAll - eCaseInt x xs = (ECase (MIR.TLit (MIR.Ident "_Int")) x xs, MIR.TLit (MIR.Ident "_Int")) - int x = (ELit (LInt x), MIR.TLit (MIR.Ident "_Int")) --} +import Monomorphizer.MonomorphizerIr as MIR (Program (..)) {- | Compiles an AST and produces a LLVM Ir string. An easy way to actually "compile" this output is to @@ -188,397 +20,3 @@ generateCode :: MIR.Program -> Err String generateCode (MIR.Program scs) = do let codegen = initCodeGenerator scs llvmIrToString . instructions <$> execStateT (compileScs scs) codegen - -compileScs :: [MIR.Def] -> CompilerState () -compileScs [] = do - emit $ UnsafeRaw "\n" - -- as a last step create all the constructors - -- //TODO maybe merge this with the data type match? - c <- gets (Map.toList . constructors) - mapM_ - ( \(id, ci) -> do - let t = returnTypeCI ci - let t' = type2LlvmType t - let x = BI.second type2LlvmType <$> argumentsCI ci - emit $ Define FastCC t' id x - top <- getNewVar - ptr <- getNewVar - -- allocated the primary type - emit $ SetVariable top (Alloca t') - - -- set the first byte to the index of the constructor - emit $ - SetVariable ptr $ - GetElementPtr - t' - (Ref t') - (VIdent top I8) - I64 - (VInteger 0) - I32 - (VInteger 0) - emit $ Store I8 (VInteger $ numCI ci) (Ref I8) ptr - - -- get a pointer of the correct type - ptr' <- getNewVar - emit $ SetVariable ptr' (Bitcast (Ref t') (VIdent top Ptr) (Ref $ CustomType id)) - cTypes <- gets customTypes - - enumerateOneM_ - ( \i (TIR.Ident arg_n, arg_t) -> do - let arg_t' = type2LlvmType arg_t - emit $ Comment (toIr arg_t' <> " " <> arg_n <> " " <> show i) - elemPtr <- getNewVar - emit $ - SetVariable - elemPtr - ( GetElementPtr - (CustomType id) - (Ref (CustomType id)) - (VIdent ptr' Ptr) - I64 - (VInteger 0) - I32 - (VInteger i) - ) - case Map.lookup arg_t' cTypes of - Just s -> do - emit $ Comment "Malloc and store" - heapPtr <- getNewVar - emit $ SetVariable heapPtr (Malloca s) - emit $ Store arg_t' (VIdent (TIR.Ident arg_n) arg_t') Ptr heapPtr - emit $ Store (Ref arg_t') (VIdent heapPtr arg_t') Ptr elemPtr - Nothing -> do - emit $ Comment "Just store" - emit $ Store arg_t' (VIdent (TIR.Ident arg_n) arg_t') Ptr elemPtr - ) - (argumentsCI ci) - - -- load and return the constructed value - emit $ Comment "Return the newly constructed value" - load <- getNewVar - emit $ SetVariable load (Load t' Ptr top) - emit $ Ret t' (VIdent load t') - emit DefineEnd - emit $ UnsafeRaw "\n" - - modify $ \s -> s{variableCount = 0} - ) - c -compileScs (MIR.DBind (MIR.Bind (name, t) args exp) : xs) = do - let t_return = type2LlvmType . last . flattenType $ t - emit $ UnsafeRaw "\n" - emit . Comment $ show name <> ": " <> show exp - let args' = map (second type2LlvmType) args - emit $ Define FastCC t_return name args' - when (name == "main") (mapM_ emit firstMainContent) - functionBody <- exprToValue exp - if name == "main" - then mapM_ emit $ lastMainContent functionBody - else emit $ Ret t_return functionBody - emit DefineEnd - modify $ \s -> s{variableCount = 0} - compileScs xs -compileScs (MIR.DData (MIR.Data typ ts) : xs) = do - let (TIR.Ident outer_id) = extractTypeName typ - -- //TODO this could be extracted from the customTypes map - let variantTypes fi = init $ map type2LlvmType (flattenType fi) - let biggestVariant = 7 + maximum (sum . (\(Inj _ fi) -> typeByteSize <$> variantTypes fi) <$> ts) - emit $ LIR.Type (TIR.Ident outer_id) [I8, Array biggestVariant I8] - typeSets <- gets customTypes - mapM_ - ( \(Inj inner_id fi) -> do - let types = (\s -> if Map.member s typeSets then Ref s else s) <$> variantTypes fi - emit $ LIR.Type inner_id (I8 : types) - ) - ts - compileScs xs - -firstMainContent :: [LLVMIr] -firstMainContent = - [] - --- UnsafeRaw "call void @_ZN2GC4Heap4initEv()\n" - -lastMainContent :: LLVMValue -> [LLVMIr] -lastMainContent var = - [ UnsafeRaw $ - "call i32 (ptr, ...) @printf(ptr noundef @.str, i64 noundef " <> toIr var <> ")\n" - , Ret I64 (VInteger 0) - ] - -defaultStart :: [LLVMIr] -defaultStart = - [ UnsafeRaw "target triple = \"x86_64-pc-linux-gnu\"\n" - , UnsafeRaw "target datalayout = \"e-m:o-i64:64-f80:128-n8:16:32:64-S128\"\n" - , UnsafeRaw "@.str = private unnamed_addr constant [3 x i8] c\"%i\n\", align 1\n" - , UnsafeRaw "@.non_exhaustive_patterns = private unnamed_addr constant [41 x i8] c\"Non-exhaustive patterns in case at %i:%i\n\"\n" - , UnsafeRaw "declare i32 @printf(ptr noalias nocapture, ...)\n" - , UnsafeRaw "declare i32 @exit(i32 noundef)\n" - , UnsafeRaw "declare ptr @malloc(i32 noundef)\n" - , UnsafeRaw "declare void @_ZN2GC4Heap4initEv()\n" - , UnsafeRaw "declare void @_ZN2GC4Heap5allocEm()\n" - , UnsafeRaw "declare void @_ZN2GC4Heap7disposeEv()\n" - ] - -compileExp :: ExpT -> CompilerState () -compileExp (MIR.ELit lit, _t) = emitLit lit -compileExp (MIR.EAdd e1 e2, t) = emitAdd t e1 e2 --- compileExp (ESub t e1 e2) = emitSub t e1 e2 -compileExp (MIR.EVar name, _t) = emitIdent name -compileExp (MIR.EApp e1 e2, t) = emitApp t e1 e2 --- compileExp (EAbs t ti e) = emitAbs t ti e -compileExp (MIR.ELet bind e, _) = emitLet bind e -compileExp (MIR.ECase e cs, t) = emitECased t e (map (t,) cs) - --- go (EMul e1 e2) = emitMul e1 e2 --- go (EDiv e1 e2) = emitDiv e1 e2 --- go (EMod e1 e2) = emitMod e1 e2 - ---- aux functions --- -emitLet :: MIR.Bind -> ExpT -> CompilerState () -emitLet (MIR.Bind id [] innerExp) e = do - evaled <- exprToValue innerExp - tempVar <- getNewVar - let t = type2LlvmType . snd $ innerExp - emit $ SetVariable tempVar (Alloca t) - emit $ Store (type2LlvmType . snd $ innerExp) evaled Ptr tempVar - emit $ SetVariable (fst id) (Load t Ptr tempVar) - compileExp e -emitLet b _ = error $ "Non empty argument list in let-bind " <> show b - -emitECased :: MIR.Type -> ExpT -> [(MIR.Type, Branch)] -> CompilerState () -emitECased t e cases = do - let cs = snd <$> cases - let ty = type2LlvmType t - let rt = type2LlvmType (snd e) - vs <- exprToValue e - lbl <- getNewLabel - let label = TIR.Ident $ "escape_" <> show lbl - stackPtr <- getNewVar - emit $ SetVariable stackPtr (Alloca ty) - mapM_ (emitCases rt ty label stackPtr vs) cs - -- crashLbl <- TIR.Ident . ("crash_" <>) . show <$> getNewLabel - -- emit $ Label crashLbl - emit . UnsafeRaw $ "call i32 (ptr, ...) @printf(ptr noundef @.non_exhaustive_patterns, i64 noundef 6, i64 noundef 6)\n" - emit . UnsafeRaw $ "call i32 @exit(i32 noundef 1)\n" - mapM_ (const increaseVarCount) [0 .. 1] - emit $ Br label - emit $ Label label - res <- getNewVar - emit $ SetVariable res (Load ty Ptr stackPtr) - where - emitCases :: LLVMType -> LLVMType -> TIR.Ident -> TIR.Ident -> LLVMValue -> Branch -> CompilerState () - emitCases rt ty label stackPtr vs (Branch (MIR.PInj consId cs, _t) exp) = do - emit $ Comment "Inj" - cons <- gets constructors - let r = fromJust $ Map.lookup consId cons - - lbl_failPos <- (\x -> TIR.Ident $ "failed_" <> show x) <$> getNewLabel - lbl_succPos <- (\x -> TIR.Ident $ "success_" <> show x) <$> getNewLabel - - consVal <- getNewVar - emit $ SetVariable consVal (ExtractValue rt vs 0) - - consCheck <- getNewVar - emit $ SetVariable consCheck (Icmp LLEq I8 (VIdent consVal I8) (VInteger $ numCI r)) - emit $ BrCond (VIdent consCheck ty) lbl_succPos lbl_failPos - emit $ Label lbl_succPos - - castPtr <- getNewVar - casted <- getNewVar - emit $ SetVariable castPtr (Alloca rt) - emit $ Store rt vs Ptr castPtr - emit $ SetVariable casted (Load (CustomType (coerce consId)) Ptr castPtr) - enumerateOneM_ - ( \i c -> do - case c of - PVar (x, topT) -> do - let topT' = type2LlvmType topT - let botT' = CustomType (coerce consId) - emit . Comment $ "ident " <> toIr topT' - cTypes <- gets customTypes - if Map.member topT' cTypes - then do - deref <- getNewVar - emit $ SetVariable deref (ExtractValue botT' (VIdent casted Ptr) i) - emit $ SetVariable x (Load topT' Ptr deref) - else emit $ SetVariable x (ExtractValue botT' (VIdent casted Ptr) i) - PLit (_l, _t) -> undefined - PInj _id _ps -> undefined - PCatch -> pure () - PEnum _id -> undefined - ) - cs - val <- exprToValue exp - emit $ Store ty val Ptr stackPtr - emit $ Br label - emit $ Label lbl_failPos - emitCases _rt ty label stackPtr vs (Branch (MIR.PLit i, t) exp) = do - emit $ Comment "Plit" - let i' = case i of - (MIR.LInt i, _) -> VInteger i - (MIR.LChar i, _) -> VChar (ord i) - ns <- getNewVar - lbl_failPos <- (\x -> TIR.Ident $ "failed_" <> show x) <$> getNewLabel - lbl_succPos <- (\x -> TIR.Ident $ "success_" <> show x) <$> getNewLabel - emit $ SetVariable ns (Icmp LLEq (type2LlvmType t) vs i') - emit $ BrCond (VIdent ns ty) lbl_succPos lbl_failPos - emit $ Label lbl_succPos - val <- exprToValue exp - emit $ Store ty val Ptr stackPtr - emit $ Br label - emit $ Label lbl_failPos - emitCases rt ty label stackPtr vs (Branch (MIR.PVar (id, _), _) exp) = do - emit $ Comment "Pvar" - -- //TODO this is pretty disgusting and would heavily benefit from a rewrite - valPtr <- getNewVar - emit $ SetVariable valPtr (Alloca rt) - emit $ Store rt vs Ptr valPtr - emit $ SetVariable id (Load rt Ptr valPtr) - val <- exprToValue exp - emit $ Store ty val Ptr stackPtr - emit $ Br label - lbl_failPos <- (\x -> TIR.Ident $ "failed_" <> show x) <$> getNewLabel - emit $ Label lbl_failPos - emitCases _rt ty label stackPtr _vs (Branch (MIR.PEnum _id, _) exp) = do - -- //TODO Penum wrong, acts as a catch all - emit $ Comment "Penum" - val <- exprToValue exp - emit $ Store ty val Ptr stackPtr - emit $ Br label - lbl_failPos <- (\x -> TIR.Ident $ "failed_" <> show x) <$> getNewLabel - emit $ Label lbl_failPos - emitCases _ ty label stackPtr _ (Branch (MIR.PCatch, _) exp) = do - emit $ Comment "Pcatch" - val <- exprToValue exp - emit $ Store ty val Ptr stackPtr - emit $ Br label - lbl_failPos <- (\x -> TIR.Ident $ "failed_" <> show x) <$> getNewLabel - emit $ Label lbl_failPos - -emitApp :: MIR.Type -> ExpT -> ExpT -> CompilerState () -emitApp rt e1 e2 = appEmitter e1 e2 [] - where - appEmitter :: ExpT -> ExpT -> [ExpT] -> CompilerState () - appEmitter e1 e2 stack = do - let newStack = e2 : stack - case e1 of - (MIR.EApp e1' e2', _) -> appEmitter e1' e2' newStack - (MIR.EVar name, t) -> do - args <- traverse exprToValue newStack - vs <- getNewVar - funcs <- gets functions - consts <- gets constructors - let visibility = - fromMaybe Local $ - Global <$ Map.lookup name consts - <|> Global <$ Map.lookup (name, t) funcs - -- this piece of code could probably be improved, i.e remove the double `const Global` - args' = map (first valueGetType . dupe) args - call = Call FastCC (type2LlvmType rt) visibility name args' - emit $ Comment $ show rt - emit $ SetVariable vs call - x -> error $ "The unspeakable happened: " <> show x - -emitIdent :: TIR.Ident -> CompilerState () -emitIdent id = do - -- !!this should never happen!! - emit $ Comment "This should not have happened!" - emit $ Variable id - emit $ UnsafeRaw "\n" - -emitLit :: MIR.Lit -> CompilerState () -emitLit i = do - -- !!this should never happen!! - let (i', t) = case i of - (MIR.LInt i'') -> (VInteger i'', I64) - (MIR.LChar i'') -> (VChar $ ord i'', I8) - varCount <- getNewVar - emit $ Comment "This should not have happened!" - emit $ SetVariable varCount (Add t i' (VInteger 0)) - -emitAdd :: MIR.Type -> ExpT -> ExpT -> CompilerState () -emitAdd t e1 e2 = do - v1 <- exprToValue e1 - v2 <- exprToValue e2 - v <- getNewVar - emit $ SetVariable v (Add (type2LlvmType t) v1 v2) - -exprToValue :: ExpT -> CompilerState LLVMValue -exprToValue = \case - (MIR.ELit i, _t) -> pure $ case i of - (MIR.LInt i) -> VInteger i - (MIR.LChar i) -> VChar $ ord i - (MIR.EVar name, t) -> do - funcs <- gets functions - cons <- gets constructors - let res = - Map.lookup (name, t) funcs - <|> ( \c -> - FunctionInfo - { numArgs = numArgsCI c - , arguments = argumentsCI c - } - ) - <$> Map.lookup name cons - case res of - Just fi -> do - if numArgs fi == 0 - then do - vc <- getNewVar - emit $ - SetVariable - vc - (Call FastCC (type2LlvmType t) Global name []) - pure $ VIdent vc (type2LlvmType t) - else pure $ VFunction name Global (type2LlvmType t) - Nothing -> pure $ VIdent name (type2LlvmType t) - e -> do - compileExp e - v <- getVarCount - pure $ VIdent (TIR.Ident $ show v) (getType e) - -type2LlvmType :: MIR.Type -> LLVMType -type2LlvmType (MIR.TLit id@(TIR.Ident name)) = case name of - "Int" -> I64 - "Char" -> I8 - _ -> CustomType id -type2LlvmType (MIR.TFun t xs) = do - let (t', xs') = function2LLVMType xs [type2LlvmType t] - Function t' xs' - where - function2LLVMType :: Type -> [LLVMType] -> (LLVMType, [LLVMType]) - function2LLVMType (TFun t xs) s = function2LLVMType xs (type2LlvmType t : s) - function2LLVMType x s = (type2LlvmType x, s) - -getType :: ExpT -> LLVMType -getType (_, t) = type2LlvmType t - -extractTypeName :: MIR.Type -> TIR.Ident -extractTypeName (MIR.TLit id) = id -extractTypeName (MIR.TFun t xs) = - let (TIR.Ident i) = extractTypeName t - (TIR.Ident is) = extractTypeName xs - in TIR.Ident $ i <> "_$_" <> is - -valueGetType :: LLVMValue -> LLVMType -valueGetType (VInteger _) = I64 -valueGetType (VChar _) = I8 -valueGetType (VIdent _ t) = t -valueGetType (VConstant s) = Array (fromIntegral $ length s) I8 -valueGetType (VFunction _ _ t) = t - -typeByteSize :: LLVMType -> Integer -typeByteSize I1 = 1 -typeByteSize I8 = 1 -typeByteSize I32 = 4 -typeByteSize I64 = 8 -typeByteSize Ptr = 8 -typeByteSize (Ref _) = 8 -typeByteSize (Function _ _) = 8 -typeByteSize (Array n t) = n * typeByteSize t -typeByteSize (CustomType _) = 8 - -enumerateOneM_ :: Monad m => (Integer -> a -> m b) -> [a] -> m () -enumerateOneM_ f = foldM_ (\i a -> f i a >> pure (i + 1)) 1 diff --git a/src/Codegen/CompilerState.hs b/src/Codegen/CompilerState.hs new file mode 100644 index 0000000..a6c100a --- /dev/null +++ b/src/Codegen/CompilerState.hs @@ -0,0 +1,141 @@ +module Codegen.CompilerState where + +import Auxiliary (snoc) +import Codegen.Auxillary (type2LlvmType, typeByteSize) +import Codegen.LlvmIr as LIR (LLVMIr (UnsafeRaw), LLVMType) +import Control.Monad.State ( + StateT, + gets, + modify, + ) +import Data.Map (Map) +import Data.Map qualified as Map +import Grammar.ErrM (Err) +import Monomorphizer.MonomorphizerIr as MIR +import TypeChecker.TypeCheckerIr qualified as TIR + +-- | The record used as the code generator state +data CodeGenerator = CodeGenerator + { instructions :: [LLVMIr] + , functions :: Map MIR.Id FunctionInfo + , customTypes :: Map LLVMType Integer + , constructors :: Map TIR.Ident ConstructorInfo + , variableCount :: Integer + , labelCount :: Integer + } + +-- | A state type synonym +type CompilerState a = StateT CodeGenerator Err a + +data FunctionInfo = FunctionInfo + { numArgs :: Int + , arguments :: [Id] + } + deriving (Show) +data ConstructorInfo = ConstructorInfo + { numArgsCI :: Int + , argumentsCI :: [Id] + , numCI :: Integer + , returnTypeCI :: MIR.Type + } + deriving (Show) + +-- | Adds a instruction to the CodeGenerator state +emit :: LLVMIr -> CompilerState () +emit l = modify $ \t -> t{instructions = Auxiliary.snoc l $ instructions t} + +-- | Increases the variable counter in the CodeGenerator state +increaseVarCount :: CompilerState () +increaseVarCount = modify $ \t -> t{variableCount = variableCount t + 1} + +-- | Returns the variable count from the CodeGenerator state +getVarCount :: CompilerState Integer +getVarCount = gets variableCount + +-- | Increases the variable count and returns it from the CodeGenerator state +getNewVar :: CompilerState TIR.Ident +getNewVar = TIR.Ident . show <$> (increaseVarCount >> getVarCount) + +-- | Increses the label count and returns a label from the CodeGenerator state +getNewLabel :: CompilerState Integer +getNewLabel = do + modify (\t -> t{labelCount = labelCount t + 1}) + gets labelCount + +{- | Produces a map of functions infos from a list of binds, + which contains useful data for code generation. +-} +getFunctions :: [MIR.Def] -> Map Id FunctionInfo +getFunctions bs = Map.fromList $ go bs + where + go [] = [] + go (MIR.DBind (MIR.Bind id args _) : xs) = + (id, FunctionInfo{numArgs = length args, arguments = args}) + : go xs + go (_ : xs) = go xs + +createArgs :: [MIR.Type] -> [Id] +createArgs xs = fst $ foldl (\(acc, l) t -> (acc ++ [(TIR.Ident ("arg_" <> show l), t)], l + 1)) ([], 0) xs + +{- | Produces a map of functions infos from a list of binds, + which contains useful data for code generation. +-} +getConstructors :: [MIR.Def] -> Map TIR.Ident ConstructorInfo +getConstructors bs = Map.fromList $ go bs + where + go [] = [] + go (MIR.DData (MIR.Data t cons) : xs) = + fst + ( foldl + ( \(acc, i) (Inj id xs) -> + ( ( id + , ConstructorInfo + { numArgsCI = length (init . flattenType $ xs) + , argumentsCI = createArgs (init . flattenType $ xs) + , numCI = i + , returnTypeCI = t -- last . flattenType $ xs + } + ) + : acc + , i + 1 + ) + ) + ([], 0) + cons + ) + <> go xs + go (_ : xs) = go xs + +getTypes :: [MIR.Def] -> Map LLVMType Integer +getTypes bs = Map.fromList $ go bs + where + go [] = [] + go (MIR.DData (MIR.Data t ts) : xs) = (type2LlvmType t, biggestVariant ts) : go xs + go (_ : xs) = go xs + variantTypes fi = init $ map type2LlvmType (flattenType fi) + biggestVariant ts = 8 + maximum (sum . (\(Inj _ fi) -> typeByteSize <$> variantTypes fi) <$> ts) + +initCodeGenerator :: [MIR.Def] -> CodeGenerator +initCodeGenerator scs = + CodeGenerator + { instructions = defaultStart + , functions = getFunctions scs + , constructors = getConstructors scs + , customTypes = getTypes scs + , variableCount = 0 + , labelCount = 0 + } + +defaultStart :: [LLVMIr] +defaultStart = + [ UnsafeRaw "target triple = \"x86_64-pc-linux-gnu\"\n" + , UnsafeRaw "target datalayout = \"e-m:o-i64:64-f80:128-n8:16:32:64-S128\"\n" + , UnsafeRaw "@.str = private unnamed_addr constant [3 x i8] c\"%i\n\", align 1\n" + , UnsafeRaw "@.non_exhaustive_patterns = private unnamed_addr constant [41 x i8] c\"Non-exhaustive patterns in case at %i:%i\n\"\n" + , UnsafeRaw "declare i32 @printf(ptr noalias nocapture, ...)\n" + , UnsafeRaw "declare i32 @exit(i32 noundef)\n" + , UnsafeRaw "declare ptr @malloc(i32 noundef)\n" + , UnsafeRaw "declare void @_ZN2GC4Heap4initEv()\n" + , UnsafeRaw "declare void @_ZN2GC4Heap5allocEm()\n" + , UnsafeRaw "declare void @_ZN2GC4Heap7disposeEv()\n" + ] \ No newline at end of file diff --git a/src/Codegen/Emits.hs b/src/Codegen/Emits.hs new file mode 100644 index 0000000..c41e340 --- /dev/null +++ b/src/Codegen/Emits.hs @@ -0,0 +1,348 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} + +module Codegen.Emits where + +import Codegen.Auxillary +import Codegen.CompilerState +import Codegen.LlvmIr as LIR +import Control.Applicative ((<|>)) +import Control.Monad (when) +import Control.Monad.State ( + gets, + modify, + ) +import Data.Bifunctor qualified as BI +import Data.Char (ord) +import Data.Coerce (coerce) +import Data.Map qualified as Map +import Data.Maybe (fromJust, fromMaybe) +import Data.Tuple.Extra (dupe, first, second) +import Monomorphizer.MonomorphizerIr as MIR +import TypeChecker.TypeCheckerIr qualified as TIR + +compileScs :: [MIR.Def] -> CompilerState () +compileScs [] = do + emit $ UnsafeRaw "\n" + -- as a last step create all the constructors + -- //TODO maybe merge this with the data type match? + c <- gets (Map.toList . constructors) + mapM_ + ( \(id, ci) -> do + let t = returnTypeCI ci + let t' = type2LlvmType t + let x = BI.second type2LlvmType <$> argumentsCI ci + emit $ Define FastCC t' id x + top <- getNewVar + ptr <- getNewVar + -- allocated the primary type + emit $ SetVariable top (Alloca t') + + -- set the first byte to the index of the constructor + emit $ + SetVariable ptr $ + GetElementPtr + t' + (Ref t') + (VIdent top I8) + I64 + (VInteger 0) + I32 + (VInteger 0) + emit $ Store I8 (VInteger $ numCI ci) (Ref I8) ptr + + -- get a pointer of the correct type + ptr' <- getNewVar + emit $ SetVariable ptr' (Bitcast (Ref t') (VIdent top Ptr) (Ref $ CustomType id)) + cTypes <- gets customTypes + + enumerateOneM_ + ( \i (TIR.Ident arg_n, arg_t) -> do + let arg_t' = type2LlvmType arg_t + emit $ Comment (toIr arg_t' <> " " <> arg_n <> " " <> show i) + elemPtr <- getNewVar + emit $ + SetVariable + elemPtr + ( GetElementPtr + (CustomType id) + (Ref (CustomType id)) + (VIdent ptr' Ptr) + I64 + (VInteger 0) + I32 + (VInteger i) + ) + case Map.lookup arg_t' cTypes of + Just s -> do + emit $ Comment "Malloc and store" + heapPtr <- getNewVar + emit $ SetVariable heapPtr (Malloca s) + emit $ Store arg_t' (VIdent (TIR.Ident arg_n) arg_t') Ptr heapPtr + emit $ Store (Ref arg_t') (VIdent heapPtr arg_t') Ptr elemPtr + Nothing -> do + emit $ Comment "Just store" + emit $ Store arg_t' (VIdent (TIR.Ident arg_n) arg_t') Ptr elemPtr + ) + (argumentsCI ci) + + -- load and return the constructed value + emit $ Comment "Return the newly constructed value" + load <- getNewVar + emit $ SetVariable load (Load t' Ptr top) + emit $ Ret t' (VIdent load t') + emit DefineEnd + emit $ UnsafeRaw "\n" + + modify $ \s -> s{variableCount = 0} + ) + c +compileScs (MIR.DBind (MIR.Bind (name, t) args exp) : xs) = do + let t_return = type2LlvmType . last . flattenType $ t + emit $ UnsafeRaw "\n" + emit . Comment $ show name <> ": " <> show exp + let args' = map (second type2LlvmType) args + emit $ Define FastCC t_return name args' + when (name == "main") (mapM_ emit firstMainContent) + functionBody <- exprToValue exp + if name == "main" + then mapM_ emit $ lastMainContent functionBody + else emit $ Ret t_return functionBody + emit DefineEnd + modify $ \s -> s{variableCount = 0} + compileScs xs +compileScs (MIR.DData (MIR.Data typ ts) : xs) = do + let (TIR.Ident outer_id) = extractTypeName typ + -- //TODO this could be extracted from the customTypes map + let variantTypes fi = init $ map type2LlvmType (flattenType fi) + let biggestVariant = 7 + maximum (sum . (\(Inj _ fi) -> typeByteSize <$> variantTypes fi) <$> ts) + emit $ LIR.Type (TIR.Ident outer_id) [I8, Array biggestVariant I8] + typeSets <- gets customTypes + mapM_ + ( \(Inj inner_id fi) -> do + let types = (\s -> if Map.member s typeSets then Ref s else s) <$> variantTypes fi + emit $ LIR.Type inner_id (I8 : types) + ) + ts + compileScs xs + +firstMainContent :: [LLVMIr] +firstMainContent = [] + +lastMainContent :: LLVMValue -> [LLVMIr] +lastMainContent var = + [ UnsafeRaw $ + "call i32 (ptr, ...) @printf(ptr noundef @.str, i64 noundef " <> toIr var <> ")\n" + , Ret I64 (VInteger 0) + ] + +compileExp :: ExpT -> CompilerState () +compileExp (MIR.ELit lit, _t) = emitLit lit +compileExp (MIR.EAdd e1 e2, t) = emitAdd t e1 e2 +compileExp (MIR.EVar name, _t) = emitIdent name +compileExp (MIR.EApp e1 e2, t) = emitApp t e1 e2 +compileExp (MIR.ELet bind e, _) = emitLet bind e +compileExp (MIR.ECase e cs, t) = emitECased t e (map (t,) cs) + +emitLet :: MIR.Bind -> ExpT -> CompilerState () +emitLet (MIR.Bind id [] innerExp) e = do + evaled <- exprToValue innerExp + tempVar <- getNewVar + let t = type2LlvmType . snd $ innerExp + emit $ SetVariable tempVar (Alloca t) + emit $ Store (type2LlvmType . snd $ innerExp) evaled Ptr tempVar + emit $ SetVariable (fst id) (Load t Ptr tempVar) + compileExp e +emitLet b _ = error $ "Non empty argument list in let-bind " <> show b + +emitECased :: MIR.Type -> ExpT -> [(MIR.Type, Branch)] -> CompilerState () +emitECased t e cases = do + let cs = snd <$> cases + let ty = type2LlvmType t + let rt = type2LlvmType (snd e) + vs <- exprToValue e + lbl <- getNewLabel + let label = TIR.Ident $ "escape_" <> show lbl + stackPtr <- getNewVar + emit $ SetVariable stackPtr (Alloca ty) + mapM_ (emitCases rt ty label stackPtr vs) cs + -- crashLbl <- TIR.Ident . ("crash_" <>) . show <$> getNewLabel + -- emit $ Label crashLbl + emit . UnsafeRaw $ "call i32 (ptr, ...) @printf(ptr noundef @.non_exhaustive_patterns, i64 noundef 6, i64 noundef 6)\n" + emit . UnsafeRaw $ "call i32 @exit(i32 noundef 1)\n" + mapM_ (const increaseVarCount) [0 .. 1] + emit $ Br label + emit $ Label label + res <- getNewVar + emit $ SetVariable res (Load ty Ptr stackPtr) + where + emitCases :: LLVMType -> LLVMType -> TIR.Ident -> TIR.Ident -> LLVMValue -> Branch -> CompilerState () + emitCases rt ty label stackPtr vs (Branch (MIR.PInj consId cs, _t) exp) = do + emit $ Comment "Inj" + cons <- gets constructors + let r = fromJust $ Map.lookup consId cons + + lbl_failPos <- (\x -> TIR.Ident $ "failed_" <> show x) <$> getNewLabel + lbl_succPos <- (\x -> TIR.Ident $ "success_" <> show x) <$> getNewLabel + + consVal <- getNewVar + emit $ SetVariable consVal (ExtractValue rt vs 0) + + consCheck <- getNewVar + emit $ SetVariable consCheck (Icmp LLEq I8 (VIdent consVal I8) (VInteger $ numCI r)) + emit $ BrCond (VIdent consCheck ty) lbl_succPos lbl_failPos + emit $ Label lbl_succPos + + castPtr <- getNewVar + casted <- getNewVar + emit $ SetVariable castPtr (Alloca rt) + emit $ Store rt vs Ptr castPtr + emit $ SetVariable casted (Load (CustomType (coerce consId)) Ptr castPtr) + enumerateOneM_ + ( \i c -> do + case c of + PVar (x, topT) -> do + let topT' = type2LlvmType topT + let botT' = CustomType (coerce consId) + emit . Comment $ "ident " <> toIr topT' + cTypes <- gets customTypes + if Map.member topT' cTypes + then do + deref <- getNewVar + emit $ SetVariable deref (ExtractValue botT' (VIdent casted Ptr) i) + emit $ SetVariable x (Load topT' Ptr deref) + else emit $ SetVariable x (ExtractValue botT' (VIdent casted Ptr) i) + PLit (_l, _t) -> undefined + PInj _id _ps -> undefined + PCatch -> pure () + PEnum _id -> undefined + ) + cs + val <- exprToValue exp + emit $ Store ty val Ptr stackPtr + emit $ Br label + emit $ Label lbl_failPos + emitCases _rt ty label stackPtr vs (Branch (MIR.PLit i, t) exp) = do + emit $ Comment "Plit" + let i' = case i of + (MIR.LInt i, _) -> VInteger i + (MIR.LChar i, _) -> VChar (ord i) + ns <- getNewVar + lbl_failPos <- (\x -> TIR.Ident $ "failed_" <> show x) <$> getNewLabel + lbl_succPos <- (\x -> TIR.Ident $ "success_" <> show x) <$> getNewLabel + emit $ SetVariable ns (Icmp LLEq (type2LlvmType t) vs i') + emit $ BrCond (VIdent ns ty) lbl_succPos lbl_failPos + emit $ Label lbl_succPos + val <- exprToValue exp + emit $ Store ty val Ptr stackPtr + emit $ Br label + emit $ Label lbl_failPos + emitCases rt ty label stackPtr vs (Branch (MIR.PVar (id, _), _) exp) = do + emit $ Comment "Pvar" + -- //TODO this is pretty disgusting and would heavily benefit from a rewrite + valPtr <- getNewVar + emit $ SetVariable valPtr (Alloca rt) + emit $ Store rt vs Ptr valPtr + emit $ SetVariable id (Load rt Ptr valPtr) + val <- exprToValue exp + emit $ Store ty val Ptr stackPtr + emit $ Br label + lbl_failPos <- (\x -> TIR.Ident $ "failed_" <> show x) <$> getNewLabel + emit $ Label lbl_failPos + emitCases _rt ty label stackPtr _vs (Branch (MIR.PEnum _id, _) exp) = do + -- //TODO Penum wrong, acts as a catch all + emit $ Comment "Penum" + val <- exprToValue exp + emit $ Store ty val Ptr stackPtr + emit $ Br label + lbl_failPos <- (\x -> TIR.Ident $ "failed_" <> show x) <$> getNewLabel + emit $ Label lbl_failPos + emitCases _ ty label stackPtr _ (Branch (MIR.PCatch, _) exp) = do + emit $ Comment "Pcatch" + val <- exprToValue exp + emit $ Store ty val Ptr stackPtr + emit $ Br label + lbl_failPos <- (\x -> TIR.Ident $ "failed_" <> show x) <$> getNewLabel + emit $ Label lbl_failPos + +emitApp :: MIR.Type -> ExpT -> ExpT -> CompilerState () +emitApp rt e1 e2 = appEmitter e1 e2 [] + where + appEmitter :: ExpT -> ExpT -> [ExpT] -> CompilerState () + appEmitter e1 e2 stack = do + let newStack = e2 : stack + case e1 of + (MIR.EApp e1' e2', _) -> appEmitter e1' e2' newStack + (MIR.EVar name, t) -> do + args <- traverse exprToValue newStack + vs <- getNewVar + funcs <- gets functions + consts <- gets constructors + let visibility = + fromMaybe Local $ + Global <$ Map.lookup name consts + <|> Global <$ Map.lookup (name, t) funcs + -- this piece of code could probably be improved, i.e remove the double `const Global` + args' = map (first valueGetType . dupe) args + call = Call FastCC (type2LlvmType rt) visibility name args' + emit $ Comment $ show rt + emit $ SetVariable vs call + x -> error $ "The unspeakable happened: " <> show x + +emitIdent :: TIR.Ident -> CompilerState () +emitIdent id = do + -- !!this should never happen!! + emit $ Comment "This should not have happened!" + emit $ Variable id + emit $ UnsafeRaw "\n" + +emitLit :: MIR.Lit -> CompilerState () +emitLit i = do + -- !!this should never happen!! + let (i', t) = case i of + (MIR.LInt i'') -> (VInteger i'', I64) + (MIR.LChar i'') -> (VChar $ ord i'', I8) + varCount <- getNewVar + emit $ Comment "This should not have happened!" + emit $ SetVariable varCount (Add t i' (VInteger 0)) + +emitAdd :: MIR.Type -> ExpT -> ExpT -> CompilerState () +emitAdd t e1 e2 = do + v1 <- exprToValue e1 + v2 <- exprToValue e2 + v <- getNewVar + emit $ SetVariable v (Add (type2LlvmType t) v1 v2) + +exprToValue :: ExpT -> CompilerState LLVMValue +exprToValue = \case + (MIR.ELit i, _t) -> pure $ case i of + (MIR.LInt i) -> VInteger i + (MIR.LChar i) -> VChar $ ord i + (MIR.EVar name, t) -> do + funcs <- gets functions + cons <- gets constructors + let res = + Map.lookup (name, t) funcs + <|> ( \c -> + FunctionInfo + { numArgs = numArgsCI c + , arguments = argumentsCI c + } + ) + <$> Map.lookup name cons + case res of + Just fi -> do + if numArgs fi == 0 + then do + vc <- getNewVar + emit $ + SetVariable + vc + (Call FastCC (type2LlvmType t) Global name []) + pure $ VIdent vc (type2LlvmType t) + else pure $ VFunction name Global (type2LlvmType t) + Nothing -> pure $ VIdent name (type2LlvmType t) + e -> do + compileExp e + v <- getVarCount + pure $ VIdent (TIR.Ident $ show v) (getType e) diff --git a/test_program.crf b/test_program.crf index c5b3f9d..14cd86c 100644 --- a/test_program.crf +++ b/test_program.crf @@ -31,7 +31,7 @@ bind x f = case x of { -- represents minus one :) minusOne : Int ; minusOne = 9223372036854775807 + 9223372036854775807 + 1; -{- + ---- LIST STUFF ---- -- a simple list data type containing ints data List () where { @@ -69,4 +69,3 @@ repeat x n = case n of { 0 => Nil ; n => Cons x (repeat x (n + minusOne)) ; }; --} \ No newline at end of file From 343be08a4a799f7ee735b3caa11fc115a206c8e9 Mon Sep 17 00:00:00 2001 From: sebastianselander Date: Wed, 29 Mar 2023 18:47:14 +0200 Subject: [PATCH 242/372] Tried solving bug, failed, added todo message, fixed printing --- src/Renamer/Renamer.hs | 158 +++++++++++++++---------------- src/TypeChecker/TypeCheckerHm.hs | 28 ++++-- 2 files changed, 98 insertions(+), 88 deletions(-) diff --git a/src/Renamer/Renamer.hs b/src/Renamer/Renamer.hs index 0a67e22..48ec228 100644 --- a/src/Renamer/Renamer.hs +++ b/src/Renamer/Renamer.hs @@ -1,22 +1,31 @@ -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedRecordDot #-} module Renamer.Renamer (rename) where -import Auxiliary (mapAccumM) -import Control.Applicative (Applicative (liftA2)) -import Control.Monad.Except (ExceptT, MonadError (throwError), - runExceptT) -import Control.Monad.State (MonadState, State, evalState, gets, - mapAndUnzipM, modify) -import Data.Function (on) -import Data.Map (Map) -import qualified Data.Map as Map -import Data.Maybe (fromMaybe) -import Data.Tuple.Extra (dupe, second) -import Grammar.Abs -import Grammar.ErrM (Err) - +import Auxiliary (mapAccumM) +import Control.Applicative (Applicative (liftA2)) +import Control.Monad.Except ( + ExceptT, + MonadError (throwError), + runExceptT, + ) +import Control.Monad.State ( + MonadState, + State, + evalState, + gets, + mapAndUnzipM, + modify, + ) +import Data.Function (on) +import Data.Map (Map) +import Data.Map qualified as Map +import Data.Maybe (fromMaybe) +import Data.Tuple.Extra (dupe, second) +import Grammar.Abs +import Grammar.ErrM (Err) +import Grammar.Print (printTree) -- | Rename all variables and local binds rename :: Program -> Err Program @@ -25,14 +34,14 @@ rename (Program defs) = Program <$> renameDefs defs initCxt :: Cxt initCxt = Cxt 0 0 -data Cxt = Cxt { var_counter :: Int - , tvar_counter :: Int - } - +data Cxt = Cxt + { var_counter :: Int + , tvar_counter :: Int + } -- | Rename monad. State holds the number of renamed names. -newtype Rn a = Rn { runRn :: ExceptT String (State Cxt) a } - deriving (Functor, Applicative, Monad, MonadState Cxt, MonadError String) +newtype Rn a = Rn {runRn :: ExceptT String (State Cxt) a} + deriving (Functor, Applicative, Monad, MonadState Cxt, MonadError String) -- | Maps old to new name type Names = Map String String @@ -40,67 +49,60 @@ type Names = Map String String renameDefs :: [Def] -> Err [Def] renameDefs defs = evalState (runExceptT (runRn $ mapM renameDef defs)) initCxt where - initNames = Map.fromList [ dupe s | DBind (Bind (LIdent s) _ _) <- defs] + initNames = Map.fromList [dupe s | DBind (Bind (LIdent s) _ _) <- defs] renameDef :: Def -> Rn Def renameDef = \case DSig (Sig name typ) -> DSig . Sig name <$> renameTVars typ DBind (Bind name vars rhs) -> do (new_names, vars') <- newNamesL initNames vars - rhs' <- snd <$> renameExp new_names rhs + rhs' <- snd <$> renameExp new_names rhs pure . DBind $ Bind name vars' rhs' DData (Data typ injs) -> do tvars <- collectTVars [] typ tvars' <- mapM nextNameTVar tvars let tvars_lt = zip tvars tvars' - typ' = substituteTVar tvars_lt typ + typ' = substituteTVar tvars_lt typ injs' = map (renameInj tvars_lt) injs pure . DData $ Data typ' injs' where collectTVars tvars = \case - TAll tvar t -> collectTVars (tvar:tvars) t - TData _ _ -> pure tvars - _ -> throwError ("Bad data type definition: " ++ show typ) + TAll tvar t -> collectTVars (tvar : tvars) t + TData _ _ -> pure tvars + _ -> throwError ("Bad data type definition: " ++ printTree typ) renameInj :: [(TVar, TVar)] -> Inj -> Inj renameInj new_types (Inj name typ) = Inj name $ substituteTVar new_types typ - substituteTVar :: [(TVar, TVar)] -> Type -> Type substituteTVar new_names typ = case typ of TLit _ -> typ - - TVar tvar | Just tvar' <- lookup tvar new_names - -> TVar tvar' - | otherwise - -> typ - + TVar tvar + | Just tvar' <- lookup tvar new_names -> + TVar tvar' + | otherwise -> + typ TFun t1 t2 -> on TFun substitute' t1 t2 - - TAll tvar t | Just tvar' <- lookup tvar new_names - -> TAll tvar' $ substitute' t - | otherwise - -> TAll tvar $ substitute' t - + TAll tvar t + | Just tvar' <- lookup tvar new_names -> + TAll tvar' $ substitute' t + | otherwise -> + TAll tvar $ substitute' t TData name typs -> TData name $ map substitute' typs - _ -> error ("Impossible " ++ show typ) + _ -> error ("Impossible " ++ show typ) where substitute' = substituteTVar new_names - renameExp :: Names -> Exp -> Rn (Names, Exp) renameExp old_names = \case - EVar (LIdent n) -> pure (old_names, EVar . LIdent . fromMaybe n $ Map.lookup n old_names) - EInj (UIdent n) -> pure (old_names, EInj . UIdent . fromMaybe n $ Map.lookup n old_names) - - ELit lit -> pure (old_names, ELit lit) - + EVar (LIdent n) -> pure (old_names, EVar . LIdent . fromMaybe n $ Map.lookup n old_names) + EInj (UIdent n) -> pure (old_names, EInj . UIdent . fromMaybe n $ Map.lookup n old_names) + ELit lit -> pure (old_names, ELit lit) EApp e1 e2 -> do (env1, e1') <- renameExp old_names e1 (env2, e2') <- renameExp old_names e2 pure (Map.union env1 env2, EApp e1' e2') - EAdd e1 e2 -> do (env1, e1') <- renameExp old_names e1 (env2, e2') <- renameExp old_names e2 @@ -111,14 +113,12 @@ renameExp old_names = \case (new_names, name') <- newNameL old_names name (new_names', vars') <- newNamesL new_names vars (new_names'', rhs') <- renameExp new_names' rhs - (new_names''', e') <- renameExp new_names'' e + (new_names''', e') <- renameExp new_names'' e pure (new_names''', ELet (Bind name' vars' rhs') e') - - EAbs par e -> do + EAbs par e -> do (new_names, par') <- newNameL old_names par - (new_names', e') <- renameExp new_names e + (new_names', e') <- renameExp new_names e pure (new_names', EAbs par' e') - EAnn e t -> do (new_names, e') <- renameExp old_names e t' <- renameTVars t @@ -145,8 +145,7 @@ renamePattern ns p = case p of (ns_new, ps') <- mapAccumM renamePattern ns ps return (ns_new, PInj cs ps') PVar name -> second PVar <$> newNameL ns name - _ -> return (ns, p) - + _ -> return (ns, p) renameTVars :: Type -> Rn Type renameTVars typ = case typ of @@ -157,24 +156,25 @@ renameTVars typ = case typ of TFun t1 t2 -> liftA2 TFun (renameTVars t1) (renameTVars t2) _ -> pure typ -substitute :: TVar -- α - -> TVar -- α_n - -> Type -- A - -> Type -- [α_n/α]A +substitute :: + TVar -> -- α + TVar -> -- α_n + Type -> -- A + Type -- [α_n/α]A substitute tvar1 tvar2 typ = case typ of - TLit _ -> typ - TVar tvar | tvar == tvar1 -> TVar tvar2 - | otherwise -> typ - TFun t1 t2 -> on TFun substitute' t1 t2 - TAll tvar t | tvar == tvar1 -> TAll tvar2 $ substitute' t - | otherwise -> TAll tvar $ substitute' t - TData name typs -> TData name $ map substitute' typs - _ -> error "Impossible" + TLit _ -> typ + TVar tvar + | tvar == tvar1 -> TVar tvar2 + | otherwise -> typ + TFun t1 t2 -> on TFun substitute' t1 t2 + TAll tvar t + | tvar == tvar1 -> TAll tvar2 $ substitute' t + | otherwise -> TAll tvar $ substitute' t + TData name typs -> TData name $ map substitute' typs + _ -> error "Impossible" where substitute' = substitute tvar1 tvar2 - - -- | Create multiple names and add them to the name environment newNamesL :: Names -> [LIdent] -> Rn (Names, [LIdent]) newNamesL = mapAccumM newNameL @@ -185,7 +185,6 @@ newNameL env (LIdent old_name) = do new_name <- makeName old_name pure (Map.insert old_name new_name env, LIdent new_name) - -- | Create multiple names and add them to the name environment newNamesU :: Names -> [UIdent] -> Rn (Names, [UIdent]) newNamesU = mapAccumM newNameU @@ -196,18 +195,17 @@ newNameU env (UIdent old_name) = do new_name <- makeName old_name pure (Map.insert old_name new_name env, UIdent new_name) - -- | Annotate name with number and increment the number @prefix ⇒ prefix_number@. makeName :: String -> Rn String makeName prefix = do - i <- gets var_counter - let name = prefix ++ "_" ++ show i - modify $ \cxt -> cxt { var_counter = succ cxt.var_counter} - pure name + i <- gets var_counter + let name = prefix ++ "_" ++ show i + modify $ \cxt -> cxt{var_counter = succ cxt.var_counter} + pure name nextNameTVar :: TVar -> Rn TVar -nextNameTVar (MkTVar (LIdent s))= do - i <- gets tvar_counter - let tvar = MkTVar . LIdent $ s ++ "_" ++ show i - modify $ \cxt -> cxt { tvar_counter = succ cxt.tvar_counter} - pure tvar +nextNameTVar (MkTVar (LIdent s)) = do + i <- gets tvar_counter + let tvar = MkTVar . LIdent $ s ++ "_" ++ show i + modify $ \cxt -> cxt{tvar_counter = succ cxt.tvar_counter} + pure tvar diff --git a/src/TypeChecker/TypeCheckerHm.hs b/src/TypeChecker/TypeCheckerHm.hs index 3ae6df2..166e680 100644 --- a/src/TypeChecker/TypeCheckerHm.hs +++ b/src/TypeChecker/TypeCheckerHm.hs @@ -27,8 +27,11 @@ import Grammar.Abs import Grammar.Print (printTree) import TypeChecker.TypeCheckerIr qualified as T +-- TODO: Save all substition sets encountered in the program and apply +-- to all top level functions in the end. + initCtx = Ctx mempty -initEnv = Env 0 'a' mempty mempty mempty "" mempty mempty +initEnv = Env 0 'a' mempty mempty mempty "" mempty mempty mempty run :: Infer a -> Either Error a run = run' initEnv initCtx @@ -53,8 +56,8 @@ checkPrg :: Program -> Infer (T.Program' Type) checkPrg (Program bs) = do preRun bs bs <- checkDef bs - sub <- solveUndecidable - bs <- mapM (mono sub) bs + sub0 <- solveUndecidable + bs <- mapM (mono sub0) bs return $ T.Program bs mono :: Subst -> T.Def' Type -> Infer (T.Def' Type) @@ -74,11 +77,19 @@ preRun (x : xs) = case x of >>= flip when ( uncatchableErr $ Aux.do - "Duplicate signatures for function" + "Duplicate signatures of function" quote $ printTree n ) insertSig (coerce n) (Just t) >> preRun xs DBind (Bind n _ e) -> do + binds <- gets declaredBinds + when + (coerce n `S.member` binds) + ( uncatchableErr $ Aux.do + "Duplicate declarations of function" + quote $ printTree n + ) + modify (\st -> st{declaredBinds = S.insert (coerce n) st.declaredBinds}) collect (collectTVars e) s <- gets sigs case M.lookup (coerce n) s of @@ -105,12 +116,12 @@ checkBind :: Bind -> Infer (T.Bind' Type) checkBind bind@(Bind name args e) = do setCurrentBind $ coerce name let lambda = makeLambda e (reverse (coerce args)) - (e, lambda_t) <- inferExp lambda + (sub0, (e, lambda_t)) <- inferExp lambda s <- gets sigs case M.lookup (coerce name) s of Just (Just t') -> do sub1 <- bindErr (unify lambda_t (skolemize t')) bind - return $ T.Bind (coerce name, apply sub1 t') [] (e, lambda_t) + return $ T.Bind (coerce name, apply (sub1 `compose` sub0) t') [] (e, lambda_t) _ -> do insertSig (coerce name) (Just lambda_t) return (T.Bind (coerce name, lambda_t) [] (e, lambda_t)) @@ -178,12 +189,12 @@ returnType :: Type -> Type returnType (TFun _ t2) = returnType t2 returnType a = a -inferExp :: Exp -> Infer (T.ExpT' Type) +inferExp :: Exp -> Infer (Subst, T.ExpT' Type) inferExp e = do (s, (e', t)) <- algoW e let subbed = apply s t modify (\st -> st{undecidedSigs = apply s st.undecidedSigs}) - return (e', subbed) + return (s, (e', subbed)) class CollectTVars a where collectTVars :: a -> Set T.Ident @@ -851,6 +862,7 @@ data Env = Env , currentBind :: T.Ident , undecidedSigs :: Map T.Ident Type , toDecide :: Set T.Ident + , declaredBinds :: Set T.Ident } deriving (Show) From aa1ff630a5f56d8a2cc357aa0b37511a932e784b Mon Sep 17 00:00:00 2001 From: Martin Fredin Date: Wed, 29 Mar 2023 22:48:26 +0200 Subject: [PATCH 243/372] Fix double vars --- src/TypeChecker/TypeCheckerBidir.hs | 6 ++---- 1 file changed, 2 insertions(+), 4 deletions(-) diff --git a/src/TypeChecker/TypeCheckerBidir.hs b/src/TypeChecker/TypeCheckerBidir.hs index 9e1e12f..53a942d 100644 --- a/src/TypeChecker/TypeCheckerBidir.hs +++ b/src/TypeChecker/TypeCheckerBidir.hs @@ -100,7 +100,7 @@ typecheckBind (Bind name vars rhs) = do -- Γ ⊢ f xs = e ↓ Α → B ⊣ Δ Just t -> do (rhs', _) <- check (foldr EAbs rhs vars) t - pure (T.Bind (coerce name, t) (coerce vars') (rhs', t)) + pure (T.Bind (coerce name, t) [] (rhs', t)) where vars' = zip vars $ getVars t @@ -111,9 +111,7 @@ typecheckBind (Bind name vars rhs) = do (e, t) <- infer $ foldr EAbs rhs vars t' <- applyEnv t e' <- applyEnvExp e - let rhs' = skipLambdas (length vars) e' - vars' = zip vars $ getVars t' - pure (T.Bind (coerce name, t') (coerce vars') (rhs', t')) + pure (T.Bind (coerce name, t') [] (e', t')) env <- gets env unless (isComplete env) err putEnv Empty From c4931c39968f80e89d16baead217c2d567b6db8c Mon Sep 17 00:00:00 2001 From: sebastian Date: Wed, 29 Mar 2023 22:59:21 +0200 Subject: [PATCH 244/372] Fixed bug in EApp, cleaned a bit, added todo for disallowing mutual recursion --- src/TypeChecker/TypeCheckerHm.hs | 216 +++++++++++++------------------ 1 file changed, 87 insertions(+), 129 deletions(-) diff --git a/src/TypeChecker/TypeCheckerHm.hs b/src/TypeChecker/TypeCheckerHm.hs index 166e680..49cef01 100644 --- a/src/TypeChecker/TypeCheckerHm.hs +++ b/src/TypeChecker/TypeCheckerHm.hs @@ -27,22 +27,7 @@ import Grammar.Abs import Grammar.Print (printTree) import TypeChecker.TypeCheckerIr qualified as T --- TODO: Save all substition sets encountered in the program and apply --- to all top level functions in the end. - -initCtx = Ctx mempty -initEnv = Env 0 'a' mempty mempty mempty "" mempty mempty mempty - -run :: Infer a -> Either Error a -run = run' initEnv initCtx - -run' :: Env -> Ctx -> Infer a -> Either Error a -run' e c = - runIdentity - . runExceptT - . flip runReaderT c - . flip evalStateT e - . runInfer +-- TODO: Disallow mutual recursion -- | Type check a program typecheck :: Program -> Either String (T.Program' Type) @@ -73,29 +58,23 @@ preRun [] = return () preRun (x : xs) = case x of DSig (Sig n t) -> do collect (collectTVars t) - gets (M.member (coerce n) . sigs) - >>= flip - when - ( uncatchableErr $ Aux.do - "Duplicate signatures of function" - quote $ printTree n - ) + duplicateDecl n $ Aux.do + "Multiple signatures of function" + quote $ printTree n insertSig (coerce n) (Just t) >> preRun xs DBind (Bind n _ e) -> do - binds <- gets declaredBinds - when - (coerce n `S.member` binds) - ( uncatchableErr $ Aux.do - "Duplicate declarations of function" - quote $ printTree n - ) - modify (\st -> st{declaredBinds = S.insert (coerce n) st.declaredBinds}) + duplicateDecl n $ Aux.do + "Multiple declarations of function" + quote $ printTree n collect (collectTVars e) s <- gets sigs case M.lookup (coerce n) s of Nothing -> insertSig (coerce n) Nothing >> preRun xs Just _ -> preRun xs - DData d@(Data t _) -> collect (collectTVars t) >> checkData d >> preRun xs + DData d@(Data t _) -> let collected = collect (collectTVars t) in checkData d collected >> preRun xs + where + -- Check if function body / signature has been declared already + duplicateDecl n msg = gets (M.member (coerce n) . sigs) >>= flip when (uncatchableErr msg) checkDef :: [Def] -> Infer [T.Def' Type] checkDef [] = return [] @@ -126,10 +105,10 @@ checkBind bind@(Bind name args e) = do insertSig (coerce name) (Just lambda_t) return (T.Bind (coerce name, lambda_t) [] (e, lambda_t)) -checkData :: Data -> Infer () -checkData err@(Data typ injs) = do +checkData :: (MonadReader Ctx m, Monad m, MonadError Error m) => Data -> m () -> m () +checkData err@(Data typ injs) ma = do (name, tvars) <- go typ - dataErr (mapM_ (\i -> checkInj i name tvars) injs) err + dataErr (mapM_ (\i -> checkInj i name tvars ma) injs) err where go = \case TData name typs @@ -140,8 +119,8 @@ checkData err@(Data typ injs) = do uncatchableErr $ unwords ["Bad data type definition: ", printTree typ] -checkInj :: Inj -> UIdent -> [TVar] -> Infer () -checkInj (Inj c inj_typ) name tvars +checkInj :: (MonadError Error m, MonadReader Ctx m, Monad m) => Inj -> UIdent -> [TVar] -> m a -> m a +checkInj (Inj c inj_typ) name tvars ma | Right False <- boundTVars tvars inj_typ = catchableErr "Unbound type variables" | TData name' typs <- returnType inj_typ @@ -156,7 +135,7 @@ checkInj (Inj c inj_typ) name tvars "with type" quote $ printTree t "already exist" - Nothing -> insertInj (coerce c) inj_typ + Nothing -> insertInj (coerce c) inj_typ ma | otherwise = uncatchableErr $ unwords @@ -246,11 +225,11 @@ algoW = \case return (nullSubst, (T.EVar $ coerce i, x)) Nothing -> do sig <- gets sigs + cb <- gets currentBind case M.lookup (coerce i) sig of Just (Just t) -> return (nullSubst, (T.EVar $ coerce i, t)) Just Nothing -> do fr <- fresh - cb <- gets currentBind modify (\st -> st{toDecide = S.insert cb st.toDecide, undecidedSigs = M.insert (coerce $ concat [[prefix], i, [delim], coerce cb]) fr st.undecidedSigs}) return (nullSubst, (T.EVar $ coerce i, fr)) Nothing -> @@ -258,7 +237,7 @@ algoW = \case "Unbound variable: " <> printTree i EInj i -> do - constr <- gets injections + constr <- asks injections case M.lookup (coerce i) constr of Just t -> return (nullSubst, (T.EVar $ coerce i, t)) Nothing -> @@ -304,11 +283,13 @@ algoW = \case err@(EApp e0 e1) -> do fr <- fresh (s0, (e0', t0)) <- algoW e0 - (s1, (e1', t1)) <- algoW e1 - s2 <- exprErr (unify (apply s1 t0) (TFun t1 fr)) err - let t = apply s2 fr - let comp = s2 `compose` s1 `compose` s0 - return (comp, apply comp (T.EApp (e0', t0) (e1', t1), t)) + applySt s0 $ do + modify (\st -> st{sigs = apply s0 st.sigs}) + (s1, (e1', t1)) <- algoW e1 + s2 <- exprErr (unify (apply s1 t0) (TFun t1 fr)) err + let t = apply s2 fr + let comp = s2 `compose` s1 `compose` s0 + return (comp, apply comp (T.EApp (e0', t0) (e1', t1), t)) -- \| Γ ⊢ e₀ : τ, S₀ S₀Γ, x : S̅₀Γ̅(τ) ⊢ e₁ : τ', S₁ -- \| ---------------------------------------------- @@ -368,8 +349,38 @@ inferBranch (Branch pat expr) = do inferPattern :: Pattern -> Infer (T.Pattern' Type, Type) inferPattern = \case PLit lit -> let lt = litType lit in return (T.PLit (lit, lt), lt) + PCatch -> (T.PCatch,) <$> fresh + PVar x -> do + fr <- fresh + let pvar = T.PVar (coerce x, fr) + return (pvar, fr) + PEnum p -> do + t <- asks (M.lookup (coerce p) . injections) + t <- + maybeToRightM + ( Error + ( Aux.do + "Constructor:" + quote $ printTree p + "does not exist" + ) + True + ) + t + unless + (typeLength t == 1) + ( catchableErr $ Aux.do + "The constructor" + quote $ printTree p + " should have " + show (typeLength t - 1) + " arguments but has been given 0" + ) + let (TData _data _ts) = t -- nasty nasty + frs <- mapM (const fresh) _ts + return (T.PEnum $ coerce p, TData _data frs) PInj constr patterns -> do - t <- gets (M.lookup (coerce constr) . injections) + t <- asks (M.lookup (coerce constr) . injections) t <- maybeToRightM ( Error @@ -399,36 +410,6 @@ inferPattern = \case ( T.PInj (coerce constr) (apply sub (map fst patterns)) , apply sub ret ) - PCatch -> (T.PCatch,) <$> fresh - PEnum p -> do - t <- gets (M.lookup (coerce p) . injections) - t <- - maybeToRightM - ( Error - ( Aux.do - "Constructor:" - quote $ printTree p - "does not exist" - ) - True - ) - t - unless - (typeLength t == 1) - ( catchableErr $ Aux.do - "The constructor" - quote $ printTree p - " should have " - show (typeLength t - 1) - " arguments but has been given 0" - ) - let (TData _data _ts) = t -- nasty nasty - frs <- mapM (const fresh) _ts - return (T.PEnum $ coerce p, TData _data frs) - PVar x -> do - fr <- fresh - let pvar = T.PVar (coerce x, fr) - return (pvar, fr) -- | Unify two types producing a new substitution unify :: Type -> Type -> Infer Subst @@ -437,7 +418,7 @@ unify t0 t1 = (TFun a b, TFun c d) -> do s1 <- unify a c s2 <- unify (apply s1 b) (apply s1 d) - return $ s1 `compose` s2 + return $ s2 `compose` s1 (TVar (MkTVar a), t@(TData _ _)) -> return $ M.singleton (coerce a) t (t@(TData _ _), TVar (MkTVar b)) -> return $ M.singleton (coerce b) t (TVar (MkTVar a), t) -> occurs (coerce a) t @@ -605,6 +586,9 @@ instance SubstType (Map T.Ident Type) where apply :: Subst -> Map T.Ident Type -> Map T.Ident Type apply = M.map . apply +instance SubstType (Map T.Ident (Maybe Type)) where + apply s = M.map (fmap $ apply s) + instance SubstType (T.ExpT' Type) where apply s (e, t) = (apply s e, apply s t) @@ -688,15 +672,18 @@ insertSig :: T.Ident -> Maybe Type -> Infer () insertSig i t = modify (\st -> st{sigs = M.insert i t (sigs st)}) -- | Insert a constructor into the start with its type -insertInj :: T.Ident -> Type -> Infer () +insertInj :: (Monad m, MonadReader Ctx m) => T.Ident -> Type -> m a -> m a insertInj i t = - modify (\st -> st{injections = M.insert i t (injections st)}) + local (\st -> st{injections = M.insert i t (injections st)}) + +applySt :: Subst -> Infer a -> Infer a +applySt s = local (\st -> st{vars = apply s st.vars}) {- | Check if an injection (constructor of data type) with an equivalent name has been declared already -} -existInj :: T.Ident -> Infer (Maybe Type) -existInj n = gets (M.lookup n . injections) +existInj :: (Monad m, MonadReader Ctx m) => T.Ident -> m (Maybe Type) +existInj n = asks (M.lookup n . injections) setCurrentBind :: T.Ident -> Infer () setCurrentBind i = modify (\st -> st{currentBind = i}) @@ -705,11 +692,12 @@ solveUndecidable :: Infer Subst solveUndecidable = do sigs <- gets sigs undecided <- gets undecidedSigs - let xs = M.toList undecided ys <- maybeToRightM (Error "SIGNATURE MISSING" False) - (mapM (tupSequence . first (join . flip M.lookup sigs . getOriginal)) xs) + ( mapM (tupSequence . first (join . flip M.lookup sigs . getOriginal)) $ + M.toList undecided + ) composeAll <$> mapM (uncurry unify) ys tupSequence :: Monad m => (m a, b) -> m (a, b) @@ -738,48 +726,6 @@ litType (LChar _) = char int = TLit "Int" char = TLit "Char" -typeEq :: Type -> Type -> StateT Subst (ExceptT Error Identity) () -typeEq (TVar (MkTVar a)) t@(TVar _) = do - st <- get - case M.lookup (coerce a) st of - Nothing -> put $ M.insert (coerce a) t st - Just t' -> - unless - (t == t') - ( catchableErr $ Aux.do - quote $ printTree t - "does not match with" - quote $ printTree t' - ) -typeEq (TFun l r) (TFun l' r') = typeEq l l' *> typeEq r r' -typeEq (TAll _ l) (TAll _ r) = typeEq l r -typeEq t@(TLit a) t'@(TLit b) = - unless - (a == b) - ( catchableErr $ Aux.do - quote $ printTree t - "does not match with" - quote $ printTree t' - ) -typeEq t@(TData nameL tL) t'@(TData nameR tR) = do - unless - (nameL == nameR) - ( catchableErr $ Aux.do - quote $ printTree t - "does not match with" - quote $ printTree t' - ) - zipWithM_ typeEq tL tR -typeEq t@(TEVar _) t'@(TEVar _) = - catchableErr $ Aux.do - quote $ printTree t - "does not match with" - quote $ printTree t' -typeEq t t' = catchableErr $ Aux.do - quote $ printTree t - "does not match with" - quote $ printTree t' - {- | Catch an error if possible and add the given expression as addition to the error message -} @@ -824,7 +770,7 @@ bindErr ma bind = {- | Catch an error if possible and add the given data as addition to the error message -} -dataErr :: Infer a -> Data -> Infer a +dataErr :: (MonadError Error m, Monad m) => m a -> Data -> m a dataErr ma d = catchError ma @@ -850,19 +796,31 @@ unzip4 = ) ([], [], [], []) -newtype Ctx = Ctx {vars :: Map T.Ident Type} +initCtx = Ctx mempty mempty +initEnv = Env 0 'a' mempty mempty "" mempty mempty + +run :: Infer a -> Either Error a +run = run' initEnv initCtx + +run' :: Env -> Ctx -> Infer a -> Either Error a +run' e c = + runIdentity + . runExceptT + . flip runReaderT c + . flip evalStateT e + . runInfer + +data Ctx = Ctx {vars :: Map T.Ident Type, injections :: Map T.Ident Type} deriving (Show) data Env = Env { count :: Int , nextChar :: Char , sigs :: Map T.Ident (Maybe Type) - , injections :: Map T.Ident Type , takenTypeVars :: Set T.Ident , currentBind :: T.Ident , undecidedSigs :: Map T.Ident Type , toDecide :: Set T.Ident - , declaredBinds :: Set T.Ident } deriving (Show) From c34041860dad36c298f6031be4d181c90440af14 Mon Sep 17 00:00:00 2001 From: sebastianselander Date: Thu, 30 Mar 2023 10:21:04 +0200 Subject: [PATCH 245/372] duplicate signatures / declarations correct --- src/TypeChecker/TypeCheckerHm.hs | 15 +++++++++++---- 1 file changed, 11 insertions(+), 4 deletions(-) diff --git a/src/TypeChecker/TypeCheckerHm.hs b/src/TypeChecker/TypeCheckerHm.hs index 49cef01..eca2c80 100644 --- a/src/TypeChecker/TypeCheckerHm.hs +++ b/src/TypeChecker/TypeCheckerHm.hs @@ -58,15 +58,18 @@ preRun [] = return () preRun (x : xs) = case x of DSig (Sig n t) -> do collect (collectTVars t) - duplicateDecl n $ Aux.do + s <- gets (M.keys . sigs) + duplicateDecl n s $ Aux.do "Multiple signatures of function" quote $ printTree n insertSig (coerce n) (Just t) >> preRun xs DBind (Bind n _ e) -> do - duplicateDecl n $ Aux.do + s <- gets (S.toList . declaredBinds) + duplicateDecl n s $ Aux.do "Multiple declarations of function" quote $ printTree n collect (collectTVars e) + insertBind $ coerce n s <- gets sigs case M.lookup (coerce n) s of Nothing -> insertSig (coerce n) Nothing >> preRun xs @@ -74,7 +77,7 @@ preRun (x : xs) = case x of DData d@(Data t _) -> let collected = collect (collectTVars t) in checkData d collected >> preRun xs where -- Check if function body / signature has been declared already - duplicateDecl n msg = gets (M.member (coerce n) . sigs) >>= flip when (uncatchableErr msg) + duplicateDecl n env msg = when (coerce n `elem` env) (uncatchableErr msg) checkDef :: [Def] -> Infer [T.Def' Type] checkDef [] = return [] @@ -671,6 +674,9 @@ withPattern p ma = case p of insertSig :: T.Ident -> Maybe Type -> Infer () insertSig i t = modify (\st -> st{sigs = M.insert i t (sigs st)}) +insertBind :: T.Ident -> Infer () +insertBind i = modify (\st -> st{declaredBinds = S.insert i st.declaredBinds}) + -- | Insert a constructor into the start with its type insertInj :: (Monad m, MonadReader Ctx m) => T.Ident -> Type -> m a -> m a insertInj i t = @@ -797,7 +803,7 @@ unzip4 = ([], [], [], []) initCtx = Ctx mempty mempty -initEnv = Env 0 'a' mempty mempty "" mempty mempty +initEnv = Env 0 'a' mempty mempty "" mempty mempty mempty run :: Infer a -> Either Error a run = run' initEnv initCtx @@ -821,6 +827,7 @@ data Env = Env , currentBind :: T.Ident , undecidedSigs :: Map T.Ident Type , toDecide :: Set T.Ident + , declaredBinds :: Set T.Ident } deriving (Show) From 59676605cdb5b623f0dc8298435525684f48f633 Mon Sep 17 00:00:00 2001 From: sebastianselander Date: Thu, 30 Mar 2023 10:55:01 +0200 Subject: [PATCH 246/372] moved injections back to state --- src/TypeChecker/TypeCheckerHm.hs | 35 ++++++++++++++++---------------- 1 file changed, 18 insertions(+), 17 deletions(-) diff --git a/src/TypeChecker/TypeCheckerHm.hs b/src/TypeChecker/TypeCheckerHm.hs index eca2c80..f0ae924 100644 --- a/src/TypeChecker/TypeCheckerHm.hs +++ b/src/TypeChecker/TypeCheckerHm.hs @@ -74,7 +74,7 @@ preRun (x : xs) = case x of case M.lookup (coerce n) s of Nothing -> insertSig (coerce n) Nothing >> preRun xs Just _ -> preRun xs - DData d@(Data t _) -> let collected = collect (collectTVars t) in checkData d collected >> preRun xs + DData d@(Data t _) -> collect (collectTVars t) >> checkData d >> preRun xs where -- Check if function body / signature has been declared already duplicateDecl n env msg = when (coerce n `elem` env) (uncatchableErr msg) @@ -108,10 +108,10 @@ checkBind bind@(Bind name args e) = do insertSig (coerce name) (Just lambda_t) return (T.Bind (coerce name, lambda_t) [] (e, lambda_t)) -checkData :: (MonadReader Ctx m, Monad m, MonadError Error m) => Data -> m () -> m () -checkData err@(Data typ injs) ma = do +checkData :: (MonadState Env m, Monad m, MonadError Error m) => Data -> m () +checkData err@(Data typ injs) = do (name, tvars) <- go typ - dataErr (mapM_ (\i -> checkInj i name tvars ma) injs) err + dataErr (mapM_ (\i -> checkInj i name tvars) injs) err where go = \case TData name typs @@ -122,8 +122,8 @@ checkData err@(Data typ injs) ma = do uncatchableErr $ unwords ["Bad data type definition: ", printTree typ] -checkInj :: (MonadError Error m, MonadReader Ctx m, Monad m) => Inj -> UIdent -> [TVar] -> m a -> m a -checkInj (Inj c inj_typ) name tvars ma +checkInj :: (MonadError Error m, MonadState Env m, Monad m) => Inj -> UIdent -> [TVar] -> m () +checkInj (Inj c inj_typ) name tvars | Right False <- boundTVars tvars inj_typ = catchableErr "Unbound type variables" | TData name' typs <- returnType inj_typ @@ -138,7 +138,7 @@ checkInj (Inj c inj_typ) name tvars ma "with type" quote $ printTree t "already exist" - Nothing -> insertInj (coerce c) inj_typ ma + Nothing -> insertInj (coerce c) inj_typ | otherwise = uncatchableErr $ unwords @@ -240,7 +240,7 @@ algoW = \case "Unbound variable: " <> printTree i EInj i -> do - constr <- asks injections + constr <- gets injections case M.lookup (coerce i) constr of Just t -> return (nullSubst, (T.EVar $ coerce i, t)) Nothing -> @@ -358,7 +358,7 @@ inferPattern = \case let pvar = T.PVar (coerce x, fr) return (pvar, fr) PEnum p -> do - t <- asks (M.lookup (coerce p) . injections) + t <- gets (M.lookup (coerce p) . injections) t <- maybeToRightM ( Error @@ -383,7 +383,7 @@ inferPattern = \case frs <- mapM (const fresh) _ts return (T.PEnum $ coerce p, TData _data frs) PInj constr patterns -> do - t <- asks (M.lookup (coerce constr) . injections) + t <- gets (M.lookup (coerce constr) . injections) t <- maybeToRightM ( Error @@ -678,9 +678,9 @@ insertBind :: T.Ident -> Infer () insertBind i = modify (\st -> st{declaredBinds = S.insert i st.declaredBinds}) -- | Insert a constructor into the start with its type -insertInj :: (Monad m, MonadReader Ctx m) => T.Ident -> Type -> m a -> m a +insertInj :: (Monad m, MonadState Env m) => T.Ident -> Type -> m () insertInj i t = - local (\st -> st{injections = M.insert i t (injections st)}) + modify (\st -> st{injections = M.insert i t (injections st)}) applySt :: Subst -> Infer a -> Infer a applySt s = local (\st -> st{vars = apply s st.vars}) @@ -688,8 +688,8 @@ applySt s = local (\st -> st{vars = apply s st.vars}) {- | Check if an injection (constructor of data type) with an equivalent name has been declared already -} -existInj :: (Monad m, MonadReader Ctx m) => T.Ident -> m (Maybe Type) -existInj n = asks (M.lookup n . injections) +existInj :: (Monad m, MonadState Env m) => T.Ident -> m (Maybe Type) +existInj n = gets (M.lookup n . injections) setCurrentBind :: T.Ident -> Infer () setCurrentBind i = modify (\st -> st{currentBind = i}) @@ -802,8 +802,8 @@ unzip4 = ) ([], [], [], []) -initCtx = Ctx mempty mempty -initEnv = Env 0 'a' mempty mempty "" mempty mempty mempty +initCtx = Ctx mempty +initEnv = Env 0 'a' mempty mempty mempty "" mempty mempty mempty run :: Infer a -> Either Error a run = run' initEnv initCtx @@ -816,7 +816,7 @@ run' e c = . flip evalStateT e . runInfer -data Ctx = Ctx {vars :: Map T.Ident Type, injections :: Map T.Ident Type} +data Ctx = Ctx {vars :: Map T.Ident Type} deriving (Show) data Env = Env @@ -824,6 +824,7 @@ data Env = Env , nextChar :: Char , sigs :: Map T.Ident (Maybe Type) , takenTypeVars :: Set T.Ident + , injections :: Map T.Ident Type , currentBind :: T.Ident , undecidedSigs :: Map T.Ident Type , toDecide :: Set T.Ident From c4477d3df4bb263e86fce271285949d669e05538 Mon Sep 17 00:00:00 2001 From: sebastianselander Date: Thu, 30 Mar 2023 11:38:06 +0200 Subject: [PATCH 247/372] moved some funcs to aux, added a universal definition of int and char, updated usages in both tcs --- src/Auxiliary.hs | 22 +++++++++++++++++++++- src/TypeChecker/TypeCheckerBidir.hs | 4 ++-- src/TypeChecker/TypeCheckerHm.hs | 22 ++-------------------- 3 files changed, 25 insertions(+), 23 deletions(-) diff --git a/src/Auxiliary.hs b/src/Auxiliary.hs index fb0b8cb..0c9f012 100644 --- a/src/Auxiliary.hs +++ b/src/Auxiliary.hs @@ -1,11 +1,13 @@ {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} module Auxiliary (module Auxiliary) where import Control.Monad.Error.Class (liftEither) import Control.Monad.Except (MonadError) import Data.Either.Combinators (maybeToRight) -import TypeChecker.TypeCheckerIr (Type (TFun)) +import Data.List (foldl') +import Grammar.Abs import Prelude hiding ((>>), (>>=)) (>>) a b = a ++ " " ++ b @@ -26,3 +28,21 @@ mapAccumM f = go (acc', x') <- f acc x (acc'', xs') <- go acc' xs pure (acc'', x' : xs') + +unzip4 :: [(a, b, c, d)] -> ([a], [b], [c], [d]) +unzip4 = + foldl' + ( \(as, bs, cs, ds) (a, b, c, d) -> + (as ++ [a], bs ++ [b], cs ++ [c], ds ++ [d]) + ) + ([], [], [], []) + +litType :: Lit -> Type +litType (LInt _) = int +litType (LChar _) = char + +int = TLit "Int" +char = TLit "Char" + +tupSequence :: Monad m => (m a, b) -> m (a, b) +tupSequence (ma, b) = (,b) <$> ma diff --git a/src/TypeChecker/TypeCheckerBidir.hs b/src/TypeChecker/TypeCheckerBidir.hs index 53a942d..031396d 100644 --- a/src/TypeChecker/TypeCheckerBidir.hs +++ b/src/TypeChecker/TypeCheckerBidir.hs @@ -6,7 +6,7 @@ module TypeChecker.TypeCheckerBidir (typecheck, getVars) where -import Auxiliary (maybeToRightM, snoc) +import Auxiliary (maybeToRightM, snoc, int, char) import Control.Applicative (Alternative, Applicative (liftA2), (<|>)) import Control.Monad.Except (ExceptT, MonadError (throwError), @@ -484,7 +484,7 @@ infer = \case -- Γ ⊢ e₁ + e₂ ↓ Int ⊣ Δ EAdd e1 e2 -> do cxt <- get - let t = TLit "Int" + let t = int e1' <- check e1 t put cxt e2' <- check e2 t diff --git a/src/TypeChecker/TypeCheckerHm.hs b/src/TypeChecker/TypeCheckerHm.hs index f0ae924..11cb94e 100644 --- a/src/TypeChecker/TypeCheckerHm.hs +++ b/src/TypeChecker/TypeCheckerHm.hs @@ -6,7 +6,7 @@ -- | A module for type checking and inference using algorithm W, Hindley-Milner module TypeChecker.TypeCheckerHm where -import Auxiliary (maybeToRightM) +import Auxiliary (int, litType, maybeToRightM, tupSequence, unzip4) import Auxiliary qualified as Aux import Control.Monad.Except import Control.Monad.Identity (Identity, runIdentity) @@ -706,9 +706,6 @@ solveUndecidable = do ) composeAll <$> mapM (uncurry unify) ys -tupSequence :: Monad m => (m a, b) -> m (a, b) -tupSequence (ma, b) = (,b) <$> ma - getOriginal :: T.Ident -> T.Ident getOriginal (T.Ident i) = coerce $ takeWhile (/= delim) $ drop 1 i @@ -725,13 +722,6 @@ typeLength :: Type -> Int typeLength (TFun _ b) = 1 + typeLength b typeLength _ = 1 -litType :: Lit -> Type -litType (LInt _) = int -litType (LChar _) = char - -int = TLit "Int" -char = TLit "Char" - {- | Catch an error if possible and add the given expression as addition to the error message -} @@ -794,14 +784,6 @@ dataErr ma d = else throwError (err{catchable = False}) ) -unzip4 :: [(a, b, c, d)] -> ([a], [b], [c], [d]) -unzip4 = - foldl' - ( \(as, bs, cs, ds) (a, b, c, d) -> - (as ++ [a], bs ++ [b], cs ++ [c], ds ++ [d]) - ) - ([], [], [], []) - initCtx = Ctx mempty initEnv = Env 0 'a' mempty mempty mempty "" mempty mempty mempty @@ -816,7 +798,7 @@ run' e c = . flip evalStateT e . runInfer -data Ctx = Ctx {vars :: Map T.Ident Type} +newtype Ctx = Ctx {vars :: Map T.Ident Type} deriving (Show) data Env = Env From 2851c408d1c4ae2bce66ac2d42b93d50772ed501 Mon Sep 17 00:00:00 2001 From: Samuel Hammersberg Date: Thu, 30 Mar 2023 11:41:10 +0200 Subject: [PATCH 248/372] Added the updated GC. --- src/GC/Makefile | 32 ++++++++++-- src/GC/docs/lib/cheap.md | 40 +++++++++++++++ src/GC/include/cheap.h | 32 ++++++++++++ src/GC/lib/cheap.cpp | 48 ++++++++++++++++++ src/GC/lib/event.cpp | 6 +-- src/GC/lib/gcoll.a | Bin 712746 -> 712746 bytes src/GC/tests/file.cpp | 11 ++++- src/GC/tests/wrapper.c | 95 ++++++++++++++++++++++++++++++++++++ src/GC/tests/wrapper_test.c | 45 +++++++++++++++++ 9 files changed, 301 insertions(+), 8 deletions(-) create mode 100644 src/GC/docs/lib/cheap.md create mode 100644 src/GC/include/cheap.h create mode 100644 src/GC/lib/cheap.cpp create mode 100644 src/GC/tests/wrapper.c create mode 100644 src/GC/tests/wrapper_test.c diff --git a/src/GC/Makefile b/src/GC/Makefile index add6d73..6b33ca8 100644 --- a/src/GC/Makefile +++ b/src/GC/Makefile @@ -40,6 +40,17 @@ game: rm -f tests/game.out $(CC) $(WFLAGS) $(STDFLAGS) $(LIB_INCL) tests/game.cpp lib/heap.cpp lib/profiler.cpp lib/event.cpp -o tests/game.out +wrapper_test: + rm -f lib/event.o lib/profiler.o lib/heap.o lib/coll.a tests/wrapper_test.out +# compile object files + $(CC) $(STDFLAGS) $(WFLAGS) $(LIB_INCL) -O3 -g -c -o lib/event.o lib/event.cpp -fPIC + $(CC) $(STDFLAGS) $(WFLAGS) $(LIB_INCL) -O3 -g -c -o lib/profiler.o lib/profiler.cpp -fPIC + $(CC) $(STDFLAGS) $(WFLAGS) $(LIB_INCL) -O3 -g -c -o lib/heap.o lib/heap.cpp -fPIC + $(CC) $(STDFLAGS) $(WFLAGS) $(LIB_INCL) -O3 -g -c -o lib/cheap.o lib/cheap.cpp -fPIC +# compile object files into library + ar rcs lib/gcoll.a lib/event.o lib/profiler.o lib/heap.o lib/cheap.o + clang -stdlib=libc++ $(WFLAGS) $(LIB_INCL) -o tests/wrapper_test.out tests/wrapper_test.c lib/gcoll.a -lstdc++ + extern_lib: # remove old files rm -f lib/heap.o lib/libheap.so tests/extern_lib.out @@ -55,12 +66,25 @@ static_lib: # remove old files rm -f lib/event.o lib/profiler.o lib/heap.o lib/gcoll.a tests/extern_lib.out # compile object files - $(CC) $(STDFLAGS) $(WFLAGS) $(LIB_INCL) -O3 -g -c -o lib/event.o lib/event.cpp -fPIC - $(CC) $(STDFLAGS) $(WFLAGS) $(LIB_INCL) -O3 -g -c -o lib/profiler.o lib/profiler.cpp -fPIC - $(CC) $(STDFLAGS) $(WFLAGS) $(LIB_INCL) -O3 -g -c -o lib/heap.o lib/heap.cpp -fPIC + $(CC) $(STDFLAGS) $(WFLAGS) $(LIB_INCL) -O3 -c -o lib/event.o lib/event.cpp -fPIC + $(CC) $(STDFLAGS) $(WFLAGS) $(LIB_INCL) -O3 -c -o lib/profiler.o lib/profiler.cpp -fPIC + $(CC) $(STDFLAGS) $(WFLAGS) $(LIB_INCL) -O3 -c -o lib/heap.o lib/heap.cpp -fPIC # create static library ar r lib/gcoll.a lib/event.o lib/profiler.o lib/heap.o # create test program static_lib_test: static_lib - $(CC) $(STDFLAGS) $(WFLAGS) $(LIB_INCL) -o tests/extern_lib.out tests/extern_lib.cpp lib/gcoll.a \ No newline at end of file + $(CC) $(STDFLAGS) $(WFLAGS) $(LIB_INCL) -o tests/extern_lib.out tests/extern_lib.cpp lib/gcoll.a + +wrapper: +# remove old files + rm -f lib/event.o lib/profiler.o lib/heap.o lib/coll.a tests/wrapper.out +# compile object files + $(CC) $(STDFLAGS) $(WFLAGS) $(LIB_INCL) -O3 -c -o lib/event.o lib/event.cpp -fPIC + $(CC) $(STDFLAGS) $(WFLAGS) $(LIB_INCL) -O3 -c -o lib/profiler.o lib/profiler.cpp -fPIC + $(CC) $(STDFLAGS) $(WFLAGS) $(LIB_INCL) -O3 -c -o lib/heap.o lib/heap.cpp -fPIC + $(CC) $(STDFLAGS) $(WFLAGS) $(LIB_INCL) -O3 -c -o lib/cheap.o lib/cheap.cpp -fPIC +# compile object files into library + ar rcs lib/gcoll.a lib/event.o lib/profiler.o lib/heap.o lib/cheap.o +# compile test program wrapper.c with normal clang + clang -stdlib=libc++ $(WFLAGS) $(LIB_INCL) -o tests/wrapper.out tests/wrapper.c lib/gcoll.a -lstdc++ diff --git a/src/GC/docs/lib/cheap.md b/src/GC/docs/lib/cheap.md new file mode 100644 index 0000000..e5c5993 --- /dev/null +++ b/src/GC/docs/lib/cheap.md @@ -0,0 +1,40 @@ +# cheap.h & cheap.cpp + +A wrapper interface for the class `GC::Heap` for easier use +in LLVM (no nasty namespaces). This interface is relatively +straight-forward and only defines functions to use the already +public functions in the class `GC::Heap`. + +The functions are declared in a normal C-style header and +defined as "pure" C-functions. Because the public functions +exposed in `GC::Heap` are static, some of the functions +just call the static functions but are wrapped as C-functions. + +For the non-static function `GC::Heap::set_profiler()` and the +singleton get-instance function `GC::Heap::the()` a struct +is used to encapsulate the heap-object. If this library is +compiled with `DEBUG` defined a struct is typedef-ed and +can be used everywhere, otherwise this struct is opaque +and cannot be used explicitly. This struct only contains +a pointer to the heap instance and is called `cheap_t`. + +## Functions +`cheap_t *cheap_the()`: Returns an encapsulated singleton +instance. It is encapsulated in an opaque struct as the +instance itself is not meant to be used outside the C++ +library. + +`void cheap_init()`: Simply calls the `Heap::init()` +function. + +`void cheap_dispose()`: Only calls the `Heap::dispose()` +function. + +`void *cheap_alloc(unsigned long size)`: Calls `Heap::alloc(size_t size)` +and returns whatever `alloc` returns. + +`void cheap_set_profiler(cheap_t *cheap, bool mode)`: +The argument `cheap` is the encapsulated Heap singleton instance. +`mode` is the same as for `Heap::set_profiler(bool mode)`. + +For more documentation on functionality, see `src/GC/docs/lib/heap.md`. \ No newline at end of file diff --git a/src/GC/include/cheap.h b/src/GC/include/cheap.h new file mode 100644 index 0000000..d2c649d --- /dev/null +++ b/src/GC/include/cheap.h @@ -0,0 +1,32 @@ +#ifndef CHEAP_H +#define CHEAP_H + +#include + +#ifdef __cplusplus +extern "C" { +#endif + +// #define DEBUG + +#ifdef DEBUG +typedef struct cheap +{ + void *obj; +} cheap_t; +#else +struct cheap; +typedef struct cheap cheap_t; +#endif + +cheap_t *cheap_the(); +void cheap_init(); +void cheap_dispose(); +void *cheap_alloc(unsigned long size); +void cheap_set_profiler(cheap_t *cheap, bool mode); + +#ifdef __cplusplus +} +#endif + +#endif /* __CHEAP_H__ */ \ No newline at end of file diff --git a/src/GC/lib/cheap.cpp b/src/GC/lib/cheap.cpp new file mode 100644 index 0000000..29a0b10 --- /dev/null +++ b/src/GC/lib/cheap.cpp @@ -0,0 +1,48 @@ +#include +#include + +#include "heap.hpp" +#include "cheap.h" + +#ifndef DEBUG +struct cheap +{ + void *obj; +}; +#endif + +cheap_t *cheap_the() +{ + cheap_t *c; + GC::Heap *heap; + + c = static_cast(malloc(sizeof(cheap_t))); + heap = &GC::Heap::the(); + c->obj = heap; + + return c; +} + +void cheap_init() +{ + GC::Heap::init(); +} + +void cheap_dispose() +{ + std::cout << "In dispose\n"; + GC::Heap::dispose(); + std::cout << "Out dispose" << std::endl; +} + +void *cheap_alloc(unsigned long size) +{ + return GC::Heap::alloc(size); +} + +void cheap_set_profiler(cheap_t *cheap, bool mode) +{ + GC::Heap *heap = static_cast(cheap->obj); + + heap->set_profiler(mode); +} \ No newline at end of file diff --git a/src/GC/lib/event.cpp b/src/GC/lib/event.cpp index 2815a77..185c613 100644 --- a/src/GC/lib/event.cpp +++ b/src/GC/lib/event.cpp @@ -1,6 +1,6 @@ -#include -#include -#include +// #include +// #include +// #include #include "chunk.hpp" #include "event.hpp" diff --git a/src/GC/lib/gcoll.a b/src/GC/lib/gcoll.a index 1fec9e8a9873bcddaccefe376f301dc380fcb024..dd34d6445a090d8ab0f17d31e151ada266147e5d 100644 GIT binary patch delta 4713 zcmZ2=Kzr2z?G1LE^$uze|MI9b3LN^qb`PtnuK0x2*Tgip99r6NXEjIH)X)Q3OI;U; z-e0fH5#{ja>g%Gl)uKB!ZbemJ-?TUE)uVsEZ>RsW6n45c>+{>a`}h98{xkmh|H;9b z5|M2$jjzPp*G-W$|M_}<+1()J?U$B3Ye;;u>F8c_0g;ER9WFe5>Hpumt^VPskjv!< zq&`LWFl)$1cpq=@tm2GtPjCGCMXtcWmyvHF>w$$^ge-dAvGgslb38V23bTxF>W2P> zECo8eY-SfM9#rgN$yuV`==-HS!8ld1PARwLp408d$r<_^rt&e~*5KT)d1b0$w!~dF z8NcjCwyeuZ`f*TY1A z5lNO;%}4bPuh?1oj6wOrt4>~yFDJFu7TnY~+i;Obnptt~2bb(Ak{26`=dDN)Si!ri zK0`#ecSX_VvR_tbc1&Khvxh%GW=FSFuBOb;}haQn%{3Z0mW@mDbet`dj zZWFN|Lb{Cme5@PRUkE;M{e|v>{g;;?Fh3D}prT8wVfjkVA8KnE<}Ktsuz8F853#*$ zHM8v)|ING8+Vgw`OU1lbxpNrzIArJEVXbNJyH&wgG4Wr<;{6>TV^?h`Y;saEzIHBS z=Ek)>j>cs(Hr5~EDYRWNTk=uaG9%+7Z@u@P5!kLBI!p1$S3~EH)ke-T?e8*rdCq;7 za?`EaXgXa@^C)jp-G^AynG&8F+g&8$K1dwP{Q7zC;w0Y-M;C}M%CB3oqCa@cSskX& zTQ}9Mo@r&^-NZA;BX3%w$g278ZPOCBy*rWiV)Yv4O+kf+wlqtwuU``!)blfORvd5D z%tc|@zw*{EyWV(j&5F6R{&g(=?2yk=>nd5d^2Otsk{zf0x15gds?#?XJ^3WP;Ac!= z{PK+Z(;AkQH+@^_^t3Yg;+%Pb{J#RXn4bTd7Jrog!?LJl;xCp9{%tktx!xmqV_nqs zRNsD`hpTq2X-hKWadMEJCXvTnKe^Y4i(*(uj|+p_#N-KZ19;@3_=kH_U#i@In0x*N3`Y9Cw_;8*gh| zX)d%DWiAgY<*#0Na&AVS+#&DaxablM>9$|I$r9XYU)c4GCVRa-`-)B6zJC3#Yr9`P z&kp3|D3tHeKJ{a|h+=KM#qGtjV_xiAHgj#zsjs)?p8532Gxnd=>zP!UWA;0xN}}=b zotd#egEK|N>uu|$bXokSPc^8w`z!Fv=oWK~qk4n(%N+jQ+Q)xg^l-c0qU5KuDdS_* zV>2_G)j<_8Pt!Lke3Q(n_nG=n<#wdN@04x+VNdrQC=)wkH}UP_slOy|yJuG`-=00C zYVKR#TYY9X*G|%XaB*Ms^8Uu%!7KmXJl7PsvE*shV~N|97Y?e`w>&hz_@pj=TZY8D zy3F+b>bFn2=7_J~kz&~MDP`@Sdsa^;sm@~(WaL*UFgOq>^rnl0`N7X48an6qt529z zEq>-wk?Th{-SD!VuBU4k-BD($zuLCyhLP@f-CHZ4x_Hi>mR;L%{F5`>wObrg1vCb_paMughqc0zcOt{6x-PE!w}xG-{pZs>`1m9);=h>%^^ldh3yVW~GPE{@0TdD|c~vwOKzAe3939=du^yhvi3Rl)gQ-;8ITf_X&GnYko~n-Xx^Ta8#Mg@ndI_<3<-wr_K(c zCLvK(o}~d(IHu?=dgAa>&+Ez~tMIN#@_OM*>sOjF{po%Dcd}Mi&)bRbp3I)5mG-^k zXz7NjfByUr=sK^FxOR=^A$f0!)v1#Y+g$(PKJnz$qlcF*YmK~lQpBF;eVXi5rdI~R z?T%}&Ug^AWTx)f(&s?UXy6RUv1LTdr8m{2A$|{yiFZ2ygy33?pU)d=d?0b{#@}p^< z8zlMn@axytujox}zvHPUdpP{O>7jMkl7-5)Myh>WCsth3U$oWN(s|RFdWTJW;?*MW z{clf+-0!q$O}*QuJMpS<_YBYPYnQuvbl&9DB(p!Cw!P`QcA)>zJht`Lu@TQCb#yBg zKEAuQd}&9?fw+rI-(I}Z=AXI7eC5oNIm>O1&kb-=eKq4apTOsOCZE&Ydi>T_>6Iqh z5)bw6&V4@ZrkBoRyZ6&1=8kZ((w>zyAOO=@7xQM6S$ZJYqz$_O@ z-le`%3}w@L0XOxpr!+hOfrgtiV|d*9fOJ{ZcXQ+3hlO%4zKjwTrg2 zRZ9Kds4=-VIy7sx%S@qrtEcELI>Y(TP4z>A#%C@*jkJD^&)s!vr~F-{<4`zHgrj{ z@hd#H$XEE?re_wdD<(1*P3KM)3eJpM*6dQRcT~%BqMQ7T{X(06_!#)+ok;uk@TcIc zldB%auA05DUoy>lewc@GNrCA4qM1qCHeNSdQokW;xj|@9h1+t5lM^MEYpnaP{`9f( z1nH>H)(`*9d6e^+DO24}b>fwY8#ZtJwnV!7e83rJS!wN8Zl`KCG{rqSQ#w=S|K1gw zr}~ERzSlk#zNx}^?$LREHmWO4CtW#hJ}qRA%F53#m*}NWxi&Low@Rt)El;NW<-!jZ z&zDa6ee(5#$Mp)6pEG479TEVW=yZ9XEvmKFVR!0Y`^G!PZSL0__(`?g27Q**x z>e>^NXWumveWSl)W8qQ7+b$R5cV`}&W>HfV+}>gF;p75~1>Dv$&rbb#pnSMz<%5M^ zZmjSxzB9WgzT~O8blMV$nP~^=i*i$RBW6!rxnX(fn{`gF<2Sc{R_%EF)5P@SHT$n_6z-by)64kKQ|Y-5)fdl3RV|i$n*VjJ z6|cK^&ApzFX73Bwp1)~YKXd8oDc{P}`5xaqc)C41&dy%}+FTj}N1Q!mL#1^rN|pHTi)wN3FM^UCQHCEguh{bplYQ=7FHd=U^$LOf z)+(O|i$45Z6|-~2kvfldpF3)wkA*z@kyw$w^0|wTTxY1>9rcZequw@LdmY}wtYJ56 zYTM*1dDA(I>e)Yk_nl)j_e$E5i}qcY|9eXwoutazUvqA4>;5G|+IJQ6QtVz%ojz4A zs8e<_qnKFzR#nkQ68AcvrwTrEe$2Pq{`SKiEbm_&QIzMqe5dA6&#uxnXH_h6idcWX ziPUP$&3d#&M{&{t$;thT&Zbr+daXIW=_h||+%z8j@aP}O5kG$%usUlkw(ZFK4Ig^n zwM@7AI?3wnyJq{Oo&)Wa<1LNAB>?t~S_SY{>Ub^k^Yt7>} zp1aek^u!epl^zsWY^Dny#s%oGgnEO9=~|6##kZDB;7Y8&e@T@*yqgOUFpj{ zYOdjxo#Q)`<5{Uez4EhqznQ+%c=W|XWNxMW`1rKBgt5opolDR7h}3;AkIT!gBhE64 zTS?pxDUs3d6ZtcV>3;H(-~y{TQ=LAswu=;{Ka&akJlBHfI-ic@z0bSEp2tc!nirq4 zniBgcEZg{6JL6wp+lcI{o#jhTrEY&OcSPn*LM_X+aHCfV>L1y!yUuNln003Lt`!mY zmRjgeJ}quwR=vDGAbWN9`yjbEW7F?EH8PnWeLHKsKE-wgZ2kJc!t#ijtO+8{qt&iW9g5NW8HWvJzF(>8WH^ZA*AR_JIw|Ya%qmNGRSX;Oz z@cGiVd*4LDBE+}Jy-7VERcg5~t@dBo^yoWxthXw!Io+)rc2}jz`|GY6d*{tuvlrLx zyLNBo#N#JV9j%V#v3uLK-}|>uauwGLrVG&~rqa{P8G|L4ZJP4-q3IesnH{Ti68AXS z_}au)?E3iS!OYg>;^%X0YAb&A)*pzQddOtj?(601SC;Kd=Tz7Jy5@c8A@!p{=YM^Y z5DzNb_jPaJOQ$>R*Sb}PwU0jBT=64z zrkzC7qsa~D6_47_{WS5n_nm*&`44D3Utrv2H@|4(&BlbEJN^V8{j-uey4(ER*Uu~B z7u1)l%|6m9HGN6DQCODP_J3bXJ!ZOJGdR2A+q3`uTpyypf13Td$Y1M0`*-iJ92>5e ze0$8f>s9Q0o};~|cKQB&w8rOQVeHpAzHft{sT-}3Y-sjDrU$yDsu_4LiUmGSY#ZP{yYy<7gK_Uy}-nh8nsPR17739Sl#$T>~zk&%P9 zn|a<0Ma#`Hk^5J9Z*_^}j*K~zU)FZ9_jX0Y)|(IKES)R=;>DTutJB|Y^qU+1>cyFS zyJ?^A&$X(*c(9W3yNdCQ$E$s+cW>Q(`SOo?&&_!oHZPNsVXhBhVgLh1Fv-ABF=y%| zT|Op5f!6e8)_)UUIyE_k3i5DHvre#JYCo{R^THhV)@OV&jLb}p3-88$Yv0n;wf_Cy zbKcs!6dBlfqgfn|lqVj3#v9Uj`eDE8i;OKzt74mj1b8);Zu002?iJd^FS>x)hh^1D z$E+vmJ91Yf{Bu>CwDMVPv(TA@7u7R2oJc#A+d?3B~)l*8EWl*82Sl*8Qal*7{Ql*8KYl*88U Vl*8Wcl*7^Pl*75*DTnJtF#v=NFs%Rp delta 4713 zcmZ2=Kzr2z?G1LE^({V!eoHDm6g>2M?H*QDUGWL4uZd}HIkZ$@XSkq<_UeXEuWkqJ zeevM}TN-YxzWy}oyH-))maX5`rB<)Ka`f-_?dSg#tF^2#eSW*TzWV?A&->5)S6_a~ zU=z>f^cDN-{%9EIeY#$M_gAW0-crxAjE7I8c30;sXdDV}TyXmG{D0GV>JL9%x$J#| z>67ge*_!eZ?#CNEt2iV4(;Ioe$Q20qvhpo!J)pRS%VNqq7QW?nj>iP2Fw3~6Zs=de zQozH@WOgayfyFKs8UJ{u*)QH7NIT{9$K@7FtqQXgC{k*%2H^;y#Yg2#jWOuG-|TNr=vyk)ANw?z3s`b*yj#a~oER2ChVh+i=8 zfOsa)2h}L9nwe!x@e7wXtiKq2pnkc3WB!Eg4If298T^BVKlny*+Bi!$rf1rJ(5>SA zVOGoZ$95;TqPZEQBi>uif0i{ew?->qnUnN`Ei9)eAn}9g_H%rPU>EP47jc zX>SaY>pLYMRRx$EA9?GOn$~f9deuzDyzo^f&K<9l+XTW>+bsC*UX&7?^WL<_ z>Pu3#oNri{^pU0qyR(c8Ck5nn8ti#s*mL>S^J@2_vleta>O0;46A&oBJY#kw&$H~* zzhTB-6Q;3AT1>p7b66w9{(kkDLpgURp1lwrnY}rv@X(e<$>sHHf`fa0CeDguuG+ci zTE?%u^~<{_!@eI$Ar|P$!>bmZqKC>(3lktw4bt~2f zZ^_SgxcqiO?W%yvdm$#v(@h%cL~_p-@4XrRaqGR1(_fhWnk?EM&{jChkjXma^{zFN z6PLz>PQMy)rmc}9z93mOrX9?@G*HV)P)`q@L@C z_AF)_r*h{1LZ6lI?>{E@?4|Li?Khk^)C*g){i!|^e(Fc=8=f!O8&@BwKT@^HHl6cl z#jP`uUhAFX{p1X&f|(za}W)T{V*OtWKJ zr+!a(N71__Mi1Dec=vQaV|u^L^nm=uy$8;2sTbbS%Ewgiw4UMp^6mp`OGJ0fb+VNx z4=~&?cUAQbZr^t<#a9yIW_^lU?0m!ENWO$~q`_kQf{8Ojvhu^scm4QTeRb=-Q2YBT zQyT=nH||)}Q|~Ew>3jP|+g&$X-(}CbskJm_|J%fKkA6J-aO2S-jhW}uHv2DY7qmDt z_vTdl-mv0}^`DntR(ik_$@y9Q0{=q&<+cZ=mN4z;I`?hE?xHpFy$L108jp@Bbx&Vo zoR@rfvsUZz&^k5lr1>Ym9S?cwziBS(M*qa$BBAHFbJ88(2;a2xS~-7X?UZf(>D7~i z)^FbHdHbT;?$AxFHn+-Oe=#h$J@wZ7w>lD{r^9j$`ZmsGm(6jim#7o=efK@JyY1n- z>1E%lH_eSXQueXSTkNoh|Fu=`*M{pwKGGBr{J_A(&Mc#Pa9xK1!#w|D6ARPwwfCT6g}pzOK28 z{q;`=_LTf;UKHnbviWn-R-1a2TfV1#cfPEdE&KCb;gs}z&!~IPCwv#*Y;#Ke)=Hym zd%``;OCNY?&0ch<#I&pHlB>R!pZN9_DzQf%9V!X!?!I(YThA|iXnF z>%CUAC}ZBV-=b@;7WoG5otE7ly~SohMeDTJUG+4~m6=G)gESGEmPcyv*A)9K%=G7>XHxA4Yp z{yfj$wVeCOys)AMdsVmf`NnM1(thu1e-rD!(q4MFCe-Z93RWAWAmni~M zR%j$@v@UX4P$HnDC@FD3R>trINUDmQt<>a#|j*J@s%5Sz`R_J}3qa(ce;q>jPr;*aOLDc?ohQzVv1IYus^PqlMy5{>OYex};% zo?1JjWu9oN;Hht`G`wq$hn|uC#t8Uw&!_2 z*GlE|+|5BVf26PTIeIg0Peu3j`zow<@L!kKI*##?!X?7rX*DNBX&od#-#Q=g?;d3<>uv}Te>=9k8w+J@cdSuQ_m%Sn@;C%vD>RflO`s@;}%POtuC0r9^W)^lm`c)rfXUDX2q3M3% zcjqDa&aso$bGC;}4#rHdi)oT$H!u47>IV)pIe^y+7UWwu-))a`nT$ zMK!A3=9eSiygU*-DN5UOZ%wl2QSV7s^Zi~Gxn<7v-0B&0eeqnC4`o)2cE5HiZkxY{ z&yKI&s8Vl2+p*aPl!CTO{GHd|xn#zi2H(4VIp$BSPp1aYc6|G)XI3vuf6255-5RH7 z&kPJYCz)3e|Lp#anB`x(!oLd6`O$M~=9{7?C)C4U$_VCv&eeD`Bf{;s)eqK=_*gJ^#9nAB2x|nxuIGi}Ihu_ZV%nU9$um0XPljD0& z{%{Si+mx8rH8GP-r~bOzwWdIr#jn zME+;K^n!DGKW0VliptC{e`L@nyQgNyv!|agGu8Ec-x$a6xNQC2+fgF&^$#9zHhshJ zXw&jdQycs4hSlsy-Y%M7@@CtkWZB(oe^?yP)3&>}@phNFWm)vcG!XCL#@k)~Ut%xr zUi(8uBiJ>w(a3j7n8sz-nQW4mYw^X zfBshUo9UNjeCdV!(U= zts{negwLN=I@5kkwyb{J;X=-PH#?o}WR~sz*&-x8o%a(TN?+yFFMXw2I_t9T zX5RQ|+a56IM}D!^@$O7ld8hbx!o6i```*7hRv$afe!8sufkU|l3+G<^>1lXA>D!*F z%UN@dKRGFXYwqXoNuMtmH*a6rJ7Y_GdQg#CkZi{qjjhMSwzl@$Msv3PoPAv`=BlE3 z`}PenlKfv&zT8`^6Zh}MA$F7c&kvcSB(G~l*3_+As_vb8{CaR-<)pH+Ju!Mt4R7QA zO>%QzakBJteQd+e_DdnAS$&K5{!DXNlW}g=ial*je9vag_+5J5=W%d^w6(=-Bf&H8 z6aKlK`9H^KwvJ?+-U^E?r#?JB&Hj=}Vt$`UOj?KOzNr(I`Im2)#jICiuy5rHi#Qq0 zAF8bTj(aSBP-3Co`h=TLGo|{OOyK9a7Ce{vbR_S6-X-=tR>IM|__WoO*hkkgjIXud z`nODOjp^Py*1=CV-7e=(;w#%=$MjlTvUJ1bAI+~9opaFfeHI!UqVqmzj_2gl;s$0_ z%liXfuj+muBo}9F`kkjjCiA0jXN}jV*sg$5-XEuI7OuRSxk_)k=sy2KlS>Wm#TLJm zbLW1VY$zdFzoB6Ej5V7<#P)aJx$W{EdrIry_%XBhdhV0c!r_|^9$K4Rw4gQm_!9;0 z?R_T?isi{pcGkV~P4kVsz!BY)q8+W#C!Tn4Z=Z0|P%KYzaxaKT*1hATc077VtB+aa zj#?kT4F$hv%*lB8&Cv4Xp|{CJn_6!lPw55`t6Oi^AAb_kt^WAh$K;+WebaB-mTx%p zYs1$B{pxG0&U2c+{=EIyok!2^t&~lyjmznLr6w4&>iYBFlCwf@#C-j{^^0GxjbE7F zz1PVfGK2rb-b%N+9PB9GaBtO0%N={TXPh$VU7EwcK9Tp~fzVXW$D)riAH6(uxpz7H zc^#X*6={!O9=@Dk&+=`R$g<6M_AazuXvS;nZ4tRL-Fdx`o#wPEvnj`SOxW}}_eHOl z_#?Xw3;DflV%|=eb@lxA3EpQtPcN-<7Jbp$m34Z7@49(!h1<`o9esc5%RvE=`7AYj zn*Ux->Aw^I=-d80ebo5NCX&U;V|Z@>(Mi zbIsRfU%NLOO+8+Ewb*Q{|IGO(7Nkk_?dOs{Tg&P-Cp2K+WV7vy&ET$psRS30fWT#oy- z^{;|-L$5iBP5&@^Zf412vvpgyS1=&&J)AX{@6xCukneHf}u(-r{-iXt$q8xZ_1x^CdHS5N6L(& zp<{jEv$|^z!XcV}J_?4J#5rBgbF3ARyRv+eNAGVb(-iSjj@C0crmT0of8zXy?F$oj zNze3H_U9*?>5PLH(v2r7&Yq(#G*kT3yRTkdUxaq)l!Pyj?3(oKMC*-tH$4n%3#Jt( zs;{}(dW_|n%@!}Ok8Tyo7$Iqgn4jO|W2OzloN% +#include +#include + +#include "cheap.h" + +typedef struct object +{ + int x, y, z; + double velocity; +} Object; + +void test_init() +{ + printf("----- IN TEST_INIT ----------------------------\n"); + + cheap_init(); + + printf("----- EXIT TEST_INIT --------------------------\n"); +} + +/* Uncomment ONLY if run with DEBUG defined in cheap.h */ + +// cheap_t *test_the() +// { +// printf("----- IN TEST_THE -----------------------------\n"); + +// cheap_t *fst_heap = cheap_the(); + +// printf("Heap 1:\t%p\n", fst_heap->obj); + +// cheap_t *snd_heap = cheap_the(); + +// printf("Heap 2:\t%p\n", snd_heap->obj); + +// printf("----- EXIT TEST_THE ---------------------------\n"); + +// free(snd_heap); +// return fst_heap; +// } + +void test_profiler(cheap_t *heap) +{ + printf("----- IN TEST_PROFILER ------------------------\n"); + + cheap_set_profiler(heap, false); + cheap_set_profiler(heap, true); + + printf("----- EXIT TEST_PROFILER ----------------------\n"); +} + +Object *test_alloc() +{ + printf("----- IN TEST_ALLOC ---------------------------\n"); + + Object *o; + o = (Object *)(cheap_alloc(sizeof(Object))); + + o->x = 3; + o->y = 4; + o->z = 5; + o->velocity = 1.0f; + + printf("----- EXIT TEST_ALLOC -------------------------\n"); + return o; +} + +void test_dispose() +{ + printf("----- IN TEST_DISPOSE -------------------------\n"); + + cheap_dispose(); + + printf("----- EXIT TEST_DISPOSE -----------------------\n"); +} + +int main() +{ + test_init(); + + /* Uncomment ONLY if run with DEBUG defined in cheap.h */ + // cheap_t *heap = test_the(); + // test_profiler(heap); + + Object *o = test_alloc(); + printf("Object size: %lu\n", sizeof(Object)); + printf("Object:\n\tx: %d\n\ty: %d\n\tz: %d\n\tvel: %f\n", o->x, o->y, o->z, o->velocity); + + test_dispose(); + + /* Sefault I don't understand, don't uncomment */ + // free(heap); + // free(o); + return 0; +} \ No newline at end of file diff --git a/src/GC/tests/wrapper_test.c b/src/GC/tests/wrapper_test.c new file mode 100644 index 0000000..729cf69 --- /dev/null +++ b/src/GC/tests/wrapper_test.c @@ -0,0 +1,45 @@ +#include +#include + +#include "cheap.h" + +typedef struct node { + int id; + struct node *child; +} Node; + +// Global variables make the test less complex +Node *HEAD = NULL; +Node *CURRENT = NULL; + +// Creates a linked list of length depth. Global head "HEAD" is updated. +void *create_linked_list(int depth) { + HEAD = (Node*)(cheap_alloc(sizeof(Node))); + HEAD->id = 0; + // Purposely omitting adding a child to "last_node", since its the last node + for (int i = 1; i < depth - 1; i++) { + insert_first(i); + } +} + +void *insert_first(int node_id) { + Node *new_head; + new_head = (Node*)(cheap_alloc(sizeof(Node))); + new_head->id = node_id; + new_head->child = HEAD; + + HEAD = new_head; +} + +void test_linked_list(int list_length){ + cheap_init(); + cheap_t *heap = cheap_the(); + cheap_set_profiler(heap, true); + create_linked_list(list_length); + cheap_dispose(); + free(heap); +} + +int main (int argc, char **argv) { + test_linked_list(30); +} \ No newline at end of file From a37a52d9f8cf9321b2efdadddd0b5cb1e67805b2 Mon Sep 17 00:00:00 2001 From: Martin Fredin Date: Thu, 30 Mar 2023 11:49:13 +0200 Subject: [PATCH 249/372] Apply env to return type. fixes #14 --- src/TypeChecker/TypeCheckerBidir.hs | 18 +++++++++++------- 1 file changed, 11 insertions(+), 7 deletions(-) diff --git a/src/TypeChecker/TypeCheckerBidir.hs b/src/TypeChecker/TypeCheckerBidir.hs index 031396d..ffadf07 100644 --- a/src/TypeChecker/TypeCheckerBidir.hs +++ b/src/TypeChecker/TypeCheckerBidir.hs @@ -548,21 +548,24 @@ checkBranch (Branch patt exp) t_patt t_exp = do pure (T.Branch patt' (exp, t_exp)) checkPattern :: Pattern -> Type -> Tc (T.Pattern' Type, Type) -checkPattern patt t_patt = (, t_patt) <$> case patt of +checkPattern patt t_patt = case patt of PVar x -> do insertEnv $ EnvVar x t_patt - pure $ T.PVar (coerce x, t_patt) + pure (T.PVar (coerce x, t_patt), t_patt) - PCatch -> pure T.PCatch + PCatch -> pure (T.PCatch, t_patt) - PLit lit | inferLit lit == t_patt -> pure $ T.PLit (lit, t_patt) - | otherwise -> throwError "Literal in pattern have wrong type" + PLit lit -> do + subtype (inferLit lit) t_patt + t_patt' <- applyEnv t_patt + pure (T.PLit (lit, t_patt), t_patt') PEnum name -> do t <- maybeToRightM ("Unknown constructor " ++ show name) =<< lookupInj name subtype t t_patt - pure $ T.PEnum (coerce name) + t_patt' <- applyEnv t_patt + pure (T.PEnum (coerce name), t_patt') PInj name ps -> do @@ -570,9 +573,10 @@ checkPattern patt t_patt = (, t_patt) <$> case patt of t_inj' <- foldrM substitute' t_inj $ getInitForalls t_inj subtype (getDataId t_inj') t_patt t_inj'' <- applyEnv t_inj' + t_patt' <- applyEnv t_patt let ts_inj = getParams t_inj'' ps' <- zipWithM (\p t -> checkPattern p =<< applyEnv t) ps ts_inj - pure $ T.PInj (coerce name) (map fst ps') + pure (T.PInj (coerce name) (map fst ps'), t_patt') where substitute' fa t = do tevar <- fresh From bbe0d77a19e88055b597ed597c8da27ca6f490ca Mon Sep 17 00:00:00 2001 From: Martin Fredin Date: Thu, 30 Mar 2023 12:35:47 +0200 Subject: [PATCH 250/372] Add signature of inferred bind to allow some mutually defined definitions --- sample-programs/basic-0 | 21 ++++++----- sample-programs/basic-1.crf | 16 ++++----- src/TypeChecker/TypeCheckerBidir.hs | 54 ++++++++++++++++++++++------- tests/TestTypeCheckerBidir.hs | 48 +++++++++++++++++++++++++ 4 files changed, 111 insertions(+), 28 deletions(-) diff --git a/sample-programs/basic-0 b/sample-programs/basic-0 index 88e4071..35b9c04 100644 --- a/sample-programs/basic-0 +++ b/sample-programs/basic-0 @@ -1,15 +1,20 @@ -data forall a. List (a) where { - Nil : List (a) - Cons : a -> List (a) -> List (a) +data Bool () where { + True : Bool () + False : Bool () }; -length : forall c. List (List (c)) -> Int; -length = \list. case list of { - Cons x xs => 1 + length xs; --- Nil => 0; --- Cons x (Cons y Nil) => 2; +even : Int -> Bool (); +even x = not (odd x) ; + +odd x = not (even x) ; + +not x = case x of { + True => False; + False => True; }; +f = g; +g = f; diff --git a/sample-programs/basic-1.crf b/sample-programs/basic-1.crf index 91317cd..a5e2ae4 100644 --- a/sample-programs/basic-1.crf +++ b/sample-programs/basic-1.crf @@ -1,9 +1,9 @@ -data True() where { - True: True() +data Bool () where { + True : Bool () + False : Bool () +}; + +toBool = case 0 of { + 0 => False; + _ => True; }; -main: Int; -main = - case True of { - True => 1; - _ => 0; - }; \ No newline at end of file diff --git a/src/TypeChecker/TypeCheckerBidir.hs b/src/TypeChecker/TypeCheckerBidir.hs index ffadf07..3930a0e 100644 --- a/src/TypeChecker/TypeCheckerBidir.hs +++ b/src/TypeChecker/TypeCheckerBidir.hs @@ -6,18 +6,19 @@ module TypeChecker.TypeCheckerBidir (typecheck, getVars) where -import Auxiliary (maybeToRightM, snoc, int, char) +import Auxiliary (char, int, maybeToRightM, snoc) import Control.Applicative (Alternative, Applicative (liftA2), (<|>)) import Control.Monad.Except (ExceptT, MonadError (throwError), - runExceptT, unless, zipWithM, - zipWithM_) + mapAndUnzipM, runExceptT, unless, + zipWithM, zipWithM_) import Control.Monad.State (MonadState (get, put), State, evalState, gets, modify) import Data.Coerce (coerce) import Data.Foldable (foldrM) import Data.Function (on) import Data.List (intercalate) +import Data.List.Extra (allSame) import Data.Map (Map) import qualified Data.Map as Map import Data.Maybe (fromMaybe, isNothing) @@ -92,7 +93,7 @@ typecheck (Program defs) = do typecheckBind :: Bind -> Tc (T.Bind' Type) typecheckBind (Bind name vars rhs) = do - bind' <- lookupSig name >>= \case + bind'@(T.Bind (name, typ) _ _) <- lookupSig name >>= \case -- TODO These Judgment aren't accurate -- (f:A → B) ∈ Γ -- Γ,(xs:A) ⊢ e ↑ Β ⊣ Δ @@ -101,8 +102,6 @@ typecheckBind (Bind name vars rhs) = do Just t -> do (rhs', _) <- check (foldr EAbs rhs vars) t pure (T.Bind (coerce name, t) [] (rhs', t)) - where - vars' = zip vars $ getVars t -- Γ ⊢ (λxs. e) ↓ A → B ⊣ Δ -- ------------------------------ @@ -114,6 +113,7 @@ typecheckBind (Bind name vars rhs) = do pure (T.Bind (coerce name, t') [] (e', t')) env <- gets env unless (isComplete env) err + insertSig (coerce name) typ putEnv Empty pure bind' where @@ -389,12 +389,13 @@ check exp typ -- Γ ⊢ e ↓ A ⊣ Θ Δ ⊢ Π covers [Δ]A TODO -- --------------------------------------- -- Γ ⊢ case e of Π ↑ C ⊣ Δ - | ECase scrut branches <- exp = do - (scrut', t_scrut) <- infer scrut - t_scrut' <- applyEnv t_scrut - typ' <- applyEnv typ - branches' <- mapM (\b -> checkBranch b t_scrut' typ') branches - pure (T.ECase (scrut', t_scrut') branches', typ') + -- TODO maybe remove only use infer rule + | ECase scrut branches <- exp = do + (scrut', t_scrut) <- infer scrut + t_scrut' <- applyEnv t_scrut + typ' <- applyEnv typ + branches' <- mapM (\b -> checkBranch b t_scrut' typ') branches + pure (T.ECase (scrut', t_scrut') branches', typ') | otherwise = subsumption where @@ -490,6 +491,18 @@ infer = \case e2' <- check e2 t pure (T.EAdd e1' e2', t) + + -- Θ ⊢ Π ∷ [Θ]A ↑ [Θ]C ⊣ Δ + -- Γ ⊢ e ↓ A ⊣ Θ Δ ⊢ Π covers [Δ]A TODO + -- --------------------------------------- + -- Γ ⊢ case e of Π ↓ C ⊣ Δ + ECase scrut branches -> do + (scrut', t_scrut) <- infer scrut + t_scrut' <- applyEnv t_scrut + (branches', ts) <- mapAndUnzipM (`inferBranch` t_scrut') branches + unless (allSame ts) $ throwError "Branches have different return types" + pure (T.ECase (scrut', t_scrut') branches', head ts) + -- | Γ ⊢ A • e ⇓ C ⊣ Δ -- Under input context Γ , applying a function of type A to e infers type C, with output context ∆ -- Instantiate existential type variables until there is an arrow type. @@ -534,6 +547,19 @@ apply typ exp = case typ of -- * Pattern matching --------------------------------------------------------------------------- +-- | Γ ⊢ p ⇒ e ∷ A ↓ C +-- Under context Γ, check pattern in branch p ⇒ e of type A and infer bodies of type C +inferBranch :: Branch -> Type -> Tc (T.Branch' Type, Type) +inferBranch (Branch patt exp) t_patt = do + env_marker <- EnvMark <$> fresh + insertEnv env_marker + patt' <- checkPattern patt t_patt + (exp', t_exp) <- infer exp + (env_l, _) <- gets (splitOn env_marker . env) + putEnv env_l + pure (T.Branch patt' (exp', t_exp), t_exp) + + -- | Γ ⊢ p ⇒ e ∷ A ↑ C -- Under context Γ, check branch p ⇒ e of type A and bodies of type C checkBranch :: Branch -> Type -> Type -> Tc (T.Branch' Type) @@ -852,6 +878,10 @@ lookupBind x = gets (Map.lookup x . binds) lookupSig :: LIdent -> Tc (Maybe Type) lookupSig x = gets (Map.lookup x . sig) +insertSig :: LIdent -> Type -> Tc () +insertSig name t = modify $ \cxt -> cxt { sig = Map.insert name t cxt.sig } + + lookupEnv :: LIdent -> Tc (Maybe Type) lookupEnv x = gets (findId . env) where diff --git a/tests/TestTypeCheckerBidir.hs b/tests/TestTypeCheckerBidir.hs index 48bf230..c75457e 100644 --- a/tests/TestTypeCheckerBidir.hs +++ b/tests/TestTypeCheckerBidir.hs @@ -31,6 +31,8 @@ testTypeCheckerBidir = describe "Bidirectional type checker test" $ do tc_tree tc_mono_case tc_pol_case + tc_mut_rec + tc_infer_case tc_id = specify "Basic identity function polymorphism" $ @@ -266,6 +268,52 @@ tc_pol_case = describe "Polymophic and recursive pattern matching" $ do , "};" ] + +tc_mut_rec = specify "Feasible mutuable recursive definitions" $ run + [ "data Bool () where {" + , " True : Bool ()" + , " False : Bool ()" + , "};" + + , "even : Int -> Bool ();" + , "even x = not (odd x);" + + , "odd x = not (even x);" + + , "not x = case x of {" + , " True => False;" + , " False => True;" + , "};" + ] `shouldSatisfy` ok + +tc_infer_case = describe "Infer case expression" $ do + specify "Wrong case expression rejected" $ + run (fs ++ wrong) `shouldNotSatisfy` ok + specify "Correct case expression accepted" $ + run (fs ++ correct) `shouldSatisfy` ok + where + fs = + [ "data Bool () where {" + , " True : Bool ()" + , " False : Bool ()" + , "};" + ] + + correct = + [ "toBool = case 0 of {" + , " 0 => False;" + , " _ => True;" + , "};" + ] + + wrong = + [ "toBool = case 0 of {" + , " 0 => False;" + , " _ => 1;" + , "};" + ] + + run :: [String] -> Err T.Program run = rmTEVar <=< typecheck <=< pProgram . myLexer . unlines From b3525db7fd756b0cb691199ba0a336da10fb45bd Mon Sep 17 00:00:00 2001 From: Samuel Hammersberg Date: Thu, 30 Mar 2023 12:31:03 +0200 Subject: [PATCH 251/372] Integrated the garbage collector. --- src/Codegen/CompilerState.hs | 6 +++--- src/Codegen/Emits.hs | 4 +++- src/Codegen/LlvmIr.hs | 2 +- src/Compiler.hs | 11 +++++++++-- test_program.crf | 10 +++++----- 5 files changed, 21 insertions(+), 12 deletions(-) diff --git a/src/Codegen/CompilerState.hs b/src/Codegen/CompilerState.hs index a6c100a..3aa4123 100644 --- a/src/Codegen/CompilerState.hs +++ b/src/Codegen/CompilerState.hs @@ -135,7 +135,7 @@ defaultStart = , UnsafeRaw "declare i32 @printf(ptr noalias nocapture, ...)\n" , UnsafeRaw "declare i32 @exit(i32 noundef)\n" , UnsafeRaw "declare ptr @malloc(i32 noundef)\n" - , UnsafeRaw "declare void @_ZN2GC4Heap4initEv()\n" - , UnsafeRaw "declare void @_ZN2GC4Heap5allocEm()\n" - , UnsafeRaw "declare void @_ZN2GC4Heap7disposeEv()\n" + , UnsafeRaw "declare external void @cheap_init()\n" + , UnsafeRaw "declare external ptr @cheap_alloc(i64)\n" + , UnsafeRaw "declare external void @cheap_dispose()\n" ] \ No newline at end of file diff --git a/src/Codegen/Emits.hs b/src/Codegen/Emits.hs index c41e340..0309514 100644 --- a/src/Codegen/Emits.hs +++ b/src/Codegen/Emits.hs @@ -127,12 +127,13 @@ compileScs (MIR.DData (MIR.Data typ ts) : xs) = do compileScs xs firstMainContent :: [LLVMIr] -firstMainContent = [] +firstMainContent = [UnsafeRaw "call void @cheap_init()\n"] lastMainContent :: LLVMValue -> [LLVMIr] lastMainContent var = [ UnsafeRaw $ "call i32 (ptr, ...) @printf(ptr noundef @.str, i64 noundef " <> toIr var <> ")\n" + , UnsafeRaw "call void @cheap_dispose()\n" , Ret I64 (VInteger 0) ] @@ -169,6 +170,7 @@ emitECased t e cases = do -- crashLbl <- TIR.Ident . ("crash_" <>) . show <$> getNewLabel -- emit $ Label crashLbl emit . UnsafeRaw $ "call i32 (ptr, ...) @printf(ptr noundef @.non_exhaustive_patterns, i64 noundef 6, i64 noundef 6)\n" + emit . UnsafeRaw $ "call void @cheap_dispose()\n" emit . UnsafeRaw $ "call i32 @exit(i32 noundef 1)\n" mapM_ (const increaseVarCount) [0 .. 1] emit $ Br label diff --git a/src/Codegen/LlvmIr.hs b/src/Codegen/LlvmIr.hs index 0ef6ac0..ac9432a 100644 --- a/src/Codegen/LlvmIr.hs +++ b/src/Codegen/LlvmIr.hs @@ -225,7 +225,7 @@ llvmIrToString = go 0 (Alloca t) -> unwords ["alloca", toIr t, "\n"] (Malloca t) -> concat - [ "call ptr @malloc(i32 ", show t, ")\n"] + [ "call ptr @cheap_alloc(i64 ", show t, ")\n"] (Store t1 val t2 (Ident id2)) -> concat [ "store ", toIr t1, " ", toIr val diff --git a/src/Compiler.hs b/src/Compiler.hs index 0b34936..c486cc4 100644 --- a/src/Compiler.hs +++ b/src/Compiler.hs @@ -15,8 +15,15 @@ compileClang = readCreateProcess . shell $ unwords [ "clang++" -- , "-Lsrc/GC/lib/", "-l:libgcoll.a" - , "-fno-exceptions -x" - , "ir" + , "-fno-rtti" + , "src/GC/lib/cheap.cpp" + , "src/GC/lib/event.cpp" + , "src/GC/lib/heap.cpp" + , "src/GC/lib/profiler.cpp" + , "-Wall -Wextra -g -std=gnu++20 -stdlib=libstdc++" + , "-Isrc/GC/include" + , "-x" + , "ir" -- , "-Lsrc/GC/lib -l:gcoll.a" , "-o" , "output/hello_world" , "-" diff --git a/test_program.crf b/test_program.crf index 14cd86c..b584ff8 100644 --- a/test_program.crf +++ b/test_program.crf @@ -1,9 +1,9 @@ --- main = head (Cons (sum (repeat 10 5)) Nil); +main = head (Cons (sum (repeat 5 9223372036854775807)) Nil); --9223372036854775807 -main = case (bind (fmap (\s . s + 1) (Just 5)) (\s . pure (s + 10))) of { - Just a => a ; - Nothing => minusOne ; -}; +-- main = case (bind (fmap (\s . s + 1) (Just 5)) (\s . pure (s + 10))) of { +-- Just a => a ; +-- Nothing => minusOne ; +-- }; ---- MAYBE MONAD ---- data Maybe () where { From 9b38c6d8046b044b47cdc232f8bf809318c1366b Mon Sep 17 00:00:00 2001 From: Samuel Hammersberg Date: Thu, 30 Mar 2023 12:37:24 +0200 Subject: [PATCH 252/372] Main now prints the exit code of the program, as Haskell likes to hide segfaults. --- src/Main.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Main.hs b/src/Main.hs index 97d75e8..a6337bf 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -135,7 +135,7 @@ main' opts s = do compile generatedCode printToErr "Compilation done!" printToErr "\n-- Program output --" - spawnWait "./output/hello_world" + print =<< spawnWait "./output/hello_world" exitSuccess From 5d2c0e787ef2610efce08f5bebf2a0b67864a6c4 Mon Sep 17 00:00:00 2001 From: Samuel Hammersberg Date: Thu, 30 Mar 2023 15:08:40 +0200 Subject: [PATCH 253/372] The compiler is now compiled with O3. --- src/Compiler.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Compiler.hs b/src/Compiler.hs index c486cc4..43c9c5e 100644 --- a/src/Compiler.hs +++ b/src/Compiler.hs @@ -8,7 +8,7 @@ import System.Process.Extra ( -- spawnWait s = spawnCommand s >>= \s >>= waitForProcess optimize :: String -> IO String -optimize = readCreateProcess (shell "opt --O3 -S") +optimize = readCreateProcess (shell "opt --O3 --tailcallopt -S") compileClang :: String -> IO String compileClang = @@ -20,7 +20,7 @@ compileClang = , "src/GC/lib/event.cpp" , "src/GC/lib/heap.cpp" , "src/GC/lib/profiler.cpp" - , "-Wall -Wextra -g -std=gnu++20 -stdlib=libstdc++" + , "-Wall -Wextra -g -std=gnu++20 -stdlib=libstdc++ -O3" , "-Isrc/GC/include" , "-x" , "ir" -- , "-Lsrc/GC/lib -l:gcoll.a" From 4831205e6793f62a2f731394a51b63f53eff9754 Mon Sep 17 00:00:00 2001 From: Martin Fredin Date: Thu, 30 Mar 2023 12:49:27 +0200 Subject: [PATCH 254/372] Remove incorrect test --- tests/TestTypeCheckerBidir.hs | 18 ------------------ 1 file changed, 18 deletions(-) diff --git a/tests/TestTypeCheckerBidir.hs b/tests/TestTypeCheckerBidir.hs index c75457e..f423720 100644 --- a/tests/TestTypeCheckerBidir.hs +++ b/tests/TestTypeCheckerBidir.hs @@ -31,7 +31,6 @@ testTypeCheckerBidir = describe "Bidirectional type checker test" $ do tc_tree tc_mono_case tc_pol_case - tc_mut_rec tc_infer_case tc_id = @@ -269,23 +268,6 @@ tc_pol_case = describe "Polymophic and recursive pattern matching" $ do ] -tc_mut_rec = specify "Feasible mutuable recursive definitions" $ run - [ "data Bool () where {" - , " True : Bool ()" - , " False : Bool ()" - , "};" - - , "even : Int -> Bool ();" - , "even x = not (odd x);" - - , "odd x = not (even x);" - - , "not x = case x of {" - , " True => False;" - , " False => True;" - , "};" - ] `shouldSatisfy` ok - tc_infer_case = describe "Infer case expression" $ do specify "Wrong case expression rejected" $ run (fs ++ wrong) `shouldNotSatisfy` ok From 72352d9619e862484f16ee12140e0b3a5d23f32e Mon Sep 17 00:00:00 2001 From: Martin Fredin Date: Thu, 30 Mar 2023 18:46:37 +0200 Subject: [PATCH 255/372] Use use tevars for bind without type signatures, fix recursive functions --- src/TypeChecker/TypeCheckerBidir.hs | 227 +++++++++++----------------- tests/TestTypeCheckerBidir.hs | 17 +++ 2 files changed, 107 insertions(+), 137 deletions(-) diff --git a/src/TypeChecker/TypeCheckerBidir.hs b/src/TypeChecker/TypeCheckerBidir.hs index 3930a0e..1f16e11 100644 --- a/src/TypeChecker/TypeCheckerBidir.hs +++ b/src/TypeChecker/TypeCheckerBidir.hs @@ -6,18 +6,18 @@ module TypeChecker.TypeCheckerBidir (typecheck, getVars) where -import Auxiliary (char, int, maybeToRightM, snoc) +import Auxiliary (int, litType, maybeToRightM, snoc) import Control.Applicative (Alternative, Applicative (liftA2), (<|>)) import Control.Monad.Except (ExceptT, MonadError (throwError), - mapAndUnzipM, runExceptT, unless, + liftEither, runExceptT, unless, zipWithM, zipWithM_) import Control.Monad.State (MonadState (get, put), State, evalState, gets, modify) import Data.Coerce (coerce) import Data.Foldable (foldrM) import Data.Function (on) -import Data.List (intercalate) +import Data.List (intercalate, partition) import Data.List.Extra (allSame) import Data.Map (Map) import qualified Data.Map as Map @@ -39,6 +39,7 @@ import qualified TypeChecker.TypeCheckerIr as T -- • Fix problems with types in Pattern/Branch in TypeCheckerIr -- • Use applyEnvExp consistently -- • Fix the different type getters functions (e.g. partitionType) functions +-- • Handle recursive functions. Maybe use a isRec : Bool variable. data EnvElem = EnvVar LIdent Type -- ^ Term variable typing. x : A | EnvTVar TVar -- ^ Universal type variable. α @@ -94,18 +95,9 @@ typecheck (Program defs) = do typecheckBind :: Bind -> Tc (T.Bind' Type) typecheckBind (Bind name vars rhs) = do bind'@(T.Bind (name, typ) _ _) <- lookupSig name >>= \case - -- TODO These Judgment aren't accurate - -- (f:A → B) ∈ Γ - -- Γ,(xs:A) ⊢ e ↑ Β ⊣ Δ - --------------------------- - -- Γ ⊢ f xs = e ↓ Α → B ⊣ Δ Just t -> do (rhs', _) <- check (foldr EAbs rhs vars) t pure (T.Bind (coerce name, t) [] (rhs', t)) - - -- Γ ⊢ (λxs. e) ↓ A → B ⊣ Δ - -- ------------------------------ - -- Γ ⊢ f xs = e ↓ [Γ]A → [Γ]B ⊣ Δ Nothing -> do (e, t) <- infer $ foldr EAbs rhs vars t' <- applyEnv t @@ -113,7 +105,7 @@ typecheckBind (Bind name vars rhs) = do pure (T.Bind (coerce name, t') [] (e', t')) env <- gets env unless (isComplete env) err - insertSig (coerce name) typ + insertSig (coerce name) typ -- HERE putEnv Empty pure bind' where @@ -265,9 +257,9 @@ instantiateL tevar typ = gets env >>= go -- Γ ⊢ τ -- ----------------------------- InstLSolve -- Γ,ά,Γ' ⊢ ά :=< τ ⊣ Γ,(ά=τ),Γ' - | isMono typ + | noForall typ , (env_l, env_r) <- splitOn (EnvTEVar tevar) env - , Right _ <- wellFormed env_l typ + , Right _ <- wellFormed env_l typ = putEnv $ (env_l :|> EnvTEVarSolved tevar typ) <> env_r | TEVar tevar' <- typ = instReach tevar tevar' @@ -305,7 +297,7 @@ instantiateR typ tevar = gets env >>= go -- Γ ⊢ τ -- ----------------------------- InstRSolve -- Γ,ά,Γ' ⊢ τ =:< ά ⊣ Γ,(ά=τ),Γ' - | isMono typ + | noForall typ , (env_l, env_r) <- splitOn (EnvTEVar tevar) env , Right _ <- wellFormed env_l typ = putEnv $ (env_l :|> EnvTEVarSolved tevar typ) <> env_r @@ -337,7 +329,6 @@ instantiateR typ tevar = gets env >>= go let (env_l, _) = splitOn (EnvTVar tvar) env putEnv env_l - | otherwise = error $ "Trying to instantiateR: " ++ ppT typ ++ " <: " ++ ppT (TEVar tevar) @@ -385,18 +376,6 @@ check exp typ putEnv env_l pure (T.EAbs (coerce name) e', typ) - -- Θ ⊢ Π ∷ [Θ]A ↑ [Θ]C ⊣ Δ - -- Γ ⊢ e ↓ A ⊣ Θ Δ ⊢ Π covers [Δ]A TODO - -- --------------------------------------- - -- Γ ⊢ case e of Π ↑ C ⊣ Δ - -- TODO maybe remove only use infer rule - | ECase scrut branches <- exp = do - (scrut', t_scrut) <- infer scrut - t_scrut' <- applyEnv t_scrut - typ' <- applyEnv typ - branches' <- mapM (\b -> checkBranch b t_scrut' typ') branches - pure (T.ECase (scrut', t_scrut') branches', typ') - | otherwise = subsumption where -- Γ,α ⊢ e ↓ A ⊣ Θ Θ ⊢ [Θ]A <: [Θ]B ⊣ Δ @@ -405,7 +384,7 @@ check exp typ subsumption = do (exp', t) <- infer exp exp'' <- applyEnvExp exp' - t' <- applyEnv t + t' <- applyEnv t typ' <- applyEnv typ subtype t' typ' pure (exp'', t') @@ -415,19 +394,20 @@ check exp typ infer :: Exp -> Tc (T.ExpT' Type) infer = \case - ELit lit -> pure (T.ELit lit, inferLit lit) + ELit lit -> pure (T.ELit lit, litType lit) - -- (x : A) ∈ Γ - -- ------------- Var - -- Γ ⊢ x ↓ A ⊣ Γ + -- (x : A) ∈ Γ (x : A) ∉ Γ + -- ------------- Var --------------- Var' + -- Γ ⊢ x ↓ A ⊣ Γ Γ ⊢ x ↓ ά ⊣ Γ,ά EVar name -> do t <- liftA2 (<|>) (lookupEnv name) (lookupSig name) >>= \case Just t -> pure t Nothing -> do - e <- maybeToRightM - ("Unbound variable " ++ show name) - =<< lookupBind name - snd <$> infer e + tevar <- fresh + insertEnv (EnvTEVar tevar) + let t = TEVar tevar + insertEnv (EnvVar name t) + pure t pure (T.EVar (coerce name), t) EInj name -> do @@ -480,28 +460,25 @@ infer = \case putEnv env_l pure (T.ELet (T.Bind (coerce name, t_rhs) [] (rhs', t_rhs)) (e',t), t) - -- Γ ⊢ e₁ ↑ Int Γ ⊢ e₁ ↑ Int + -- Γ ⊢ e₁ ↑ Int ⊣ Θ Θ ⊢ e₂ ↑ Int -- --------------------------- +I -- Γ ⊢ e₁ + e₂ ↓ Int ⊣ Δ EAdd e1 e2 -> do - cxt <- get - let t = int - e1' <- check e1 t - put cxt - e2' <- check e2 t - pure (T.EAdd e1' e2', t) + e1' <- check e1 int + e2' <- check e2 int + e1'' <- applyEnvExpT e1' + e2'' <- applyEnvExpT e2' + pure (T.EAdd e1'' e2'', int) - -- Θ ⊢ Π ∷ [Θ]A ↑ [Θ]C ⊣ Δ + -- Θ ⊢ Π ∷ A ↓ C ⊣ Δ -- Γ ⊢ e ↓ A ⊣ Θ Δ ⊢ Π covers [Δ]A TODO -- --------------------------------------- -- Γ ⊢ case e of Π ↓ C ⊣ Δ ECase scrut branches -> do (scrut', t_scrut) <- infer scrut - t_scrut' <- applyEnv t_scrut - (branches', ts) <- mapAndUnzipM (`inferBranch` t_scrut') branches - unless (allSame ts) $ throwError "Branches have different return types" - pure (T.ECase (scrut', t_scrut') branches', head ts) + (branches', t_return) <- inferBranches branches t_scrut + pure (T.ECase (scrut', t_scrut) branches', t_return) -- | Γ ⊢ A • e ⇓ C ⊣ Δ -- Under input context Γ , applying a function of type A to e infers type C, with output context ∆ @@ -547,45 +524,71 @@ apply typ exp = case typ of -- * Pattern matching --------------------------------------------------------------------------- --- | Γ ⊢ p ⇒ e ∷ A ↓ C --- Under context Γ, check pattern in branch p ⇒ e of type A and infer bodies of type C +-- Γ ⊢ p ⇒ e ∷ A ↓ B ⊣ Θ +-- Θ ⊢ Π ∷ [Θ]A ↓ C ⊣ Δ +-- [Δ]B <: C +-- --------------------------- +-- Γ ⊢ (p ⇒ e),Π ∷ A ↓ C ⊣ Δ +inferBranches :: [Branch] -> Type -> Tc ([T.Branch' Type], Type) +inferBranches branches t_patt = do + (branches', ts_exp) <- inferBranches' t_patt branches + ts_exp' <- mapM applyEnv ts_exp + let (monos, pols) = partition isMono ts_exp' + t_exp <- liftEither $ bodyType t_patt monos + mapM_ (subtype t_exp) pols + pure (branches', t_exp) + where + + bodyType :: Type -> [Type] -> Err Type + bodyType t_patt = \case + [] -> pure t_patt + [m] -> pure m + m:n:ms | m == n -> bodyType t_patt (n:ms) + | otherwise -> throwError $ unwords [ "Wrong return types: " + , ppT m, "≠", ppT n ] + + inferBranches' = go [] [] + where + go branches ts_exp t = \case + [] -> pure (branches, ts_exp) + b:bs -> do + (b', t_e) <- inferBranch b t + t' <- applyEnv t + go (snoc b' branches) (snoc t_e ts_exp) t' bs + +-- Γ ⊢ p ↑ A ⊣ Θ Θ ⊢ e ↓ C ⊣ Δ +-- ------------------------------- +-- Γ ⊢ p ⇒ e ∷ A ↓ C ⊣ Δ inferBranch :: Branch -> Type -> Tc (T.Branch' Type, Type) inferBranch (Branch patt exp) t_patt = do - env_marker <- EnvMark <$> fresh - insertEnv env_marker patt' <- checkPattern patt t_patt (exp', t_exp) <- infer exp - (env_l, _) <- gets (splitOn env_marker . env) - putEnv env_l pure (T.Branch patt' (exp', t_exp), t_exp) - --- | Γ ⊢ p ⇒ e ∷ A ↑ C --- Under context Γ, check branch p ⇒ e of type A and bodies of type C -checkBranch :: Branch -> Type -> Type -> Tc (T.Branch' Type) -checkBranch (Branch patt exp) t_patt t_exp = do - env_marker <- EnvMark <$> fresh - insertEnv env_marker - patt' <- checkPattern patt t_patt - t_exp' <- applyEnv t_exp - (exp, t_exp) <- check exp t_exp' - (env_l, _) <- gets (splitOn env_marker . env) - putEnv env_l - pure (T.Branch patt' (exp, t_exp)) - checkPattern :: Pattern -> Type -> Tc (T.Pattern' Type, Type) checkPattern patt t_patt = case patt of + + -- ------------------- + -- Γ ⊢ x ↑ A ⊣ Γ,(x:A) PVar x -> do insertEnv $ EnvVar x t_patt pure (T.PVar (coerce x, t_patt), t_patt) + -- ------------- + -- Γ ⊢ _ ↑ A ⊣ Γ PCatch -> pure (T.PCatch, t_patt) + -- Γ ⊢ τ ↓ A ⊣ Γ Γ ⊢ A <: B ⊣ Δ + -- ------------------------------ + -- Γ ⊢ τ ↑ B ⊣ Δ PLit lit -> do - subtype (inferLit lit) t_patt + subtype (litType lit) t_patt t_patt' <- applyEnv t_patt pure (T.PLit (lit, t_patt), t_patt') + -- (x : A) ∈ Γ Γ ⊢ A <: B ⊣ Δ + -- --------------------------- + -- Γ ⊢ inj₀ x ↑ B ⊣ Δ PEnum name -> do t <- maybeToRightM ("Unknown constructor " ++ show name) =<< lookupInj name @@ -599,13 +602,14 @@ checkPattern patt t_patt = case patt of t_inj' <- foldrM substitute' t_inj $ getInitForalls t_inj subtype (getDataId t_inj') t_patt t_inj'' <- applyEnv t_inj' - t_patt' <- applyEnv t_patt let ts_inj = getParams t_inj'' ps' <- zipWithM (\p t -> checkPattern p =<< applyEnv t) ps ts_inj + t_patt' <- applyEnv t_patt pure (T.PInj (coerce name) (map fst ps'), t_patt') where substitute' fa t = do tevar <- fresh + -- insertEnv (EnvTEVar tevar) pure $ substitute tvar tevar t where TAll tvar _ = fa dummy @@ -666,6 +670,9 @@ splitOn x env = second (S.drop 1) $ S.breakl (==x) env dropTrailing :: EnvElem -> Tc () dropTrailing x = modifyEnv $ S.takeWhileL (/= x) +applyEnvExpT :: (T.Exp' Type, Type) -> Tc (T.Exp' Type, Type) +applyEnvExpT (e, t) = liftA2 (,) (applyEnvExp e) (applyEnv t) + applyEnvExp :: T.Exp' Type -> Tc (T.Exp' Type) applyEnvExp exp = case exp of T.ELet (T.Bind id vars rhs) exp -> do @@ -681,7 +688,6 @@ applyEnvExp exp = case exp of (mapM applyEnvBranch branches) _ -> pure exp where - applyEnvExpT (e, t) = liftA2 (,) (applyEnvExp e) (applyEnv t) applyEnvId = secondM applyEnv applyEnvBranch (T.Branch (p, t) e) = do pt <- liftA2 (,) (applyEnvPattern p) (applyEnv t) @@ -752,20 +758,24 @@ wellFormed env = \case TData _ typs -> mapM_ (wellFormed env) typs +noForall :: Type -> Bool +noForall = \case + TAll{} -> False + TFun t1 t2 -> on (&&) noForall t1 t2 + TData _ typs -> all noForall typs + TVar _ -> True + TEVar _ -> True + TLit _ -> True + isMono :: Type -> Bool isMono = \case TAll{} -> False TFun t1 t2 -> on (&&) isMono t1 t2 TData _ typs -> all isMono typs - TVar _ -> True - TEVar _ -> True + TVar _ -> False + TEVar _ -> False TLit _ -> True -inferLit :: Lit -> Type -inferLit = \case - LInt _ -> TLit "Int" - LChar _ -> TLit "Char" - fresh :: Tc TEVar fresh = do tevar <- gets (MkTEVar . LIdent . ("a#" ++) . show . next_tevar) @@ -803,60 +813,6 @@ skipForalls = go [] TAll tvar t -> go (snoc (TAll tvar) acc) t _ -> (acc, typ) - -getForallsData :: Type -> [Type -> Type] -getForallsData = fst . partitionData - -getTData :: Type -> Type -getTData = snd . partitionData - -partitionData :: Type -> ([Type -> Type], Type) -partitionData = go . ([],) - where - go (acc, typ) = case typ of - TAll tvar t -> go (snoc (TAll tvar) acc, t) - TData {} -> (acc, typ) - TFun _ t -> go (acc, t) - _ -> error "Bad data type" - - -partitionTypeWithForall :: Type -> ([Type], Type) -partitionTypeWithForall typ = (t_vars', t_return') - where - t_vars' = map (\t -> foldr applyForall t foralls) t_vars - t_return' = foldr applyForall t_return foralls - - applyForall fa t | usesTVar tvar t = fa t - | otherwise = t - where TAll tvar _ = fa t - - (t_vars, t_return) = go [] typ' - (foralls, typ') = skipForalls typ - - - go acc t = case t of - TFun t1 t2 -> go (snoc t1 acc) t2 - _ -> (acc, t) - -usesTVar :: TVar -> Type -> Bool -usesTVar tvar = \case - TLit _ -> False - TVar tvar' | tvar' == tvar -> True - | otherwise -> False - TFun t1 t2 -> on (||) usesTVar' t1 t2 - TAll tvar' t | tvar' == tvar -> error "Redeclaration of TVar" - | otherwise -> usesTVar' t - TData _ typs -> any usesTVar' typs - _ -> error "Impossible" - where - usesTVar' = usesTVar tvar - -skipLambdas :: Int -> T.Exp' Type -> T.Exp' Type -skipLambdas i exp - | i == 0 = exp - | T.EAbs _ (e, _) <- exp = skipLambdas (i-1) e - | otherwise = error "Number of expected lambdas doesn't match expression" - isComplete :: Env -> Bool isComplete = isNothing . S.findIndexL unSolvedTEVar where @@ -872,9 +828,6 @@ toTVar = \case insertEnv :: EnvElem -> Tc () insertEnv x = modifyEnv (:|> x) -lookupBind :: LIdent -> Tc (Maybe Exp) -lookupBind x = gets (Map.lookup x . binds) - lookupSig :: LIdent -> Tc (Maybe Type) lookupSig x = gets (Map.lookup x . sig) diff --git a/tests/TestTypeCheckerBidir.hs b/tests/TestTypeCheckerBidir.hs index f423720..5e1d5b1 100644 --- a/tests/TestTypeCheckerBidir.hs +++ b/tests/TestTypeCheckerBidir.hs @@ -32,6 +32,8 @@ testTypeCheckerBidir = describe "Bidirectional type checker test" $ do tc_mono_case tc_pol_case tc_infer_case + tc_rec1 + tc_rec2 tc_id = specify "Basic identity function polymorphism" $ @@ -295,6 +297,21 @@ tc_infer_case = describe "Infer case expression" $ do , "};" ] +tc_rec1 = specify "Infer simple recursive definition" $ + run ["test x = 1 + test (x + 1);"] `shouldSatisfy` ok + +tc_rec2 = specify "Infer recursive definition with pattern matching" $ run + [ "data Bool () where {" + , " False : Bool ()" + , " True : Bool ()" + , "};" + + , "test = \\x. case x of {" + , " 10 => True;" + , " _ => test (x+1);" + , "};" + ] `shouldSatisfy` ok + run :: [String] -> Err T.Program run = rmTEVar <=< typecheck <=< pProgram . myLexer . unlines From 7d2a0e60d8b0c4d453ef5ffed0ca4bf886534336 Mon Sep 17 00:00:00 2001 From: Martin Fredin Date: Thu, 30 Mar 2023 19:07:12 +0200 Subject: [PATCH 256/372] Fixes --- src/TypeChecker/TypeCheckerBidir.hs | 75 ++++++++++++++--------------- 1 file changed, 35 insertions(+), 40 deletions(-) diff --git a/src/TypeChecker/TypeCheckerBidir.hs b/src/TypeChecker/TypeCheckerBidir.hs index 1f16e11..60667c5 100644 --- a/src/TypeChecker/TypeCheckerBidir.hs +++ b/src/TypeChecker/TypeCheckerBidir.hs @@ -39,7 +39,6 @@ import qualified TypeChecker.TypeCheckerIr as T -- • Fix problems with types in Pattern/Branch in TypeCheckerIr -- • Use applyEnvExp consistently -- • Fix the different type getters functions (e.g. partitionType) functions --- • Handle recursive functions. Maybe use a isRec : Bool variable. data EnvElem = EnvVar LIdent Type -- ^ Term variable typing. x : A | EnvTVar TVar -- ^ Universal type variable. α @@ -53,44 +52,43 @@ type Env = Seq EnvElem -- | Ordered context -- Γ ::= ・| Γ, α | Γ, ά | Γ, ▶ ά | Γ, x:A data Cxt = Cxt - { env :: Env -- ^ Local scope context Γ - , sig :: Map LIdent Type -- ^ Top-level signatures x : A - , binds :: Map LIdent Exp -- ^ Top-level binds x : e - , next_tevar :: Int -- ^ Counter to distinguish ά - , data_injs :: Map UIdent Type -- ^ Data injections (constructors) K/inj : A + { env :: Env -- ^ Local scope context Γ + , sig :: Map LIdent Type -- ^ Top-level signatures x : A + , binds :: Map LIdent Exp -- ^ Top-level binds x : e + , next_tevar :: Int -- ^ Counter to distinguish ά + , data_injs :: Map UIdent Type -- ^ Data injections (constructors) K/inj : A } deriving (Show, Eq) newtype Tc a = Tc { runTc :: ExceptT String (State Cxt) a } deriving (Functor, Applicative, Monad, Alternative, MonadState Cxt, MonadError String) -typecheck :: Program -> Err (T.Program' Type) -typecheck (Program defs) = do - datatypes <- mapM typecheckDataType [ d | DData d <- defs ] - - - let initCxt = Cxt - { env = mempty - , sig = Map.fromList [ (name, t) - | DSig' name t <- defs - ] - , binds = Map.fromList [ (name, foldr EAbs rhs vars) - | DBind' name vars rhs <- defs - ] - , next_tevar = 0 - , data_injs = Map.fromList [ (name, t) - | Data _ injs <- datatypes - , Inj name t <- injs - ] +initCxt :: [Def] -> Cxt +initCxt defs = Cxt + { env = mempty + , sig = Map.fromList [ (name, t) + | DSig' name t <- defs + ] + , binds = Map.fromList [ (name, foldr EAbs rhs vars) + | DBind' name vars rhs <- defs + ] + , next_tevar = 0 + , data_injs = Map.fromList [ (name, t) + | DData (Data _ injs) <- defs + , Inj name t <- injs + ] } - binds' <- evalState (runExceptT (runTc $ mapM typecheckBind binds)) initCxt; - pure . T.Program $ map T.DData (coerceData datatypes) ++ map T.DBind binds' - where - binds = [ b | DBind b <- defs ] - -- TODO this should happen in typecheckDataType - coerceData = map (\(Data t injs) -> T.Data t $ map - (\(Inj name typ) -> T.Inj (coerce name) typ) injs) +typecheck :: Program -> Err (T.Program' Type) +typecheck (Program defs) = do + dataTypes' <- mapM typecheckDataType [ d | DData d <- defs ] + binds' <- typecheckBinds (initCxt defs) [b | DBind b <- defs] + pure . T.Program $ map T.DData dataTypes' ++ map T.DBind binds' +typecheckBinds :: Cxt -> [Bind] -> Err [T.Bind' Type] +typecheckBinds cxt = flip evalState cxt + . runExceptT + . runTc + . mapM typecheckBind typecheckBind :: Bind -> Tc (T.Bind' Type) typecheckBind (Bind name vars rhs) = do @@ -105,7 +103,7 @@ typecheckBind (Bind name vars rhs) = do pure (T.Bind (coerce name, t') [] (e', t')) env <- gets env unless (isComplete env) err - insertSig (coerce name) typ -- HERE + insertSig (coerce name) typ putEnv Empty pure bind' where @@ -114,11 +112,11 @@ typecheckBind (Bind name vars rhs) = do , "Did you forget to add type annotation to a polymorphic function?" ] -typecheckDataType :: Data -> Err Data +typecheckDataType :: Data -> Err (T.Data' Type) typecheckDataType (Data typ injs) = do (name, tvars) <- go [] typ injs' <- mapM (\i -> typecheckInj i name tvars) injs - pure (Data typ injs') + pure (T.Data typ injs') where go tvars = \case TAll tvar t -> go (tvar:tvars) t @@ -128,7 +126,7 @@ typecheckDataType (Data typ injs) = do -> pure (name, tvars') _ -> throwError $ unwords ["Bad data type definition: ", ppT typ] -typecheckInj :: Inj -> UIdent -> [TVar] -> Err Inj +typecheckInj :: Inj -> UIdent -> [TVar] -> Err (T.Inj' Type) typecheckInj (Inj inj_name inj_typ) name tvars | not $ boundTVars tvars inj_typ = throwError "Unbound type variables" @@ -136,7 +134,7 @@ typecheckInj (Inj inj_name inj_typ) name tvars , name' == name , Right tvars' <- mapM toTVar typs , all (`elem` tvars) tvars' - = pure (Inj inj_name $ foldr TAll inj_typ tvars') + = pure $ T.Inj (coerce inj_name) (foldr TAll inj_typ tvars') | otherwise = throwError $ unwords ["Bad type constructor: ", show name @@ -470,7 +468,6 @@ infer = \case e2'' <- applyEnvExpT e2' pure (T.EAdd e1'' e2'', int) - -- Θ ⊢ Π ∷ A ↓ C ⊣ Δ -- Γ ⊢ e ↓ A ⊣ Θ Δ ⊢ Π covers [Δ]A TODO -- --------------------------------------- @@ -612,7 +609,7 @@ checkPattern patt t_patt = case patt of -- insertEnv (EnvTEVar tevar) pure $ substitute tvar tevar t where - TAll tvar _ = fa dummy + TAll tvar _ = fa int getParams = \case TAll _ t -> getParams t @@ -856,8 +853,6 @@ modifyEnv f = pattern DBind' name vars exp = DBind (Bind name vars exp) pattern DSig' name typ = DSig (Sig name typ) -dummy = TLit "Int" - --------------------------------------------------------------------------- -- * Debug --------------------------------------------------------------------------- From d097cd28e8d384990d3a172d55de2e2e6b94b85d Mon Sep 17 00:00:00 2001 From: Rakarake Date: Fri, 31 Mar 2023 17:02:54 +0200 Subject: [PATCH 257/372] New morb tree for internal use in monomorphizer, data types implemented --- language.cabal | 2 + sample-programs/mono-2.crf | 13 ++ src/Monomorphizer/DataTypeRemover.hs | 54 ++++++++ src/Monomorphizer/Monomorphizer.hs | 107 ++++++++++++---- src/Monomorphizer/MorbIr.hs | 183 +++++++++++++++++++++++++++ 5 files changed, 334 insertions(+), 25 deletions(-) create mode 100644 sample-programs/mono-2.crf create mode 100644 src/Monomorphizer/DataTypeRemover.hs create mode 100644 src/Monomorphizer/MorbIr.hs diff --git a/language.cabal b/language.cabal index ddf0fa0..1c54e3f 100644 --- a/language.cabal +++ b/language.cabal @@ -40,6 +40,8 @@ executable language LambdaLifter Monomorphizer.Monomorphizer Monomorphizer.MonomorphizerIr + Monomorphizer.MorbIr + Monomorphizer.DataTypeRemover Codegen.Codegen Codegen.LlvmIr Codegen.Auxillary diff --git a/sample-programs/mono-2.crf b/sample-programs/mono-2.crf new file mode 100644 index 0000000..ade504b --- /dev/null +++ b/sample-programs/mono-2.crf @@ -0,0 +1,13 @@ +data Either(a b) where { + Left: a -> Either (a b) + Right: b -> Either (a b) +}; + +unwrapLeft x = case x of { + Left y => y; +}; + +wow = Left 5; + +main = unwrapLeft wow; + diff --git a/src/Monomorphizer/DataTypeRemover.hs b/src/Monomorphizer/DataTypeRemover.hs new file mode 100644 index 0000000..cf353fb --- /dev/null +++ b/src/Monomorphizer/DataTypeRemover.hs @@ -0,0 +1,54 @@ +module Monomorphizer.DataTypeRemover (removeDataTypes) where +import qualified Monomorphizer.MorbIr as M1 +import qualified Monomorphizer.MonomorphizerIr as M2 +import TypeChecker.TypeCheckerIr (Ident (Ident)) + +removeDataTypes :: M1.Program -> M2.Program +removeDataTypes (M1.Program defs) = M2.Program (map pDef defs) + +pDef :: M1.Def -> M2.Def +pDef (M1.DBind b) = M2.DBind (pBind b) +pDef (M1.DData d) = M2.DData (pData d) + +pData :: M1.Data -> M2.Data +pData (M1.Data t cs) = M2.Data (pType t) (map pCons cs) + +pCons :: M1.Inj -> M2.Inj +pCons (M1.Inj ident t) = M2.Inj ident (pType t) + +pType :: M1.Type -> M2.Type +pType (M1.TLit ident) = M2.TLit ident +pType (M1.TFun t1 t2) = M2.TFun (pType t1) (pType t2) +pType (M1.TData (Ident str) args) = M2.TLit (Ident (str ++ show args)) -- This is the step + +pBind :: M1.Bind -> M2.Bind +pBind (M1.Bind id argIds expt) = M2.Bind (pId id) (map pId argIds) (pExpT expt) + +pId :: (Ident, M1.Type) -> (Ident, M2.Type) +pId (ident, t) = (ident, pType t) + +pExpT :: M1.ExpT -> M2.ExpT +pExpT (exp, t) = (pExp exp, pType t) + +pExp :: M1.Exp -> M2.Exp +pExp (M1.EVar ident) = M2.EVar ident +pExp (M1.ELit lit) = M2.ELit (pLit lit) +pExp (M1.ELet bind expt) = M2.ELet (pBind bind) (pExpT expt) +pExp (M1.EApp e1 e2) = M2.EApp (pExpT e1) (pExpT e2) +pExp (M1.EAdd e1 e2) = M2.EAdd (pExpT e1) (pExpT e2) +pExp (M1.ECase expT branches) = M2.ECase (pExpT expT) (map pBranch branches) + +pBranch :: M1.Branch -> M2.Branch +pBranch (M1.Branch (patt, t) expt) = M2.Branch (pPattern patt, pType t) (pExpT expt) + +pPattern :: M1.Pattern -> M2.Pattern +pPattern (M1.PVar id) = M2.PVar (pId id) +pPattern (M1.PLit (lit, t)) = M2.PLit (pLit lit, pType t) +pPattern (M1.PInj ident patts) = M2.PInj ident (map pPattern patts) +pPattern M1.PCatch = M2.PCatch +pPattern (M1.PEnum ident) = M2.PEnum ident + +pLit :: M1.Lit -> M2.Lit +pLit (M1.LInt v) = M2.LInt v +pLit (M1.LChar c) = M2.LChar c + diff --git a/src/Monomorphizer/Monomorphizer.hs b/src/Monomorphizer/Monomorphizer.hs index 0a98b00..6d298cd 100644 --- a/src/Monomorphizer/Monomorphizer.hs +++ b/src/Monomorphizer/Monomorphizer.hs @@ -26,15 +26,18 @@ module Monomorphizer.Monomorphizer (monomorphize, morphExp, morphBind) where import qualified TypeChecker.TypeCheckerIr as T import TypeChecker.TypeCheckerIr (Ident (Ident)) -import qualified Monomorphizer.MonomorphizerIr as M +import qualified Monomorphizer.MorbIr as M +import qualified Monomorphizer.MonomorphizerIr as O +import Monomorphizer.DataTypeRemover (removeDataTypes) import Debug.Trace -import Control.Monad.State (MonadState, gets, modify, StateT (runStateT)) +import Control.Monad.State (MonadState (get), gets, modify, StateT (runStateT)) import qualified Data.Map as Map import qualified Data.Set as Set import Data.Maybe (fromJust) import Control.Monad.Reader (Reader, MonadReader (local, ask), asks, runReader) import Data.Coerce (coerce) +import Grammar.Print (printTree) -- | State Monad wrapper for "Env". newtype EnvM a = EnvM (StateT Output (Reader Env) a) @@ -48,11 +51,13 @@ data Outputted = Incomplete | Complete M.Bind | Data M.Data -- Static environment data Env = Env { -- | All binds in the program. - input :: Map.Map Ident T.Bind, + input :: Map.Map Ident T.Bind, + -- | All constructors and their respective data def. + dataDefs :: Map.Map Ident T.Data, -- | Maps polymorphic identifiers with concrete types. - polys :: Map.Map Ident M.Type, - -- | Local variables - locals :: Set.Set Ident + polys :: Map.Map Ident M.Type, + -- | Local variables. + locals :: Set.Set Ident } localExists :: Ident -> EnvM Bool @@ -85,8 +90,11 @@ getMain = asks (\env -> fromJust $ Map.lookup (T.Ident "main") (input env)) mapTypes :: T.Type -> M.Type -> [(Ident, M.Type)] mapTypes (T.TLit _) (M.TLit _) = [] mapTypes (T.TVar (T.MkTVar i1)) tm = [(i1, tm)] -mapTypes (T.TFun pt1 pt2) (M.TFun mt1 mt2) = mapTypes pt1 mt1 ++ - mapTypes pt2 mt2 +mapTypes (T.TFun pt1 pt2) (M.TFun mt1 mt2) = mapTypes pt1 mt1 ++ + mapTypes pt2 mt2 +mapTypes (T.TData tIdent pTs) (M.TData mIdent mTs) = if tIdent /= mIdent + then error "Nuh uh" + else foldl (\xs (p, m) -> mapTypes p m ++ xs) [] (zip pTs mTs) mapTypes _ _ = error "structure of types not the same!" -- | Gets the mapped monomorphic type of a polymorphic type in the current context. @@ -100,11 +108,10 @@ getMonoFromPoly t = do env <- ask (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 - Nothing -> error $ - "type not found! type: " ++ show ident ++ ", error in previous compilation steps" - -- This is pretty ugly, could use a new type - (T.TData (Ident str) args) -> let args' = map (getMono polys) args in - M.TLit $ Ident (str ++ "$" ++ show args') + Nothing -> M.TLit (Ident "void") + --error $ "type not found! type: " ++ show ident ++ ", error in previous compilation steps" + (T.TData ident args) -> M.TData ident (map (getMono polys) args) + -- TODO: TAll should work different/should not exist in this tree (T.TAll _ t) -> getMono polys t -- | If ident not already in env's output, morphed bind to output @@ -144,6 +151,43 @@ morphApp expectedType (e1, t1) (e2, t2)= do e1' <- morphExp (M.TFun t2' expectedType) e1 return $ M.EApp (e1', t1') (e2', t2') +addOutputData :: M.Data -> EnvM () +addOutputData d@(M.Data (M.TData ident _) _) = modify $ Map.insert ident (Data d) + +-- Gets data bind from the name of a constructor +getInputData :: Ident -> EnvM (Maybe T.Data) +getInputData ident = do env <- ask + return $ Map.lookup ident (dataDefs env) + +-- | Expects polymorphic types in data definition to be mapped +-- in environment. +morphData :: T.Data -> EnvM () +morphData (T.Data t cs) = do + t' <- getMonoFromPoly t + output <- get + cs' <- mapM (\(T.Inj ident t) -> do t' <- getMonoFromPoly t + return (M.Inj ident t')) cs + addOutputData $ M.Data t' cs' + +morphCons :: M.Type -> Ident -> EnvM () +morphCons expectedType ident = do + maybeD <- getInputData ident + case maybeD of + Nothing -> error $ "identifier '" ++ show ident ++ "' not found" + Just d -> do + -- Find the polymorphic type of cons + case findConsType d ident of + Nothing -> error "didn't find constructor" + Just consType -> do + -- Map polymorphic types + local (\env -> env { + polys = Map.fromList (mapTypes consType expectedType) }) $ do + morphData d + +-- TODO: detect internal errors here +findConsType :: T.Data -> Ident -> Maybe T.Type +findConsType (T.Data _ cs) name1 = foldl (\maybe (T.Inj name2 t) -> if name2 == name1 then Just t else maybe) Nothing cs + -- TODO: Change in tree so that these are the same. -- Converts Lit convertLit :: T.Lit -> M.Lit @@ -175,8 +219,9 @@ morphExp expectedType exp = case exp of else do bind <- getInputBind ident case bind of - Nothing -> + Nothing -> do -- This is a constructor + morphCons expectedType ident return $ M.EVar ident Just bind' -> do -- New bind to process @@ -217,9 +262,9 @@ newName t (T.Bind (Ident bindName, _) _ _) = newName' (M.TFun t1 t2) = newName' t1 ++ "_" ++ newName' t2 -- Monomorphization step -monomorphize :: T.Program -> M.Program -monomorphize (T.Program defs) = M.Program $ getDefsFromOutput - (runEnvM Map.empty (createEnv defs) monomorphize') +monomorphize :: T.Program -> O.Program +monomorphize (T.Program defs) = removeDataTypes $ M.Program (getDefsFromOutput + (runEnvM Map.empty (createEnv defs) monomorphize')) where monomorphize' :: EnvM () monomorphize' = do @@ -233,13 +278,30 @@ runEnvM o env (EnvM stateM) = snd $ runReader (runStateT stateM o) env -- | Creates the environment based on the input binds. createEnv :: [T.Def] -> Env -createEnv defs = Env { input = Map.fromList bindPairs, - polys = Map.empty, - locals = Set.empty } +createEnv defs = Env { input = Map.fromList bindPairs, + dataDefs = Map.fromList dataPairs, + polys = Map.empty, + locals = Set.empty } where bindPairs = (map (\b -> (getBindName b, b)) . getBindsFromDefs) defs + dataPairs :: [(Ident, T.Data)] + dataPairs = (foldl (\acc d@(T.Data _ cs) -> map ((,d) . getConsName) cs ++ acc) [] . getDataFromDefs) defs -- Helper functions +-- Gets custom data declarations form defs. +getDataFromDefs :: [T.Def] -> [T.Data] +getDataFromDefs = foldl (\bs -> \case + T.DBind _ -> bs + T.DData d -> d:bs) [] + +getConsName :: T.Inj -> Ident +getConsName (T.Inj ident _) = ident + +getBindsFromDefs :: [T.Def] -> [T.Bind] +getBindsFromDefs = foldl (\bs -> \case + T.DBind b -> b:bs + T.DData _ -> bs) [] + getDefsFromOutput :: Output -> [M.Def] getDefsFromOutput outputMap = (map snd . Map.toList) $ fmap (\case @@ -248,11 +310,6 @@ getDefsFromOutput outputMap = (map snd . Map.toList) $ fmap Data d -> M.DData d) outputMap -getBindsFromDefs :: [T.Def] -> [T.Bind] -getBindsFromDefs = foldl (\bs -> \case - T.DBind b -> b:bs - T.DData _ -> bs) [] - getBindName :: T.Bind -> Ident getBindName (T.Bind (ident, _) _ _) = ident diff --git a/src/Monomorphizer/MorbIr.hs b/src/Monomorphizer/MorbIr.hs new file mode 100644 index 0000000..20f9496 --- /dev/null +++ b/src/Monomorphizer/MorbIr.hs @@ -0,0 +1,183 @@ +{-# LANGUAGE LambdaCase #-} +module Monomorphizer.MorbIr where + +import Grammar.Print +import TypeChecker.TypeCheckerIr qualified as TIR (Ident (..)) + +type Id = (TIR.Ident, Type) + +newtype Program = Program [Def] + deriving (Show, Ord, Eq) + +data Def = DBind Bind | DData Data + deriving (Show, Ord, Eq) + +data Data = Data Type [Inj] + deriving (Show, Ord, Eq) + +data Bind = Bind Id [Id] ExpT + deriving (Show, Ord, Eq) + +data Exp + = EVar TIR.Ident + | ELit Lit + | ELet Bind ExpT + | EApp ExpT ExpT + | EAdd ExpT ExpT + | ECase ExpT [Branch] + deriving (Show, Ord, Eq) + +data Pattern + = PVar Id + | PLit (Lit, Type) + | PInj TIR.Ident [Pattern] + | PCatch + | PEnum TIR.Ident + deriving (Eq, Ord, Show) + +data Branch = Branch (Pattern, Type) ExpT + deriving (Eq, Ord, Show) + +type ExpT = (Exp, Type) + +data Inj = Inj TIR.Ident Type + deriving (Show, Ord, Eq) + +data Lit + = LInt Integer + | LChar Char + deriving (Show, Ord, Eq) + +data Type = TLit TIR.Ident | TFun Type Type | TData TIR.Ident [Type] + + deriving (Show, Ord, Eq) + +flattenType :: Type -> [Type] +flattenType (TFun t1 t2) = t1 : flattenType t2 +flattenType x = [x] + +instance Print Program where + prt i (Program sc) = prPrec i 0 $ prt 0 sc + +instance Print (Bind) where + prt i (Bind sig@(name, _) parms rhs) = + prPrec i 0 $ + concatD + [ prtSig sig + , prt 0 name + , prtIdPs 0 parms + , doc $ showString "=" + , prt 0 rhs + ] + +prtSig :: Id -> Doc +prtSig (name, t) = + concatD + [ prt 0 name + , doc $ showString ":" + , prt 0 t + , doc $ showString ";" + ] + +instance Print (ExpT) where + prt i (e, t) = + concatD + [ doc $ showString "(" + , prt i e + , doc $ showString "," + , prt i t + , doc $ showString ")" + ] + +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 (prt i) + +instance Print Exp where + prt i = \case + EVar name -> prPrec i 3 $ prt 0 name + ELit lit -> prPrec i 3 $ prt 0 lit + ELet b e -> + prPrec i 3 $ + concatD + [ doc $ showString "let" + , prt 0 b + , doc $ showString "in" + , prt 0 e + ] + EApp e1 e2 -> + prPrec i 2 $ + concatD + [ prt 2 e1 + , prt 3 e2 + ] + EAdd e1 e2 -> + prPrec i 1 $ + concatD + [ prt 1 e1 + , doc $ showString "+" + , prt 2 e2 + ] + ECase e branches -> + prPrec i 0 $ + concatD + [ doc $ showString "case" + , prt 0 e + , doc $ showString "of" + , doc $ showString "{" + , prt 0 branches + , doc $ showString "}" + ] + +instance Print Branch where + prt i (Branch (pattern_, t) exp) = prPrec i 0 (concatD [doc (showString "("), prt 0 pattern_, doc (showString " : "), prt 0 t, doc (showString ")"), doc (showString "=>"), prt 0 exp]) + +instance Print [Branch] where + prt _ [] = concatD [] + prt _ [x] = concatD [prt 0 x] + prt _ (x : xs) = concatD [prt 0 x, doc (showString ";"), prt 0 xs] + +instance Print Def where + prt i = \case + DBind bind -> prPrec i 0 (concatD [prt 0 bind]) + DData data_ -> prPrec i 0 (concatD [prt 0 data_]) + +instance Print Data where + prt i = \case + Data type_ injs -> prPrec i 0 (concatD [doc (showString "data"), prt 0 type_, doc (showString "where"), doc (showString "{"), prt 0 injs, doc (showString "}")]) + +instance Print Inj where + prt i = \case + Inj uident type_ -> prPrec i 0 (concatD [prt 0 uident, doc (showString ":"), prt 0 type_]) + +instance Print Pattern where + prt i = \case + PVar name -> prPrec i 1 (concatD [prt 0 name]) + PLit (lit, _) -> prPrec i 1 (concatD [prt 0 lit]) + PCatch -> prPrec i 1 (concatD [doc (showString "_")]) + PEnum name -> prPrec i 1 (concatD [prt 0 name]) + PInj uident patterns -> prPrec i 0 (concatD [prt 0 uident, prt 1 patterns]) + +instance Print [Def] where + prt _ [] = concatD [] + prt _ [x] = concatD [prt 0 x] + prt _ (x : xs) = concatD [prt 0 x, doc (showString ";"), prt 0 xs] + +instance Print [Type] where + prt _ [] = concatD [] + prt _ (x : xs) = concatD [prt 0 x, doc (showString " "), prt 0 xs] + +instance Print Type where + prt i = \case + TLit uident -> prPrec i 1 (concatD [prt 0 uident]) + TFun type_1 type_2 -> prPrec i 0 (concatD [prt 1 type_1, doc (showString "->"), prt 0 type_2]) + +instance Print Lit where + prt i = \case + LInt int -> prt i int + LChar char -> prt i char + From 15c18271bac5ed8571bae76c69bd5dc4c72fbbae Mon Sep 17 00:00:00 2001 From: Rakarake Date: Fri, 31 Mar 2023 17:53:56 +0200 Subject: [PATCH 258/372] Monomorphizer, fixed problem with type of bind --- sample-programs/mono.crf | 4 +++- src/Monomorphizer/Monomorphizer.hs | 20 +++++++++++--------- 2 files changed, 14 insertions(+), 10 deletions(-) diff --git a/sample-programs/mono.crf b/sample-programs/mono.crf index e682b7d..8f5fbbc 100644 --- a/sample-programs/mono.crf +++ b/sample-programs/mono.crf @@ -1,5 +1,7 @@ const x y = x; -f x = (const x 'c'); +id x = x; + +f x = (id 5); main = f 5; diff --git a/src/Monomorphizer/Monomorphizer.hs b/src/Monomorphizer/Monomorphizer.hs index 6d298cd..1d1571f 100644 --- a/src/Monomorphizer/Monomorphizer.hs +++ b/src/Monomorphizer/Monomorphizer.hs @@ -119,7 +119,7 @@ getMonoFromPoly t = do env <- ask -- Returns the annotated bind name. -- TODO: Redundancy? btype and t should always be the same. morphBind :: M.Type -> T.Bind -> EnvM Ident -morphBind expectedType b@(T.Bind (Ident _, btype) args (exp, t)) = +morphBind expectedType b@(T.Bind (Ident _, btype) args (exp, expt)) = local (\env -> env { locals = Set.fromList (map fst args), polys = Map.fromList (mapTypes btype expectedType) }) $ do @@ -131,7 +131,8 @@ morphBind expectedType b@(T.Bind (Ident _, btype) args (exp, t)) = -- Mark so that this bind will not be processed in recursive or cyclic -- function calls markBind (coerce name') - exp' <- morphExp expectedType exp + expt' <- getMonoFromPoly expt + exp' <- morphExp expt' exp -- Get monomorphic type sof args args' <- mapM convertArg args addOutputBind $ M.Bind (coerce name', expectedType) @@ -145,11 +146,10 @@ convertArg (ident, t) = do t' <- getMonoFromPoly t -- Morphs function applications, such as EApp and EAdd morphApp :: M.Type -> T.ExpT -> T.ExpT -> EnvM M.Exp morphApp expectedType (e1, t1) (e2, t2)= do - t1' <- getMonoFromPoly t1 t2' <- getMonoFromPoly t2 e2' <- morphExp t2' e2 e1' <- morphExp (M.TFun t2' expectedType) e1 - return $ M.EApp (e1', t1') (e2', t2') + return $ M.EApp (e1', M.TFun t2' expectedType) (e2', t2') addOutputData :: M.Data -> EnvM () addOutputData d@(M.Data (M.TData ident _) _) = modify $ Map.insert ident (Data d) @@ -209,10 +209,10 @@ morphExp expectedType exp = case exp of morphExp t' exp T.ECase (exp, t) bs -> do t' <- getMonoFromPoly t - exp' <- morphExp t' exp bs' <- mapM morphBranch bs + exp' <- morphExp t' exp return $ M.ECase (exp', t') bs' - T.EVar ident@(Ident str) -> do + T.EVar ident -> do isLocal <- localExists ident if isLocal then do return $ M.EVar (coerce ident) @@ -246,7 +246,8 @@ morphPattern = \case T.PLit (lit, t) -> do t' <- getMonoFromPoly t return $ M.PLit (convertLit lit, t') T.PCatch -> return M.PCatch - T.PEnum v -> return $ M.PEnum v + -- Constructor ident + T.PEnum ident -> return $ M.PEnum ident T.PInj ident ps -> do ps' <- mapM morphPattern ps return $ M.PInj ident ps' @@ -258,8 +259,9 @@ newName t (T.Bind (Ident bindName, _) _ _) = else Ident (bindName ++ "$" ++ newName' t) where newName' :: M.Type -> String - newName' (M.TLit (Ident str)) = str - newName' (M.TFun t1 t2) = newName' t1 ++ "_" ++ newName' t2 + newName' (M.TLit (Ident str)) = str + newName' (M.TFun t1 t2) = newName' t1 ++ "_" ++ newName' t2 + newName' (M.TData (Ident str) ts) = str ++ "." ++ foldl (\s t -> s ++ "," ++ newName' t) "" ts -- Monomorphization step monomorphize :: T.Program -> O.Program From b0ec5a2333275e50e993cb2efa5902d91f515417 Mon Sep 17 00:00:00 2001 From: Samuel Hammersberg Date: Fri, 31 Mar 2023 18:16:26 +0200 Subject: [PATCH 259/372] Started working on a Case Desugar phase. --- src/CaseDesugar/CaseDesugar.hs | 83 ++++++++++++ src/CaseDesugar/CaseDesugarIr.hs | 226 +++++++++++++++++++++++++++++++ 2 files changed, 309 insertions(+) create mode 100644 src/CaseDesugar/CaseDesugar.hs create mode 100644 src/CaseDesugar/CaseDesugarIr.hs diff --git a/src/CaseDesugar/CaseDesugar.hs b/src/CaseDesugar/CaseDesugar.hs new file mode 100644 index 0000000..e1db55e --- /dev/null +++ b/src/CaseDesugar/CaseDesugar.hs @@ -0,0 +1,83 @@ +{-# LANGUAGE LambdaCase #-} + +module CaseDesugar.CaseDesugar (desuga) where + +import CaseDesugar.CaseDesugarIr qualified as CIR +import TypeChecker.TypeCheckerIr qualified as TIR + +desuga :: TIR.Program -> CIR.Program +desuga (TIR.Program x) = CIR.Program $ desugaDef <$> x + +desugaDef :: TIR.Def -> CIR.Def +desugaDef (TIR.DBind bin@TIR.Bind{}) = CIR.DBind $ desugaBind bin +desugaDef (TIR.DData dat@TIR.Data{}) = CIR.DData $ desugaData dat + +desugaData :: TIR.Data -> CIR.Data +desugaData (TIR.Data t injs) = CIR.Data (desugaType t) (desugaInj <$> injs) + +desugaType :: TIR.Type -> CIR.Type +desugaType (TIR.TLit (TIR.Ident s)) = CIR.TLit (CIR.Ident s) +desugaType (TIR.TVar tv) = CIR.TVar (desugaTVar tv) +desugaType (TIR.TData (TIR.Ident s) ts) = CIR.TData (CIR.Ident s) (desugaType <$> ts) +desugaType (TIR.TFun t1 t2) = CIR.TFun (desugaType t1) (desugaType t2) +desugaType (TIR.TAll _ t1) = desugaType t1 + +desugaTVar :: TIR.TVar -> CIR.TVar +desugaTVar (TIR.MkTVar (TIR.Ident s)) = CIR.MkTVar (CIR.Ident s) + +desugaInj :: TIR.Inj -> CIR.Inj +desugaInj (TIR.Inj (TIR.Ident s) t) = CIR.Inj (CIR.Ident s) (desugaType t) + +desugaId :: TIR.Id -> CIR.Id +desugaId (TIR.Ident s, t) = (CIR.Ident s, desugaType t) + +desugaBind :: TIR.Bind -> CIR.Bind +desugaBind (TIR.Bind id args exp) = + CIR.Bind (desugaId id) (desugaId <$> args) (desugaExpT exp) + +desugaExpT :: TIR.ExpT -> CIR.ExpT +desugaExpT (exp, t) = (desugaExp exp, desugaType t) + +desugaExp :: TIR.Exp -> CIR.Exp +desugaExp (TIR.EVar (TIR.Ident s)) = CIR.EVar (CIR.Ident s) +desugaExp (TIR.EInj (TIR.Ident s)) = CIR.EInj (CIR.Ident s) +desugaExp (TIR.ELit lit) = CIR.ELit lit +desugaExp (TIR.ELet b e) = CIR.ELet (desugaBind b) (desugaExpT e) +desugaExp (TIR.EApp e1 e2) = CIR.EApp (desugaExpT e1) (desugaExpT e2) +desugaExp (TIR.EAdd e1 e2) = CIR.EAdd (desugaExpT e1) (desugaExpT e2) +desugaExp (TIR.EAbs (TIR.Ident s) e) = CIR.EAbs (CIR.Ident s) (desugaExpT e) +desugaExp (TIR.ECase e branches) = CIR.ECase (desugaExpT e) (desugaBranches branches) + +desugaBranches :: [TIR.Branch] -> [CIR.Branch] +desugaBranches bs = do + let injections = filter (\case (TIR.Branch (TIR.PInj{}, _) _) -> True; _ -> False) bs + let patterns = filter (\case (TIR.Branch (TIR.PInj{}, _) _) -> True; _ -> False) bs + undefined + +desugaBranch :: TIR.Branch -> CIR.Branch +desugaBranch (TIR.Branch (TIR.PInj (TIR.Ident s) ps, pt) e) = do + undefined +desugaBranch (TIR.Branch (p, pt) e) = do + CIR.Branch + ( case p of + TIR.PVar id -> (CIR.PVar (desugaId id), desugaType pt) + TIR.PLit (lit, t) -> (CIR.PLit (lit, desugaType t), desugaType pt) + TIR.PCatch -> (CIR.PCatch, desugaType pt) + TIR.PEnum (TIR.Ident s) -> (CIR.PEnum (CIR.Ident s), desugaType pt) + ) + (desugaExpT e) + +{- +case (Tupli 5 5) of + Tupli 6 5 => 1 + Tupli _ x => 3 + x => 1 +=== +case (Tupli 5 5) of + Tupli x y => case x of + 6 => case y of + 5 => 1 + x => 3 + _ => case y of + x => 3 +-} \ No newline at end of file diff --git a/src/CaseDesugar/CaseDesugarIr.hs b/src/CaseDesugar/CaseDesugarIr.hs new file mode 100644 index 0000000..dd9864f --- /dev/null +++ b/src/CaseDesugar/CaseDesugarIr.hs @@ -0,0 +1,226 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE PatternSynonyms #-} + +module CaseDesugar.CaseDesugarIr ( + module Grammar.Abs, + module CaseDesugar.CaseDesugarIr, +) where + +import Data.String (IsString) +import Grammar.Abs (Lit (..)) +import Grammar.Print +import Prelude +import Prelude qualified as C (Eq, Ord, Read, Show) + +newtype Program' t = Program [Def' t] + deriving (C.Eq, C.Ord, C.Show, C.Read) + +data Def' t + = DBind (Bind' t) + | DData (Data' t) + deriving (C.Eq, C.Ord, C.Show, C.Read) + +data Type + = TLit Ident + | TVar TVar + | TData Ident [Type] + | TFun Type Type + deriving (C.Eq, C.Ord, C.Show, C.Read) + +data Data' t = Data t [Inj' t] + deriving (C.Eq, C.Ord, C.Show, C.Read) + +data Inj' t = Inj Ident t + deriving (C.Eq, C.Ord, C.Show, C.Read) + +newtype Ident = Ident String + deriving (C.Eq, C.Ord, C.Show, C.Read, IsString) + +data Pattern' t + = PVar (Id' t) -- TODO should be Ident + | PLit (Lit, t) -- TODO should be Lit + | PCatch + | PEnum Ident + deriving (C.Eq, C.Ord, C.Show, C.Read) + +data Exp' t + = EVar Ident + | EInj Ident + | ELit Lit + | ELet (Bind' t) (ExpT' t) + | EApp (ExpT' t) (ExpT' t) + | EAdd (ExpT' t) (ExpT' t) + | EAbs Ident (ExpT' t) + | ECase (ExpT' t) [Branch' t] + deriving (C.Eq, C.Ord, C.Show, C.Read) + +newtype TVar = MkTVar Ident + deriving (C.Eq, C.Ord, C.Show, C.Read) + +type Id' t = (Ident, t) +type ExpT' t = (Exp' t, t) + +data Bind' t = Bind (Id' t) [Id' t] (ExpT' t) + deriving (C.Eq, C.Ord, C.Show, C.Read) + +data Branch' t = Branch (Pattern' t, t) (ExpT' t) + deriving (C.Eq, C.Ord, C.Show, C.Read) + +instance Print Ident where + prt _ (Ident s) = doc $ showString s + +instance Print t => Print (Program' t) where + prt i (Program sc) = prPrec i 0 $ prt 0 sc + +instance Print t => Print (Bind' t) where + prt i (Bind sig@(name, _) parms rhs) = + prPrec i 0 $ + concatD + [ prtSig sig + , prt 0 name + , prtIdPs 0 parms + , doc $ showString "=" + , prt 0 rhs + ] + +prtSig :: Print t => Id' t -> Doc +prtSig (name, t) = + concatD + [ prt 0 name + , doc $ showString ":" + , prt 0 t + , doc $ showString ";" + ] + +instance Print t => Print (ExpT' t) where + prt i (e, t) = + concatD + [ doc $ showString "(" + , prt i e + , doc $ showString "," + , prt i t + , doc $ showString ")" + ] + +instance Print t => Print [Bind' t] where + prt _ [] = concatD [] + prt _ [x] = concatD [prt 0 x] + prt _ (x : xs) = concatD [prt 0 x, doc (showString ";"), prt 0 xs] + +prtIdPs :: Print t => Int -> [Id' t] -> Doc +prtIdPs i = prPrec i 0 . concatD . map (prt i) + +instance Print t => Print (Id' t) where + prt i (name, t) = + concatD + [ doc $ showString "(" + , prt i name + , doc $ showString "," + , prt i t + , doc $ showString ")" + ] + +instance Print t => Print (Exp' t) where + prt i = \case + EVar name -> prPrec i 3 $ prt 0 name + EInj name -> prPrec i 3 $ prt 0 name + ELit lit -> prPrec i 3 $ prt 0 lit + ELet b e -> + prPrec i 3 $ + concatD + [ doc $ showString "let" + , prt 0 b + , doc $ showString "in" + , prt 0 e + ] + EApp e1 e2 -> + prPrec i 2 $ + concatD + [ prt 2 e1 + , prt 3 e2 + ] + EAdd e1 e2 -> + prPrec i 1 $ + concatD + [ prt 1 e1 + , doc $ showString "+" + , prt 2 e2 + ] + EAbs v e -> + prPrec i 0 $ + concatD + [ doc $ showString "\\" + , prt 0 v + , doc $ showString "." + , prt 0 e + ] + ECase e branches -> + prPrec i 0 $ + concatD + [ doc $ showString "case" + , prt 0 e + , doc $ showString "of" + , doc $ showString "{" + , prt 0 branches + , doc $ showString "}" + ] + +instance Print t => Print (Branch' t) where + prt i (Branch (pattern_, t) exp) = prPrec i 0 (concatD [doc (showString "("), prt 0 pattern_, doc (showString " : "), prt 0 t, doc (showString ")"), doc (showString "=>"), prt 0 exp]) + +instance Print t => Print [Branch' t] where + prt _ [] = concatD [] + prt _ [x] = concatD [prt 0 x] + prt _ (x : xs) = concatD [prt 0 x, doc (showString ";"), prt 0 xs] + +instance Print t => Print (Def' t) where + prt i = \case + DBind bind -> prPrec i 0 (concatD [prt 0 bind]) + DData data_ -> prPrec i 0 (concatD [prt 0 data_]) + +instance Print t => Print (Data' t) where + prt i = \case + Data type_ injs -> prPrec i 0 (concatD [doc (showString "data"), prt 0 type_, doc (showString "where"), doc (showString "{"), prt 0 injs, doc (showString "}")]) + +instance Print t => Print (Inj' t) where + prt i = \case + Inj uident type_ -> prPrec i 0 (concatD [prt 0 uident, doc (showString ":"), prt 0 type_]) + +instance Print t => Print (Pattern' t) where + prt i = \case + PVar name -> prPrec i 1 (concatD [prt 0 name]) + PLit (lit, _) -> prPrec i 1 (concatD [prt 0 lit]) + PCatch -> prPrec i 1 (concatD [doc (showString "_")]) + PEnum name -> prPrec i 1 (concatD [prt 0 name]) + +instance Print t => Print [Def' t] where + prt _ [] = concatD [] + prt _ [x] = concatD [prt 0 x] + prt _ (x : xs) = concatD [prt 0 x, doc (showString ";"), prt 0 xs] + +instance Print [Type] where + prt _ [] = concatD [] + prt _ (x : xs) = concatD [prt 0 x, doc (showString " "), prt 0 xs] + +instance Print Type where + prt i = \case + TLit uident -> prPrec i 1 (concatD [prt 0 uident]) + TVar tvar -> prPrec i 1 (concatD [prt 0 tvar]) + TData uident types -> prPrec i 1 (concatD [prt 0 uident, doc (showString "("), prt 0 types, doc (showString ")")]) + TFun type_1 type_2 -> prPrec i 0 (concatD [prt 1 type_1, doc (showString "->"), prt 0 type_2]) + +instance Print TVar where + prt i (MkTVar ident) = prt i ident + +type Program = Program' Type +type Def = Def' Type +type Data = Data' Type +type Bind = Bind' Type +type Branch = Branch' Type +type Pattern = Pattern' Type +type Inj = Inj' Type +type Exp = Exp' Type +type ExpT = ExpT' Type +type Id = Id' Type +pattern DBind' id vars expt = DBind (Bind id vars expt) +pattern DData' typ injs = DData (Data typ injs) From e2e469d84ea5b434697b2ccca49e5b1c2912ef5a Mon Sep 17 00:00:00 2001 From: Samuel Hammersberg Date: Fri, 31 Mar 2023 18:17:28 +0200 Subject: [PATCH 260/372] Added some examples that were shown to our handledare. --- sample-programs/example-programs/ex1.crf | 1 + sample-programs/example-programs/ex2.crf | 4 +++ sample-programs/example-programs/ex3.crf | 11 ++++++ sample-programs/example-programs/ex4.crf | 11 ++++++ sample-programs/example-programs/ex5.crf | 26 ++++++++++++++ sample-programs/example-programs/ex6.crf | 43 ++++++++++++++++++++++++ 6 files changed, 96 insertions(+) create mode 100644 sample-programs/example-programs/ex1.crf create mode 100644 sample-programs/example-programs/ex2.crf create mode 100644 sample-programs/example-programs/ex3.crf create mode 100644 sample-programs/example-programs/ex4.crf create mode 100644 sample-programs/example-programs/ex5.crf create mode 100644 sample-programs/example-programs/ex6.crf diff --git a/sample-programs/example-programs/ex1.crf b/sample-programs/example-programs/ex1.crf new file mode 100644 index 0000000..c7ad3b2 --- /dev/null +++ b/sample-programs/example-programs/ex1.crf @@ -0,0 +1 @@ +main = 5 + 2; \ No newline at end of file diff --git a/sample-programs/example-programs/ex2.crf b/sample-programs/example-programs/ex2.crf new file mode 100644 index 0000000..3510463 --- /dev/null +++ b/sample-programs/example-programs/ex2.crf @@ -0,0 +1,4 @@ +main = case 78 of { + 5 => 45; + x => x + 24; +}; \ No newline at end of file diff --git a/sample-programs/example-programs/ex3.crf b/sample-programs/example-programs/ex3.crf new file mode 100644 index 0000000..408e685 --- /dev/null +++ b/sample-programs/example-programs/ex3.crf @@ -0,0 +1,11 @@ +data Maybe () where { + Just : Int -> Maybe () + Nothing : Maybe () +}; + +demoFunc x = case x of { + Just x => x + 24; + Nothing => 0; +}; + +main = demoFunc (Just 5) ; \ No newline at end of file diff --git a/sample-programs/example-programs/ex4.crf b/sample-programs/example-programs/ex4.crf new file mode 100644 index 0000000..a64adb5 --- /dev/null +++ b/sample-programs/example-programs/ex4.crf @@ -0,0 +1,11 @@ +data Maybe () where { + Just : Int -> Maybe () + Nothing : Maybe () +}; + +demoFunc x = case x of { + Just x => x + 24; + Nothing => 0; +}; + +main = demoFunc Nothing ; \ No newline at end of file diff --git a/sample-programs/example-programs/ex5.crf b/sample-programs/example-programs/ex5.crf new file mode 100644 index 0000000..b9457ed --- /dev/null +++ b/sample-programs/example-programs/ex5.crf @@ -0,0 +1,26 @@ +main = case f (Just 10) of { + Just a => a ; + Nothing => 0 ; +}; + +f x = bind (fmap (\s . s + 1) x) (\s . pure (s + 10)) ; + +data Maybe () where { + Just : Int -> Maybe () + Nothing : Maybe () +}; + +fmap : (Int -> Int) -> Maybe () -> Maybe () ; +fmap f m = case m of { + Just a => pure (f a) ; + Nothing => Nothing ; +}; + +pure : Int -> Maybe () ; +pure x = Just x; + +bind : Maybe () -> (Int -> Maybe ()) -> Maybe () ; +bind x f = case x of { + Just x => f x ; + Nothing => Nothing ; +}; \ No newline at end of file diff --git a/sample-programs/example-programs/ex6.crf b/sample-programs/example-programs/ex6.crf new file mode 100644 index 0000000..41894a0 --- /dev/null +++ b/sample-programs/example-programs/ex6.crf @@ -0,0 +1,43 @@ +main = sum (repeat (sumlength (repeat 10 2000)) 5); + +-- a simple list data type containing ints +data List () where { + Cons : Int -> List () -> List () + Nil : List () +}; + +-- take the length of a list +length : List () -> Int ; +length x = case x of { + Cons _ xs => 1 + length xs ; + Nil => 0 ; +}; +-- sum a list +sum : List () -> Int ; +sum x = case x of { + Cons a xs => a + sum xs ; + Nil => 0 ; +}; + +-- sum + length of a list +sumlength: List () -> Int ; +sumlength x = sum x + length x ; + +-- take the head of a list +head : List () -> Int ; +head x = case x of { + Cons h _ => h ; +}; + +-- repeat an element n times +repeat : Int -> Int -> List () ; +repeat x n = repeatHelp Nil x n; +repeatHelp : List () -> Int -> Int -> List () ; +repeatHelp acc x n = case n of { + 0 => acc ; + n => repeatHelp (Cons x acc) x (n + minusOne) ; +}; + +-- represents minus one :) +minusOne : Int ; +minusOne = 9223372036854775807 + 9223372036854775807 + 1; \ No newline at end of file From c4f78ca37d713975043f43c415052a1990a10333 Mon Sep 17 00:00:00 2001 From: sebastianselander Date: Fri, 31 Mar 2023 18:26:58 +0200 Subject: [PATCH 261/372] Merge in mutual recursion handling --- src/TypeChecker/TypeCheckerHm.hs | 194 ++++++++++++++----------------- 1 file changed, 89 insertions(+), 105 deletions(-) diff --git a/src/TypeChecker/TypeCheckerHm.hs b/src/TypeChecker/TypeCheckerHm.hs index 11cb94e..01a7e16 100644 --- a/src/TypeChecker/TypeCheckerHm.hs +++ b/src/TypeChecker/TypeCheckerHm.hs @@ -6,16 +6,15 @@ -- | A module for type checking and inference using algorithm W, Hindley-Milner module TypeChecker.TypeCheckerHm where -import Auxiliary (int, litType, maybeToRightM, tupSequence, unzip4) +import Auxiliary (int, litType, maybeToRightM, unzip4) import Auxiliary qualified as Aux import Control.Monad.Except import Control.Monad.Identity (Identity, runIdentity) import Control.Monad.Reader import Control.Monad.State -import Data.Bifunctor (first) import Data.Coerce (coerce) import Data.Function (on) -import Data.List (foldl') +import Data.List (foldl', intercalate) import Data.List.Extra (unsnoc) import Data.Map (Map) import Data.Map qualified as M @@ -40,19 +39,10 @@ typecheck = onLeft msg . run . checkPrg checkPrg :: Program -> Infer (T.Program' Type) checkPrg (Program bs) = do preRun bs - bs <- checkDef bs - sub0 <- solveUndecidable - bs <- mapM (mono sub0) bs + (subs, bs) <- checkDef bs + ctrace "SUBS" $ unionSubsts subs return $ T.Program bs -mono :: Subst -> T.Def' Type -> Infer (T.Def' Type) -mono s bind@(T.DBind (T.Bind (name, t) args e)) = do - b <- gets (S.member name . toDecide) - if b - then return $ T.DBind $ T.Bind (name, apply s t) (apply s args) (apply s e) - else return bind -mono _ (T.DData d) = return $ T.DData d - preRun :: [Def] -> Infer () preRun [] = return () preRun (x : xs) = case x of @@ -62,7 +52,8 @@ preRun (x : xs) = case x of duplicateDecl n s $ Aux.do "Multiple signatures of function" quote $ printTree n - insertSig (coerce n) (Just t) >> preRun xs + insertSig (coerce n) t + preRun xs DBind (Bind n _ e) -> do s <- gets (S.toList . declaredBinds) duplicateDecl n s $ Aux.do @@ -70,43 +61,46 @@ preRun (x : xs) = case x of quote $ printTree n collect (collectTVars e) insertBind $ coerce n - s <- gets sigs - case M.lookup (coerce n) s of - Nothing -> insertSig (coerce n) Nothing >> preRun xs + sigs <- gets sigs + case M.lookup (coerce n) sigs of + Nothing -> do + fr <- fresh + insertSig (coerce n) fr + preRun xs Just _ -> preRun xs DData d@(Data t _) -> collect (collectTVars t) >> checkData d >> preRun xs where -- Check if function body / signature has been declared already + duplicateDecl :: (Monad m, MonadError Error m) => LIdent -> [T.Ident] -> String -> m () duplicateDecl n env msg = when (coerce n `elem` env) (uncatchableErr msg) -checkDef :: [Def] -> Infer [T.Def' Type] -checkDef [] = return [] +checkDef :: [Def] -> Infer ([Subst], [T.Def' Type]) +checkDef [] = return ([], []) checkDef (x : xs) = case x of (DBind b) -> do - b' <- checkBind b - xs' <- checkDef xs - return $ T.DBind b' : xs' + (sub0, b') <- checkBind b + (sub1, xs') <- checkDef xs + return (sub1 ++ sub0, T.DBind b' : xs') (DData d) -> do - xs' <- checkDef xs - return $ T.DData (coerceData d) : xs' + (sub, xs') <- checkDef xs + return (sub, T.DData (coerceData d) : xs') (DSig _) -> checkDef xs where coerceData (Data t injs) = T.Data t $ map (\(Inj name typ) -> T.Inj (coerce name) typ) injs -checkBind :: Bind -> Infer (T.Bind' Type) +checkBind :: Bind -> Infer ([Subst], T.Bind' Type) checkBind bind@(Bind name args e) = do - setCurrentBind $ coerce name let lambda = makeLambda e (reverse (coerce args)) (sub0, (e, lambda_t)) <- inferExp lambda s <- gets sigs case M.lookup (coerce name) s of - Just (Just t') -> do - sub1 <- bindErr (unify lambda_t (skolemize t')) bind - return $ T.Bind (coerce name, apply (sub1 `compose` sub0) t') [] (e, lambda_t) - _ -> do - insertSig (coerce name) (Just lambda_t) - return (T.Bind (coerce name, lambda_t) [] (e, lambda_t)) + Just t' -> do + sub1 <- bindErr (unify t' lambda_t) bind + ctrace "SUB0" sub0 + ctrace "SUB1" sub1 + return ([sub1, sub0], T.Bind (coerce name, t') [] (e, lambda_t)) + _ -> error "First pass through failed to add function to env" checkData :: (MonadState Env m, Monad m, MonadError Error m) => Data -> m () checkData err@(Data typ injs) = do @@ -174,8 +168,7 @@ returnType a = a inferExp :: Exp -> Infer (Subst, T.ExpT' Type) inferExp e = do (s, (e', t)) <- algoW e - let subbed = apply s t - modify (\st -> st{undecidedSigs = apply s st.undecidedSigs}) + subbed <- apply s t return (s, (e', subbed)) class CollectTVars a where @@ -202,16 +195,9 @@ algoW = \case (sub0, (e', t')) <- exprErr (algoW e) err sub1 <- unify t t' sub2 <- unify t' t - unless - (apply sub1 t == t' && apply sub2 t' == t) - ( uncatchableErr $ Aux.do - "Annotated type" - quote $ printTree t - "does not match inferred type" - quote $ printTree t' - ) let comp = sub2 `compose` sub1 `compose` sub0 - return (comp, apply comp (e', t)) + et <- apply comp (e', t) + return (comp, et) -- \| ------------------ -- \| Γ ⊢ i : Int, ∅ @@ -228,13 +214,8 @@ algoW = \case return (nullSubst, (T.EVar $ coerce i, x)) Nothing -> do sig <- gets sigs - cb <- gets currentBind case M.lookup (coerce i) sig of - Just (Just t) -> return (nullSubst, (T.EVar $ coerce i, t)) - Just Nothing -> do - fr <- fresh - modify (\st -> st{toDecide = S.insert cb st.toDecide, undecidedSigs = M.insert (coerce $ concat [[prefix], i, [delim], coerce cb]) fr st.undecidedSigs}) - return (nullSubst, (T.EVar $ coerce i, fr)) + Just t -> return (nullSubst, (T.EVar $ coerce i, t)) Nothing -> uncatchableErr $ "Unbound variable: " @@ -257,9 +238,10 @@ algoW = \case fr <- fresh withBinding (coerce name) fr $ do (s1, (e', t')) <- exprErr (algoW e) err - let varType = apply s1 fr + varType <- apply s1 fr let newArr = TFun varType t' - return (s1, apply s1 (T.EAbs (coerce name) (e', t'), newArr)) + eabs <- apply s1 (T.EAbs (coerce name) (e', t'), newArr) + return (s1, eabs) -- \| Γ ⊢ e₀ : τ₀, S₀ S₀Γ ⊢ e₁ : τ₁, S₁ -- \| s₂ = mgu(s₁τ₀, Int) s₃ = mgu(s₂τ₁, Int) @@ -302,7 +284,7 @@ algoW = \case err@(ELet b@(Bind name args e) e1) -> do (s1, (_, t0)) <- algoW (makeLambda e (coerce args)) - bind' <- exprErr (checkBind b) err + (_, bind') <- exprErr (checkBind b) err env <- asks vars let t' = generalize (apply s1 env) t0 withBinding (coerce name) t' $ do @@ -422,15 +404,15 @@ unify t0 t1 = s1 <- unify a c s2 <- unify (apply s1 b) (apply s1 d) return $ s2 `compose` s1 - (TVar (MkTVar a), t@(TData _ _)) -> return $ M.singleton (coerce a) t - (t@(TData _ _), TVar (MkTVar b)) -> return $ M.singleton (coerce b) t + (TVar (MkTVar a), t@(TData _ _)) -> return $ coerce $ M.singleton (coerce a) t + (t@(TData _ _), TVar (MkTVar b)) -> return $ coerce $ M.singleton (coerce b) t (TVar (MkTVar a), t) -> occurs (coerce a) t (t, TVar (MkTVar b)) -> occurs (coerce b) t (TAll _ t, b) -> unify t b (a, TAll _ t) -> unify a t (TLit a, TLit b) -> if a == b - then return M.empty + then return nullSubst else catchableErr $ Aux.do "Can not unify" @@ -452,7 +434,7 @@ unify t0 t1 = quote $ printTree t' (TEVar a, TEVar b) -> if a == b - then return M.empty + then return nullSubst else catchableErr $ Aux.do "Can not unify" @@ -472,7 +454,7 @@ I.E. { a = a -> b } is an unsolvable constraint since there is no substitution where these are equal -} occurs :: T.Ident -> Type -> Infer Subst -occurs i t@(TVar _) = return (M.singleton i t) +occurs i t@(TVar _) = return (coerce $ M.singleton i t) occurs i t = if S.member i (free t) then @@ -483,7 +465,7 @@ occurs i t = "with" quote $ printTree t ) - else return $ M.singleton i t + else return $ coerce $ M.singleton i t {- | Generalize a type over all free variables in the substitution set Used for let bindings to allow expression that do not type check in @@ -509,7 +491,7 @@ inst :: Type -> Infer Type inst = \case TAll (MkTVar bound) t -> do fr <- fresh - let s = M.singleton (coerce bound) fr + let s = coerce $ M.singleton (coerce bound) fr apply s <$> inst t TFun t1 t2 -> TFun <$> inst t1 <*> inst t2 rest -> return rest @@ -545,7 +527,8 @@ skolemize t = t -- | A class for substitutions class SubstType t where -- | Apply a substitution to t - apply :: Subst -> t -> t + -- apply :: MonadError e m => Subst -> t -> m t + apply :: Subst -> t -> Infer t class FreeVars t where -- | Get all free variables from t @@ -565,32 +548,47 @@ instance FreeVars a => FreeVars [a] where free = let f acc x = acc `S.union` free x in foldl' f S.empty instance SubstType Type where - apply :: Subst -> Type -> Type - apply sub t = do + apply sub@(Subst s) t = do case t of - TLit a -> TLit a - TVar (MkTVar a) -> case M.lookup (coerce a) sub of - Nothing -> TVar (MkTVar $ coerce a) - Just t -> t - TAll (MkTVar i) t -> case M.lookup (coerce i) sub of - Nothing -> TAll (MkTVar i) (apply sub t) + TLit a -> return $ TLit a + TVar (MkTVar a) -> case M.lookup (coerce a) s of + Nothing -> return $ TVar (MkTVar $ coerce a) + Just t -> return $ t + TAll (MkTVar i) t -> case M.lookup (coerce i) s of + Nothing -> TAll (MkTVar i) <$> apply sub t Just _ -> apply sub t - TFun a b -> TFun (apply sub a) (apply sub b) - TData name a -> TData name (apply sub a) - TEVar (MkTEVar a) -> case M.lookup (coerce a) sub of - Nothing -> TEVar (MkTEVar a) - Just t -> t + TFun a b -> TFun <$> apply sub a <*> apply sub b + TData name a -> TData name <$> apply sub a + TEVar (MkTEVar a) -> case M.lookup (coerce a) s of + Nothing -> return $ TEVar (MkTEVar a) + Just t -> return $ t instance FreeVars (Map T.Ident Type) where free :: Map T.Ident Type -> Set T.Ident free = free . M.elems instance SubstType (Map T.Ident Type) where - apply :: Subst -> Map T.Ident Type -> Map T.Ident Type - apply = M.map . apply + apply s = undefined -- M.map (apply s) -instance SubstType (Map T.Ident (Maybe Type)) where - apply s = M.map (fmap $ apply s) +instance SubstType Subst where + apply s@(Subst m1) (Subst m2) = do + let both = M.keys $ M.intersection m1 m2 + case both of + [] -> Subst <$> apply s m2 + xs -> do + sub0 <- apply s m2 + sub1 <- loop xs m1 m2 + apply sub1 (Subst sub0) + where + loop [] _ _ = return nullSubst + loop (x : xs) m1 m2 = do + let k1 = m1 M.! x + let k2 = m2 M.! x + sub <- unify k1 k2 + subs <- loop xs m1 m2 + return $ sub `compose` subs + +-- Subst $ M.map (apply s) m2 instance SubstType (T.ExpT' Type) where apply s (e, t) = (apply s e, apply s t) @@ -636,16 +634,19 @@ instance SubstType (T.Id' Type) where -- | Represents the empty substition set nullSubst :: Subst -nullSubst = mempty +nullSubst = Subst mempty -- | Compose two substitution sets compose :: Subst -> Subst -> Subst -compose m1 m2 = M.map (apply m1) m2 `M.union` m1 +compose m1 m2 = Subst $ M.map (apply $ coerce m1) (coerce m2) `M.union` coerce m1 -- | Compose a list of substitution sets into one composeAll :: [Subst] -> Subst composeAll = foldl' compose nullSubst +unionSubsts :: [Subst] -> Subst +unionSubsts = Subst . foldl' M.union M.empty . map coerce + {- | Convert a function with arguments to its pointfree version > makeLambda (add x y = x + y) = add = \x. \y. x + y -} @@ -671,7 +672,7 @@ withPattern p ma = case p of T.PEnum _ -> ma -- | Insert a function signature into the environment -insertSig :: T.Ident -> Maybe Type -> Infer () +insertSig :: T.Ident -> Type -> Infer () insertSig i t = modify (\st -> st{sigs = M.insert i t (sigs st)}) insertBind :: T.Ident -> Infer () @@ -691,24 +692,6 @@ with an equivalent name has been declared already existInj :: (Monad m, MonadState Env m) => T.Ident -> m (Maybe Type) existInj n = gets (M.lookup n . injections) -setCurrentBind :: T.Ident -> Infer () -setCurrentBind i = modify (\st -> st{currentBind = i}) - -solveUndecidable :: Infer Subst -solveUndecidable = do - sigs <- gets sigs - undecided <- gets undecidedSigs - ys <- - maybeToRightM - (Error "SIGNATURE MISSING" False) - ( mapM (tupSequence . first (join . flip M.lookup sigs . getOriginal)) $ - M.toList undecided - ) - composeAll <$> mapM (uncurry unify) ys - -getOriginal :: T.Ident -> T.Ident -getOriginal (T.Ident i) = coerce $ takeWhile (/= delim) $ drop 1 i - delim :: Char delim = '_' prefix :: Char @@ -785,7 +768,7 @@ dataErr ma d = ) initCtx = Ctx mempty -initEnv = Env 0 'a' mempty mempty mempty "" mempty mempty mempty +initEnv = Env 0 'a' mempty mempty mempty mempty run :: Infer a -> Either Error a run = run' initEnv initCtx @@ -804,19 +787,20 @@ newtype Ctx = Ctx {vars :: Map T.Ident Type} data Env = Env { count :: Int , nextChar :: Char - , sigs :: Map T.Ident (Maybe Type) + , sigs :: Map T.Ident Type , takenTypeVars :: Set T.Ident , injections :: Map T.Ident Type - , currentBind :: T.Ident - , undecidedSigs :: Map T.Ident Type - , toDecide :: Set T.Ident , declaredBinds :: Set T.Ident } deriving (Show) data Error = Error {msg :: String, catchable :: Bool} deriving (Show) -type Subst = Map T.Ident Type + +newtype Subst = Subst (Map T.Ident Type) + +instance Show Subst where + show (Subst s) = "[" ++ let xs = (map (\(a, b) -> printTree a ++ " = " ++ printTree b) $ M.toList s) in intercalate " | " xs ++ "]" newtype Infer a = Infer {runInfer :: StateT Env (ReaderT Ctx (ExceptT Error Identity)) a} deriving (Functor, Applicative, Monad, MonadReader Ctx, MonadError Error, MonadState Env) From b7420b5adb9534a6012fe3d7f8962ef0a03bcacd Mon Sep 17 00:00:00 2001 From: sebastianselander Date: Fri, 31 Mar 2023 18:27:30 +0200 Subject: [PATCH 262/372] Merge in mutual recursion handling --- src/TypeChecker/TypeCheckerHm.hs | 137 +++++++++++++++++++------------ 1 file changed, 84 insertions(+), 53 deletions(-) diff --git a/src/TypeChecker/TypeCheckerHm.hs b/src/TypeChecker/TypeCheckerHm.hs index 01a7e16..518b3e8 100644 --- a/src/TypeChecker/TypeCheckerHm.hs +++ b/src/TypeChecker/TypeCheckerHm.hs @@ -39,9 +39,8 @@ typecheck = onLeft msg . run . checkPrg checkPrg :: Program -> Infer (T.Program' Type) checkPrg (Program bs) = do preRun bs - (subs, bs) <- checkDef bs - ctrace "SUBS" $ unionSubsts subs - return $ T.Program bs + (sub, bs) <- checkDef bs + return $ T.Program $ apply sub bs preRun :: [Def] -> Infer () preRun [] = return () @@ -74,13 +73,14 @@ preRun (x : xs) = case x of duplicateDecl :: (Monad m, MonadError Error m) => LIdent -> [T.Ident] -> String -> m () duplicateDecl n env msg = when (coerce n `elem` env) (uncatchableErr msg) -checkDef :: [Def] -> Infer ([Subst], [T.Def' Type]) -checkDef [] = return ([], []) +checkDef :: [Def] -> Infer (Subst, [T.Def' Type]) +checkDef [] = return (nullSubst, []) checkDef (x : xs) = case x of (DBind b) -> do (sub0, b') <- checkBind b (sub1, xs') <- checkDef xs - return (sub1 ++ sub0, T.DBind b' : xs') + comp <- sub0 `composey` sub1 + return (comp, T.DBind b' : xs') (DData d) -> do (sub, xs') <- checkDef xs return (sub, T.DData (coerceData d) : xs') @@ -89,17 +89,16 @@ checkDef (x : xs) = case x of coerceData (Data t injs) = T.Data t $ map (\(Inj name typ) -> T.Inj (coerce name) typ) injs -checkBind :: Bind -> Infer ([Subst], T.Bind' Type) +checkBind :: Bind -> Infer (Subst, T.Bind' Type) checkBind bind@(Bind name args e) = do let lambda = makeLambda e (reverse (coerce args)) (sub0, (e, lambda_t)) <- inferExp lambda s <- gets sigs case M.lookup (coerce name) s of - Just t' -> do - sub1 <- bindErr (unify t' lambda_t) bind - ctrace "SUB0" sub0 - ctrace "SUB1" sub1 - return ([sub1, sub0], T.Bind (coerce name, t') [] (e, lambda_t)) + Just t -> do + sub1 <- bindErr (unify t lambda_t) bind + comp <- sub1 `composey` sub0 + return (comp, T.Bind (coerce name, apply comp t) [] (e, lambda_t)) _ -> error "First pass through failed to add function to env" checkData :: (MonadState Env m, Monad m, MonadError Error m) => Data -> m () @@ -168,7 +167,7 @@ returnType a = a inferExp :: Exp -> Infer (Subst, T.ExpT' Type) inferExp e = do (s, (e', t)) <- algoW e - subbed <- apply s t + let subbed = apply s t return (s, (e', subbed)) class CollectTVars a where @@ -195,9 +194,17 @@ algoW = \case (sub0, (e', t')) <- exprErr (algoW e) err sub1 <- unify t t' sub2 <- unify t' t + unless + (apply sub1 t == t' && apply sub2 t' == t) + ( uncatchableErr $ Aux.do + "Annotated type" + quote $ printTree t + "does not match inferred type" + quote $ printTree t' + ) let comp = sub2 `compose` sub1 `compose` sub0 - et <- apply comp (e', t) - return (comp, et) + -- return (comp, apply comp (e', t)) + return (comp, (e', t)) -- \| ------------------ -- \| Γ ⊢ i : Int, ∅ @@ -238,10 +245,10 @@ algoW = \case fr <- fresh withBinding (coerce name) fr $ do (s1, (e', t')) <- exprErr (algoW e) err - varType <- apply s1 fr + let varType = apply s1 fr let newArr = TFun varType t' - eabs <- apply s1 (T.EAbs (coerce name) (e', t'), newArr) - return (s1, eabs) + -- return (s1, apply s1 (T.EAbs (coerce name) (e', t'), newArr)) + return (s1, (T.EAbs (coerce name) (e', t'), newArr)) -- \| Γ ⊢ e₀ : τ₀, S₀ S₀Γ ⊢ e₁ : τ₁, S₁ -- \| s₂ = mgu(s₁τ₀, Int) s₃ = mgu(s₂τ₁, Int) @@ -255,10 +262,8 @@ algoW = \case s3 <- exprErr (unify (apply s2 t0) int) err s4 <- exprErr (unify (apply s3 t1) int) err let comp = s4 `compose` s3 `compose` s2 `compose` s1 - return - ( comp - , apply comp (T.EAdd (e0', t0) (e1', t1), int) - ) + -- return (comp, apply comp (T.EAdd (e0', t0) (e1', t1), int)) + return (comp, (T.EAdd (e0', t0) (e1', t1), int)) -- \| Γ ⊢ e₀ : τ₀, S₀ S₀Γ ⊢ e₁ : τ₁, S1 -- \| τ' = newvar S₂ = mgu(S₁τ₀, τ₁ → τ') @@ -273,8 +278,10 @@ algoW = \case (s1, (e1', t1)) <- algoW e1 s2 <- exprErr (unify (apply s1 t0) (TFun t1 fr)) err let t = apply s2 fr - let comp = s2 `compose` s1 `compose` s0 - return (comp, apply comp (T.EApp (e0', t0) (e1', t1), t)) + comp <- foldM composey nullSubst [s2, s1, s0] + -- let comp = s2 `compose` s1 `compose` s0 + -- return (comp, apply comp (T.EApp (e0', t0) (e1', t1), t)) + return (comp, (T.EApp (e0', t0) (e1', t1), t)) -- \| Γ ⊢ e₀ : τ, S₀ S₀Γ, x : S̅₀Γ̅(τ) ⊢ e₁ : τ', S₁ -- \| ---------------------------------------------- @@ -290,12 +297,14 @@ algoW = \case withBinding (coerce name) t' $ do (s2, (e1', t2)) <- algoW e1 let comp = s2 `compose` s1 - return (comp, apply comp (T.ELet bind' (e1', t2), t2)) + -- return (comp, apply comp (T.ELet bind' (e1', t2), t2)) + return (comp, (T.ELet bind' (e1', t2), t2)) ECase caseExpr injs -> do (sub, (e', t)) <- algoW caseExpr (subst, injs, ret_t) <- checkCase t injs let comp = subst `compose` sub - return (comp, apply comp (T.ECase (e', t) injs, ret_t)) + -- return (comp, apply comp (T.ECase (e', t) injs, ret_t)) + return (comp, (T.ECase (e', t) injs, ret_t)) EAppInf{} -> error "desugar phase failed" checkCase :: Type -> [Branch] -> Infer (Subst, [T.Branch' Type], Type) @@ -528,7 +537,7 @@ skolemize t = t class SubstType t where -- | Apply a substitution to t -- apply :: MonadError e m => Subst -> t -> m t - apply :: Subst -> t -> Infer t + apply :: Subst -> t -> t class FreeVars t where -- | Get all free variables from t @@ -550,43 +559,28 @@ instance FreeVars a => FreeVars [a] where instance SubstType Type where apply sub@(Subst s) t = do case t of - TLit a -> return $ TLit a + TLit a -> TLit a TVar (MkTVar a) -> case M.lookup (coerce a) s of - Nothing -> return $ TVar (MkTVar $ coerce a) - Just t -> return $ t + Nothing -> TVar (MkTVar $ coerce a) + Just t -> t TAll (MkTVar i) t -> case M.lookup (coerce i) s of - Nothing -> TAll (MkTVar i) <$> apply sub t + Nothing -> TAll (MkTVar i) (apply sub t) Just _ -> apply sub t - TFun a b -> TFun <$> apply sub a <*> apply sub b - TData name a -> TData name <$> apply sub a + TFun a b -> TFun (apply sub a) (apply sub b) + TData name a -> TData name (apply sub a) TEVar (MkTEVar a) -> case M.lookup (coerce a) s of - Nothing -> return $ TEVar (MkTEVar a) - Just t -> return $ t + Nothing -> TEVar (MkTEVar a) + Just t -> t instance FreeVars (Map T.Ident Type) where free :: Map T.Ident Type -> Set T.Ident free = free . M.elems instance SubstType (Map T.Ident Type) where - apply s = undefined -- M.map (apply s) + apply s = M.map (apply s) instance SubstType Subst where - apply s@(Subst m1) (Subst m2) = do - let both = M.keys $ M.intersection m1 m2 - case both of - [] -> Subst <$> apply s m2 - xs -> do - sub0 <- apply s m2 - sub1 <- loop xs m1 m2 - apply sub1 (Subst sub0) - where - loop [] _ _ = return nullSubst - loop (x : xs) m1 m2 = do - let k1 = m1 M.! x - let k2 = m2 M.! x - sub <- unify k1 k2 - subs <- loop xs m1 m2 - return $ sub `compose` subs + apply s (Subst m2) = Subst $ apply s m2 -- Subst $ M.map (apply s) m2 @@ -640,6 +634,30 @@ nullSubst = Subst mempty compose :: Subst -> Subst -> Subst compose m1 m2 = Subst $ M.map (apply $ coerce m1) (coerce m2) `M.union` coerce m1 +-- Order matters. +{- +sub0 = Subst $ (M.singleton "a" (arr d e)) `M.union` (M.singleton "b" (arr d f)) `M.union` (M.singleton "c" (arr f e)) +sub1 = Subst $ (M.singleton "a" (arr g bool)) `M.union` (M.singleton "b" (arr g bool)) `M.union` (M.singleton "c" (arr bool bool)) `M.union` (M.singleton "h" bool) `M.union` (M.singleton "i" bool) +sub0 `composey` sub1 != sub1 `composey` sub0 + -} +composey :: Subst -> Subst -> Infer Subst +composey s0@(Subst m1) s1@(Subst m2) = do + let both = M.keys $ M.intersection m1 m2 + case both of + [] -> return $ s0 `compose` s1 + xs -> do + let m2' = apply s0 m2 + sub <- loop xs m1 m2' + return $ sub `compose` Subst m2 + where + loop [] _ _ = return nullSubst + loop (x : xs) m1 m2 = do + let k1 = m1 M.! x + let k2 = m2 M.! x + sub <- unify k1 k2 + subs <- loop xs m1 m2 + return $ sub `compose` subs + -- | Compose a list of substitution sets into one composeAll :: [Subst] -> Subst composeAll = foldl' compose nullSubst @@ -800,7 +818,7 @@ data Error = Error {msg :: String, catchable :: Bool} newtype Subst = Subst (Map T.Ident Type) instance Show Subst where - show (Subst s) = "[" ++ let xs = (map (\(a, b) -> printTree a ++ " = " ++ printTree b) $ M.toList s) in intercalate " | " xs ++ "]" + show (Subst s) = "[ " ++ let xs = (map (\(a, b) -> printTree a ++ " = " ++ printTree b) $ M.toList s) in intercalate " | " xs ++ " ]" newtype Infer a = Infer {runInfer :: StateT Env (ReaderT Ctx (ExceptT Error Identity)) a} deriving (Functor, Applicative, Monad, MonadReader Ctx, MonadError Error, MonadState Env) @@ -816,3 +834,16 @@ quote s = "'" ++ s ++ "'" ctrace :: (Monad m, Show a) => String -> a -> m () ctrace str a = trace (str ++ ": " ++ show a) pure () + +{- +Save each subst mapped to their respective function +Apply composition of all used functions to the function + +a = id 0 ; +b = id 'a' ; +id x = x ; + +apply_on_a = id_sub `compose` a_sub +apply_on_b = id_sub `compose` b_sub +apply_on_id = id_sub +-} From 0749ca062d7a73b2444af8f1b19163945d8135b3 Mon Sep 17 00:00:00 2001 From: sebastianselander Date: Fri, 31 Mar 2023 18:28:04 +0200 Subject: [PATCH 263/372] Merge in mutual recursion handling --- src/TypeChecker/TypeCheckerHm.hs | 131 ++++++++++++++++++------------- src/TypeChecker/TypeCheckerIr.hs | 5 ++ test_program.crf | 43 ---------- 3 files changed, 81 insertions(+), 98 deletions(-) diff --git a/src/TypeChecker/TypeCheckerHm.hs b/src/TypeChecker/TypeCheckerHm.hs index 518b3e8..33765e0 100644 --- a/src/TypeChecker/TypeCheckerHm.hs +++ b/src/TypeChecker/TypeCheckerHm.hs @@ -8,6 +8,7 @@ module TypeChecker.TypeCheckerHm where import Auxiliary (int, litType, maybeToRightM, unzip4) import Auxiliary qualified as Aux +import Control.Arrow ((&&&)) import Control.Monad.Except import Control.Monad.Identity (Identity, runIdentity) import Control.Monad.Reader @@ -18,7 +19,7 @@ import Data.List (foldl', intercalate) import Data.List.Extra (unsnoc) import Data.Map (Map) import Data.Map qualified as M -import Data.Maybe (fromJust) +import Data.Maybe (fromJust, fromMaybe, mapMaybe) import Data.Set (Set) import Data.Set qualified as S import Debug.Trace (trace) @@ -26,8 +27,6 @@ import Grammar.Abs import Grammar.Print (printTree) import TypeChecker.TypeCheckerIr qualified as T --- TODO: Disallow mutual recursion - -- | Type check a program typecheck :: Program -> Either String (T.Program' Type) typecheck = onLeft msg . run . checkPrg @@ -37,10 +36,16 @@ typecheck = onLeft msg . run . checkPrg onLeft _ (Right x) = Right x checkPrg :: Program -> Infer (T.Program' Type) -checkPrg (Program bs) = do - preRun bs - (sub, bs) <- checkDef bs - return $ T.Program $ apply sub bs +checkPrg (Program bs) = T.Program <$> (preRun bs >> checkDef bs >>= mapM substPrg) + +substPrg :: T.Def' Type -> Infer (T.Def' Type) +substPrg (T.DBind (T.Bind (name, t) args e)) = do + (bu, sub) <- gets (bindUsages &&& bindSubs) + let uses = fromMaybe [] $ M.lookup name bu + let subs = mapMaybe (`M.lookup` sub) (name : uses) + sub <- foldM composey nullSubst (reverse subs) + return . T.DBind $ T.Bind (name, apply sub t) (apply sub args) (apply sub e) +substPrg d = return d preRun :: [Def] -> Infer () preRun [] = return () @@ -51,7 +56,7 @@ preRun (x : xs) = case x of duplicateDecl n s $ Aux.do "Multiple signatures of function" quote $ printTree n - insertSig (coerce n) t + insertSig (coerce n) (Instantiated t) preRun xs DBind (Bind n _ e) -> do s <- gets (S.toList . declaredBinds) @@ -64,7 +69,7 @@ preRun (x : xs) = case x of case M.lookup (coerce n) sigs of Nothing -> do fr <- fresh - insertSig (coerce n) fr + insertSig (coerce n) (Generalized fr) preRun xs Just _ -> preRun xs DData d@(Data t _) -> collect (collectTVars t) >> checkData d >> preRun xs @@ -73,33 +78,38 @@ preRun (x : xs) = case x of duplicateDecl :: (Monad m, MonadError Error m) => LIdent -> [T.Ident] -> String -> m () duplicateDecl n env msg = when (coerce n `elem` env) (uncatchableErr msg) -checkDef :: [Def] -> Infer (Subst, [T.Def' Type]) -checkDef [] = return (nullSubst, []) +checkDef :: [Def] -> Infer [T.Def' Type] +checkDef [] = return [] checkDef (x : xs) = case x of (DBind b) -> do - (sub0, b') <- checkBind b - (sub1, xs') <- checkDef xs - comp <- sub0 `composey` sub1 - return (comp, T.DBind b' : xs') + b' <- checkBind b + xs' <- checkDef xs + return $ T.DBind b' : xs' (DData d) -> do - (sub, xs') <- checkDef xs - return (sub, T.DData (coerceData d) : xs') + xs' <- checkDef xs + return $ T.DData (coerceData d) : xs' (DSig _) -> checkDef xs where coerceData (Data t injs) = T.Data t $ map (\(Inj name typ) -> T.Inj (coerce name) typ) injs -checkBind :: Bind -> Infer (Subst, T.Bind' Type) +checkBind :: Bind -> Infer (T.Bind' Type) checkBind bind@(Bind name args e) = do + setCurrentBind $ coerce name let lambda = makeLambda e (reverse (coerce args)) (sub0, (e, lambda_t)) <- inferExp lambda s <- gets sigs case M.lookup (coerce name) s of Just t -> do - sub1 <- bindErr (unify t lambda_t) bind + let t' = case t of + Instantiated a -> skolemize a + Generalized a -> a + sub1 <- bindErr (unify t' lambda_t) bind comp <- sub1 `composey` sub0 - return (comp, T.Bind (coerce name, apply comp t) [] (e, lambda_t)) - _ -> error "First pass through failed to add function to env" + insertBindSubst (coerce name) comp + return (T.Bind (coerce name, apply comp t') [] (e, lambda_t)) + _ -> do + uncatchableErr $ "Undeclared function: " ++ printTree name checkData :: (MonadState Env m, Monad m, MonadError Error m) => Data -> m () checkData err@(Data typ injs) = do @@ -203,7 +213,6 @@ algoW = \case quote $ printTree t' ) let comp = sub2 `compose` sub1 `compose` sub0 - -- return (comp, apply comp (e', t)) return (comp, (e', t)) -- \| ------------------ @@ -221,8 +230,11 @@ algoW = \case return (nullSubst, (T.EVar $ coerce i, x)) Nothing -> do sig <- gets sigs + cb <- gets currentBind case M.lookup (coerce i) sig of - Just t -> return (nullSubst, (T.EVar $ coerce i, t)) + Just t -> do + insertBindUsage cb (coerce i) + return (nullSubst, (T.EVar $ coerce i, unlevel t)) Nothing -> uncatchableErr $ "Unbound variable: " @@ -247,7 +259,6 @@ algoW = \case (s1, (e', t')) <- exprErr (algoW e) err let varType = apply s1 fr let newArr = TFun varType t' - -- return (s1, apply s1 (T.EAbs (coerce name) (e', t'), newArr)) return (s1, (T.EAbs (coerce name) (e', t'), newArr)) -- \| Γ ⊢ e₀ : τ₀, S₀ S₀Γ ⊢ e₁ : τ₁, S₁ @@ -262,7 +273,6 @@ algoW = \case s3 <- exprErr (unify (apply s2 t0) int) err s4 <- exprErr (unify (apply s3 t1) int) err let comp = s4 `compose` s3 `compose` s2 `compose` s1 - -- return (comp, apply comp (T.EAdd (e0', t0) (e1', t1), int)) return (comp, (T.EAdd (e0', t0) (e1', t1), int)) -- \| Γ ⊢ e₀ : τ₀, S₀ S₀Γ ⊢ e₁ : τ₁, S1 @@ -274,13 +284,10 @@ algoW = \case fr <- fresh (s0, (e0', t0)) <- algoW e0 applySt s0 $ do - modify (\st -> st{sigs = apply s0 st.sigs}) (s1, (e1', t1)) <- algoW e1 s2 <- exprErr (unify (apply s1 t0) (TFun t1 fr)) err let t = apply s2 fr comp <- foldM composey nullSubst [s2, s1, s0] - -- let comp = s2 `compose` s1 `compose` s0 - -- return (comp, apply comp (T.EApp (e0', t0) (e1', t1), t)) return (comp, (T.EApp (e0', t0) (e1', t1), t)) -- \| Γ ⊢ e₀ : τ, S₀ S₀Γ, x : S̅₀Γ̅(τ) ⊢ e₁ : τ', S₁ @@ -289,16 +296,17 @@ algoW = \case -- The bar over S₀ and Γ means "generalize" - err@(ELet b@(Bind name args e) e1) -> do - (s1, (_, t0)) <- algoW (makeLambda e (coerce args)) - (_, bind') <- exprErr (checkBind b) err + (ELet (Bind name args e) e1) -> do + (s1, (e, t0)) <- algoW (makeLambda e (coerce args)) env <- asks vars let t' = generalize (apply s1 env) t0 withBinding (coerce name) t' $ do (s2, (e1', t2)) <- algoW e1 let comp = s2 `compose` s1 - -- return (comp, apply comp (T.ELet bind' (e1', t2), t2)) - return (comp, (T.ELet bind' (e1', t2), t2)) + return + ( comp + , (T.ELet (T.Bind (coerce name, t0) [] (e, t0)) (e1', t2), t2) + ) ECase caseExpr injs -> do (sub, (e', t)) <- algoW caseExpr (subst, injs, ret_t) <- checkCase t injs @@ -413,8 +421,10 @@ unify t0 t1 = s1 <- unify a c s2 <- unify (apply s1 b) (apply s1 d) return $ s2 `compose` s1 - (TVar (MkTVar a), t@(TData _ _)) -> return $ coerce $ M.singleton (coerce a) t - (t@(TData _ _), TVar (MkTVar b)) -> return $ coerce $ M.singleton (coerce b) t + (TVar (MkTVar a), t@(TData _ _)) -> + return $ coerce $ M.singleton (coerce a) t + (t@(TData _ _), TVar (MkTVar b)) -> + return $ coerce $ M.singleton (coerce b) t (TVar (MkTVar a), t) -> occurs (coerce a) t (t, TVar (MkTVar b)) -> occurs (coerce b) t (TAll _ t, b) -> unify t b @@ -603,7 +613,8 @@ instance SubstType (T.Exp' Type) where instance SubstType (T.Def' Type) where apply s = \case - T.DBind (T.Bind name args e) -> T.DBind $ T.Bind (apply s name) (apply s args) (apply s e) + T.DBind (T.Bind name args e) -> + T.DBind $ T.Bind (apply s name) (apply s args) (apply s e) d -> d instance SubstType (T.Branch' Type) where @@ -636,8 +647,14 @@ compose m1 m2 = Subst $ M.map (apply $ coerce m1) (coerce m2) `M.union` coerce m -- Order matters. {- -sub0 = Subst $ (M.singleton "a" (arr d e)) `M.union` (M.singleton "b" (arr d f)) `M.union` (M.singleton "c" (arr f e)) -sub1 = Subst $ (M.singleton "a" (arr g bool)) `M.union` (M.singleton "b" (arr g bool)) `M.union` (M.singleton "c" (arr bool bool)) `M.union` (M.singleton "h" bool) `M.union` (M.singleton "i" bool) +sub0 = Subst $ (M.singleton "a" (arr d e)) + `M.union` (M.singleton "b" (arr d f)) + `M.union` (M.singleton "c" (arr f e)) +sub1 = Subst $ (M.singleton "a" (arr g bool)) + `M.union` (M.singleton "b" (arr g bool)) + `M.union` (M.singleton "c" (arr bool bool)) + `M.union` (M.singleton "h" bool) + `M.union` (M.singleton "i" bool) sub0 `composey` sub1 != sub1 `composey` sub0 -} composey :: Subst -> Subst -> Infer Subst @@ -690,12 +707,21 @@ withPattern p ma = case p of T.PEnum _ -> ma -- | Insert a function signature into the environment -insertSig :: T.Ident -> Type -> Infer () +insertSig :: T.Ident -> Level Type -> Infer () insertSig i t = modify (\st -> st{sigs = M.insert i t (sigs st)}) insertBind :: T.Ident -> Infer () insertBind i = modify (\st -> st{declaredBinds = S.insert i st.declaredBinds}) +insertBindSubst :: T.Ident -> Subst -> Infer () +insertBindSubst name sub = modify (\st -> st{bindSubs = M.insert name sub st.bindSubs}) + +setCurrentBind :: T.Ident -> Infer () +setCurrentBind n = modify (\st -> st{currentBind = n, bindUsages = M.insertWith (++) n [] st.bindUsages}) + +insertBindUsage :: T.Ident -> T.Ident -> Infer () +insertBindUsage cur use = modify (\st -> st{bindUsages = M.insertWith (++) cur [use] st.bindUsages}) + -- | Insert a constructor into the start with its type insertInj :: (Monad m, MonadState Env m) => T.Ident -> Type -> m () insertInj i t = @@ -786,7 +812,7 @@ dataErr ma d = ) initCtx = Ctx mempty -initEnv = Env 0 'a' mempty mempty mempty mempty +initEnv = Env 0 'a' mempty mempty mempty mempty "" mempty mempty run :: Infer a -> Either Error a run = run' initEnv initCtx @@ -805,20 +831,28 @@ newtype Ctx = Ctx {vars :: Map T.Ident Type} data Env = Env { count :: Int , nextChar :: Char - , sigs :: Map T.Ident Type + , sigs :: Map T.Ident (Level Type) , takenTypeVars :: Set T.Ident , injections :: Map T.Ident Type , declaredBinds :: Set T.Ident + , currentBind :: T.Ident + , bindSubs :: Map T.Ident Subst + , bindUsages :: Map T.Ident [T.Ident] } deriving (Show) +data Level a = Instantiated {unlevel :: a} | Generalized {unlevel :: a} + deriving (Show) + data Error = Error {msg :: String, catchable :: Bool} deriving (Show) newtype Subst = Subst (Map T.Ident Type) instance Show Subst where - show (Subst s) = "[ " ++ let xs = (map (\(a, b) -> printTree a ++ " = " ++ printTree b) $ M.toList s) in intercalate " | " xs ++ " ]" + show (Subst s) = "[ " ++ intercalate " | " xs ++ " ]" + where + xs = map (\(a, b) -> printTree a ++ " = " ++ printTree b) $ M.toList s newtype Infer a = Infer {runInfer :: StateT Env (ReaderT Ctx (ExceptT Error Identity)) a} deriving (Functor, Applicative, Monad, MonadReader Ctx, MonadError Error, MonadState Env) @@ -834,16 +868,3 @@ quote s = "'" ++ s ++ "'" ctrace :: (Monad m, Show a) => String -> a -> m () ctrace str a = trace (str ++ ": " ++ show a) pure () - -{- -Save each subst mapped to their respective function -Apply composition of all used functions to the function - -a = id 0 ; -b = id 'a' ; -id x = x ; - -apply_on_a = id_sub `compose` a_sub -apply_on_b = id_sub `compose` b_sub -apply_on_id = id_sub --} diff --git a/src/TypeChecker/TypeCheckerIr.hs b/src/TypeChecker/TypeCheckerIr.hs index b3f51d7..d59e429 100644 --- a/src/TypeChecker/TypeCheckerIr.hs +++ b/src/TypeChecker/TypeCheckerIr.hs @@ -188,6 +188,11 @@ instance Print t => Print (Inj' t) where prt i = \case Inj uident type_ -> prPrec i 0 (concatD [prt 0 uident, doc (showString ":"), prt 0 type_]) +instance Print t => Print [Inj' t] where + prt _ [] = concatD [] + prt i [x] = prt i x + prt i (x : xs) = prPrec i 0 $ concatD [prt i x, doc $ showString "\n ", prt i xs] + instance Print t => Print (Pattern' t) where prt i = \case PVar name -> prPrec i 1 (concatD [prt 0 name]) diff --git a/test_program.crf b/test_program.crf index b584ff8..432d33f 100644 --- a/test_program.crf +++ b/test_program.crf @@ -26,46 +26,3 @@ bind : Maybe () -> (Int -> Maybe ()) -> Maybe () ; bind x f = case x of { Just x => f x ; Nothing => Nothing ; -}; - --- represents minus one :) -minusOne : Int ; -minusOne = 9223372036854775807 + 9223372036854775807 + 1; - ----- LIST STUFF ---- --- a simple list data type containing ints -data List () where { - Cons : Int -> List () -> List () - Nil : List () -}; - --- take the length of a list -length : List () -> Int ; -length x = case x of { - Cons _ xs => 1 + length xs ; - Nil => 0 ; -}; - --- sum a list -sum : List () -> Int ; -sum x = case x of { - Cons a xs => a + sum xs ; - Nil => 0 ; -}; - --- sum + length of a list -sumlength: List () -> Int ; -sumlength x = sum x + length x ; - --- take the head of a list -head : List () -> Int ; -head x = case x of { - Cons h _ => h ; -}; - --- repeat an element n times -repeat : Int -> Int -> List () ; -repeat x n = case n of { - 0 => Nil ; - n => Cons x (repeat x (n + minusOne)) ; -}; From 00e23a16dd1bdef713e53bff6db7f7ba1560c5ae Mon Sep 17 00:00:00 2001 From: Rakarake Date: Fri, 31 Mar 2023 18:58:33 +0200 Subject: [PATCH 264/372] Monomorphization of datatypes done! --- sample-programs/mono.crf | 4 +--- src/Monomorphizer/Monomorphizer.hs | 29 ++++++++++++++++------------- 2 files changed, 17 insertions(+), 16 deletions(-) diff --git a/sample-programs/mono.crf b/sample-programs/mono.crf index 8f5fbbc..e682b7d 100644 --- a/sample-programs/mono.crf +++ b/sample-programs/mono.crf @@ -1,7 +1,5 @@ const x y = x; -id x = x; - -f x = (id 5); +f x = (const x 'c'); main = f 5; diff --git a/src/Monomorphizer/Monomorphizer.hs b/src/Monomorphizer/Monomorphizer.hs index 1d1571f..9567bd4 100644 --- a/src/Monomorphizer/Monomorphizer.hs +++ b/src/Monomorphizer/Monomorphizer.hs @@ -235,21 +235,24 @@ morphBranch :: T.Branch -> EnvM M.Branch morphBranch (T.Branch (p, pt) (e, et)) = do pt' <- getMonoFromPoly pt et' <- getMonoFromPoly et - e' <- morphExp et' e - p' <- morphPattern p - return $ M.Branch (p', pt') (e', et') + env <- ask + (p', newLocals) <- morphPattern (locals env) p + local (const env { locals = Set.union newLocals (locals env) }) $ do + e' <- morphExp et' e + return $ M.Branch (p', pt') (e', et') -morphPattern :: T.Pattern -> EnvM M.Pattern -morphPattern = \case +-- Morphs pattern (patter -> expression), gives the newly bound local variables. +morphPattern :: Set.Set Ident -> T.Pattern -> EnvM (M.Pattern, Set.Set Ident) +morphPattern ls = \case T.PVar (ident, t) -> do t' <- getMonoFromPoly t - return $ M.PVar (ident, t') - T.PLit (lit, t) -> do t' <- getMonoFromPoly t - return $ M.PLit (convertLit lit, t') - T.PCatch -> return M.PCatch + return (M.PVar (ident, t'), Set.insert ident ls) + T.PLit (lit, t) -> do t' <- getMonoFromPoly t + return (M.PLit (convertLit lit, t'), ls) + T.PCatch -> return (M.PCatch, ls) -- Constructor ident - T.PEnum ident -> return $ M.PEnum ident - T.PInj ident ps -> do ps' <- mapM morphPattern ps - return $ M.PInj ident ps' + T.PEnum ident -> return (M.PEnum ident, ls) + T.PInj ident ps -> do pairs <- mapM (morphPattern ls) ps + return (M.PInj ident (map fst pairs), Set.unions (map snd pairs)) -- | Creates a new identifier for a function with an assigned type newName :: M.Type -> T.Bind -> Ident @@ -261,7 +264,7 @@ newName t (T.Bind (Ident bindName, _) _ _) = newName' :: M.Type -> String newName' (M.TLit (Ident str)) = str newName' (M.TFun t1 t2) = newName' t1 ++ "_" ++ newName' t2 - newName' (M.TData (Ident str) ts) = str ++ "." ++ foldl (\s t -> s ++ "," ++ newName' t) "" ts + newName' (M.TData (Ident str) ts) = str ++ foldl (\s t -> s ++ "." ++ newName' t) "" ts -- Monomorphization step monomorphize :: T.Program -> O.Program From c6173c007756c2705455a77e56fb03aa9c5bedec Mon Sep 17 00:00:00 2001 From: Rakarake Date: Fri, 31 Mar 2023 19:25:48 +0200 Subject: [PATCH 265/372] Plus now working in monomorphizer --- src/Monomorphizer/Monomorphizer.hs | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/src/Monomorphizer/Monomorphizer.hs b/src/Monomorphizer/Monomorphizer.hs index 9567bd4..6bbbdcd 100644 --- a/src/Monomorphizer/Monomorphizer.hs +++ b/src/Monomorphizer/Monomorphizer.hs @@ -93,9 +93,9 @@ mapTypes (T.TVar (T.MkTVar i1)) tm = [(i1, tm)] mapTypes (T.TFun pt1 pt2) (M.TFun mt1 mt2) = mapTypes pt1 mt1 ++ mapTypes pt2 mt2 mapTypes (T.TData tIdent pTs) (M.TData mIdent mTs) = if tIdent /= mIdent - then error "Nuh uh" + then error "nuh uh" else foldl (\xs (p, m) -> mapTypes p m ++ xs) [] (zip pTs mTs) -mapTypes _ _ = error "structure of types not the same!" +mapTypes t1 t2 = error $ "structure of types not the same: '" ++ printTree t1 ++ "', '" ++ printTree t2 ++ "'" -- | Gets the mapped monomorphic type of a polymorphic type in the current context. getMonoFromPoly :: T.Type -> EnvM M.Type @@ -144,12 +144,12 @@ convertArg (ident, t) = do t' <- getMonoFromPoly t return (ident, t') -- Morphs function applications, such as EApp and EAdd -morphApp :: M.Type -> T.ExpT -> T.ExpT -> EnvM M.Exp -morphApp expectedType (e1, t1) (e2, t2)= do +morphApp :: (M.ExpT -> M.ExpT -> M.Exp) -> M.Type -> T.ExpT -> T.ExpT -> EnvM M.Exp +morphApp node expectedType (e1, t1) (e2, t2)= do t2' <- getMonoFromPoly t2 e2' <- morphExp t2' e2 e1' <- morphExp (M.TFun t2' expectedType) e1 - return $ M.EApp (e1', M.TFun t2' expectedType) (e2', t2') + return $ node (e1', M.TFun t2' expectedType) (e2', t2') addOutputData :: M.Data -> EnvM () addOutputData d@(M.Data (M.TData ident _) _) = modify $ Map.insert ident (Data d) @@ -201,9 +201,9 @@ morphExp expectedType exp = case exp of T.EInj ident -> do return $ M.EVar ident T.EApp e1 e2 -> do - morphApp expectedType e1 e2 + morphApp M.EApp expectedType e1 e2 T.EAdd e1 e2 -> do - morphApp expectedType e1 e2 + morphApp M.EAdd expectedType e1 e2 T.EAbs ident (exp, t) -> local (\env -> env { locals = Set.insert ident (locals env) }) $ do t' <- getMonoFromPoly t morphExp t' exp From ec57712eec6d533021440426ff6638cd832b19de Mon Sep 17 00:00:00 2001 From: Rakarake Date: Fri, 31 Mar 2023 19:43:05 +0200 Subject: [PATCH 266/372] Fixed bad names after monomorphizer --- src/Monomorphizer/DataTypeRemover.hs | 11 ++++++++--- 1 file changed, 8 insertions(+), 3 deletions(-) diff --git a/src/Monomorphizer/DataTypeRemover.hs b/src/Monomorphizer/DataTypeRemover.hs index cf353fb..d4444d7 100644 --- a/src/Monomorphizer/DataTypeRemover.hs +++ b/src/Monomorphizer/DataTypeRemover.hs @@ -17,9 +17,14 @@ pCons :: M1.Inj -> M2.Inj pCons (M1.Inj ident t) = M2.Inj ident (pType t) pType :: M1.Type -> M2.Type -pType (M1.TLit ident) = M2.TLit ident -pType (M1.TFun t1 t2) = M2.TFun (pType t1) (pType t2) -pType (M1.TData (Ident str) args) = M2.TLit (Ident (str ++ show args)) -- This is the step +pType (M1.TLit ident) = M2.TLit ident +pType (M1.TFun t1 t2) = M2.TFun (pType t1) (pType t2) +pType d = M2.TLit (Ident (newName d)) -- This is the step + +newName :: M1.Type -> String +newName (M1.TLit (Ident str)) = str +newName (M1.TFun t1 t2) = newName t1 ++ newName t2 +newName (M1.TData (Ident str) args) = str ++ concatMap newName args pBind :: M1.Bind -> M2.Bind pBind (M1.Bind id argIds expt) = M2.Bind (pId id) (map pId argIds) (pExpT expt) From 4b14cbdebf9d94b27296bf531f12303ae885de37 Mon Sep 17 00:00:00 2001 From: sebastian Date: Sat, 1 Apr 2023 17:10:26 +0200 Subject: [PATCH 267/372] reverted Hindley-Milner type checker to before mutual recursion merge --- src/TypeChecker/TypeCheckerHm.hs | 221 +++++++++++++------------------ 1 file changed, 93 insertions(+), 128 deletions(-) diff --git a/src/TypeChecker/TypeCheckerHm.hs b/src/TypeChecker/TypeCheckerHm.hs index 33765e0..710343f 100644 --- a/src/TypeChecker/TypeCheckerHm.hs +++ b/src/TypeChecker/TypeCheckerHm.hs @@ -6,20 +6,20 @@ -- | A module for type checking and inference using algorithm W, Hindley-Milner module TypeChecker.TypeCheckerHm where -import Auxiliary (int, litType, maybeToRightM, unzip4) +import Auxiliary (int, litType, maybeToRightM, tupSequence, unzip4) import Auxiliary qualified as Aux -import Control.Arrow ((&&&)) import Control.Monad.Except import Control.Monad.Identity (Identity, runIdentity) import Control.Monad.Reader import Control.Monad.State +import Data.Bifunctor (first) import Data.Coerce (coerce) import Data.Function (on) -import Data.List (foldl', intercalate) +import Data.List (foldl') import Data.List.Extra (unsnoc) import Data.Map (Map) import Data.Map qualified as M -import Data.Maybe (fromJust, fromMaybe, mapMaybe) +import Data.Maybe (fromJust) import Data.Set (Set) import Data.Set qualified as S import Debug.Trace (trace) @@ -27,6 +27,8 @@ import Grammar.Abs import Grammar.Print (printTree) import TypeChecker.TypeCheckerIr qualified as T +-- TODO: Disallow mutual recursion + -- | Type check a program typecheck :: Program -> Either String (T.Program' Type) typecheck = onLeft msg . run . checkPrg @@ -36,16 +38,20 @@ typecheck = onLeft msg . run . checkPrg onLeft _ (Right x) = Right x checkPrg :: Program -> Infer (T.Program' Type) -checkPrg (Program bs) = T.Program <$> (preRun bs >> checkDef bs >>= mapM substPrg) +checkPrg (Program bs) = do + preRun bs + bs <- checkDef bs + sub0 <- solveUndecidable + bs <- mapM (mono sub0) bs + return $ T.Program bs -substPrg :: T.Def' Type -> Infer (T.Def' Type) -substPrg (T.DBind (T.Bind (name, t) args e)) = do - (bu, sub) <- gets (bindUsages &&& bindSubs) - let uses = fromMaybe [] $ M.lookup name bu - let subs = mapMaybe (`M.lookup` sub) (name : uses) - sub <- foldM composey nullSubst (reverse subs) - return . T.DBind $ T.Bind (name, apply sub t) (apply sub args) (apply sub e) -substPrg d = return d +mono :: Subst -> T.Def' Type -> Infer (T.Def' Type) +mono s bind@(T.DBind (T.Bind (name, t) args e)) = do + b <- gets (S.member name . toDecide) + if b + then return $ T.DBind $ T.Bind (name, apply s t) (apply s args) (apply s e) + else return bind +mono _ (T.DData d) = return $ T.DData d preRun :: [Def] -> Infer () preRun [] = return () @@ -56,8 +62,7 @@ preRun (x : xs) = case x of duplicateDecl n s $ Aux.do "Multiple signatures of function" quote $ printTree n - insertSig (coerce n) (Instantiated t) - preRun xs + insertSig (coerce n) (Just t) >> preRun xs DBind (Bind n _ e) -> do s <- gets (S.toList . declaredBinds) duplicateDecl n s $ Aux.do @@ -65,17 +70,13 @@ preRun (x : xs) = case x of quote $ printTree n collect (collectTVars e) insertBind $ coerce n - sigs <- gets sigs - case M.lookup (coerce n) sigs of - Nothing -> do - fr <- fresh - insertSig (coerce n) (Generalized fr) - preRun xs + s <- gets sigs + case M.lookup (coerce n) s of + Nothing -> insertSig (coerce n) Nothing >> preRun xs Just _ -> preRun xs DData d@(Data t _) -> collect (collectTVars t) >> checkData d >> preRun xs where -- Check if function body / signature has been declared already - duplicateDecl :: (Monad m, MonadError Error m) => LIdent -> [T.Ident] -> String -> m () duplicateDecl n env msg = when (coerce n `elem` env) (uncatchableErr msg) checkDef :: [Def] -> Infer [T.Def' Type] @@ -100,16 +101,12 @@ checkBind bind@(Bind name args e) = do (sub0, (e, lambda_t)) <- inferExp lambda s <- gets sigs case M.lookup (coerce name) s of - Just t -> do - let t' = case t of - Instantiated a -> skolemize a - Generalized a -> a - sub1 <- bindErr (unify t' lambda_t) bind - comp <- sub1 `composey` sub0 - insertBindSubst (coerce name) comp - return (T.Bind (coerce name, apply comp t') [] (e, lambda_t)) + Just (Just t') -> do + sub1 <- bindErr (unify lambda_t (skolemize t')) bind + return $ T.Bind (coerce name, apply (sub1 `compose` sub0) t') [] (e, lambda_t) _ -> do - uncatchableErr $ "Undeclared function: " ++ printTree name + insertSig (coerce name) (Just lambda_t) + return (T.Bind (coerce name, lambda_t) [] (e, lambda_t)) checkData :: (MonadState Env m, Monad m, MonadError Error m) => Data -> m () checkData err@(Data typ injs) = do @@ -178,6 +175,7 @@ inferExp :: Exp -> Infer (Subst, T.ExpT' Type) inferExp e = do (s, (e', t)) <- algoW e let subbed = apply s t + modify (\st -> st{undecidedSigs = apply s st.undecidedSigs}) return (s, (e', subbed)) class CollectTVars a where @@ -213,7 +211,7 @@ algoW = \case quote $ printTree t' ) let comp = sub2 `compose` sub1 `compose` sub0 - return (comp, (e', t)) + return (comp, apply comp (e', t)) -- \| ------------------ -- \| Γ ⊢ i : Int, ∅ @@ -232,9 +230,11 @@ algoW = \case sig <- gets sigs cb <- gets currentBind case M.lookup (coerce i) sig of - Just t -> do - insertBindUsage cb (coerce i) - return (nullSubst, (T.EVar $ coerce i, unlevel t)) + Just (Just t) -> return (nullSubst, (T.EVar $ coerce i, t)) + Just Nothing -> do + fr <- fresh + modify (\st -> st{toDecide = S.insert cb st.toDecide, undecidedSigs = M.insert (coerce $ concat [[prefix], i, [delim], coerce cb]) fr st.undecidedSigs}) + return (nullSubst, (T.EVar $ coerce i, fr)) Nothing -> uncatchableErr $ "Unbound variable: " @@ -259,7 +259,7 @@ algoW = \case (s1, (e', t')) <- exprErr (algoW e) err let varType = apply s1 fr let newArr = TFun varType t' - return (s1, (T.EAbs (coerce name) (e', t'), newArr)) + return (s1, apply s1 (T.EAbs (coerce name) (e', t'), newArr)) -- \| Γ ⊢ e₀ : τ₀, S₀ S₀Γ ⊢ e₁ : τ₁, S₁ -- \| s₂ = mgu(s₁τ₀, Int) s₃ = mgu(s₂τ₁, Int) @@ -273,7 +273,10 @@ algoW = \case s3 <- exprErr (unify (apply s2 t0) int) err s4 <- exprErr (unify (apply s3 t1) int) err let comp = s4 `compose` s3 `compose` s2 `compose` s1 - return (comp, (T.EAdd (e0', t0) (e1', t1), int)) + return + ( comp + , apply comp (T.EAdd (e0', t0) (e1', t1), int) + ) -- \| Γ ⊢ e₀ : τ₀, S₀ S₀Γ ⊢ e₁ : τ₁, S1 -- \| τ' = newvar S₂ = mgu(S₁τ₀, τ₁ → τ') @@ -284,11 +287,12 @@ algoW = \case fr <- fresh (s0, (e0', t0)) <- algoW e0 applySt s0 $ do + modify (\st -> st{sigs = apply s0 st.sigs}) (s1, (e1', t1)) <- algoW e1 s2 <- exprErr (unify (apply s1 t0) (TFun t1 fr)) err let t = apply s2 fr - comp <- foldM composey nullSubst [s2, s1, s0] - return (comp, (T.EApp (e0', t0) (e1', t1), t)) + let comp = s2 `compose` s1 `compose` s0 + return (comp, apply comp (T.EApp (e0', t0) (e1', t1), t)) -- \| Γ ⊢ e₀ : τ, S₀ S₀Γ, x : S̅₀Γ̅(τ) ⊢ e₁ : τ', S₁ -- \| ---------------------------------------------- @@ -296,23 +300,20 @@ algoW = \case -- The bar over S₀ and Γ means "generalize" - (ELet (Bind name args e) e1) -> do - (s1, (e, t0)) <- algoW (makeLambda e (coerce args)) + err@(ELet b@(Bind name args e) e1) -> do + (s1, (_, t0)) <- algoW (makeLambda e (coerce args)) + bind' <- exprErr (checkBind b) err env <- asks vars let t' = generalize (apply s1 env) t0 withBinding (coerce name) t' $ do (s2, (e1', t2)) <- algoW e1 let comp = s2 `compose` s1 - return - ( comp - , (T.ELet (T.Bind (coerce name, t0) [] (e, t0)) (e1', t2), t2) - ) + return (comp, apply comp (T.ELet bind' (e1', t2), t2)) ECase caseExpr injs -> do (sub, (e', t)) <- algoW caseExpr (subst, injs, ret_t) <- checkCase t injs let comp = subst `compose` sub - -- return (comp, apply comp (T.ECase (e', t) injs, ret_t)) - return (comp, (T.ECase (e', t) injs, ret_t)) + return (comp, apply comp (T.ECase (e', t) injs, ret_t)) EAppInf{} -> error "desugar phase failed" checkCase :: Type -> [Branch] -> Infer (Subst, [T.Branch' Type], Type) @@ -421,17 +422,15 @@ unify t0 t1 = s1 <- unify a c s2 <- unify (apply s1 b) (apply s1 d) return $ s2 `compose` s1 - (TVar (MkTVar a), t@(TData _ _)) -> - return $ coerce $ M.singleton (coerce a) t - (t@(TData _ _), TVar (MkTVar b)) -> - return $ coerce $ M.singleton (coerce b) t + (TVar (MkTVar a), t@(TData _ _)) -> return $ M.singleton (coerce a) t + (t@(TData _ _), TVar (MkTVar b)) -> return $ M.singleton (coerce b) t (TVar (MkTVar a), t) -> occurs (coerce a) t (t, TVar (MkTVar b)) -> occurs (coerce b) t (TAll _ t, b) -> unify t b (a, TAll _ t) -> unify a t (TLit a, TLit b) -> if a == b - then return nullSubst + then return M.empty else catchableErr $ Aux.do "Can not unify" @@ -453,7 +452,7 @@ unify t0 t1 = quote $ printTree t' (TEVar a, TEVar b) -> if a == b - then return nullSubst + then return M.empty else catchableErr $ Aux.do "Can not unify" @@ -473,7 +472,7 @@ I.E. { a = a -> b } is an unsolvable constraint since there is no substitution where these are equal -} occurs :: T.Ident -> Type -> Infer Subst -occurs i t@(TVar _) = return (coerce $ M.singleton i t) +occurs i t@(TVar _) = return (M.singleton i t) occurs i t = if S.member i (free t) then @@ -484,7 +483,7 @@ occurs i t = "with" quote $ printTree t ) - else return $ coerce $ M.singleton i t + else return $ M.singleton i t {- | Generalize a type over all free variables in the substitution set Used for let bindings to allow expression that do not type check in @@ -510,7 +509,7 @@ inst :: Type -> Infer Type inst = \case TAll (MkTVar bound) t -> do fr <- fresh - let s = coerce $ M.singleton (coerce bound) fr + let s = M.singleton (coerce bound) fr apply s <$> inst t TFun t1 t2 -> TFun <$> inst t1 <*> inst t2 rest -> return rest @@ -546,7 +545,6 @@ skolemize t = t -- | A class for substitutions class SubstType t where -- | Apply a substitution to t - -- apply :: MonadError e m => Subst -> t -> m t apply :: Subst -> t -> t class FreeVars t where @@ -567,18 +565,19 @@ instance FreeVars a => FreeVars [a] where free = let f acc x = acc `S.union` free x in foldl' f S.empty instance SubstType Type where - apply sub@(Subst s) t = do + apply :: Subst -> Type -> Type + apply sub t = do case t of TLit a -> TLit a - TVar (MkTVar a) -> case M.lookup (coerce a) s of + TVar (MkTVar a) -> case M.lookup (coerce a) sub of Nothing -> TVar (MkTVar $ coerce a) Just t -> t - TAll (MkTVar i) t -> case M.lookup (coerce i) s of + TAll (MkTVar i) t -> case M.lookup (coerce i) sub of Nothing -> TAll (MkTVar i) (apply sub t) Just _ -> apply sub t TFun a b -> TFun (apply sub a) (apply sub b) TData name a -> TData name (apply sub a) - TEVar (MkTEVar a) -> case M.lookup (coerce a) s of + TEVar (MkTEVar a) -> case M.lookup (coerce a) sub of Nothing -> TEVar (MkTEVar a) Just t -> t @@ -587,12 +586,11 @@ instance FreeVars (Map T.Ident Type) where free = free . M.elems instance SubstType (Map T.Ident Type) where - apply s = M.map (apply s) + apply :: Subst -> Map T.Ident Type -> Map T.Ident Type + apply = M.map . apply -instance SubstType Subst where - apply s (Subst m2) = Subst $ apply s m2 - --- Subst $ M.map (apply s) m2 +instance SubstType (Map T.Ident (Maybe Type)) where + apply s = M.map (fmap $ apply s) instance SubstType (T.ExpT' Type) where apply s (e, t) = (apply s e, apply s t) @@ -613,8 +611,7 @@ instance SubstType (T.Exp' Type) where instance SubstType (T.Def' Type) where apply s = \case - T.DBind (T.Bind name args e) -> - T.DBind $ T.Bind (apply s name) (apply s args) (apply s e) + T.DBind (T.Bind name args e) -> T.DBind $ T.Bind (apply s name) (apply s args) (apply s e) d -> d instance SubstType (T.Branch' Type) where @@ -639,49 +636,16 @@ instance SubstType (T.Id' Type) where -- | Represents the empty substition set nullSubst :: Subst -nullSubst = Subst mempty +nullSubst = mempty -- | Compose two substitution sets compose :: Subst -> Subst -> Subst -compose m1 m2 = Subst $ M.map (apply $ coerce m1) (coerce m2) `M.union` coerce m1 - --- Order matters. -{- -sub0 = Subst $ (M.singleton "a" (arr d e)) - `M.union` (M.singleton "b" (arr d f)) - `M.union` (M.singleton "c" (arr f e)) -sub1 = Subst $ (M.singleton "a" (arr g bool)) - `M.union` (M.singleton "b" (arr g bool)) - `M.union` (M.singleton "c" (arr bool bool)) - `M.union` (M.singleton "h" bool) - `M.union` (M.singleton "i" bool) -sub0 `composey` sub1 != sub1 `composey` sub0 - -} -composey :: Subst -> Subst -> Infer Subst -composey s0@(Subst m1) s1@(Subst m2) = do - let both = M.keys $ M.intersection m1 m2 - case both of - [] -> return $ s0 `compose` s1 - xs -> do - let m2' = apply s0 m2 - sub <- loop xs m1 m2' - return $ sub `compose` Subst m2 - where - loop [] _ _ = return nullSubst - loop (x : xs) m1 m2 = do - let k1 = m1 M.! x - let k2 = m2 M.! x - sub <- unify k1 k2 - subs <- loop xs m1 m2 - return $ sub `compose` subs +compose m1 m2 = M.map (apply m1) m2 `M.union` m1 -- | Compose a list of substitution sets into one composeAll :: [Subst] -> Subst composeAll = foldl' compose nullSubst -unionSubsts :: [Subst] -> Subst -unionSubsts = Subst . foldl' M.union M.empty . map coerce - {- | Convert a function with arguments to its pointfree version > makeLambda (add x y = x + y) = add = \x. \y. x + y -} @@ -707,21 +671,12 @@ withPattern p ma = case p of T.PEnum _ -> ma -- | Insert a function signature into the environment -insertSig :: T.Ident -> Level Type -> Infer () +insertSig :: T.Ident -> Maybe Type -> Infer () insertSig i t = modify (\st -> st{sigs = M.insert i t (sigs st)}) insertBind :: T.Ident -> Infer () insertBind i = modify (\st -> st{declaredBinds = S.insert i st.declaredBinds}) -insertBindSubst :: T.Ident -> Subst -> Infer () -insertBindSubst name sub = modify (\st -> st{bindSubs = M.insert name sub st.bindSubs}) - -setCurrentBind :: T.Ident -> Infer () -setCurrentBind n = modify (\st -> st{currentBind = n, bindUsages = M.insertWith (++) n [] st.bindUsages}) - -insertBindUsage :: T.Ident -> T.Ident -> Infer () -insertBindUsage cur use = modify (\st -> st{bindUsages = M.insertWith (++) cur [use] st.bindUsages}) - -- | Insert a constructor into the start with its type insertInj :: (Monad m, MonadState Env m) => T.Ident -> Type -> m () insertInj i t = @@ -736,6 +691,24 @@ with an equivalent name has been declared already existInj :: (Monad m, MonadState Env m) => T.Ident -> m (Maybe Type) existInj n = gets (M.lookup n . injections) +setCurrentBind :: T.Ident -> Infer () +setCurrentBind i = modify (\st -> st{currentBind = i}) + +solveUndecidable :: Infer Subst +solveUndecidable = do + sigs <- gets sigs + undecided <- gets undecidedSigs + ys <- + maybeToRightM + (Error "SIGNATURE MISSING" False) + ( mapM (tupSequence . first (join . flip M.lookup sigs . getOriginal)) $ + M.toList undecided + ) + composeAll <$> mapM (uncurry unify) ys + +getOriginal :: T.Ident -> T.Ident +getOriginal (T.Ident i) = coerce $ takeWhile (/= delim) $ drop 1 i + delim :: Char delim = '_' prefix :: Char @@ -812,7 +785,7 @@ dataErr ma d = ) initCtx = Ctx mempty -initEnv = Env 0 'a' mempty mempty mempty mempty "" mempty mempty +initEnv = Env 0 'a' mempty mempty mempty "" mempty mempty mempty run :: Infer a -> Either Error a run = run' initEnv initCtx @@ -831,28 +804,19 @@ newtype Ctx = Ctx {vars :: Map T.Ident Type} data Env = Env { count :: Int , nextChar :: Char - , sigs :: Map T.Ident (Level Type) + , sigs :: Map T.Ident (Maybe Type) , takenTypeVars :: Set T.Ident , injections :: Map T.Ident Type - , declaredBinds :: Set T.Ident , currentBind :: T.Ident - , bindSubs :: Map T.Ident Subst - , bindUsages :: Map T.Ident [T.Ident] + , undecidedSigs :: Map T.Ident Type + , toDecide :: Set T.Ident + , declaredBinds :: Set T.Ident } deriving (Show) -data Level a = Instantiated {unlevel :: a} | Generalized {unlevel :: a} - deriving (Show) - data Error = Error {msg :: String, catchable :: Bool} deriving (Show) - -newtype Subst = Subst (Map T.Ident Type) - -instance Show Subst where - show (Subst s) = "[ " ++ intercalate " | " xs ++ " ]" - where - xs = map (\(a, b) -> printTree a ++ " = " ++ printTree b) $ M.toList s +type Subst = Map T.Ident Type newtype Infer a = Infer {runInfer :: StateT Env (ReaderT Ctx (ExceptT Error Identity)) a} deriving (Functor, Applicative, Monad, MonadReader Ctx, MonadError Error, MonadState Env) @@ -868,3 +832,4 @@ quote s = "'" ++ s ++ "'" ctrace :: (Monad m, Show a) => String -> a -> m () ctrace str a = trace (str ++ ": " ++ show a) pure () + From ec8d554af1e7d8cf5f7527145dba925b6f8db663 Mon Sep 17 00:00:00 2001 From: sebastian Date: Sat, 1 Apr 2023 18:45:08 +0200 Subject: [PATCH 268/372] Disabled shadowing in pattern match with nice error message, added aux functions --- src/Auxiliary.hs | 7 +++++++ src/Renamer/Renamer.hs | 23 ++++++++++++++++++----- 2 files changed, 25 insertions(+), 5 deletions(-) diff --git a/src/Auxiliary.hs b/src/Auxiliary.hs index 0c9f012..b4972a7 100644 --- a/src/Auxiliary.hs +++ b/src/Auxiliary.hs @@ -46,3 +46,10 @@ char = TLit "Char" tupSequence :: Monad m => (m a, b) -> m (a, b) tupSequence (ma, b) = (,b) <$> ma + +fst_ :: (a, b, c) -> a +snd_ :: (a, b, c) -> b +trd_ :: (a, b, c) -> c +snd_ (_, a, _) = a +fst_ (a, _, _) = a +trd_ (_, _, a) = a diff --git a/src/Renamer/Renamer.hs b/src/Renamer/Renamer.hs index 48ec228..d30412f 100644 --- a/src/Renamer/Renamer.hs +++ b/src/Renamer/Renamer.hs @@ -5,23 +5,31 @@ module Renamer.Renamer (rename) where import Auxiliary (mapAccumM) import Control.Applicative (Applicative (liftA2)) +import Control.Monad (when) import Control.Monad.Except ( ExceptT, - MonadError (throwError), + MonadError (catchError, throwError), runExceptT, ) import Control.Monad.State ( MonadState, State, + StateT, evalState, + evalStateT, + get, gets, + lift, mapAndUnzipM, modify, + put, ) import Data.Function (on) import Data.Map (Map) import Data.Map qualified as Map import Data.Maybe (fromMaybe) +import Data.Set (Set) +import Data.Set qualified as Set import Data.Tuple.Extra (dupe, second) import Grammar.Abs import Grammar.ErrM (Err) @@ -134,17 +142,22 @@ renameBranches ns xs = do if null new_names then return (mempty, xs') else return (head new_names, xs') renameBranch :: Names -> Branch -> Rn (Names, Branch) -renameBranch ns (Branch patt e) = do - (new_names, patt') <- renamePattern ns patt +renameBranch ns b@(Branch patt e) = do + (new_names, patt') <- catchError (evalStateT (renamePattern ns patt) mempty) (\x -> throwError $ x ++ " in pattern '" ++ printTree b ++ "'") (new_names', e') <- renameExp new_names e return (new_names', Branch patt' e') -renamePattern :: Names -> Pattern -> Rn (Names, Pattern) +renamePattern :: Names -> Pattern -> StateT (Set LIdent) Rn (Names, Pattern) renamePattern ns p = case p of PInj cs ps -> do (ns_new, ps') <- mapAccumM renamePattern ns ps return (ns_new, PInj cs ps') - PVar name -> second PVar <$> newNameL ns name + PVar name -> do + vs <- get + when (name `Set.member` vs) (throwError $ "Conflicting definitions of '" ++ printTree name ++ "'") + put (Set.insert name vs) + nn <- lift $ newNameL ns name + return $ second PVar nn _ -> return (ns, p) renameTVars :: Type -> Rn Type From 6c180554ecb9950a6c5409b01c6adcb980ab91e5 Mon Sep 17 00:00:00 2001 From: sebastian Date: Sun, 2 Apr 2023 00:04:33 +0200 Subject: [PATCH 269/372] Reworked order of inference, added prettifier for tvars etc etc. --- Grammar.cf | 1 - src/TypeChecker/TypeCheckerHm.hs | 363 +++++++++++++++++++------------ src/TypeChecker/TypeCheckerIr.hs | 16 +- test_program.crf | 41 ++-- 4 files changed, 245 insertions(+), 176 deletions(-) diff --git a/Grammar.cf b/Grammar.cf index 9ca0db6..55763f4 100644 --- a/Grammar.cf +++ b/Grammar.cf @@ -48,7 +48,6 @@ EVar. Exp3 ::= LIdent; EInj. Exp3 ::= UIdent; ELit. Exp3 ::= Lit; EApp. Exp2 ::= Exp2 Exp3; -EAppInf. Exp2 ::= Exp3 "`" Exp3 "`"; EAdd. Exp1 ::= Exp1 "+" Exp2; ELet. Exp ::= "let" Bind "in" Exp; EAbs. Exp ::= "\\" LIdent "." Exp; diff --git a/src/TypeChecker/TypeCheckerHm.hs b/src/TypeChecker/TypeCheckerHm.hs index 710343f..7b88fe5 100644 --- a/src/TypeChecker/TypeCheckerHm.hs +++ b/src/TypeChecker/TypeCheckerHm.hs @@ -6,16 +6,15 @@ -- | A module for type checking and inference using algorithm W, Hindley-Milner module TypeChecker.TypeCheckerHm where -import Auxiliary (int, litType, maybeToRightM, tupSequence, unzip4) +import Auxiliary (int, litType, maybeToRightM, unzip4) import Auxiliary qualified as Aux import Control.Monad.Except import Control.Monad.Identity (Identity, runIdentity) import Control.Monad.Reader import Control.Monad.State -import Data.Bifunctor (first) import Data.Coerce (coerce) import Data.Function (on) -import Data.List (foldl') +import Data.List (foldl', nub, sortOn) import Data.List.Extra (unsnoc) import Data.Map (Map) import Data.Map qualified as M @@ -40,18 +39,63 @@ typecheck = onLeft msg . run . checkPrg checkPrg :: Program -> Infer (T.Program' Type) checkPrg (Program bs) = do preRun bs + sgs <- gets sigs + bs <- map snd . sortOn fst <$> bindCount bs bs <- checkDef bs - sub0 <- solveUndecidable - bs <- mapM (mono sub0) bs - return $ T.Program bs + return . prettify sgs . T.Program $ bs -mono :: Subst -> T.Def' Type -> Infer (T.Def' Type) -mono s bind@(T.DBind (T.Bind (name, t) args e)) = do - b <- gets (S.member name . toDecide) - if b - then return $ T.DBind $ T.Bind (name, apply s t) (apply s args) (apply s e) - else return bind -mono _ (T.DData d) = return $ T.DData d +-- | Send the map of user declared signatures to not rename stuff the user defined +prettify :: Map T.Ident (Maybe Type) -> T.Program' Type -> T.Program' Type +prettify s (T.Program defs) = T.Program $ map (go s) defs + where + go :: Map T.Ident (Maybe Type) -> T.Def' Type -> T.Def' Type + go _ (T.DData d) = T.DData d + go m b@(T.DBind (T.Bind (name, t) args e)) + | Just (Just _) <- M.lookup name m = b + | otherwise = + let fvs = nub $ freeOrdered t + m = M.fromList $ zip fvs letters + in T.DBind $ T.Bind (name, replace m t) args e + +replace :: Map T.Ident T.Ident -> Type -> Type +replace m (TVar (MkTVar (LIdent a))) = + TVar $ MkTVar $ LIdent $ coerce $ m M.! coerce a +replace m (TFun t1 t2) = (TFun `on` replace m) t1 t2 +replace m (TData name ts) = TData name (map (replace m) ts) +replace m (TAll (MkTVar forall_) t) = + TAll (MkTVar $ coerce $ m M.! coerce forall_) (replace m t) +replace _ t = t + +bindCount :: [Def] -> Infer [(Int, Def)] +bindCount [] = return [] +bindCount (x : xs) = do + (o, d) <- go x + b <- bindCount xs + return $ (o, d) : b + where + go :: Def -> Infer (Int, Def) + go b@(DBind (Bind _ _ e)) = do + db <- gets declaredBinds + let n = runIdentity $ evalStateT (countBinds db e) mempty + return (n, b) + go (DSig sig) = pure (0, DSig sig) + go (DData data_) = pure (-1, DData data_) + + countBinds :: Set T.Ident -> Exp -> StateT (Set T.Ident) Identity Int + countBinds declared = \case + EVar i -> do + found <- get + if coerce i `S.member` declared && not (coerce i `S.member` found) + then put (S.insert (coerce i) found) >> return 1 + else return 0 + ELet _ e -> countBinds declared e + EApp e1 e2 -> (+) <$> countBinds declared e1 <*> countBinds declared e2 + EAdd e1 e2 -> (+) <$> countBinds declared e1 <*> countBinds declared e2 + EAbs _ e -> countBinds declared e + ECase e1 brnchs -> do + let f (Branch _ e2) = countBinds declared e2 + (+) . sum <$> mapM f brnchs <*> countBinds declared e1 + _ -> return 0 preRun :: [Def] -> Infer () preRun [] = return () @@ -94,16 +138,43 @@ checkDef (x : xs) = case x of coerceData (Data t injs) = T.Data t $ map (\(Inj name typ) -> T.Inj (coerce name) typ) injs +freeOrdered :: Type -> [T.Ident] +freeOrdered (TVar (MkTVar a)) = return (coerce a) +freeOrdered (TAll (MkTVar bound) t) = return (coerce bound) ++ freeOrdered t +freeOrdered (TFun a b) = freeOrdered a ++ freeOrdered b +freeOrdered (TData _ a) = concatMap freeOrdered a +freeOrdered _ = mempty + checkBind :: Bind -> Infer (T.Bind' Type) -checkBind bind@(Bind name args e) = do - setCurrentBind $ coerce name +checkBind (Bind name args e) = do let lambda = makeLambda e (reverse (coerce args)) - (sub0, (e, lambda_t)) <- inferExp lambda + (e, lambda_t) <- inferExp lambda s <- gets sigs case M.lookup (coerce name) s of Just (Just t') -> do - sub1 <- bindErr (unify lambda_t (skolemize t')) bind - return $ T.Bind (coerce name, apply (sub1 `compose` sub0) t') [] (e, lambda_t) + let fvs0 = nub $ freeOrdered t' + let m0 = M.fromList $ zip fvs0 letters + let fvs1 = nub $ freeOrdered lambda_t + let m1 = M.fromList $ zip fvs1 letters + let t0 = replace m0 t' + let t1 = replace m1 lambda_t + ctrace "lambda" lambda_t + ctrace "t'" t' + ctrace "t0" t0 + ctrace "t1" t1 + unless + (t1 <<= t0) + ( throwError $ + Error + ( Aux.do + "Inferred type" + quote $ printTree t1 + "doesn't match given type" + quote $ printTree $ mkForall t0 + ) + False + ) + return $ T.Bind (coerce name, t') [] (e, lambda_t) _ -> do insertSig (coerce name) (Just lambda_t) return (T.Bind (coerce name, lambda_t) [] (e, lambda_t)) @@ -171,12 +242,11 @@ returnType :: Type -> Type returnType (TFun _ t2) = returnType t2 returnType a = a -inferExp :: Exp -> Infer (Subst, T.ExpT' Type) +inferExp :: Exp -> Infer (T.ExpT' Type) inferExp e = do (s, (e', t)) <- algoW e let subbed = apply s t - modify (\st -> st{undecidedSigs = apply s st.undecidedSigs}) - return (s, (e', subbed)) + return (e', subbed) class CollectTVars a where collectTVars :: a -> Set T.Ident @@ -203,7 +273,7 @@ algoW = \case sub1 <- unify t t' sub2 <- unify t' t unless - (apply sub1 t == t' && apply sub2 t' == t) + (apply sub1 t <<= apply sub2 t') ( uncatchableErr $ Aux.do "Annotated type" quote $ printTree t @@ -211,7 +281,7 @@ algoW = \case quote $ printTree t' ) let comp = sub2 `compose` sub1 `compose` sub0 - return (comp, apply comp (e', t)) + return (comp, (apply comp e', skolemize t)) -- \| ------------------ -- \| Γ ⊢ i : Int, ∅ @@ -228,12 +298,10 @@ algoW = \case return (nullSubst, (T.EVar $ coerce i, x)) Nothing -> do sig <- gets sigs - cb <- gets currentBind case M.lookup (coerce i) sig of Just (Just t) -> return (nullSubst, (T.EVar $ coerce i, t)) Just Nothing -> do fr <- fresh - modify (\st -> st{toDecide = S.insert cb st.toDecide, undecidedSigs = M.insert (coerce $ concat [[prefix], i, [delim], coerce cb]) fr st.undecidedSigs}) return (nullSubst, (T.EVar $ coerce i, fr)) Nothing -> uncatchableErr $ @@ -283,13 +351,12 @@ algoW = \case -- \| -------------------------------------- -- \| Γ ⊢ e₀ e₁ : S₂τ', S₂S₁S₀ - err@(EApp e0 e1) -> do + EApp e0 e1 -> do fr <- fresh (s0, (e0', t0)) <- algoW e0 applySt s0 $ do - modify (\st -> st{sigs = apply s0 st.sigs}) (s1, (e1', t1)) <- algoW e1 - s2 <- exprErr (unify (apply s1 t0) (TFun t1 fr)) err + s2 <- unify (apply s1 t0) (TFun t1 fr) let t = apply s2 fr let comp = s2 `compose` s1 `compose` s0 return (comp, apply comp (T.EApp (e0', t0) (e1', t1), t)) @@ -300,15 +367,21 @@ algoW = \case -- The bar over S₀ and Γ means "generalize" - err@(ELet b@(Bind name args e) e1) -> do - (s1, (_, t0)) <- algoW (makeLambda e (coerce args)) - bind' <- exprErr (checkBind b) err - env <- asks vars - let t' = generalize (apply s1 env) t0 - withBinding (coerce name) t' $ do - (s2, (e1', t2)) <- algoW e1 - let comp = s2 `compose` s1 - return (comp, apply comp (T.ELet bind' (e1', t2), t2)) + ELet (Bind name args e) e1 -> do + fr <- fresh + withBinding (coerce name) fr $ do + (s1, e@(_, t0)) <- algoW (makeLambda e (coerce args)) + env <- asks vars + let t' = generalize (apply s1 env) t0 + withBinding (coerce name) t' $ do + (s2, (e1', t2)) <- algoW e1 + let comp = s2 `compose` s1 + return + ( comp + , apply + comp + (T.ELet (T.Bind (coerce name, t0) [] e) (e1', t2), t2) + ) ECase caseExpr injs -> do (sub, (e', t)) <- algoW caseExpr (subst, injs, ret_t) <- checkCase t injs @@ -339,9 +412,9 @@ checkCase expT brnchs = do return (comp, apply comp injs, apply comp returns_type) inferBranch :: Branch -> Infer (Subst, Type, T.Branch' Type, Type) -inferBranch (Branch pat expr) = do +inferBranch err@(Branch pat expr) = do newPat@(pat, branchT) <- inferPattern pat - (sub, newExp@(_, exprT)) <- withPattern pat (algoW expr) + (sub, newExp@(_, exprT)) <- catchError (withPattern pat (algoW expr)) (\x -> throwError Error{msg = x.msg <> " in pattern '" <> printTree err <> "'", catchable = False}) return ( sub , apply sub branchT @@ -417,73 +490,78 @@ inferPattern = \case -- | Unify two types producing a new substitution unify :: Type -> Type -> Infer Subst unify t0 t1 = - case (t0, t1) of - (TFun a b, TFun c d) -> do - s1 <- unify a c - s2 <- unify (apply s1 b) (apply s1 d) - return $ s2 `compose` s1 - (TVar (MkTVar a), t@(TData _ _)) -> return $ M.singleton (coerce a) t - (t@(TData _ _), TVar (MkTVar b)) -> return $ M.singleton (coerce b) t - (TVar (MkTVar a), t) -> occurs (coerce a) t - (t, TVar (MkTVar b)) -> occurs (coerce b) t - (TAll _ t, b) -> unify t b - (a, TAll _ t) -> unify a t - (TLit a, TLit b) -> - if a == b - then return M.empty - else catchableErr $ + let fvs = S.toList $ free t0 `S.union` free t1 + m = M.fromList $ zip fvs letters + in case (t0, t1) of + (TFun a b, TFun c d) -> do + s1 <- unify a c + s2 <- unify (apply s1 b) (apply s1 d) + return $ s2 `compose` s1 + (TVar (MkTVar a), t@(TData _ _)) -> return $ M.singleton (coerce a) t + (t@(TData _ _), TVar (MkTVar b)) -> return $ M.singleton (coerce b) t + (TVar (MkTVar a), t) -> occurs (coerce a) t + (t, TVar (MkTVar b)) -> occurs (coerce b) t + (TAll _ t, b) -> unify t b + (a, TAll _ t) -> unify a t + (TLit a, TLit b) -> + if a == b + then return M.empty + else catchableErr $ + Aux.do + "Can not unify" + quote $ printTree (TLit a) + "with" + quote $ printTree (TLit b) + (TData name t, TData name' t') -> + if name == name' && length t == length t' + then do + xs <- zipWithM unify t t' + return $ foldr compose nullSubst xs + else catchableErr $ + Aux.do + "Type constructor:" + printTree name + quote $ printTree $ map (replace m) t + "does not match with:" + printTree name' + quote $ printTree $ map (replace m) t' + (TEVar a, TEVar b) -> + if a == b + then return M.empty + else catchableErr $ + Aux.do + "Can not unify" + quote $ printTree (TEVar a) + "with" + quote $ printTree (TEVar b) + (a, b) -> do + catchableErr $ Aux.do "Can not unify" - quote $ printTree (TLit a) + quote $ printTree $ replace m a "with" - quote $ printTree (TLit b) - (TData name t, TData name' t') -> - if name == name' && length t == length t' - then do - xs <- zipWithM unify t t' - return $ foldr compose nullSubst xs - else catchableErr $ - Aux.do - "Type constructor:" - printTree name - quote $ printTree t - "does not match with:" - printTree name' - quote $ printTree t' - (TEVar a, TEVar b) -> - if a == b - then return M.empty - else catchableErr $ - Aux.do - "Can not unify" - quote $ printTree (TEVar a) - "with" - quote $ printTree (TEVar b) - (a, b) -> do - catchableErr $ - Aux.do - "Can not unify" - quote $ printTree a - "with" - quote $ printTree b + quote $ printTree $ replace m b {- | Check if a type is contained in another type. I.E. { a = a -> b } is an unsolvable constraint since there is no substitution where these are equal -} occurs :: T.Ident -> Type -> Infer Subst +occurs i t@(TEVar _) = return (M.singleton i t) occurs i t@(TVar _) = return (M.singleton i t) occurs i t = - if S.member i (free t) - then - catchableErr - ( Aux.do - "Occurs check failed, can't unify" - quote $ printTree (TVar $ MkTVar (coerce i)) - "with" - quote $ printTree t - ) - else return $ M.singleton i t + let fvs = S.toList $ free t + m = M.fromList $ zip fvs letters + in if S.member i (free t) + then + catchableErr + ( Aux.do + "Occurs check failed, can't unify" + quote $ printTree $ replace m (TVar $ MkTVar (coerce i)) + "with" + quote $ printTree $ replace m t + ) + else return $ M.singleton i t {- | Generalize a type over all free variables in the substitution set Used for let bindings to allow expression that do not type check in @@ -517,29 +595,48 @@ inst = \case -- | Generate a new fresh variable fresh :: Infer Type fresh = do - c <- gets nextChar n <- gets count - taken <- gets takenTypeVars - if c == 'z' - then do - modify (\st -> st{count = succ (count st), nextChar = 'a'}) - else modify (\st -> st{nextChar = next (nextChar st)}) - if coerce [c] `S.member` taken - then do - fresh - else - if n == 0 - then return . TVar . MkTVar $ LIdent [c] - else return . TVar . MkTVar . LIdent $ c : show n + modify (\st -> st{count = succ (count st)}) + return $ TVar $ MkTVar $ LIdent $ show n + +-- Is the left a subtype of the right +(<<=) :: Type -> Type -> Bool +(<<=) (TVar _) _ = True +(<<=) (TAll _ t1) (TAll _ t2) = t1 <<= t2 +(<<=) (TFun a b) (TFun c d) = a <<= c && b <<= d +(<<=) (TData n1 ts1) (TData n2 ts2) = + n1 == n2 + && length ts1 == length ts2 + && and (zipWith (<<=) ts1 ts2) +(<<=) t0 t@(TAll _ _) = go t0 t where - next :: Char -> Char - next 'z' = 'a' - next a = succ a + go t0 t@(TAll _ t1) = S.toList (free t0) == foralls t && go' t0 t1 + go _ _ = undefined + + go' (TEVar (MkTEVar a)) (TVar (MkTVar b)) = a == b + go' (TEVar (MkTEVar a)) (TEVar (MkTEVar b)) = a == b + go' (TFun a b) (TFun c d) = a `go'` c && b `go'` d + go' _ _ = False +(<<=) a b = a == b + +foralls :: Type -> [T.Ident] +foralls (TAll (MkTVar a) t) = coerce a : foralls t +foralls _ = [] + +mkForall :: Type -> Type +mkForall t = case map (TAll . MkTVar . coerce) $ S.toList $ free t of + [] -> t + (x : xs) -> + let f acc [] = acc + f acc (x : xs) = f (x acc) xs + (y : ys) = reverse $ x : xs + in f (y t) ys skolemize :: Type -> Type skolemize (TVar (MkTVar a)) = TEVar $ MkTEVar a skolemize (TAll x t) = TAll x (skolemize t) skolemize (TFun t1 t2) = (TFun `on` skolemize) t1 t2 +skolemize (TData n ts) = TData n (map skolemize ts) skolemize t = t -- | A class for substitutions @@ -551,6 +648,9 @@ class FreeVars t where -- | Get all free variables from t free :: t -> Set T.Ident +instance FreeVars (T.Bind' Type) where + free (T.Bind (_, t) _ _) = free t + instance FreeVars Type where free :: Type -> Set T.Ident free (TVar (MkTVar a)) = S.singleton (coerce a) @@ -568,7 +668,7 @@ instance SubstType Type where apply :: Subst -> Type -> Type apply sub t = do case t of - TLit a -> TLit a + TLit _ -> t TVar (MkTVar a) -> case M.lookup (coerce a) sub of Nothing -> TVar (MkTVar $ coerce a) Just t -> t @@ -577,9 +677,7 @@ instance SubstType Type where Just _ -> apply sub t TFun a b -> TFun (apply sub a) (apply sub b) TData name a -> TData name (apply sub a) - TEVar (MkTEVar a) -> case M.lookup (coerce a) sub of - Nothing -> TEVar (MkTEVar a) - Just t -> t + TEVar (MkTEVar _) -> t instance FreeVars (Map T.Ident Type) where free :: Map T.Ident Type -> Set T.Ident @@ -611,7 +709,8 @@ instance SubstType (T.Exp' Type) where instance SubstType (T.Def' Type) where apply s = \case - T.DBind (T.Bind name args e) -> T.DBind $ T.Bind (apply s name) (apply s args) (apply s e) + T.DBind (T.Bind name args e) -> + T.DBind $ T.Bind (apply s name) (apply s args) (apply s e) d -> d instance SubstType (T.Branch' Type) where @@ -691,29 +790,6 @@ with an equivalent name has been declared already existInj :: (Monad m, MonadState Env m) => T.Ident -> m (Maybe Type) existInj n = gets (M.lookup n . injections) -setCurrentBind :: T.Ident -> Infer () -setCurrentBind i = modify (\st -> st{currentBind = i}) - -solveUndecidable :: Infer Subst -solveUndecidable = do - sigs <- gets sigs - undecided <- gets undecidedSigs - ys <- - maybeToRightM - (Error "SIGNATURE MISSING" False) - ( mapM (tupSequence . first (join . flip M.lookup sigs . getOriginal)) $ - M.toList undecided - ) - composeAll <$> mapM (uncurry unify) ys - -getOriginal :: T.Ident -> T.Ident -getOriginal (T.Ident i) = coerce $ takeWhile (/= delim) $ drop 1 i - -delim :: Char -delim = '_' -prefix :: Char -prefix = '$' - flattenType :: Type -> [Type] flattenType (TFun a b) = flattenType a <> flattenType b flattenType a = [a] @@ -785,7 +861,7 @@ dataErr ma d = ) initCtx = Ctx mempty -initEnv = Env 0 'a' mempty mempty mempty "" mempty mempty mempty +initEnv = Env 0 'a' mempty mempty mempty mempty run :: Infer a -> Either Error a run = run' initEnv initCtx @@ -807,9 +883,6 @@ data Env = Env , sigs :: Map T.Ident (Maybe Type) , takenTypeVars :: Set T.Ident , injections :: Map T.Ident Type - , currentBind :: T.Ident - , undecidedSigs :: Map T.Ident Type - , toDecide :: Set T.Ident , declaredBinds :: Set T.Ident } deriving (Show) @@ -830,6 +903,8 @@ uncatchableErr msg = throwError $ Error msg False quote :: String -> String quote s = "'" ++ s ++ "'" +letters :: [T.Ident] +letters = map T.Ident $ [1 ..] >>= flip replicateM ['a' .. 'z'] + ctrace :: (Monad m, Show a) => String -> a -> m () ctrace str a = trace (str ++ ": " ++ show a) pure () - diff --git a/src/TypeChecker/TypeCheckerIr.hs b/src/TypeChecker/TypeCheckerIr.hs index d59e429..c5ff1cf 100644 --- a/src/TypeChecker/TypeCheckerIr.hs +++ b/src/TypeChecker/TypeCheckerIr.hs @@ -13,12 +13,12 @@ import Prelude import Prelude qualified as C (Eq, Ord, Read, Show) newtype Program' t = Program [Def' t] - deriving (C.Eq, C.Ord, C.Show, C.Read) + deriving (C.Eq, C.Ord, C.Show, C.Read, Functor) data Def' t = DBind (Bind' t) | DData (Data' t) - deriving (C.Eq, C.Ord, C.Show, C.Read) + deriving (C.Eq, C.Ord, C.Show, C.Read, Functor) data Type = TLit Ident @@ -29,10 +29,10 @@ data Type deriving (C.Eq, C.Ord, C.Show, C.Read) data Data' t = Data t [Inj' t] - deriving (C.Eq, C.Ord, C.Show, C.Read) + deriving (C.Eq, C.Ord, C.Show, C.Read, Functor) data Inj' t = Inj Ident t - deriving (C.Eq, C.Ord, C.Show, C.Read) + deriving (C.Eq, C.Ord, C.Show, C.Read, Functor) newtype Ident = Ident String deriving (C.Eq, C.Ord, C.Show, C.Read, IsString) @@ -43,7 +43,7 @@ data Pattern' t | PCatch | PEnum Ident | PInj Ident [Pattern' t] -- TODO should be (Pattern' t, t) - deriving (C.Eq, C.Ord, C.Show, C.Read) + deriving (C.Eq, C.Ord, C.Show, C.Read, Functor) data Exp' t = EVar Ident @@ -54,7 +54,7 @@ data Exp' t | EAdd (ExpT' t) (ExpT' t) | EAbs Ident (ExpT' t) | ECase (ExpT' t) [Branch' t] - deriving (C.Eq, C.Ord, C.Show, C.Read) + deriving (C.Eq, C.Ord, C.Show, C.Read, Functor) newtype TVar = MkTVar Ident deriving (C.Eq, C.Ord, C.Show, C.Read) @@ -63,10 +63,10 @@ type Id' t = (Ident, t) type ExpT' t = (Exp' t, t) data Bind' t = Bind (Id' t) [Id' t] (ExpT' t) - deriving (C.Eq, C.Ord, C.Show, C.Read) + deriving (C.Eq, C.Ord, C.Show, C.Read, Functor) data Branch' t = Branch (Pattern' t, t) (ExpT' t) - deriving (C.Eq, C.Ord, C.Show, C.Read) + deriving (C.Eq, C.Ord, C.Show, C.Read, Functor) instance Print Ident where prt _ (Ident s) = doc $ showString s diff --git a/test_program.crf b/test_program.crf index 432d33f..435a071 100644 --- a/test_program.crf +++ b/test_program.crf @@ -1,28 +1,23 @@ -main = head (Cons (sum (repeat 5 9223372036854775807)) Nil); --9223372036854775807 - --- main = case (bind (fmap (\s . s + 1) (Just 5)) (\s . pure (s + 10))) of { --- Just a => a ; --- Nothing => minusOne ; --- }; - ----- MAYBE MONAD ---- -data Maybe () where { - Just : Int -> Maybe () - Nothing : Maybe () +data List (a) where { + Nil : List (a) + Cons : a -> List (a) -> List (a) }; -fmap : (Int -> Int) -> Maybe () -> Maybe () ; -fmap f m = case m of { - Just a => pure (f a) ; - Nothing => Nothing ; +main = length (Cons 1 (Cons 2 Nil)) ; +id x = x; +const x y = x ; + +map : (o -> g) -> List (o) -> List (g) ; +map f xs = case xs of { + Nil => Nil ; + Cons x xs => Cons (f x) (map f xs) ; }; -pure : Int -> Maybe () ; -pure x = Just x; +length : List (Int) -> Int ; +length xs = case xs of { + Nil => 0 ; + Cons _ xs => 1 + length xs ; +}; --- scombinator not working yet :) - -bind : Maybe () -> (Int -> Maybe ()) -> Maybe () ; -bind x f = case x of { - Just x => f x ; - Nothing => Nothing ; +id_int : a -> b ; +id_int x = (x : a) ; From aaaff776e0f4f07dceb9b5b921f1bd4b8f4c30d8 Mon Sep 17 00:00:00 2001 From: sebastian Date: Sun, 2 Apr 2023 00:42:42 +0200 Subject: [PATCH 270/372] Add some boiler plate for warnings --- src/TypeChecker/TypeChecker.hs | 2 +- src/TypeChecker/TypeCheckerHm.hs | 12 ++++++++---- 2 files changed, 9 insertions(+), 5 deletions(-) diff --git a/src/TypeChecker/TypeChecker.hs b/src/TypeChecker/TypeChecker.hs index 6c95a09..b7e4b9c 100644 --- a/src/TypeChecker/TypeChecker.hs +++ b/src/TypeChecker/TypeChecker.hs @@ -15,4 +15,4 @@ typecheck tc = rmTEVar <=< f where f = case tc of Bi -> Bi.typecheck - Hm -> Hm.typecheck + Hm -> fmap fst . Hm.typecheck diff --git a/src/TypeChecker/TypeCheckerHm.hs b/src/TypeChecker/TypeCheckerHm.hs index 7b88fe5..9927b69 100644 --- a/src/TypeChecker/TypeCheckerHm.hs +++ b/src/TypeChecker/TypeCheckerHm.hs @@ -12,6 +12,7 @@ import Control.Monad.Except import Control.Monad.Identity (Identity, runIdentity) import Control.Monad.Reader import Control.Monad.State +import Control.Monad.Writer import Data.Coerce (coerce) import Data.Function (on) import Data.List (foldl', nub, sortOn) @@ -29,7 +30,7 @@ import TypeChecker.TypeCheckerIr qualified as T -- TODO: Disallow mutual recursion -- | Type check a program -typecheck :: Program -> Either String (T.Program' Type) +typecheck :: Program -> Either String (T.Program' Type, [Warning]) typecheck = onLeft msg . run . checkPrg where onLeft :: (Error -> String) -> Either Error a -> Either String a @@ -863,13 +864,14 @@ dataErr ma d = initCtx = Ctx mempty initEnv = Env 0 'a' mempty mempty mempty mempty -run :: Infer a -> Either Error a +run :: Infer a -> Either Error (a, [Warning]) run = run' initEnv initCtx -run' :: Env -> Ctx -> Infer a -> Either Error a +run' :: Env -> Ctx -> Infer a -> Either Error (a, [Warning]) run' e c = runIdentity . runExceptT + . runWriterT . flip runReaderT c . flip evalStateT e . runInfer @@ -891,7 +893,9 @@ data Error = Error {msg :: String, catchable :: Bool} deriving (Show) type Subst = Map T.Ident Type -newtype Infer a = Infer {runInfer :: StateT Env (ReaderT Ctx (ExceptT Error Identity)) a} +newtype Warning = NonExhaustive String + +newtype Infer a = Infer {runInfer :: StateT Env (ReaderT Ctx (WriterT [Warning] (ExceptT Error Identity))) a} deriving (Functor, Applicative, Monad, MonadReader Ctx, MonadError Error, MonadState Env) catchableErr :: MonadError Error m => String -> m a From 03a486410f24fb3adb72672529276448119d99a0 Mon Sep 17 00:00:00 2001 From: sebastian Date: Sun, 2 Apr 2023 13:42:47 +0200 Subject: [PATCH 271/372] Added somewhat detailed README --- README.md | 211 ++++++++++++++++++++++++++++++- src/Desugar/Desugar.hs | 1 - src/TypeChecker/TypeCheckerHm.hs | 5 - 3 files changed, 210 insertions(+), 7 deletions(-) diff --git a/README.md b/README.md index 1cfb72a..36d6e8f 100644 --- a/README.md +++ b/README.md @@ -1 +1,210 @@ -# language \ No newline at end of file +# Build +First generate the parser using [BNFC](https://bnfc.digitalgrammars.com/), +this is done using the command `bnfc -o src -d Grammar.cf` +Churf can then be built using `cabal install` + +Using the tool [make](https://www.gnu.org/software/make/) the entire thing can be built by running `make` +If [just](https://github.com/casey/just) is preferred then run `just build` + +# Compiling a program + +Using the Hindley-Milner type checker: `./language -t hm example.crf` +Using the bidirectional type checker: `./language -t bi example.crf` + +# Syntax and quirks + +The syntactic requirements differ a bit using the different type checkers. +The bidirectional type checker require explicit `forall` everywhere a type +forall quantified type variable is declared. In the Hindley-Milner type checker +all type variables are assumed to be forall quantified. + +Currently for the code generator and monomorphizer to work correctly it is +expected that the function `main` exist with either explicitly given type `Int` +or inferrable. + +Single line comments are written using `--` +Multi line comments are written using `{-` and `-}` + +## Program + +A program is a list of defs separated by semicolons, which in turn is either a bind, a signature, or a data types +`Program ::= [Def]` + +```hs +data Test () where { + Test : Test () +}; +test : Int ; +test = 0 ; +``` + +## Bind + +A bind is a name followed by a white space separated list of arguments, then an equal sign followed by an expression. +Both name and arguments have to start with lower case letters +`Bind ::= LIdent [LIdent] "=" Exp + +```hs +example x y = x + y ; +``` + +## Signature +A signature is a name followed by a colon and then the type +The name has to start with a lowe case letter +`Sig ::= LIdent ":" Type` + +```hs +const : a -> b -> a ; +``` + +## Data type +A data type is declared as follows + +`Data ::= "data" Type "where" "{" [Inj] "}"` + +The words in quotes are necessary keywords +The type can be any type for parsing, but only `TData` will type check. + +The list of inj is separated by white space. Using new lines is recommended for ones own sanity. + + +```hs +data Maybe (a) where { + Nothing : Maybe (a) + Just : a -> Maybe (a) +}; +``` +The parens are necessary for every data type to make the grammar unambiguous. +Thus in `data Bool () where ...` the parens *do* *not* represent Unit + +### Inj +An inj is a constructor for the data type + +It is declared like a signature, except the name has to start with a lower case letter. +The return type of the constructor also has match the type of the data type to type check. + +`Inj ::= UIdent ":" Type` + +## Type + +A type can be either a type literal, type variable, function type, explicit forall quantified type or a type representing a data type +A type literal have to start with an upper case letter, type variables have to start with a lower case letter, +data types have to start with an upper case letter, a function type is two types separated by an arrow (arrows right associative), +and foralls take one type variable followed by a type. + +`TLit ::= UIdent` +`TVar ::= LIdent` +`TData ::= UIdent "(" [Type] ")"` +`TFun ::= Type "->" Type` +`TAll ::= "forall" LIdent "." Type` + +```hs +exampleLit : Int ; +exampleVar : a ; +exampleData : Maybe (a) ; +exampleFun : Int -> a ; +exampleAll : forall a. forall b. a -> b ; +``` + +## Expressions + +There are a couple different expressions, probably best explained by their rules + +Type annotated expression +`EAnn ::= "(" Exp ":" Type ")"` + +Variable +`EVar ::= LIdent` +```hs +x +``` + +constructor +`EInj ::= UIdent` +```hs +Just +``` + +Literal +`ELit ::= Lit` +```hs +0 +``` + +Function application +`EApp ::= Exp2 Exp3` +```hs +f 0 +``` + +Addition +`EAdd ::= Exp1 "+" Exp2` +```hs +3 + 5 +``` + +Let expression +`ELet ::= "let" Bind "in" Exp ` +```hs +let f x = x in f 0 +``` + +Abstraction, known as lambda or closure +`EAbs ::= "\\" LIdent "." Exp` +```hs +\x. x +``` + +Case expression consist of a list semicolon separated list of Branches +`ECase ::= "case" Exp "of" "{" [Branch] "}"` +```hs +case xs of { + Cons x xs => 1; + Nil => 0; +}; + +### Branch +A branch is a pattern followed by the fat arrow and then an expression + +`Branch ::= Pattern "=>" Exp` + +### Pattern +A pattern can be either a variable, literal, a wildcard represented by `_`, an enum constructor (constructor with zero arguments) +, or a constructor followed by a recursive list of patterns. + +Variable match +`PVar ::= LIdent` +The x in the following example +```hs +x => 0 +``` +Literal match +`PLit ::= Lit` +The 1 in the following example +```hs +1 => 0 +``` +A wildcard match +`PCatch ::= "_"` +The underscore in the following example +```hs +_ => 0 +``` +A constructor without arguments +`PEnum ::= UIdent` +The Nothing in the following example +```hs +Nothing => 0 +``` +The recursive match on a constructor +`PInj ::= UIdent [Pattern1]` +The outer Just represents the UIdent and the rest is the recursive match +```hs +Just (Just 0) => 1 +``` + +For simplicity sake a user does not need to consider these last two cases as different in parsing. +We allow arbitrarily deep pattern matching. + +## Literal +We currently allow two different literals: Integer and Char diff --git a/src/Desugar/Desugar.hs b/src/Desugar/Desugar.hs index f67fa05..a2a5ffd 100644 --- a/src/Desugar/Desugar.hs +++ b/src/Desugar/Desugar.hs @@ -19,7 +19,6 @@ desugarBind (Bind name args e) = Bind name args (desugarExp e) desugarExp :: Exp -> Exp desugarExp = \case - EAppInf e2 e1 -> (EApp `on` desugarExp) e1 e2 EApp e1 e2 -> (EApp `on` desugarExp) e1 e2 EAdd e1 e2 -> (EAdd `on` desugarExp) e1 e2 EAbs i e -> EAbs i (desugarExp e) diff --git a/src/TypeChecker/TypeCheckerHm.hs b/src/TypeChecker/TypeCheckerHm.hs index 9927b69..1b6ae4d 100644 --- a/src/TypeChecker/TypeCheckerHm.hs +++ b/src/TypeChecker/TypeCheckerHm.hs @@ -159,10 +159,6 @@ checkBind (Bind name args e) = do let m1 = M.fromList $ zip fvs1 letters let t0 = replace m0 t' let t1 = replace m1 lambda_t - ctrace "lambda" lambda_t - ctrace "t'" t' - ctrace "t0" t0 - ctrace "t1" t1 unless (t1 <<= t0) ( throwError $ @@ -388,7 +384,6 @@ algoW = \case (subst, injs, ret_t) <- checkCase t injs let comp = subst `compose` sub return (comp, apply comp (T.ECase (e', t) injs, ret_t)) - EAppInf{} -> error "desugar phase failed" checkCase :: Type -> [Branch] -> Infer (Subst, [T.Branch' Type], Type) checkCase _ [] = catchableErr "Atleast one case required" From 6a2ebf4ecd95eadc57067bfa047f001bde70e9a2 Mon Sep 17 00:00:00 2001 From: sebastian Date: Sun, 2 Apr 2023 13:46:46 +0200 Subject: [PATCH 272/372] Fixed structure a bit --- README.md | 35 ++++++++++++++++++++++++++++++++--- 1 file changed, 32 insertions(+), 3 deletions(-) diff --git a/README.md b/README.md index 36d6e8f..6793058 100644 --- a/README.md +++ b/README.md @@ -1,6 +1,7 @@ # Build First generate the parser using [BNFC](https://bnfc.digitalgrammars.com/), this is done using the command `bnfc -o src -d Grammar.cf` + Churf can then be built using `cabal install` Using the tool [make](https://www.gnu.org/software/make/) the entire thing can be built by running `make` @@ -9,6 +10,7 @@ If [just](https://github.com/casey/just) is preferred then run `just build` # Compiling a program Using the Hindley-Milner type checker: `./language -t hm example.crf` + Using the bidirectional type checker: `./language -t bi example.crf` # Syntax and quirks @@ -42,7 +44,8 @@ test = 0 ; A bind is a name followed by a white space separated list of arguments, then an equal sign followed by an expression. Both name and arguments have to start with lower case letters -`Bind ::= LIdent [LIdent] "=" Exp + +`Bind ::= LIdent [LIdent] "=" Exp` ```hs example x y = x + y ; @@ -51,6 +54,7 @@ example x y = x + y ; ## Signature A signature is a name followed by a colon and then the type The name has to start with a lowe case letter + `Sig ::= LIdent ":" Type` ```hs @@ -65,7 +69,7 @@ A data type is declared as follows The words in quotes are necessary keywords The type can be any type for parsing, but only `TData` will type check. -The list of inj is separated by white space. Using new lines is recommended for ones own sanity. +The list of Inj is separated by white space. Using new lines is recommended for ones own sanity. ```hs @@ -93,9 +97,13 @@ data types have to start with an upper case letter, a function type is two types and foralls take one type variable followed by a type. `TLit ::= UIdent` + `TVar ::= LIdent` + `TData ::= UIdent "(" [Type] ")"` + `TFun ::= Type "->" Type` + `TAll ::= "forall" LIdent "." Type` ```hs @@ -111,57 +119,68 @@ exampleAll : forall a. forall b. a -> b ; There are a couple different expressions, probably best explained by their rules Type annotated expression + `EAnn ::= "(" Exp ":" Type ")"` Variable + `EVar ::= LIdent` ```hs x ``` -constructor +Constructor + `EInj ::= UIdent` ```hs Just ``` Literal + `ELit ::= Lit` ```hs 0 ``` Function application + `EApp ::= Exp2 Exp3` ```hs f 0 ``` Addition + `EAdd ::= Exp1 "+" Exp2` ```hs 3 + 5 ``` Let expression + `ELet ::= "let" Bind "in" Exp ` ```hs let f x = x in f 0 ``` Abstraction, known as lambda or closure + `EAbs ::= "\\" LIdent "." Exp` ```hs \x. x ``` Case expression consist of a list semicolon separated list of Branches + `ECase ::= "case" Exp "of" "{" [Branch] "}"` + ```hs case xs of { Cons x xs => 1; Nil => 0; }; +``` ### Branch A branch is a pattern followed by the fat arrow and then an expression @@ -173,31 +192,41 @@ A pattern can be either a variable, literal, a wildcard represented by `_`, an e , or a constructor followed by a recursive list of patterns. Variable match + `PVar ::= LIdent` + The x in the following example ```hs x => 0 ``` Literal match + `PLit ::= Lit` + The 1 in the following example ```hs 1 => 0 ``` A wildcard match + `PCatch ::= "_"` + The underscore in the following example ```hs _ => 0 ``` A constructor without arguments + `PEnum ::= UIdent` + The Nothing in the following example ```hs Nothing => 0 ``` The recursive match on a constructor + `PInj ::= UIdent [Pattern1]` + The outer Just represents the UIdent and the rest is the recursive match ```hs Just (Just 0) => 1 From faffb2744ebd6c11f9f40fd9181b0110eb2ee409 Mon Sep 17 00:00:00 2001 From: sebastian Date: Sun, 2 Apr 2023 13:47:35 +0200 Subject: [PATCH 273/372] Fixed structure a bit more --- README.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/README.md b/README.md index 6793058..afd3239 100644 --- a/README.md +++ b/README.md @@ -5,7 +5,7 @@ this is done using the command `bnfc -o src -d Grammar.cf` Churf can then be built using `cabal install` Using the tool [make](https://www.gnu.org/software/make/) the entire thing can be built by running `make` -If [just](https://github.com/casey/just) is preferred then run `just build` +or using [just](https://github.com/casey/just), `just build` # Compiling a program From bd02f527956dafca0c3f1002cb700f38fd310b2c Mon Sep 17 00:00:00 2001 From: sebastian Date: Sun, 2 Apr 2023 13:48:11 +0200 Subject: [PATCH 274/372] Fixed structure a bit morer --- README.md | 1 + 1 file changed, 1 insertion(+) diff --git a/README.md b/README.md index afd3239..7266b86 100644 --- a/README.md +++ b/README.md @@ -13,6 +13,7 @@ Using the Hindley-Milner type checker: `./language -t hm example.crf` Using the bidirectional type checker: `./language -t bi example.crf` +The program to compile has to have the file extension `.crf` # Syntax and quirks The syntactic requirements differ a bit using the different type checkers. From cc5755c3a91055b3d9fb01f0281440945cb63e13 Mon Sep 17 00:00:00 2001 From: Martin Fredin Date: Mon, 3 Apr 2023 09:24:13 +0200 Subject: [PATCH 275/372] Add layout grammar --- Grammar.cf | 10 +- Makefile | 6 +- language.cabal | 3 + src/Main.hs | 76 +++++------ tests/TestTypeCheckerBidir.hs | 236 ++++++++++++++++------------------ 5 files changed, 155 insertions(+), 176 deletions(-) diff --git a/Grammar.cf b/Grammar.cf index 55763f4..586140c 100644 --- a/Grammar.cf +++ b/Grammar.cf @@ -37,7 +37,6 @@ internal MkTEVar. TEVar ::= LIdent; Data. Data ::= "data" Type "where" "{" [Inj] "}" ; Inj. Inj ::= UIdent ":" Type ; -separator nonempty Inj " " ; ------------------------------------------------------------------------------- -- * Expressions @@ -76,8 +75,13 @@ PInj. Pattern ::= UIdent [Pattern1]; -- * AUX ------------------------------------------------------------------------------- -terminator Def ";"; -terminator Branch ";" ; +layout "of", "where", "let"; +layout stop "in"; +layout toplevel; + +separator Def ";"; +separator Branch ";" ; +separator Inj ";"; separator LIdent ""; separator Type " "; diff --git a/Makefile b/Makefile index d5c908c..bba98b0 100644 --- a/Makefile +++ b/Makefile @@ -3,7 +3,7 @@ language : src/Grammar/Test cabal install --installdir=. --overwrite-policy=always -src/Grammar/Test.hs src/Grammar/Lex.x src/Grammar/Par.y : Grammar.cf +src/Grammar/Test.hs src/Grammar/Lex.x src/Grammar/Par.y src/Grammar/Layout : Grammar.cf bnfc -o src -d $< src/Grammar/Par.hs : src/Grammar/Par.y @@ -15,8 +15,8 @@ src/Grammar/Lex.hs : src/Grammar/Lex.x src/Grammar/%.y : Grammar.cf bnfc -o src -d $< -src/Grammar/Test : src/Grammar/Test.hs src/Grammar/Par.hs src/Grammar/Lex.hs - ghc src/Grammar/Test.hs src/Grammar/Par.hs src/Grammar/Lex.hs src/Grammar/Abs.hs src/Grammar/Skel.hs src/Grammar/Print.hs -o src/Grammar/test +src/Grammar/Test : src/Grammar/Test.hs src/Grammar/Par.hs src/Grammar/Lex.hs src/Grammar/Layout + ghc src/Grammar/Test.hs src/Grammar/Par.hs src/Grammar/Lex.hs src/Grammar/Abs.hs src/Grammar/Skel.hs src/Grammar/Print.hs src/Grammar/Layout -o src/Grammar/test clean : rm -r src/Grammar diff --git a/language.cabal b/language.cabal index 1c54e3f..82e1492 100644 --- a/language.cabal +++ b/language.cabal @@ -30,6 +30,8 @@ executable language Grammar.Print Grammar.Skel Grammar.ErrM + Grammar.ErrM + Grammar.Layout Auxiliary Renamer.Renamer TypeChecker.TypeChecker @@ -82,6 +84,7 @@ Test-suite language-testsuite Grammar.Print Grammar.Skel Grammar.ErrM + Grammar.Layout Auxiliary Monomorphizer.Monomorphizer Monomorphizer.MonomorphizerIr diff --git a/src/Main.hs b/src/Main.hs index a6337bf..3e21803 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -2,44 +2,36 @@ module Main where -import Codegen.Codegen (generateCode) -import Compiler (compile) -import Control.Monad (when) -import Data.Bool (bool) -import Data.List.Extra (isSuffixOf) -import Data.Maybe (fromJust, isNothing) -import Desugar.Desugar (desugar) -import GHC.IO.Handle.Text (hPutStrLn) -import Grammar.ErrM (Err) -import Grammar.Par (myLexer, pProgram) -import Grammar.Print (printTree) -import LambdaLifter (lambdaLift) -import Monomorphizer.Monomorphizer (monomorphize) -import Renamer.Renamer (rename) -import System.Console.GetOpt ( - ArgDescr (NoArg, ReqArg), - ArgOrder (RequireOrder), - OptDescr (Option), - getOpt, - usageInfo, - ) -import System.Directory ( - createDirectory, - doesPathExist, - getDirectoryContents, - removeDirectoryRecursive, - setCurrentDirectory, - ) -import System.Environment (getArgs) -import System.Exit ( - ExitCode (ExitFailure), - exitFailure, - exitSuccess, - exitWith, - ) -import System.IO (stderr) -import System.Process (spawnCommand, waitForProcess) -import TypeChecker.TypeChecker (TypeChecker (Bi, Hm), typecheck) +import Codegen.Codegen (generateCode) +import Compiler (compile) +import Control.Monad (when) +import Data.Bool (bool) +import Data.List.Extra (isSuffixOf) +import Data.Maybe (fromJust, isNothing) +import Desugar.Desugar (desugar) +import GHC.IO.Handle.Text (hPutStrLn) +import Grammar.ErrM (Err) +import Grammar.Layout (resolveLayout) +import Grammar.Par (myLexer, pProgram) +import Grammar.Print (printTree) +import LambdaLifter (lambdaLift) +import Monomorphizer.Monomorphizer (monomorphize) +import Renamer.Renamer (rename) +import System.Console.GetOpt (ArgDescr (NoArg, ReqArg), + ArgOrder (RequireOrder), + OptDescr (Option), getOpt, + usageInfo) +import System.Directory (createDirectory, doesPathExist, + getDirectoryContents, + removeDirectoryRecursive, + setCurrentDirectory) +import System.Environment (getArgs) +import System.Exit (ExitCode (ExitFailure), + exitFailure, exitSuccess, + exitWith) +import System.IO (stderr) +import System.Process (spawnCommand, waitForProcess) +import TypeChecker.TypeChecker (TypeChecker (Bi, Hm), typecheck) main :: IO () main = getArgs >>= parseArgs >>= uncurry main' @@ -86,11 +78,11 @@ chooseTypechecker s options = options{typechecker = tc} tc = case s of "hm" -> pure Hm "bi" -> pure Bi - _ -> Nothing + _ -> Nothing data Options = Options - { help :: Bool - , debug :: Bool + { help :: Bool + , debug :: Bool , typechecker :: Maybe TypeChecker } @@ -99,7 +91,7 @@ main' opts s = do file <- readFile s printToErr "-- Parse Tree -- " - parsed <- fromSyntaxErr . pProgram $ myLexer file + parsed <- fromSyntaxErr . pProgram . resolveLayout True $ myLexer file bool (printToErr $ printTree parsed) (printToErr $ show parsed) opts.debug printToErr "-- Desugar --" diff --git a/tests/TestTypeCheckerBidir.hs b/tests/TestTypeCheckerBidir.hs index 5e1d5b1..33d7575 100644 --- a/tests/TestTypeCheckerBidir.hs +++ b/tests/TestTypeCheckerBidir.hs @@ -10,6 +10,7 @@ import Test.Hspec import Control.Monad ((<=<)) import Grammar.ErrM (Err, pattern Bad, pattern Ok) +import Grammar.Layout (resolveLayout) import Grammar.Par (myLexer, pProgram) import Renamer.Renamer (rename) import TypeChecker.RemoveTEVar (RemoveTEVar (rmTEVar)) @@ -38,52 +39,52 @@ testTypeCheckerBidir = describe "Bidirectional type checker test" $ do tc_id = specify "Basic identity function polymorphism" $ run - [ "id : forall a. a -> a;" - , "id x = x;" - , "main = id 4;" + [ "id : forall a. a -> a" + , "id x = x" + , "main = id 4" ] `shouldSatisfy` ok tc_double = specify "Addition inference" $ run - ["double x = x + x;"] + ["double x = x + x"] `shouldSatisfy` ok tc_add_lam = specify "Addition lambda inference" $ run - ["four = (\\x. x + x) 2;"] + ["four = (\\x. x + x) 2"] `shouldSatisfy` ok tc_const = specify "Basic polymorphism with multiple type variables" $ run - [ "const : forall a. forall b. a -> b -> a;" - , "const x y = x;" - , "main = const 'a' 65;" + [ "const : forall a. forall b. a -> b -> a" + , "const x y = x" + , "main = const 'a' 65" ] `shouldSatisfy` ok tc_simple_rank2 = specify "Simple rank two polymorphism" $ run - [ "id : forall a. a -> a;" - , "id x = x;" - , "f : forall a. a -> (forall b. b -> b) -> a;" - , "f x g = g x;" - , "main = f 4 id;" + [ "id : forall a. a -> a" + , "id x = x" + , "f : forall a. a -> (forall b. b -> b) -> a" + , "f x g = g x" + , "main = f 4 id" ] `shouldSatisfy` ok tc_rank2 = specify "Rank two polymorphism is ok" $ run - [ "const : forall a. forall b. a -> b -> a;" - , "const x y = x;" - , "rank2 : forall a. forall b. a -> (forall c. c -> Int) -> b -> Int;" - , "rank2 x f y = f x + f y;" - , "main = rank2 3 (\\x. const 5 x : forall a. a -> Int) 'h';" + [ "const : forall a. forall b. a -> b -> a" + , "const x y = x" + , "rank2 : forall a. forall b. a -> (forall c. c -> Int) -> b -> Int" + , "rank2 x f y = f x + f y" + , "main = rank2 3 (\\x. const 5 x : forall a. a -> Int) 'h'" ] `shouldSatisfy` ok @@ -92,20 +93,20 @@ tc_identity = describe "(∀b. b → b) should only accept the identity function specify "identity is accepted" $ run (fs ++ id) `shouldSatisfy` ok where fs = - [ "f : forall a. a -> (forall b. b -> b) -> a;" - , "f x g = g x;" - , "id : forall a. a -> a;" - , "id x = x;" - , "id_int : Int -> Int;" - , "id_int x = x;" + [ "f : forall a. a -> (forall b. b -> b) -> a" + , "f x g = g x" + , "id : forall a. a -> a" + , "id x = x" + , "id_int : Int -> Int" + , "id_int x = x" ] id = - [ "main : Int;" - , "main = f 4 id;" + [ "main : Int" + , "main = f 4 id" ] id_int = - [ "main : Int;" - , "main = f 4 id_int;" + [ "main : Int" + , "main = f 4 id_int" ] tc_pair = describe "Pair. Type variables in Pair a b typechecked" $ do @@ -113,26 +114,24 @@ tc_pair = describe "Pair. Type variables in Pair a b typechecked" $ do specify "Correct arguments are accepted" $ run (fs ++ correct) `shouldSatisfy` ok where fs = - [ "data forall a. forall b. Pair (a b) where {" + [ "data forall a. forall b. Pair (a b) where" , " Pair : a -> b -> Pair (a b)" - , "};" - , "main : Pair (Int Char);" + , "main : Pair (Int Char)" ] - wrong = ["main = Pair 'a' 65;"] - correct = ["main = Pair 65 'a';"] + wrong = ["main = Pair 'a' 65"] + correct = ["main = Pair 65 'a'"] tc_tree = describe "Tree. Recursive data type" $ do specify "Wrong tree is rejected" $ run (fs ++ wrong) `shouldNotSatisfy` ok specify "Correct tree is accepted" $ run (fs ++ correct) `shouldSatisfy` ok where fs = - [ "data forall a. Tree (a) where {" + [ "data forall a. Tree (a) where" , " Node : a -> Tree (a) -> Tree (a) -> Tree (a)" , " Leaf : a -> Tree (a)" - , "};" ] - wrong = ["tree = Node 1 (Node 2 (Node 4) (Leaf 5)) (Leaf 3);"] - correct = ["tree = Node 1 (Node 2 (Leaf 4) (Leaf 5)) (Leaf 3);"] + wrong = ["tree = Node 1 (Node 2 (Node 4) (Leaf 5)) (Leaf 3)"] + correct = ["tree = Node 1 (Node 2 (Leaf 4) (Leaf 5)) (Leaf 3)"] tc_mono_case = describe "Monomorphic pattern matching" $ do specify "First wrong case expression rejected" $ @@ -147,39 +146,34 @@ tc_mono_case = describe "Monomorphic pattern matching" $ do run correct2 `shouldSatisfy` ok where wrong1 = - [ "simple : Int -> Int;" - , "simple c = case c of {" - , " 'F' => 0;" - , " 'T' => 1;" - , "};" + [ "simple : Int -> Int" + , "simple c = case c of" + , " 'F' => 0" + , " 'T' => 1" ] wrong2 = - [ "simple : Char -> Int;" - , "simple c = case c of {" - , " 'F' => 0;" - , " 1 => 1;" - , "};" + [ "simple : Char -> Int" + , "simple c = case c of" + , " 'F' => 0" + , " 1 => 1" ] wrong3 = - [ "simple : Char -> Int;" - , "simple c = case c of {" - , " 'F' => 0;" - , " 'T' => '1';" - , "};" + [ "simple : Char -> Int" + , "simple c = case c of" + , " 'F' => 0" + , " 'T' => '1'" ] correct1 = - [ "simple : Char -> Int;" - , "simple c = case c of {" - , " 'F' => 0;" - , " 'T' => 1;" - , "};" + [ "simple : Char -> Int" + , "simple c = case c of" + , " 'F' => 0" + , " 'T' => 1" ] correct2 = - [ "simple : Char -> Int;" - , "simple c = case c of {" - , " 'F' => 0;" - , " _ => 1;" - , "};" + [ "simple : Char -> Int" + , "simple c = case c of" + , " 'F' => 0" + , " _ => 1" ] tc_pol_case = describe "Polymophic and recursive pattern matching" $ do @@ -201,72 +195,63 @@ tc_pol_case = describe "Polymophic and recursive pattern matching" $ do run (fs ++ correct4) `shouldSatisfy` ok where fs = - [ "data forall a. List (a) where {" + [ "data forall a. List (a) where" , " Nil : List (a)" , " Cons : a -> List (a) -> List (a)" - , "};" ] wrong1 = - [ "length : forall c. List (c) -> Int;" - , "length = \\list. case list of {" - , " Nil => 0;" - , " Cons 6 xs => 1 + length xs;" - , "};" + [ "length : forall c. List (c) -> Int" + , "length = \\list. case list of" + , " Nil => 0" + , " Cons 6 xs => 1 + length xs" ] wrong2 = - [ "length : forall c. List (c) -> Int;" - , "length = \\list. case list of {" - , " Cons => 0;" - , " Cons x xs => 1 + length xs;" - , "};" + [ "length : forall c. List (c) -> Int" + , "length = \\list. case list of" + , " Cons => 0" + , " Cons x xs => 1 + length xs" ] wrong3 = - [ "length : forall c. List (c) -> Int;" - , "length = \\list. case list of {" - , " 0 => 0;" - , " Cons x xs => 1 + length xs;" - , "};" + [ "length : forall c. List (c) -> Int" + , "length = \\list. case list of" + , " 0 => 0" + , " Cons x xs => 1 + length xs" ] wrong4 = - [ "elems : forall c. List (List(c)) -> Int;" - , "elems = \\list. case list of {" - , " Nil => 0;" - , " Cons Nil Nil => 0;" - , " Cons Nil xs => elems xs;" - , " Cons (Cons Nil ys) xs => 1 + elems (Cons ys xs);" - , "};" + [ "elems : forall c. List (List(c)) -> Int" + , "elems = \\list. case list of" + , " Nil => 0" + , " Cons Nil Nil => 0" + , " Cons Nil xs => elems xs" + , " Cons (Cons Nil ys) xs => 1 + elems (Cons ys xs)" ] correct1 = - [ "length : forall c. List (c) -> Int;" - , "length = \\list. case list of {" - , " Nil => 0;" - , " Cons x xs => 1 + length xs;" - , " Cons x (Cons y Nil) => 2;" - , "};" + [ "length : forall c. List (c) -> Int" + , "length = \\list. case list of" + , " Nil => 0" + , " Cons x xs => 1 + length xs" + , " Cons x (Cons y Nil) => 2" ] correct2 = - [ "length : forall c. List (c) -> Int;" - , "length = \\list. case list of {" - , " Nil => 0;" - , " non_empty => 1;" - , "};" + [ "length : forall c. List (c) -> Int" + , "length = \\list. case list of" + , " Nil => 0" + , " non_empty => 1" ] correct3 = - [ "length : List (Int) -> Int;" - , "length = \\list. case list of {" - , " Nil => 0;" - , " Cons 1 Nil => 1;" - , " Cons x (Cons 2 xs) => 2 + length xs;" - , "};" + [ "length : List (Int) -> Int" + , "length = \\list. case list of" + , " Nil => 0" + , " Cons 1 Nil => 1" + , " Cons x (Cons 2 xs) => 2 + length xs" ] correct4 = - [ "elems : forall c. List (List(c)) -> Int;" - , "elems = \\list. case list of {" - , " Nil => 0;" - , " Cons Nil Nil => 0;" - , " Cons Nil xs => elems xs;" - , " Cons (Cons _ ys) xs => 1 + elems (Cons ys xs);" - , "};" + [ "elems : forall c. List (List(c)) -> Int" + , "elems = \\list. case list of" + , " Nil => 0" + , " Cons Nil Nil => 0" + , " Cons Nil xs => elems xs" + , " Cons (Cons _ ys) xs => 1 + elems (Cons ys xs)" ] @@ -277,44 +262,39 @@ tc_infer_case = describe "Infer case expression" $ do run (fs ++ correct) `shouldSatisfy` ok where fs = - [ "data Bool () where {" + [ "data Bool () where" , " True : Bool ()" , " False : Bool ()" - , "};" ] correct = - [ "toBool = case 0 of {" - , " 0 => False;" - , " _ => True;" - , "};" + [ "toBool = case 0 of" + , " 0 => False" + , " _ => True" ] wrong = - [ "toBool = case 0 of {" - , " 0 => False;" - , " _ => 1;" - , "};" + [ "toBool = case 0 of" + , " 0 => False" + , " _ => 1" ] tc_rec1 = specify "Infer simple recursive definition" $ - run ["test x = 1 + test (x + 1);"] `shouldSatisfy` ok + run ["test x = 1 + test (x + 1)"] `shouldSatisfy` ok tc_rec2 = specify "Infer recursive definition with pattern matching" $ run - [ "data Bool () where {" + [ "data Bool () where" , " False : Bool ()" , " True : Bool ()" - , "};" - , "test = \\x. case x of {" - , " 10 => True;" - , " _ => test (x+1);" - , "};" + , "test = \\x. case x of" + , " 10 => True" + , " _ => test (x+1)" ] `shouldSatisfy` ok run :: [String] -> Err T.Program -run = rmTEVar <=< typecheck <=< pProgram . myLexer . unlines +run = rmTEVar <=< typecheck <=< pProgram . resolveLayout True . myLexer . unlines ok = \case Ok _ -> True From 0d6c5920a99bbd865215570d6eeef319a31b1bf0 Mon Sep 17 00:00:00 2001 From: Martin Fredin Date: Mon, 3 Apr 2023 09:24:27 +0200 Subject: [PATCH 276/372] Fix type checker --- src/TypeChecker/TypeCheckerBidir.hs | 17 +++++++++++++---- 1 file changed, 13 insertions(+), 4 deletions(-) diff --git a/src/TypeChecker/TypeCheckerBidir.hs b/src/TypeChecker/TypeCheckerBidir.hs index 60667c5..66ef087 100644 --- a/src/TypeChecker/TypeCheckerBidir.hs +++ b/src/TypeChecker/TypeCheckerBidir.hs @@ -12,18 +12,18 @@ import Control.Applicative (Alternative, Applicative (liftA2), import Control.Monad.Except (ExceptT, MonadError (throwError), liftEither, runExceptT, unless, zipWithM, zipWithM_) -import Control.Monad.State (MonadState (get, put), State, - evalState, gets, modify) +import Control.Monad.State (MonadState, State, evalState, gets, + modify) import Data.Coerce (coerce) import Data.Foldable (foldrM) import Data.Function (on) import Data.List (intercalate, partition) -import Data.List.Extra (allSame) import Data.Map (Map) import qualified Data.Map as Map import Data.Maybe (fromMaybe, isNothing) import Data.Sequence (Seq (..)) import qualified Data.Sequence as S +import qualified Data.Set as Set import Data.Tuple.Extra (second, secondM) import Debug.Trace (trace) import Grammar.Abs @@ -72,11 +72,20 @@ initCxt defs = Cxt | DBind' name vars rhs <- defs ] , next_tevar = 0 - , data_injs = Map.fromList [ (name, t) + , data_injs = Map.fromList [ (name, foldr TAll t $ unboundedTVars t) | DData (Data _ injs) <- defs , Inj name t <- injs ] } + where + unboundedTVars = uncurry (Set.\\) . go (mempty, mempty) + where + go (unbounded, bounded) = \case + TAll tvar t -> go (unbounded, Set.insert tvar bounded) t + TVar tvar -> (Set.insert tvar unbounded, bounded) + TFun t1 t2 -> foldl go (unbounded, bounded) [t1, t2] + TData _ typs -> foldl go (unbounded, bounded) typs + _ -> (unbounded, bounded) typecheck :: Program -> Err (T.Program' Type) typecheck (Program defs) = do From c998241c65807d676ceca6b95a3563bb6dfe67f4 Mon Sep 17 00:00:00 2001 From: Martin Fredin Date: Mon, 3 Apr 2023 09:39:24 +0200 Subject: [PATCH 277/372] Fix tests --- tests/TestTypeCheckerHm.hs | 32 ++++++++++++-------------------- 1 file changed, 12 insertions(+), 20 deletions(-) diff --git a/tests/TestTypeCheckerHm.hs b/tests/TestTypeCheckerHm.hs index bf51a29..af9ae02 100644 --- a/tests/TestTypeCheckerHm.hs +++ b/tests/TestTypeCheckerHm.hs @@ -1,26 +1,18 @@ -{-# LANGUAGE QualifiedDo #-} {-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE QualifiedDo #-} module TestTypeCheckerHm where -import Control.Monad ((<=<)) -import DoStrings qualified as D -import Grammar.Par (myLexer, pProgram) -import Grammar.Print (printTree) -import Test.Hspec -import Prelude ( - Bool (..), - Either (..), - fmap, - foldl1, - not, - ($), - (.), - (>>), - ) +import Control.Monad ((<=<)) +import qualified DoStrings as D +import Grammar.Par (myLexer, pProgram) +import Grammar.Print (printTree) +import Prelude (Bool (..), Either (..), fmap, + foldl1, fst, not, ($), (.), (>>)) +import Test.Hspec -- import Test.QuickCheck -import TypeChecker.TypeCheckerHm (typecheck) +import TypeChecker.TypeCheckerHm (typecheck) testTypeCheckerHm = describe "Hindley-Milner type checker test" $ do foldl1 (>>) goods @@ -217,10 +209,10 @@ bes = testSatisfy desc test satisfaction = specify desc $ run test `shouldSatisfy` satisfaction testBe desc test shouldbe = specify desc $ run test `shouldBe` run shouldbe -run = fmap printTree . typecheck <=< pProgram . myLexer +run = fmap (printTree . fst) . typecheck <=< pProgram . myLexer ok (Right _) = True -ok (Left _) = False +ok (Left _) = False bad = not . ok @@ -232,7 +224,7 @@ _const = D.do _List = D.do "data List (a) where" " {" - " Nil : List (a)" + " Nil : List (a);" " Cons : a -> List (a) -> List (a)" " };" From 03bb6a8534324c24154297e6d62b6b437433c4a6 Mon Sep 17 00:00:00 2001 From: Martin Fredin Date: Mon, 3 Apr 2023 09:42:14 +0200 Subject: [PATCH 278/372] Fix sample-program --- sample-programs/basic-0 | 23 +++++++++-------------- 1 file changed, 9 insertions(+), 14 deletions(-) diff --git a/sample-programs/basic-0 b/sample-programs/basic-0 index 35b9c04..bc71161 100644 --- a/sample-programs/basic-0 +++ b/sample-programs/basic-0 @@ -1,20 +1,15 @@ -data Bool () where { - True : Bool () +data Bool () where + True : Bool () False : Bool () -}; -even : Int -> Bool (); -even x = not (odd x) ; +not x = case x of + True => False + False => True + +even : Int -> Bool () +even x = not (odd x) +odd x = not (even x) -odd x = not (even x) ; - -not x = case x of { - True => False; - False => True; -}; - -f = g; -g = f; From a1b1343d6794caaa8c77920592f8ce16161cc5e8 Mon Sep 17 00:00:00 2001 From: Martin Fredin Date: Mon, 3 Apr 2023 12:04:52 +0200 Subject: [PATCH 279/372] Add latex file --- Grammar.tex | 215 ++++++++++++++++++++++++++++++++++++++++++++++++++++ Makefile | 19 ++--- 2 files changed, 222 insertions(+), 12 deletions(-) create mode 100644 Grammar.tex diff --git a/Grammar.tex b/Grammar.tex new file mode 100644 index 0000000..4a16b00 --- /dev/null +++ b/Grammar.tex @@ -0,0 +1,215 @@ +%% File generated by the BNF Converter (bnfc 2.9.4.1). + +\batchmode + +\documentclass[a4paper,11pt]{article} +\usepackage[T1]{fontenc} +\usepackage[utf8x]{inputenc} +\setlength{\parindent}{0mm} +\setlength{\parskip}{1mm} + +\title{The Language Grammar} +\author{BNF-converter} + +\begin{document} +\maketitle + + +\newcommand{\emptyP}{\mbox{$\epsilon$}} +\newcommand{\terminal}[1]{\mbox{{\texttt {#1}}}} +\newcommand{\nonterminal}[1]{\mbox{$\langle \mbox{{\sl #1 }} \! \rangle$}} +\newcommand{\arrow}{\mbox{::=}} +\newcommand{\delimit}{\mbox{$|$}} +\newcommand{\reserved}[1]{\mbox{{\texttt {#1}}}} +\newcommand{\literal}[1]{\mbox{{\texttt {#1}}}} +\newcommand{\symb}[1]{\mbox{{\texttt {#1}}}} + +This document was automatically generated by the {\em BNF-Converter}. +It was generated together with the lexer, the parser, and the +abstract syntax module, which guarantees that the document +matches with the implementation of the language +(provided no hand-hacking has taken place). + +\section*{The lexical structure of Grammar} + +\subsection*{Literals} +Character literals \nonterminal{Char}\ have the form +\terminal{'}$c$\terminal{'}, where $c$ is any single character. + +Integer literals \nonterminal{Int}\ are nonempty sequences of digits. + + + +UIdent literals are recognized by the regular expression +\({\nonterminal{upper}} (\mbox{`\_'} \mid {\nonterminal{digit}} \mid {\nonterminal{letter}})*\) + +LIdent literals are recognized by the regular expression +\({\nonterminal{lower}} (\mbox{`\_'} \mid {\nonterminal{digit}} \mid {\nonterminal{letter}})*\) + +\subsection*{Reserved words and symbols} +The set of reserved words is the set of terminals appearing in the grammar. Those reserved words that consist of non-letter characters are called symbols, and they are treated in a different way from those that are similar to identifiers. The lexer follows rules familiar from languages like Haskell, C, and Java, including longest match and spacing conventions. + +The reserved words used in Grammar are the following: \\ + +\begin{tabular}{lll} +{\reserved{case}} &{\reserved{data}} &{\reserved{forall}} \\ +{\reserved{in}} &{\reserved{let}} &{\reserved{of}} \\ +{\reserved{where}} & & \\ +\end{tabular}\\ + +The symbols used in Grammar are the following: \\ + +\begin{tabular}{lll} +{\symb{:}} &{\symb{{$=$}}} &{\symb{(}} \\ +{\symb{)}} &{\symb{{$-$}{$>$}}} &{\symb{.}} \\ +{\symb{\{}} &{\symb{\}}} &{\symb{{$+$}}} \\ +{\symb{$\backslash$}} &{\symb{{$=$}{$>$}}} &{\symb{\_}} \\ +{\symb{;}} & & \\ +\end{tabular}\\ + +\subsection*{Comments} +Single-line comments begin with {\symb{{$-$}{$-$}}}. \\Multiple-line comments are enclosed with {\symb{\{{$-$}}} and {\symb{{$-$}\}}}. + +\section*{The syntactic structure of Grammar} + +Non-terminals are enclosed between $\langle$ and $\rangle$. +The symbols {\arrow} (production), {\delimit} (union) +and {\emptyP} (empty rule) belong to the BNF notation. +All other symbols are terminals.\\ + +\begin{tabular}{lll} +{\nonterminal{Program}} & {\arrow} &{\nonterminal{ListDef}} \\ +\end{tabular}\\ + +\begin{tabular}{lll} +{\nonterminal{Def}} & {\arrow} &{\nonterminal{Bind}} \\ + & {\delimit} &{\nonterminal{Sig}} \\ + & {\delimit} &{\nonterminal{Data}} \\ +\end{tabular}\\ + +\begin{tabular}{lll} +{\nonterminal{Sig}} & {\arrow} &{\nonterminal{LIdent}} {\terminal{:}} {\nonterminal{Type}} \\ +\end{tabular}\\ + +\begin{tabular}{lll} +{\nonterminal{Bind}} & {\arrow} &{\nonterminal{LIdent}} {\nonterminal{ListLIdent}} {\terminal{{$=$}}} {\nonterminal{Exp}} \\ +\end{tabular}\\ + +\begin{tabular}{lll} +{\nonterminal{Type1}} & {\arrow} &{\nonterminal{UIdent}} \\ + & {\delimit} &{\nonterminal{TVar}} \\ + & {\delimit} &{\nonterminal{UIdent}} {\terminal{(}} {\nonterminal{ListType}} {\terminal{)}} \\ + & {\delimit} &{\terminal{(}} {\nonterminal{Type}} {\terminal{)}} \\ +\end{tabular}\\ + +\begin{tabular}{lll} +{\nonterminal{Type}} & {\arrow} &{\nonterminal{Type1}} {\terminal{{$-$}{$>$}}} {\nonterminal{Type}} \\ + & {\delimit} &{\terminal{forall}} {\nonterminal{TVar}} {\terminal{.}} {\nonterminal{Type}} \\ + & {\delimit} &{\nonterminal{Type1}} \\ +\end{tabular}\\ + +\begin{tabular}{lll} +{\nonterminal{TVar}} & {\arrow} &{\nonterminal{LIdent}} \\ +\end{tabular}\\ + +\begin{tabular}{lll} +{\nonterminal{Data}} & {\arrow} &{\terminal{data}} {\nonterminal{Type}} {\terminal{where}} {\terminal{\{}} {\nonterminal{ListInj}} {\terminal{\}}} \\ +\end{tabular}\\ + +\begin{tabular}{lll} +{\nonterminal{Inj}} & {\arrow} &{\nonterminal{UIdent}} {\terminal{:}} {\nonterminal{Type}} \\ +\end{tabular}\\ + +\begin{tabular}{lll} +{\nonterminal{Exp4}} & {\arrow} &{\terminal{(}} {\nonterminal{Exp}} {\terminal{:}} {\nonterminal{Type}} {\terminal{)}} \\ + & {\delimit} &{\terminal{(}} {\nonterminal{Exp}} {\terminal{)}} \\ +\end{tabular}\\ + +\begin{tabular}{lll} +{\nonterminal{Exp3}} & {\arrow} &{\nonterminal{LIdent}} \\ + & {\delimit} &{\nonterminal{UIdent}} \\ + & {\delimit} &{\nonterminal{Lit}} \\ + & {\delimit} &{\nonterminal{Exp4}} \\ +\end{tabular}\\ + +\begin{tabular}{lll} +{\nonterminal{Exp2}} & {\arrow} &{\nonterminal{Exp2}} {\nonterminal{Exp3}} \\ + & {\delimit} &{\nonterminal{Exp3}} \\ +\end{tabular}\\ + +\begin{tabular}{lll} +{\nonterminal{Exp1}} & {\arrow} &{\nonterminal{Exp1}} {\terminal{{$+$}}} {\nonterminal{Exp2}} \\ + & {\delimit} &{\nonterminal{Exp2}} \\ +\end{tabular}\\ + +\begin{tabular}{lll} +{\nonterminal{Exp}} & {\arrow} &{\terminal{let}} {\nonterminal{Bind}} {\terminal{in}} {\nonterminal{Exp}} \\ + & {\delimit} &{\terminal{$\backslash$}} {\nonterminal{LIdent}} {\terminal{.}} {\nonterminal{Exp}} \\ + & {\delimit} &{\terminal{case}} {\nonterminal{Exp}} {\terminal{of}} {\terminal{\{}} {\nonterminal{ListBranch}} {\terminal{\}}} \\ + & {\delimit} &{\nonterminal{Exp1}} \\ +\end{tabular}\\ + +\begin{tabular}{lll} +{\nonterminal{Lit}} & {\arrow} &{\nonterminal{Integer}} \\ + & {\delimit} &{\nonterminal{Char}} \\ +\end{tabular}\\ + +\begin{tabular}{lll} +{\nonterminal{Branch}} & {\arrow} &{\nonterminal{Pattern}} {\terminal{{$=$}{$>$}}} {\nonterminal{Exp}} \\ +\end{tabular}\\ + +\begin{tabular}{lll} +{\nonterminal{Pattern1}} & {\arrow} &{\nonterminal{LIdent}} \\ + & {\delimit} &{\nonterminal{Lit}} \\ + & {\delimit} &{\terminal{\_}} \\ + & {\delimit} &{\nonterminal{UIdent}} \\ + & {\delimit} &{\terminal{(}} {\nonterminal{Pattern}} {\terminal{)}} \\ +\end{tabular}\\ + +\begin{tabular}{lll} +{\nonterminal{Pattern}} & {\arrow} &{\nonterminal{UIdent}} {\nonterminal{ListPattern1}} \\ + & {\delimit} &{\nonterminal{Pattern1}} \\ +\end{tabular}\\ + +\begin{tabular}{lll} +{\nonterminal{ListDef}} & {\arrow} &{\emptyP} \\ + & {\delimit} &{\nonterminal{Def}} \\ + & {\delimit} &{\nonterminal{Def}} {\terminal{;}} {\nonterminal{ListDef}} \\ +\end{tabular}\\ + +\begin{tabular}{lll} +{\nonterminal{ListBranch}} & {\arrow} &{\emptyP} \\ + & {\delimit} &{\nonterminal{Branch}} \\ + & {\delimit} &{\nonterminal{Branch}} {\terminal{;}} {\nonterminal{ListBranch}} \\ +\end{tabular}\\ + +\begin{tabular}{lll} +{\nonterminal{ListInj}} & {\arrow} &{\emptyP} \\ + & {\delimit} &{\nonterminal{Inj}} \\ + & {\delimit} &{\nonterminal{Inj}} {\terminal{;}} {\nonterminal{ListInj}} \\ +\end{tabular}\\ + +\begin{tabular}{lll} +{\nonterminal{ListLIdent}} & {\arrow} &{\emptyP} \\ + & {\delimit} &{\nonterminal{LIdent}} {\nonterminal{ListLIdent}} \\ +\end{tabular}\\ + +\begin{tabular}{lll} +{\nonterminal{ListType}} & {\arrow} &{\emptyP} \\ + & {\delimit} &{\nonterminal{Type}} {\nonterminal{ListType}} \\ +\end{tabular}\\ + +\begin{tabular}{lll} +{\nonterminal{ListTVar}} & {\arrow} &{\emptyP} \\ + & {\delimit} &{\nonterminal{TVar}} {\nonterminal{ListTVar}} \\ +\end{tabular}\\ + +\begin{tabular}{lll} +{\nonterminal{ListPattern1}} & {\arrow} &{\nonterminal{Pattern1}} \\ + & {\delimit} &{\nonterminal{Pattern1}} {\nonterminal{ListPattern1}} \\ +\end{tabular}\\ + + + +\end{document} + diff --git a/Makefile b/Makefile index bba98b0..ccd1325 100644 --- a/Makefile +++ b/Makefile @@ -1,6 +1,6 @@ .PHONY : sdist clean -language : src/Grammar/Test +language : src/Grammar/Test Grammar.tex cabal install --installdir=. --overwrite-policy=always src/Grammar/Test.hs src/Grammar/Lex.x src/Grammar/Par.y src/Grammar/Layout : Grammar.cf @@ -18,21 +18,16 @@ src/Grammar/%.y : Grammar.cf src/Grammar/Test : src/Grammar/Test.hs src/Grammar/Par.hs src/Grammar/Lex.hs src/Grammar/Layout ghc src/Grammar/Test.hs src/Grammar/Par.hs src/Grammar/Lex.hs src/Grammar/Abs.hs src/Grammar/Skel.hs src/Grammar/Print.hs src/Grammar/Layout -o src/Grammar/test +Grammar.tex : + bnfc --latex Grammar.cf + clean : rm -r src/Grammar rm language + rm -rf dist-newstyles + rm Grammar.aux Grammar.fdb_latexmk Grammar.fls Grammar.log Grammar.pdf Grammar.synctex.gz Grammar.tex test : - ./language ./sample-programs/basic-1 - ./language ./sample-programs/basic-2 - ./language ./sample-programs/basic-3 - ./language ./sample-programs/basic-4 - ./language ./sample-programs/basic-5 - ./language ./sample-programs/basic-6 - ./language ./sample-programs/basic-7 - ./language ./sample-programs/basic-8 - -run : - cabal -v0 new-run language -- "test_program" + cabal v2-test # EOF From e5dc28b28226c65ad5cb886883aaf254d1b77288 Mon Sep 17 00:00:00 2001 From: Martin Fredin Date: Mon, 3 Apr 2023 12:11:21 +0200 Subject: [PATCH 280/372] Add pdf of grammar --- .gitignore | 3 +- Grammar.pdf | Bin 0 -> 179560 bytes Grammar.tex | 215 ---------------------------------------------------- Makefile | 6 +- 4 files changed, 7 insertions(+), 217 deletions(-) create mode 100644 Grammar.pdf delete mode 100644 Grammar.tex diff --git a/.gitignore b/.gitignore index 0984599..fd90be9 100644 --- a/.gitignore +++ b/.gitignore @@ -2,9 +2,10 @@ dist-newstyle *.y *.x *.bak +Grammar.tex src/Grammar language test_program_result output/ *.o -*.out \ No newline at end of file +*.out diff --git a/Grammar.pdf b/Grammar.pdf new file mode 100644 index 0000000000000000000000000000000000000000..f7f7a701e9a4afa734d48301a1595340199e55eb GIT binary patch literal 179560 zcmY!laBR8|4K8B^1BLvgEG`=xE`6WWy!4U`1w&IqO9e3C(s#?uDM>9- z(09v8EJ<}qP0mkA<+8KmDlREXP0Z!0xOFw$d-82Fo_){5e~4A8rTr9A{dz5Bmf1`n z{<&{gzT6TsGh2J2YWSq`&40iCbqLz@RAckWwR=5k8W=cgDn2|tyZL?G>Jn8WHP=<) z=H=Qaxu<#WHEP=|@_+W*SKptcy}u@{8uIC!+3v}AkKXj3Yb%qp{omtfx;JJ_6$FHD-#bPC52dzsy<+9WcC zzBc`fRN5I5I4zFz99JC2q^*Lt49Xw~$WJS@{$1|Rt+!oth95j#b+-bQ(pAJVo z>+Ci8X0nCdI^=1T%C>d#hhLpDUAMXUcH2wcxgF8WI*&pxJ_{0EX*_Lt($Vwgbyv;4 zU-n%edR|1t&%J2dy^P7K`RhznxDPTgiJ9(L^Xb?pc0Ey%9g(|>1J-bFZqK@LS>yYu zUrTS*7R}wRCNKW^Nycuu>wVHY>Ww!^_usr-_aeuV<=4NBibvUgYrc^?v9EH|-3r&A zF^7ZScI2*_)NZ?m+v<|1IA_9@n-BP(|JuM-t5_$YuE(>jvHnZ^yd$+cv_DAuAO9UE zx0dhtt={7g;u`WDkALI4;&mk1OYN)V(}=qB!F6w<9u>yt?p^D6c}rqBe{t@&YpXwP z%qmMPf8Xe8^VXgJtC~;$R$W;MF0qS~*SDm3Nz0pD@K$8mv8%`G@!hbg(-s|^!LrU` z>fx2$)p3Yt~)G@kT*qD$PQ47IINnjK$-^^b^W^_?_2VbiwUd7f1U+#SyVSw*<&u&!gT%5=Gw$7QVJNhoZ>7PoXK`WC z&FeFdM1EefUOiR$ziJp$nAPt`-0#j^<`mf09e8s~ueD5jMRnB6yZ6&Tj! zvpUxF%g0|$#cCy1`~T(VZwpRq6h3G0-B^Dj+g$D2vB7_xB^#b4TTTdiq+-;_{rKEl z1M92XxJ%w$-dJ2KKl%LgigvY6(mj<{a&F)jmzeR3FR-XUhtkamG6*T$W>d&bOJnAv>N?-s$nS6Bjp3vG2A1X}Tl$zwVu&cvzC8;W&hC6^H}MT zyX)7L-~B6TuMYUw7W%$Cbs>)+w9^lj4rqlv*G9ok{L zFDPzYD)u4m{x^loPBAY%wBydqwPp8L&i!i_I{Ejy99vx9lOMJ6pQNO>GMn@B6=m(|jL$-a zIS=J`?|o$(&b9W$7X_n_v&w27H+)!^&A(V6U+(;!_`gnaC9C+Rp0}#oAG;~vbeW~l znnV_x(jE<^5H7hmH4~AH+plJ1|Jrb2?h4_;!m@P5wVxgp=)LMF&APSn-J<;dDWzX8 z?lwGAx2<-@HPf6Gm9zF#ZCsMILFd4~Yi-lBx-u#Rr>$DH#{YJQ5l4nJhqTlD#_uPh zj%?G;arZNN*}rWL-%s%mH#WL0W^hT5h?~-$AXmzkD#q-7hKXIt@9&O>dwZvTbQB1A z`RH<*gyp=oJZJaCzbXh0OQ{G}Ui)0_Rd7^Oqd~>*{I?7?oN*GbHa9+Gy)#McQik(N z13Bjoog04^>F(2-wOFX)&#Nz|G^Wf-m>4bpH}~(_X&t)Kz4qp8T0I9Z%e>FMa#C~i zPn|z+j?Yg2&-6PoB9tpNF9llir{<-AY7Ik6EY*jhr75`fP#|1=oQ;UhUmPY-dw%@` z!PQUS{ry+4b?U5l%WkcT4UO8ae|Oa)v%-kP4ue3mRiEx#Pw(ESC@#In_tx|y#}1#F zGt>AvUyPn!Tr8)UKo5_ZN<<8Mi_wyeJR)KqLOZr_)$u>yY%gZNZ&y;RcWcW+#xk|_ zb3Lz1UOf@8(fDTv>$Wh*BdS6!tb&Oi1(*MMNy(>JoN@0dOm5|0Yw~Cp@0Yda;yo7k zBNsfh`8Us%MOxDCmw~ytN!-3qPj44$%}KP|R~O&(>U?6z{T;I(YAc@LaC{xYYUIT( z7~Jtd?dtpPvuY>Pds?n;J2^|9?T8}_&%+SQ&-|JD&P~$r{+uFaxFh@JyXCj;@rP&p zxUREE%ja6=yM6bUU+vv~(MeJ5N#gSFci*Wws;Jz1tr{p}sI_}T{l3$yzI=0OD!ln; z%9GP;Zm6wRJ1@!kedV`ReXkV{TA!+TaNvi**D2d<6-2b|7b%y{ z@f-ZyRw%acaa`&3cIVKN2s(6S%7Ph|myh*w#gZB|Vxn*6LV?YCp(W&Tr#S*$kXbH-$>2s!)U{odTf zNl)s|CUk5p)61)=)L3$5#;M2Gd|wqG7JQl$f2G6tvIx(oyLLG_)68;Z#Tt$|K6zO4 z?^fd0SryS@TMu$+%@o@ydT9OLQ%)OOI1^*L>OZBXzP+;W-My#1=^Wih8SnMo<7nPs zmmn3$JXKgW(BEwP)T2Ki%$Z&uxrzVk7ai?STXzSDp8dbe>%+rOf2aPQARd~d&Ct3^ z`{d#GM$snUvl-2&yi4A`?&dX329voG_XO{iZHewu{J-X!l?ShpONj-u)6ML%=y~y{ zl6XzN|9mWRZtvqgjGW4D?|pRSYyM2`5Wc+lv_>;XU5rnUfY5s zIMo<-x=2ac3;lH9SR|}bIDmodwjFP~2IO5xumppdi5-bqk(&TnVO&Lt|=`tp~y zitlm>*%YT?(XPvVj`yqDx+Hy_Mvm)yBifYpbXz&+oUO`vdTeo}4BU^S?8u-JeqHuE55h!4ePSnn{87AH*J3G>sApG zS;oJ~u24{zjmPcbk^=<-Wrx+DK6@$_!Z*!YXYc9c_b-<@&reR6AL)6Xg=?Nc`%<=V zg3GQ%KDM+vC~hI@{;KUw=En=Og-%TTsID)%&%@@tjcQ`JVwI8n`fj6hM){H=kLLJz z{GP%wF*s++-sLZg)l!l~e@>2Vp0~K?OHJ9%4H1X4oM*KL+eV-K-yf~MfSq~m(JQR^ zhurMNeol0ZS?T2K-1TNlu6=m)_R%AG!~c8h zF^fJUBg~@D($D}>@)1$=U5)himo^mG_gVWJ$Evbd$A7S9@ox!P^yq?fRn}^)rll;Q znoTlMp?}}YZa&$S^QQN0i^d#>j1N8g^X2YW_`9>Ox7Ua(Wb3nx>s_a;rc zU;VCC`(*CP)JoT?cz?ViPke++!)u<-tH=m=p`y|RVBs1>L{Zx5FxoO&}_koQC%WgbAs`8?X zW6PfBoSb&bUACzu>YonY;)^KezBHqUN9gwy$CV$i1a*BVj0s?!8sZUZt>u(!{?Pl` z=dTeTEo(m7KGs&ASCL*Lx@M)S*7oT(#Y{XJn>lYTnvnBbCRqKzR?h(Sx$Ebj)p_L2 zIot2x%akfn8+Ojrt$9JO&Lv2lVP|<=5oYJ|adT~#hhvtg=D(K?`zP}C9C^fPu|hn7 zTS}LkWmeKksnxrWJ^i7$?C*|i*4HEUuZ!OF&+XELWH%r2$?Z2^{;jBbskxVP?h23n z5k7uz>Jxvad)Pj3o7}$K-%^Mp>`ZHupSx1vH=E}-UM{lC&tCKM;vM&r`QlTxcljG% zO{wf-o#h?(~gw%&#xL^MY3?dBXB3NxKep*}E?2*Dkja`P!*+a#x_~lZkV7g;a%Z zSohDg{i>-$R6%!-?uso<^B&g*zA>u){-M0)ehho!<%KDGlFsx+eXxoPW=)q|4=RkdS&2XOM%>S5p=(gF9~yT-B@cv8pafbp3xW9hAE*yHUETQY+_k#z&MZEW;olo4 zzv-W0xh02r<*kN~&TO47cJTr7_9ilOdink_Ki(v#!-{^f^yJ|qRqBxo(D2tJ=lKCXr-UNGRM8k3##)b zE4?k)(kc2d(>Fx-*6eTTL&7hC~D~=jR+wb>^ z|JSd5A04S(nf`3%P2+0&^KtnWH{VNr(!Q}Mkt5WE>pZ_8gE!OEk`fbz1O*8l6$UnL zCJW2n2^Hx_?$ETF{F(&6QFMCD+@ z0tE@3kLCisQ(3f}?@rw2Aj`NwO{(<(qs7z<68buq?lJmDJb&-5U_OVPW8wsX-Ji8( zS3GDsp!6_6B!IoE++l}6Sc~)A#Zcas6`8NIYc!`Qd{I z6}Eoi1B!Fcr?bqRu9&l#>r@!$+eb|f4+|SU|C=%~f@RKz_i+pC+h4ahRWGRdx9!aY zjp*H<4Rh`qC?tzqy2`t7;U9MA0>*!DH@iP*R7xl`R4f!!I3(Kfp~br4oVdZKLke}Q ziqG>7@zmK#n6PEIOE5od-{LG#$6#l%!kVe$_%6jiHUEr1_;WKfGUQGyun}n6;J%3A z|2n?{fQc@ z2LuYf<^1wcT!`fpcUMEBz=jPL0X-icd_QkhzVL*7?H~7bY^V5mZS>3T=_fA!_wMFj ze$E~LHCotzoKM=7!Bi^f@UGtYE|U&ZoA5q`|LObwd;R=>@z0)9|4)7S|IXv;*_%JZ z=lnK*@W0bJcEY*1dI6SKyB=~HU2qgW((o&Ph32E}Wu*e!Jj|#6@5_3yki}AC!5hvg z&)PY-8(QmsPqYYKqJHR`o)CZe58v7M>mC;$v{Vl4*qtHs=}(tpO5?%*qRK0H-nr~> zD`3g{$LCnca`Iul?310n3LUTJ*RELbAmeuNSI({uriBqYSGXN4YMNA;zBCG?WOaY| zb2LxEgQ4}9a8N_b%)bp~89ERCEKpTxQ24R)^>kK2#wG!YCbo+jC-%=-)Z{SX@6S^A z8!Lm_% z!nwths`lkCsGqfL_Euw~fXja$eiC!nnCIrYYQAgakEEq1OWsYLf7A7ybmkU2gRR-0 zq_^2FEw=Gwzq-p_W?EfN#HM2Pk`BuoDmPpm_f^Pmx|Fc&rAY7w%Svs*ZNZU=IV!xh zn?C-wn7l4z$*pt@!@M&dHX#(Z3#rAHON} zHc#B^&Y$p5p|g{?}mBc-hTU*$WFCbZRNm=TLSNWHod$r^QV8mnc{-*tskyD z5A?bxr^j8rZ|XemX}4%A1!^7Y;`d$!%~ z{`T}+fZ*x6J;mQ*w^>H&I|ScwWwa?tQV6lXc*Ohq`^(3sd*9#VqV2d@ps6IfZt>&| zOVsPH9_;^rOXU0G)BG>L{BFMXXr9YfjWh2}Qr$oG*rv<c5;%i??fhEA!nQZ z-$9o}oq6TYKWw>YQ~790@o_CKvFY2M+TL(sTq?yQxGhX2K4!n0n|19S>l&7uPo!rq zk=$MIwL3F*>jMV1xeIIN1pew+ayGc^z`MOwXD3?DUOMqq-16jEj`c0}9q(skWp>ud z&Y0$8`&eh+liGYMzTmx+=gwPsE^m{)Y)16?IC+Is?K!j4Lkhkw?sziysB-zP+XZXY z_goeZs=1fHE`E=AsORh2o17KO@%1_97Q2hRy2ULV+vbujW6GNySloI-@!r1M{Zl#P zw`Z@Key`}tub&k?hgV*#%%66->UitnNmijr6Zczdr2lLa4ypdYc==0W*Tvbp1?F#W zyguVafMvhj{?kEozcfm2<=c8=Vtd`MS;6l|TCUZ|}*f9HL$1-1r7wk_LKMM_;=EqjG{_*YD#d}PoI;lw%d8+p6Pt9?wYwP@%PQ+jd2lXO=gc4O>HlFIL*eX z{`fa9^OII0nb~GZruz5e)ZH6*wunqhTFDpkCNn6(RYv~)o7*?{x)>F$j^W<7Es2-m z&53_CUoUgmDos9rx@hgks}ClI*Bv;1dq(yXnU%*5>s&b0@T$Q_u=e0@r%60BdC&a4 zl$NDzH=)^hM<-jdXs5<@)3E2)4l37lH4t`qn;t zXBzr4;ppv^>%M;6x&G)m_Ra2c*I&&jG5gf=?!&cG_Z{6oIH!nsh}>IoYM&}s?#iV* zn+&48KX)q%)~dZ&F3R#REjP&3{*ThDM^^+^cx*Xb|3UCa`{bmUiuWr&n@9HVxLN)B z()=rD7p<=Hw7r`dz5XYw&dN{4OYVEMU))%Hz0z9qwe*1xL8i6g*JM6R?>3&hVp@sh z_my9iWxV?4 zdzICe17W`Nr%Ag z4eM2g)pc%>RdHnRG9d;cU3u)dt!9MNA?L~ zhMk|Qtpok9|C9;y(s$U}e*bg(t5*x8;?6DBj93(0^VEOy^SF%j+rRdS-k)Uqc@=MT zu!qi`R}}%~PiAfQ36sydW_-^^<$3b!^s=V5Co?Wr`}5yiYQw+4w=RGALF?qa;~LIu zoW1o;jvc=F>2D-!>7Hy)*S&J)k-J&{*M8GDHak*!RxCrQoYFLwtMnBpdE=R%5SJ5_fUjYP-TY?AL|iCg*c zVVc$w-my>ID_`~}_q^gWKopo1f~F)vOk;3tPE9F-&5e!_|}d_ZDsVaL&Hc zlUGW1x8#~f8BWh8b5?HQmEZ+%&Wes-iow4Vsb!7kk8ShtQ>=sK> z3V!%EFk{o<45!QcQ;+W1wf5bYxf9NIR-e;kYvncCwEf{p6}& zyXXCm`!?4cy$jn9GdR99T9@M&BzIS^_oMusRX3_!Tha(ShD|_=Yg9m3l-JhPt@3awEb<>(W$LJPDZ?J{Q7ivpp1mj@lOqX_e}fs zYB=OKRft7STpwvP@9KwQnHyO#7mRnbMw@1zE8+Qgnl)n2k=5F3$!^U80^n+Ki69{zh;5U#6#cTntCgr zKK{FRxdflW_42HYi&vxgrcSa5{hA@JG;gQ$=ATX}sXr{6Q&V;sv(LDEx%01!W~h-v z(%a2n4gPc6tJl93{CPh9bX=TV$mEyXv`T+$IQKYY=Dn6BBJI6L-T zz4KUX*2Zn-21W7rdcs4}ZtM+~+UNK0&rO%fnm6UtN@{L*+L&kTh*xayo%MV1(sM$O zt7omAa;2pDvSC=`Q|0$xgyvhH-&6To_3) z;d)=YlxnopgO&SYzUHm})7`nf_{b(le-IN&MI7a>Mwuo`}u6Ycg{##^Ra&Y<;VbuZ^v#vNT@T643ziZRnYsX@>{9GPpU73ZyA z+jjY)-dv%(x;O48x(7V*UHkd5V!wUE42Rl{1}`rh`SDVCdGdu#=VgB0@?f&6wRj%& zVe<98D&6s1N3L3A$|bf%$K`%8dr>o8#@ohe?w%(N(rh^f-5aJKNi}U2R<`p!)xJUf z>Ti9`;J&+J(|3J&@Us8b=3E)g>}^-8ruOW;6qc8h`=IB}!&k?u-**RHyf*ElZbbc| zdZ({HPPr@m@n5y>ZD`=q^rWnB{j-Dk;tjpyY(u6@d~jp$kG=WLjmmSkJDQYzUvZzY zx^%j2$0XiBwXIeastH%NxG%VItv>#($eKx;417GN*lY7guF~)L<`U*QW6F-WF4?R# zI=&jq=N+iocK-U_2M<#%%@ZdY_6nDj{w&j)uKHo2!|Hz-{-@H*udnd@p;(&X{_V87 z>#m)%A7A}IX%=K4?j5Y}%>qRJi`lyy7B%`Q)~#%dg~f7EN6GAz5j~7PG&r|TbS&!G7 z?LU5rtL21J47p0}zy;oOxdUxw=& z>LzMS9d(%WZGUj2>+(N4oXY1Od$w->L&@1a*UrqGbLwH2SaFqAIPd*$i*44hwkxQ% z|NN~n;W>-jir$RJlV^UsY;;{=lT}>OY#E&oH}^4xR_@tYksr@*)h6D&`$$nmY;IulA%m%e{n{^8QBmA0W%Cz)BFu9NGIo|Z{}K59-gBd@2fR$vur7MP+F1IerwLf?~WCnx@5!H z>^Xbd&zI^y?+eA}9GzM_D>k_Lw)0>-bd5EQK)RkjR=Xe?kgV@#%l9#xX+cM*?)GynP9=#q*Ak^ zZJv|4=gYm|i7<|oYF+;8|I|luC#!Upzh^C&!(Taj>i!8I7EIPUI(p2*)FnjtxR7R2GY3Bi)Xw);QsjF7Tbj9 zZD&{Ax^9s1X%uWm$ZgauthRn|^UG^UlsW?Xeo1 zU)aN5pRYMik#5^tSijg<+B~+gzg$yaQ?P!b;qsgdaWUS#=YC1=XtOO~+WR;*Lu!ku zNyn5o%I3Kbe>=`v6MFg5zv4q3R~~;ho|8QzFmm=`=fF2le(}Gp(DMx5-0^POm52w6 zYCY@bZd;pkWwAlh+U}RrpZ2%ji>xueGF7C0mizzdwlAX|%Cv60qjUb!4#uA1Clx}n zR|O_)(vnuJs@%By{CxG+Abq}oUu)jaYd?{FVeLWI_~loU@>rDFI}*b-Z}IJ2RcQAw z?S5Xm7z1 ze|J~@7Ur+a*=O&4?fU!G@sIyi7RFn|wJ2^pwn`(z?1$pqb1|w`bEZ1E^j>#+x3zJV z-^Zsv*EL)&cmCGhf89{FY;y4tjY+|a%qGU22)(`O&$1iqqwY#?d3K9oy<7OHsH1&V zeR@ClOB`l*xqidf{2Ak6LwBv~ud7XGnYr@6lgXASEoyO{&sV*)p69n%y`wE>b54|{ zaieugq>)9j?^)Z>x3ebZRC%tQzW-R^Zu_RD*vL&YG$yrav`lXQp(Hyc(J=P7@xLYe z-%s0G_GzNbY47N$d&(y_aDG^}VCf9?@6*!~c|woIeiVxnV+<-6yry$U!KdnbVeisy zbs80uzb}Y;o&BhKA6sQ)3&VevT`6x)zFH}i%=$R=(vszS8P73anY~w8>|YOC&2`H= zyDxa2VqH1;+rnaz<#CPeuPs*xZ2RCne`;yqjnI2%7w+YHKZmQmc|kw>v&NWK+n7Yz zbnVCXv8-B3?0gZo)9;D3+$~x zw=Me9oUdS8^PcO)9_zk6>yEJK`aiGgT~lozCHt%{@cQxe=Hf~BZL$oz?OXMCcZMJf{`Qo?foyi!A;AX~yf{nTvUpTX|jD3gnEp z|M?T+i~WYx6Q6x$ zSpQH)v)6FF^5+`nteXrsYZYaUuSm?w?437dkNc)uN6!86RnPik%nZ-o@O|QmU&*JAgc%#u#~z5k zr#Jn@zG=ONi?=UPK6rG?pKr&%&v0r!r)J3fp0#O1Mfz8cMNLJ?p5JbqeL5}rOT@e% zBJ0h%kH;{a=Y2Q*iJzXzTcx*~)b|~|rFUS{4ZFwY>Qm2$u@qj^5nm?qzCLlw!XFv2 zcZ5O?hZQ&fN<7eRxxv;w=~b0yb*JdHz?nbImb>_L9Ep1Rw5u&^9_Reye5A7>APRk1&R;~E$)w;U&Ug9C)#Ep8f4Q+HIj#PEn8M}XTlVh$QO}?~`|BjkX-N|UtkaT4 z@QFwx1v4WvI1hDN(%2lb)`N&?$r9F(EBCLNDSC8xv>$0G;n!3=d*SX`2Id|tlPr|Gob{`t|Q?Yrf7dp7-}n?KivMH`^zl zJrEIaQt}}OqvC@M#|0BQcpO}>b7(LL2nq@d2@0w{d}7kLC~?Am1J31=ES*hC4~+hI zFKB9MxESFh+H>qviC{s)G;tmV5oQL})P^7Nnx+zxrTUF<}U}{ zO|YNJIkAAr=gxu^_B#v@vA$(?b7F{KU@L7p5E#L)zr&b?^MD+m!L=)lFRC3L)Ss}b z=U{5sU(U?H#rR+L-TLqA9Rhyjr*D`neCRGS&-dm-v5a~F5-bb&F9|yRUc}0fu;a77 zl0=(R!rz1U5;S<;bg2G0C&R;_Damx;2Gjp(?L|&bwih%MMMS=>c6k_|xMBMmw(>B? z9lM<$WQd$x|0iUjM~CpYTYp>rmwaQCdC1KFV|QWWp}Dbjq7UCZRm|aPuc~r13H=|m zLEvP)K{$t$f})a=lBzCSLj{wi_(%|GB|oZareb&?xdhE@n-wX=iC4OH)y`Q&|v?5mNglBFWg|f z;F@rp;otp`;uG^1UTw8--h1c&?Nyy@$?T4t@3?+{H+2eBSfPL9CPP(}c@MvkQD&+%q&GAwNm*vV?FQK_G;aO339=M%FE)LTBU7Zjd4fu&)h z#|C-MZ6|NcWl>=0nCqI}@jhRWxux|1hsib823>uQ2Tcx>{=8bDBA~$Y@ynrm)?)v9 z6IzwtG}a0~FzDd^Wv}r;|JU;Q|J#mkFgU~gRr-f}l3$#Mj`ZJXs~c;!^Ny>?%h5AdbTSW=g3tq`LbsB z*K21cNu6K#NaVHafoJWjUSBLd+4j|*`TX1YQoL)gO!ncqR41izBc$s3L7y`!8H;vE zRXmi;5c|dOpZT4;?l~F%^}Ee^KdtbqxplSnerdw8>cz*xc*3<+wtAj7jAwc5D}TFX zpWMSUrDvp;rmMSf8wr05eD`xwzlm#BI_RL%5YAzQLV(~fi(D&vT#n;|Ojn9pnwzph!HP%|-R`_Ao zw(a-!PWC>TV& z&0pV`nK_f^*>e_&68X5zmM)WjO*=5<`{v!xSsr-oY}oMrRC>>WqfCN=t9P^H?%3;N zEo9kve?H69(DyG*b$bGO4%cYp9$tS)_3Jtrd%OF$wG#@2gNsk}JUV$cAiHvk_4EU| z8qu69R!$}Q_d&P)V`ma_G?!B+}|7tCZU!)xz$Upx0pX! z#H^mH9>RTF;$Dl!B|ED%oPuj}uGl|3xN~A<_BYP-XRl2D$^Jg}PHOY}={={m_xk#M zdiO*B!Is|om(fYTZMGZ{WYFGRse3Pud&1O;Ic@yar;eKK6PZ+JP~ZQ&@Xb>1oVRmU z_6J=RxqQ24qW^@SYuDY&K2^TXysI=7{wS);ViQoW;ga&S}ilI zvi_;yw`0e1wTwGg+htWIPI~b9u0@;jhDTZ=i5l1UU;962O38_b536_Th%N9aR0zB^ zHRf;I@4V2nFI}F+Y`=Xk#_veYO*f9f(yz14CAseM@NuyRt(?7O$+x|hEZ5G@;(PZ? z>O?2A`%M0K3)%fl3YMKXnWB2x?h2dY*1ZkVN%oh0Lkl<-yxbBh^J@3bdtyuL&HP!<)7F@khs<8F@5F|ipNl+wnfdr`obTOyDe7R#F4os+zs?GJ#FyXk zR96;kE_-h=U1NE6S8{9pmyKci&a)cCA1%yVnPI*6|D5okD8DZqD)Cje_q8|mg>9O& zQ2S;7U)RrEZ-3s>+~T+A%Y62}{kPui+~+dAP*X(TRx;!NM`6E=O)oFc*mLW^#K&vW z7YEG_ykNhy-o$J{M26n0)4S@fPxd|j)BES8+#}Bpr!JWJ;j!M+>aP6yIk}rVRklVv zQ~Kj?xy_%w-`d&Y_Gvr5(#t<;=Kj{o>OQdLEc26`UJ zEsDB)_9;BDF7~*;=ia>8HuH7f6y2D{n*GEiK=|y`M8n`mreW6vk zm057tl5Zi&htHqYe5OBhp4p_Iy06#8d$vt^vS(|y4cp?)k)0x68)xr46lt;G{Tj{p zNB=~;TcT?@@%5`d{#E4>v1g(l@17oa^(Vg#8>_HT@F9ccs&CdteR?_}TR80$=d)8j zj@fB@I|VBzhiT{Tg~jX3do?n%Gr6T-JARz|V}@I^&cd&5bF-Zl_o-ixyLdbL zd-RN>0T)W;{urEDsbFll!|Ds)c}vyCFB~eBF@A<^%FTBtozI%QH)FrLn@!n+c2)x+ zS!bU9<3evmV_&Eol`wtAd*Gh)Kb~c^Cg1Yoz6I8A(qi27A#s}ZV@++LlAqSHwoZ#u zn9~gR9$A>$mbB${TG}SzoxHV%hs{rFoc`MSWwZDKCf@S*(|R_xB(Ccb@r&&fgP)VqUaa;JWJvi({1|FYPk*Qr0VS&fo?tZx3}+2*hD&A{W* zjYBp*JGRfu3ZAoW*A$cXWqe;IX-8%r`uZ*0!simdc~rLr@Vo@3?jPv)BGQQk1%W(kZp zod3A{zUn6?Q8&YDM;$WxSbp-o=~-hxpM6K%F8ki~-%LMSubH<<;#AW1y^sG-`1doL z|NURFO*+q3EYEZomUVUVNPX!pWAY)&d#aJ>gGg(s$7?E{?|7ki?g8`O7ZWYsn(weY zyy@rJ`)-pG7cMZCbGp=dyo!C}`hryPePUMe)3*J)bIez3cd6a^>jK)}UxvQhyp(Sh zhZc|Bs-IK0#B8l%n%OnWdC5(;dAFUC%dORW6N~Iu2qa#(vCqOqQ0`2lXHJT|kZ`tz z*#x=i_cnF8d%8a^veucpaYC-*@-zOaUxK){?+Q5FK3CIpO;?NFLvy3IGtQ#I)uY=)++fvl?%i z%X5>Gf2{dx*1>PgY`XBT-2S}f>=s4a&R;L((C;vMW>UF4e7Ww_0LLTwQ_Qxd_UfFm zc)!W!&4OFozO=BI?wOmgD^Q}`CQ&lC;9K(&`IhWe)3%ou{H(~2u-;QSCFZeVdFoc1 zbyF86+3$SzglU#>{ZB2^%{O;-gs+;r`lZeBwes^yAL|}&Q~iFzWXIRNp0~^MxKloy zsF`JONA4d_ytn%FX;V7XLnkgN(tZ9p!OAmot6Xt|*@~*Vs`Kw0+aAYg|GDjaE0=w4 zS55Sy%!0;Dy?5<>4WA{v-XD#f`*Y^5t2Q5>$R7}wIT+$mzI3(h72{Xe{MmmOtgfut zx8+y$(c`u&4%@o0ZC#vnAb7uFkdm3G=(QaTR_aQMpA%MpkKV1bTB)Sq603W^NBES3 z-06G=6=yH*`ZtkBPu8-(|GGx@$;1$ICVQJRD|YR!Q@e6^-miK0m+rrOfBgyTIbT=T zF5OgL>Hp>Q3i(A`_mp{ES}N}IN%0+Dd|RjB;Ln_LNjL60o-uXtr-zksIcxOiPEixyyezG9bLX6O*N-#>9m+d%ZvI=5)n}X6CLfCN z-%Srmp5HrO{yt}ye#gjrS&-BB(xY2{ zUY(oy>h6u#A^xvUpIDvGF8)_!U%bH13x+dKio`fF11F=8E^SSM9zP~jc&F(cmJ^P?+;~8$Xq1xGlHIVb{kV*WVsTy|x6EF0WFWcd%j~e|WLL#w(7yc*9%n z+I~^lvb5l=zQV@FJ-L^KiyuVvUfIODn*XrqqqvXD9ObQVUB6W)A{aEAsqKc{@+iC8 zzuJmVnKiBUG)dYSWb$W{g@4J;1V4+QP4C<&P6`YXz2^4qPC6s^2vZtd`J?VPaW=1)aA zw@H)FEdR75GWVhB-BnWG7k|#vU6?V!BypedN|n`4Yd-}yCyR>iWaghY-T&aN)SW@v z?@p}sUAq5fyUM3sJi5()jAgQ{vPC{kGnrc;(rdaS=;=BRsYzw)9QQo5C|~Kc*&)%# z%sVaLFiDpEfsv}2{r)!9nePw(xpLDl=jXm^mX(Qp%)6#1_wVD{&C+>xd0I|g-PN5( z*2T^73fy+=?V@g}U3Q1E67#AAOX@;mgR^hO$>zID85y0c+`oRZ@8V2zzxc;pD|Wx< zT>bauZ;P8>U!3~)_rdb+sIB*Qnrl1froWp|;1hRzf`9Sq9hxm(OHR5?aI7!3vOSjZ+Jf; zbo1nmPYR357Qb0H{XP$Sk$vg62Q$Sxy(dggm)`HvecyRocjWDhYc}6jKO1fC%X+F{ z_65s5s{yrSxkx)*H5C)T{YR6Joq*uE>-wF_edV%46#{$BR~!w^0$wpGV3e5abYeqQ0_be!!@r=dXY0 zPX&Ibf1%<%tG7tAe~t`fU$^$rx_2uNx7?l1|LT_eCLz@pR=c^gzh0kaI&t1^FV`eJ zuf)&OL;}`dnsDvr(`|o`Exfx{f6BBI(b8vDwYwW}ehfaRbG?`AV>;tWuZ%9~*-bNC z7_;sjwK7@Yp3rvKhW#R&MWkp1((9>!g?W zW3%NoUYua5yR*KH)!%7We)%J-in$t(4B6te?RSIsw_V?NZ`RG9Ywdb;S)voB-8L`!8@}+j)dLQzQwx6E=3m<-TL0|$ zI+jwF-;>tAo3&qk$GmM!{cg6EicHUUOBQTqT9y#{re5Itnsy_zv|YrKfBj>nk0+2*~WK&k%?9MxmJF<8mG@!sS0f@YP0hs`Q@!`UD&1F+IlbX`#_Jt#O(a~N=PX-i ztaf0(TlXT((EU0Q8-&;Cep{2Z`&wu)=n_k8(srEBRGd#9}uYb%`JNI1=$_pvCp z+$r#%-TFB@XCK~_=iKw>YDL`ltB2Q5Xw5YaU3>As^U_kWCyvhRLnmyEEt&7LYs#)` zp0O|VKg2yzUn;?JQs~Gge)9}@-uo}>vnB->3zyWSZ9Y~}m}5Sv=lq!tf34YWcVvE? zb+pjvFO=j9NPUL9&HI%))_GO*NdgHwF9#U-N`*OkV@OD)@nfoTz27R}cR_-#ka*CaJr{vAFC2A{q zv!jmOIy3RlPM_^F|N8IA`*|_^Qq3$S$1R7in!RBZHgVaVv@H1F{C(xsy3IzhAF9>4 zmH2s|byrnf6-s_LseSHjv9x(VKTLbSGw5jDvX3$oBMbJ`FaO|tl*hN{cIkP)ONY*| zi8T3qXigI9G~2f; zlNTy<+gIYYv6^V^{^K7?&itBNeAeaD&ah=?&saxIGg?*~wS2ASuL+-nKRFya|6VSTllv{rRJr+sD9qaYiTdzHNqv1y0+Kot$wm*WzlU%3pJAt zmk)Lf;g{||GtQa6=ev?waP*vs>-9sTCnVNf+jF7fsKUDSF`SFf$=>t3ZCC8}J@13} z`djN>99huT7{VRPdV1T_O_kddR99?2v(7GRr{kscgL{?V&#(#a-QM}F{J+H$WTt7E@K z;;z`Vq@&MRGykWO?E}Gg73~MVcuUDCoRix6^68K8(>XFPRSiqK|GM?h+_LA|zWn1S zUhF>RRr=|fX1d0!|0T=HKi;1iB7XAOo8@ZDHTM2B?V5VCTd@D-RAH|@Mdm@O=dEVg zSLtXkKhybY%f>6oFW6Ro-^z8xWOaMLa%`>90ddKIQ|sPeobhAsnaR1rxf3lz1YHWk zOhcy~+*wfX-1ee-Z%&}-(Z?-n*-4Rh`Io;>FJB#^VJ>pt@l>v3(K4+c?|&}xUE!^= zi2qmaPP03?@-IUL_k5PvykXjo)7NWqKducF$vk~-1?S3&*2R4*-Z0&Bp5kJddiA*D z^=V%wg~y!Y(VVp`EjGL)YM<=M8lJ~}@4CJ`dt|HIJ==EELp7O0I>}R%B-L4GPk3(I zzO+dvC{@3>z}ZyARQB!HO19@)BqH5*#m-xA8O&j5qoy9KD}zv-w_}Ir^G) zt6#CrZt-}QcimT259QPe7z^E0;j0Qt$ymwrTAriiO6%F__YJhR$wmKeySaITp4uG2 z+$DESC+-UWzwnR4uIrAc5_Kx(w5Z!JTkxu9$CFEQ55JmtGtfrw^*5`#2M$<%_R2Qj zy@UC=L&nx;ldJxi&X)QnJBjy5Ay;WgV{LG|8ms9n*#isXQ(RpFwa!lEyw1dOXwn;z z2U9D%yWMmYm_L_k8{awiHLbicIeYGfqhFUloB8n61lFR6xS!8Tl0L-wmkX-2#`Ic! z-%y$N`1OB=*E(DlSmrJ<_n#Xo7@8WucTO59n31uVUoAIToK<1_D_pwijBwg}(Lm+Vw|avsdln|}oLk0s>_G>c2aCgXc0K`i#v@Df zy1nnSF)<1`EO>L@Wy$y42CEz5&zKAZSYId!2AD|pO9{1pZQHpsx#0JozZ?(RIT((l zrY>!*-_0DdXTd!K4hcpBhU7a7<95g@CRiNc;cRp?yiwosV0!uSgn;cwkNo-b$K_yL zM&Od|vllfO9N=#&WS`-5F(5yF1^0vSlMK!q#J~7wE=sXsC@z=yrGJ3uW!FdMYG+0Z zW*N3dr3)6~@-5s~q#JI_CM;XbZ{Xx8SU>UWeXyF(H5AAO5TO&&A^Wr;N>6 z!9!m}qOn!+4#PSF3z38+EA_iR9_L^_z%f1E#XzR_$j|25g9a8iB;9|^wUSt{GKq=d zvDTkpd8tRd&WRTmWk~!9?@ii&=s{m3^TS1LUp_S{8DwmV|GDz;o`nK;b|xSFXL4P* z@ryIdzr97RiZL1NPx5j~+3I zORz8(wCy@5kn+E;&)7Nkf7Ih&?|DD7-(V{IB+SlGzxUtQl>Xou+(L}U|IPll`)Ja# zs9WVFy{-SI{Lv2x6@AIiAu@3SYsU#MM#e{v9tAOEW_mh&uzxJkoLK+q2YkK{hgTO<0U_(n;xaTnEyLVLBV5s{9!dkO;(2L>gJ6pJK`RPO=@r`yc4p^ z;ctDnq=H(PLsEerLrm{MhVUikH`gEQdi+U*S^3VKy$1#SHQt$(9Q~v8=b*}e;oqwl z);BB2v>cNa<9XYez2Nu$xdlQZ#m6icJWTjfKcg{d|CxLLjUGhA8MN^K+Wt^p)v;#J z-onp+qpNpR{g3;<&u2kEy+%t;rX1(Q?oSm`S1SY8A9|(!scue1=~`>OqiG6ZLWg&M z(6|sgUnM;I*}7GePYW-*sPp*fsTVJQDuf+u?&hrDE&lVN_RL$Y5;nb!yjPtkE_$f1 zu778NjGl+scF&h6wwjk=pQnFcQtcSMRo-h~`Qq*GPP}8=}a6)~{5e@^9zJ7t3~^eE;KnqUZBfb2-n%Z;;;RX{nrl zf8QB-nG;O1;;+A6^|b9=mb_1H!RbhYS!PFk=FeLHo2U2qYOTs;VKXNlIvVpz^z3e@ z2P%6%(p2|c><+u` z=&8%kvA)ky`5i3F5qHD=!~sTyyf<}!FDHma#uer*?%#iBl7o;CXVDLXqa_cg%$TjE zmpFeR!*t22?-8M=B+fNTm2QpNH|0FTg^eFBNWK=3D5_fXv*(_O*xx@D3}Lyo%Cd#K z?*7_Tyu|#Oz{%PJe)huilI~93eS81pUq0@i-iY=tUC<`7%rT$w=3|WsF%xX0v!Ws# zGVWYlt6J_JSytGkeN)IKG{tXo!n*yf({n4XKKo`nbwgy9m(}@ZuWz@WO0C@J&Ly~( zOVTLuz=Z3;?crB^zfD>xZMJUampa8FkHT+uB9j$LFKEBn_xN2%-ihViJEt;b-}K#i zCv59XPWvhI;x$A5CJMgt2p3EWe=+Na?#s{DGCwbO%AR`chV_RX?6$@WrThAi-`M?* zM{Q%O{rp?6Uq3p1#}WpABXE+c^D~wJ9^hQHZ#M!3mHyW zI%c*kJ7XT7d|`HZ(lxgr{f$~D=Cw6XxT{;ediR=Ff^4}*Hkxe@JMF(HIk?Kyn?^2@_AR~nb>u=t&oTG4#hB>eHg z!kcw|(Vukwy)?haE`9TZ^elVHH%?zOKlt7~nr&&qJ*WTFJRdghqX#sv=)GY~UAn&d zr|04uHL=epOmtc|+2<$Q?%(E8&F3F_

doDnGja0S=jzf)CM_?&_!_npCERVcam^P~>AWaC zZ{dbjTP7P7(uqQc zuez@;-&Yp*KwtXUB1a1YOQi*=+t+e79^CapM33#z*|m2~pSBhHi*cM@-(GRMV~zQg zjOMw8pZvL=o>XyK8GOf|W2H>Zv_DIwPKAdYZd%uO_}1jS4R7y#STX&}vkhr4t{xP0 z3BQqKbvs)rf`7A~wCy)0FSCD-Hbx(~w)D#C2KJ!8eID%><0KB&y}UowXV0NsC$hP> ziL#mQITI{qRa`PTc+%2Mk~?=j4t-WVcmJ}Y_Z)1OO!>>2i*Dq!*1hbJH?0?DXqSJp z+&uT@69>J8uNGDEu77;p+A?HD2)|Upii$5SswrI_54?)TbqXnSDpBEzez9F@rYXg7Au}` z@YkCwb#o2<*8Y@ytMYo^bH-hNr^P;STJ`&{?kr6+rs7JGId-oI(x+votkFW8y^o? zmFedlvFG(mPEkCW)yLn;de7`&@!kF3o;{!Or{L!%k6J|)*&dD8iMO}ze4+ID>CbcA z9L#)DecJChy+5m;5tsEmd33T`e!f)8>t7ou=bg!K5er{@y-U-C=SG*_ ztOGtb*{g26(%WE_X>!DN_OU%&=U3kBE}6LN*+0*Phq4UQN;bR>Ek5`oIryDNPf_!y z_lkci138P&ZB#FKaa`|V**R9}=Xd@5?YL*2e!sh+>J$I9wd+JA4n=8bcD!|-FthAK z(!<#w{%Hta$iH?;TaAS8 zC&I&jpZ>$yT5Igz6@N^#Qz)GOq@!NiU8`I6?-fpUT3F@=&E-8VAR!a9UPsmIYk}m7 zl^5*ZK9fqB*EgliF97%LW&f{c^`s7}%nE{WzcAnz3RZGv}#;{Ibk<4Vf=5T0c!7?2q*J>1`SpOSaF6 zh*_)6`^WWpKw857%?Tb|>yDV;GbpWUy!dPP=Ra@#m#uoW^pc*&Ece*Pr)z?KAFDi4 zdrSQ#&!>meRr>cYoc!(1zrtgFZ&T~%PHX+t(%Fp`!;P! zU@+TyG;smXRQWG&!aAf^7j)Om@obM=@r%Xw>diU}^;o37v|4}n5sLA# z*3$}m>~urzj@HxF4AYF;Z^Y`_pIm$3K>3mRr>8%wIU?kL<(uw&`}^M;^lTCsE7K*4 z>!YpjpJ{r`$ek&Epeal%uv=;RZB_f}AFJF_S6}wl=3b}gl=|IO*2}L?bARr?x*hr_ zr@n9%TkRh?)1SvXu<^po89z?4SKr*hQL)>*y<6w3?ToXE{vUQ^v*`Z!&#+i%x#p&C z+Qj9PWP5wJ&3eSEEUoVe5Hb1$wt?T>sgz5=b z=Kpoc)uz9kpVm@QP)l_NAY z>0)-zl7D~hpImZnQ{A-tI$=d>igiCv3*Ndr+c|x$u4DV0#gl)VuXQ@Ce__u|mebv( z;%nAFF;mGe)s#4U!1uQp;)_Wmwg z$+Gg-s=vKktfktM7hSkwV9${&KWV=9_ZziseL{<;rltRmD=Lr)+VjF~zH7VJ<3GC} z2wzT~+;w+P=Zksw@)SRQSlG$N_a@gjG@f73W-qg+)d9KqmlqBnUuh9^ciXY1gnuV` zWliLzud2KY<49c=bn|849sSL>vwm&k`BajnD0H#M&a5cu@UjJ+`{qwDop{sxhIG$n zv;Vap**$Yil6}6hZg!8DT%%_9@qzi#Yl_>M`nOMzPJMgpW`(kf%A+eMUrl-b!F`kP zs-&lHoAf8U-d|;ZsY7$c-wX_FuS@@|GVkUO zm1iA=(`(l%f4r5$H+SuqZTidmz6GA#mh&)srg7zmbn8cp-+1@L_>@~_r~MHM-+eCf z!Hbj!{?U)y%-Q6GW8=JpSo%MI_1)LNdh<4K+_$Q`KTf!>Flt{O{P6CYz|%pC)s8gg z?5USOf8l`%f9#vGK0TE^PKKvWL|=I2u*mnqHzD&~n(TI699};4WlH{A@b3NjxG*#@l^OP;N~(lS^A~V&tJbQrmc*;7#i)jeL-q|SXIEX z12G3~KhNG-#FK6CUMQcPU3>1c$qORl=EuK|df6M`VydhWH^-*%_qvWc2Fq_V@~7?l ze%S3Rr;+^18il6v_0CNftO~!RUwV5vX@}k0S2geY=1e;HlEdwb_?>W`YZH*f6cG28Y{E@upXDzzM^MvXJ4PyhhI}4Rh-qh!Lajfn}o$?k6+(ZW1n19%{!}c zsg^x`d!CS~E2r~Tw#5ru9{X&%V$@x=vxfIkne_}KX_li6=}M)0OpZ@*5%3DQs3E)m zg8uPI{mEbL_CAlZ(#YH0pY%9#VdF`&&Ijee@rxOR?{2f3xAx}h?MHm2UoV~BAM%p> zHpiMb0at@+ENzqt%Re-Rn!*FU^;KXePzeGR^__o&v~ch z{1gjWv}Xa^wu#=lyJyw^n4$mbIX8^I^ln;PZP|3I zt>~$-#1o~T6X&vBEqfLuxyR>tbJefa3 zC&$v7D0)5RN^{UGjXgTXWf3Agy%Vl=%yeDDYSJUHK%r}zt?9G$oR2>gBDf9CrB6tC zz%li6Wu{r^GA7Rp7k3=@nD??i$z{2I*Jj0rhF_{dA7hlY_*dt?+Euweq*GCQ#{p?> zsr&JzU);IHCf2WLKNOZ!`0LIM>7*#-!=iJ;gVIl=Pvw3oUnU(_eQRmY7JkK^mg}iY zR;cZtebv=?=Csdp={YW2vp;^x)7BPP;qby~sX}C5)a_GS6Pr&wZ_V?qy13-K#|I(D zM4L0yf9gBEj>=@%T)RWs^8$}T*}?l3aza{;x^1lXhUU(H_?OO!W}5VL(yTMf)ovPZ z@ZQum{p8E8WAaC8PPd=%2u|xSHu_-QH|@og+5@fOl4{b)bELvLdGpJ!daMjt*B;8g z^6U1^GXsNHzF2lvEPG$DkMP;!EX==H6XOniYz?VYiH`PeHTzxpib40C|6K1k7fob) z=U@5Qx%lEvN#P%UXBeKyIiCAIfAI{DOZz8h7wGscE)5F|H{qRXaJ(ttcFP|jmOG!1 z)lb-K_RpU|Px#`S|9xF9n$i-wE3`f_aTp&xp!Br! z;ofugt*zKOS=J?~3wT$Y2$bzhmA<^qvAjL-p6lALj#un4@c)64^H@=!o+$n(%2*7;Gc6R%bCqme(zo#Fnia- z`5{UdGbAeKoi)E+a!)-#(BbpKn8+G+E#)u%|AQ_+n_AkWdHqSpF~bcK3uET%ZZiI} zEW~8@2DVV|^v4&(->Y0-pm=z4z3{Q}O!ce2n*`pR59EHj`pSbXAC}u%vrJk3iu>jn zyD!=4=U%cO^@^bYOfd6#bG^zIF3DZL;!G1#lC zS<2z>^~dTH!_Ky8zR7EBEBLN{?D(0>QA-qmd_Q0&RMK^C?zOxZJlq~(G1{uHSJu%#8PzJ=^vU)%{ajazA#n z|6Va!Y2KC1+qA#!-pUu460~84Va=_JccLZx&2^1ETK!Ia`C{T@y)7TB~!jp&gF4Y$@Ha0Q!E@8Ch*?BGW+G`PYkoq zIrF?Ktn>W8c1`y~?l;X7bp1TVPPPd-Typf+>-xQcf5GSvPe1Sc8ZU@O=#*;E?b`+e|*-i zTAjHjt9s_T(#ci#vtG@~HF}#G#jCx}L4A4FNq_c*J&Uh0aUXyD=AUp;K;*(u<<@&1 z4IbN;Ei!tqHA`Tnh<2-xU5H{~wZx~ZiGT0REt)&W-tyN!w(j8EDGJj#re3iBTAupy z!wcm-7vF1mELAI7|6zAn)RP6V)xKw|(~jObJ0)gsKleLP0j;=Ij&83v_#R%pxzzQO ze$DCw(~B4WmNPz(xiKJ3D7l;X?enFQ=DQon_APeUP$}zTzv`F&g1qlq zPikkLjnKQRqRVuMcXmRo(8XPcjBFK466RhloHI`#s6kM+y7?Ge+OI3C|G)mRuqnoB z;qwSZ|CJ>RzD)LLRtuRTn?6mWewN2}CjGMW5o>H6R!&P3kC1s~Ctb7lW@O939W&&$ zIdY5p%9d8#=XfYKJK}=)t**CTW;{7FU;gcP{=^pjf9mBayQ{KY;=R5~d|ZB3_(0&g z7iTs(uaS?4yPNclvuWGZUDBBv$<+^6{JxYhbr17$&g-GO{ut@;s6DMVHLkr?k$H2! z=7OEVSHyk=&R0ovTP(w+vE={veAB-(9-eqV^=H~Ew|->>jv%|4<`#nYPW=CFGubar z_H?)23*Up5lTUE)tXg|#YVl*U52xoDns8ex8-`jY$STDce(=38jfEj9Gb=MZ{Dpkg z{H;}X(LR5IqYtZ2ydt#Zs&1Uv=`CsrJ2(==45ls@p0UeS_iNilP1f75TV_s}$50$y zT%l&=7A3!Pcj?x1M{I7mZ7}*5^lHzX#nJK^m$&;WhotX}etpBgUhtLl#XB?74jeaK z5OsP#Q#-a9(!9UvG4VM*f(#NCvXM*F!1aACTQycgA`m}E!WEXus z%d^Nvq2=uMaJi;sN3X5AT_d?oEdOfH{^|PqOuCaUuRE$(zIY+~(a@F4Uwz-n5!2}J zlPulwsiCukXW~z`XS~WKQ&zdGvzat&@^bT{ZQm~*ykdD|^Fy07g9&SnY>G9^kjPtg zcS3G+lYM>f&8JIzb9C9SYYSWQIG)|xvrJ1`>(j#>XY6Av+`Oe?#XV%q3~$!GHTTW_ zaq|u@>wB{wbvI5}zZ3Gh-0a|a)o%I+j-PBlW|vJ`_-EFy50{juvbXqauYD|cIbs6y zUR$99%}xa=YcBVTpS-1Np4oG^=yYo(*DrR9iQAZy7B#VLo!=nPo6Pn1_={Ob=l%g*4x=K9JFn;Cz;oLn^m=4#?kM5-tK7GiR;eoy0_EP^z{=vz7G?Q&p*o1 zFZ}C$wRZN*ea}}5wI<|CXB^s;rWQa^VC0Qa?kPd^oO;#(`>n) zzcqjU=s0V!o7I|)Ds$d6T#)_b9d7nT-!}oh>eciEV>Y@iOGi;L%bax*6%(B>e ze@f{A-EW7>9@m5me`&h?B=A_gXx-+*`L&o0DYhv*w8at}x+va<2V~i-}pUGOaqt`q8 z$>FspW;s0B>gm61gPl_Px{y7O*4Vgj?~Zj%o^EmVSB@0N+!aTXn$mlJaVZ5CJ)9QY z{%!Xf-X}9m`tLF_xy||aHTdV*YYS#RGn*jk^fl+%idciiU-p&cU27=3Ua>p=#~o)U z|I$O^7d|OO^7TY<+)4GwF@1Kw=a$S#pHS|OIOZ=~iX<66s=B&4RJe6sId&<@_qO?q zmx3phJC^6q|7e(-^SkKO*{jpMw)!4nE#~M8QvDEi$wlZ-)7lpi1}D7|WcHqXQ_22O z^qp`3t4iBL0}1X|yW*K74_dz1Da`*va@Xv|t3524D*M=q>PjMR3Y@s5`h`(yp=8f& zgY{FFWa$fbRPD@fwmI?8t2x=AwYi4jkf-;N2Z>$E&5Vu8)~lXOvsv)aDQr=z^Z#l3 z0m~xu1XK=Jyvv-jB2H+brum@^mkq+vA{V}$4?C$C^B{YEj+m{7S>pWHJa2yOOpLwR zJ>OD1F5~I)0}~hCn$)bNoDlnrGp^Y7qEJv}`b#G_9~JX!KYs`LR&8A}>C6n{2Q71K z17>hMTYq-Ok8;nu_P!UNPkueS^t<=>`}6Kg%>LM-`P!{+);q%=ZaNPGDx>Sgyf$s~3v+L+MMj>T z=RMnEctWT8O>v0Wzh}jk$9FitiIh7ofB0kd30udh&0CYx6w{(}7JXw8+{Lo-_CMa0 zCwsX{Rv%!siaYf50Q$6l`baB6|v>}&h{7^l^o4mf{t-lbmo51(9=-n`r7t8@M4T3*Ze^NQO8YQ$xV z8Sj;;NZ5W=vzdK9pxSHyZAw3R6{W{O;8KIOgjVBpi1@7$ZKvox+)idXRZyxDww^j~M4gdP$_pg(NQ{=x#7i%;#HC@u3@UcXP`GEJf&na#H zHicGODz!RK6<%%s;`BemZTIRAaa)GD9Xb4AN$~4y#(TF-4ESH8ac#A?_lZxN-to-W zj$-1Oo~a)xc{^v-3*nvyFQ(P|P8tf$k9%2NVRmcI5ek@o{i&Pq*p#9lCdG*){5cgl z_uAsZ$XVO#So_Ok`@XSlaGDU?Cd!{U*JzdRsTGdD9+^$vI`#4gW{;az6Mq|S;oaP5 z)$zGe_vC|vb5(RrbPgtD&F*$O;w$yH#aujueaa%mx21QR{{7=Q&C{Uj_efPi>{Qi( z1d$`(->y+x9l!FI;ojU`aw(UeN){=7^Z8|PbTD zq4+QJ&YZ5Xp0jq(i7>75!tUb%;Y%6|pO%%eEU7#n%8{t`L))i(TZZG1j z_`fyrP|ei!Kb?N9F{B>KZcr~s5 z`fYkJ{c}ihOmSM-j%R+R>9%V=eB5H7xN^>S$xBy{hna}$ZQ&{Xygg#(|A)tSO*m|& z+2|J}pK3gBZQYlQ!(Pi956ProtGerR;6?e7OSy^R2DjC(&*c9c3)a;kxh3`-wkpTCU6AT=T3q_JZ_; zQ`aX<-@DaH-<)SnhwM7#a~dIs-&?uudAcx3;kJL;rX_AW5;aTJV^n?q2(Z)WKTGHRFdX)R<}IlHAkp<}^epDMFz|5?kgh0R*MvtC1>XAY}^ z!|iz)-6toh+PoJRo9ED3-m!X3@g1#2(%pOO^Hx3o`*I)Gk8_(N`4(C3c(?lLtO*+w z1C?ageN@VlSv=wMq~3(km+PMC-98a}xAxe-_UU@t5{|e?7A>8>e*HIx2eJ~L^L8?q z#-zm>H`Kjb#M=Cgudv(_(AS=I z`s{wQ(%5dBH9dz#_S`(5^D)EZU)s+MFR2@rd$nf%-_zLs=<53X8wC;~uPvCRc37la zzRJp~Wh`LGa#~$AYw_NlEgNq-yB_&du_tEvyS}(wZriwgE}1$3r38tHRjWf*dE8(2 ziK1gdOmu=*Y}vbnP1@Qu=`)nWZ!}l54WtI znzpgy+fH2_W6d)a)p_hu+7GSu&h9xgF?7+i1>9B)E?P3IPj5ZhP;uoGcXa}m^F+)0B$)F{) zDoE$d9eai|Jvjv;B8&PQl+(GbqYahQ75E*PGnfJxZ!t$iFs?asMyEi8A<(*--<{jI zIGtgu;o1F745iu1!rao_?hU)aZpv^N zY~8@da5OSf!hJkhzD%Uk2bYNjKuGecY%-L|PQ+?@ZPXM1Vc zqo3@&CS}`xtbg@_@!bE7YkL1B|NYhfb^e;gzxV69S%`@>bhd6Zejt9~%ptM9m-|a5 zZ!+D=T=2&_=TXxC`zz}?EdL(nclg`iX2Kx6;H7Gy6Y}SwtxOwrA z?1IB*e#HA8`V)V?KDz3EvykA%;_pch(%20)Y&2qyxbdH{U~}QGKlGkzFL_e=z z`OjbT|J(noXE!*MFEG4wYtvlA{0XU9#U3-)S3JzIRJr?R%R;HUM%*t>g?#VjTXl57 z&d!4mMeps^ikm0R^zh94_&>X+TL*pjUE;RUq2+PsNsUPcdsFvJPuf&ueE-#2^QC{T z?=twC%~2X7om|;5`-AoKFJHGZxZd*oc4p4!tjum8>3dB#T-b9UwndsNhWT^Tru*O87e?{hXQ=Ex@?d42 zoQPqcvE-6YmNkL1cfIG~Fna8}JA6)+_dh?aWfynn{@Qh4yNfI4dWX+lwOG6NvHMi) z>SfcP?0xa_?%X-~>yOkW+`5zyxZh`&^PQ-_Q5pQ+PgZQXb0a&l?Zf;d%Qv2u@xPmP zd(HQVeYwxi7ibF@ShZiuW#WA8BYEHBqjoIQcD}IL2j5S(%+^|$_0{FUmR9dizl`5n zH1M7}@Uw{NX2*KD`tZjw`=eY`utNg*uC^!!{3?wXOW#d#8sfI~V3%l3Z|DTgcm3@n!9tYiVVVOAgsDm0WMv)tl1P)Kt=HbM~pl zonu+^0`AC*Jx}@l?Tq)w!0t@b^wdhTtIVHdO4~xBKK)$2y~UvA(1G=Z2|02G-9P6| zx!-@uIo&G8#?}05;s3AyGqYE{yfIg&>>iVCW@^yo1vSTCTx*f8*HdQsdHcMy4tuWt z77sPUc#}sw;Rm;_h|sru{4*G zk;TGwPrvM`OPnWE7?5h=+4r%=MON-^09xv(=EFuS$L4%_UX;f*JumNAcx9uL zfTi@gxMe5xckNo^xlc7KbbT*NVd*N3awWZ-z(qIroUW^0-#uTS-E=#%5K@aYYqyZRN&})zng72 z$1$Jl*Ea}vueI5!lp*G5y?y_WKfgn7zI~tAyl-RrXO}r*NsmJfnD$=e-r;`9*tBV0 zm!*p58mTvYJc3o%dhV88)c5#hvF68%mV3vWw8esyrf^@@m=n|ZY`=SbYRtidi`ORk zIydZH6!0{P^_je3>z}8r{n4rZ-=lQC#UIwN{BugGODSI`Wb?E9T}-ntoSXT`x!1nv zCCl6^+TR?nNN;ng(4TFm6mZx`bYnN0>J0_SZga!;r|Y+VJ?Aj*@Qvk)^ZC@4rf2wH za_C#DEVryWyV`!Y`srT#E8fSq|IqQ9B$vqRJGWAH{@2ZKxO+nk)04JM*}nazgtfb2 z=FYrzTD3b4ggRHYxB0%?*Us_v{J~7!@Id*hM32X(gzL9ITA6V89A80<(X-6(Hn%slCE(|4rQlqhyw<%*@ANrUK0K~WE&lhwZtaSnwVyd__WLrY z+z@Bj)~ILOb9s~AK^HkMcFvRfaq;E4?;rn5-ooB=)?V2ys4!sO%Joiq@`^utMSrep zuup$4-yHnE%!DnJdvD)d&+i)fPxs{e{3&JSWsUEfeyDxp^sS~#|5)12a$2kswP20p zvS;bDFD746V*OK;DgX0>iTmvxKbp+=cGz!DR`S?&xZrKk`cNlTuOmNOgO2ZOJkqh} z@HOMDtJJsD8dnG|Z)W(P&eChN#aKDu$l3XK%$aW8QFTdqG$U}+*?@bk3a*!BR(#{k z)H76&Zj)vcZAfSe`N{sRfI)8G>f)D0A9a`3^KEb27Fzd1K|uCRxFc7bVC3!95x-}A z54gWjvG~emhuw$cey0eSHXh(son^20hVzs~luwG=&-F@d53kKoIy3vI{JE7~{OoDW zciXhL{MF>H*YtX`xW-Q*ll$g*{tx)(D{mrcDjF-4sc`I?Lj1FGd7af4 z&QAH3`XT(}r)i7B6bz%Izj0hr;N0BWlQ3h;N7YGAewQyTUwQZWx}IbfhlBvl4ci&# zT)iBn|MX$j#ir;h=e1{4I0f!1Px-TF=bzx3l{3?~=e*P5tNa$k9dhMT$qrBE&rJIM zQ&&yD9VK+}?rAZX`87xWoZ5IaYfb*NjZ5~~B-a&~*k5ZtxPHqC)60D|XR>uo7dc$( zm*iH7u$(;e(R)R!#>;gjnVM^Yveh2H@MF}ywK>dg^X=Rz4x2Yi>jfUR*0Sv_x%%^& z)Zavr*4kZFW#%#_U|`+x`)No`|P#ZRUAGB%nrOkx${{gO*}#-EKx4J_Il^n-YrE!zacilVqi0xfvG&h_1$Lje{m*|!iOl;*|_oaVj*{XHLKl&XOE8WrE+^ebxZEfP2*p6=b>m0GHlkte%tC~gAqdIyv7>3l>o?Fnj@rYmDq;i%cvAW(jwy%;| zk$)z7NB7&h`_KNjax=YHJ27I}nXTatAOFi}YM1t}P2yR*N~WfO`L}PQ#N5L?>QS<1 zU4GfTU)hj9Ju1ZH^yIp#llyWnm%j+u{ABwEN#ldtdxE+}1SVf!@JD=Ntcb~U72X#& z*M4}WH9_U7g{y3?VBV&1*%RNRG~aC1xg);a%vsHE=BDM(&%WG|Sa6%*_7xr%GhmpUnFP69bh)S8sE;`B%fjpn9Vqi^R5&X%Ax(6Kspyq`8}1 z&K_JLu_(jcU*>Sswhy72LQg!j^Y>0<)cNEW!WXyiiNJ~DijVp3O|L%i>T3GL#Z5DB z$h0@gXL9L*R}E%)bi(~mS6v?_KcA;+g46$QuD_r9!ox@|7ct6 zd1-TC$fSlze?OWp&a%+2*K26paV$SHbyAn_nY>`!g4t8jpC!Vu_ivR9?ecia#Z@KcDz#Beq&-vfiQoeGi?`_#4(aJ9Il+}x_w=MW2!mF>R z$f4OVJAZX=f7kJ3|MQ;?I$X55T+8Jj^81>!{L`-|XV>_7D!*&kv!Cg*(>cW@s#2UM zXVy-?XP=!fU1657?BW3-zUMY~tkNFLdetq>9cnJU%kX&1?C?2d_F~d;&a?X4+zwyt zS3VsW8)}wld~6C|zvaYiErY+!8k1xW{m6dncjw|?_Hy^m`j&ai&nSNRQ=0cVG#Ae|*?a1o-20DLHc!&rTaxiBsBN9a z^U|1{wg(qmC+-VLwE6lZv*6N#--$Q9<5rkTU+P#?QMl@lSLsR5?&F5>f`xzD)}H;n z`>BIN(!|bds& zWLDlYVXWB}Zo6x-i}9*yy*p0K^H^lL<-dB6hiaRXfF{RX50gh%=Ux;K{d`wcWs=_U zyQxPvpSdNQux6^vk;}_vFC|3me0ay|3>VktiFa0bhCEeV>8L6{H$1$^Jg~swNk+zZ zC*l3;yLLS7H+*NvdsO9CZ0+>j_tpx@K2|PuWb&{18y_#aa+cTomj?0A zl*+hYeEru08#lcA8hltX@pjFxH=cjpmu~vOHa(|Ydv|qSb`<~XIe*hvN?)J+_?1y= z=CaN=g_ZA0{wGDWl-m5>`(cIj*(Gt}+jbXwXmVR`UU>fM#-9^eru`S(v_5*;G>J23 zW%YjLg`8N;Zn?I$Z|1Itb}0{oPAvBkSzmbJCD%_Q7k|;MmGivp<$gMH^eF7C;+ZvR z^Umy_KYxaL{xDa4a$wc>(js5;Hsga_vu-)B4D7!l^xUez=Jna?!k0ZCZY)^#y?5R> zo`Z$wBzsp%@17o*FD-u6p}Uqxa^BApJ>v*XE1&sJ*Tr9HX)mvSeD}hOrFl0?L^K!c zD=w5wd*d(9`NqPociGM#vESd6N)fbH)E(aA8x4+|2V!+se4j+Vnr_ z@z*5%eSRtKr;RZ4NhWpg?y!r;cBEXLe#FpQd;T;|wzqe+-?IrOa|x(aAG^PFS>W$t z$JD6zze19~o4!~+^XHG3S-)m`@}E}`-J7|m_4fw08P_%Ko31YGJD}`tAFRL-@b1RV zLuXgLWckE0)m;0E`Ht@l9c5`NmojeL^nU8e3eQ*9Sy|Xin*`&VW(7TRTe1I|tDg^# z)6v|?1q*j)FVy=jdU%hzS9FZlmdy)Kd;WMjX~MDobw4+WiyyqVA;w^R+wb%(1#87D zxBSR<^LV>oT4nCS_Kv6Tn^xanwbNSH`ORTvg_%cfn*~@~Sq&O0wmeci^K&ITXJEjs zvh-EEwRwN;JL#lU@bR2v{{7N}-Z$<=%qrzBN#43nS8MTd@u0-q;MO-6r01_b_wUb+ z$mH%x34heiEY_d;h((Tl??da;pUWN|zo8(-!e~_g=%mfE`2z26^ZUr$S+##IQ=8-8 zXFtW2Zah2?{NG4;+LM#h_B217$(y$BPr$CUXo=O_ht7VSm%sh*)X7f*?1Lup+r7yZ zESYt_X~M@Jx=$BNDO~@3^f9;Inlpzimw*4YjnA!W`p%;)_E(O~HJ$d(T`O``qr{ri zvGXbw7evpzI=Mya&Y3AoDr9d@et4$)0@JOqBA*o>Rvl^j|EyksvCMFr?XBB;d9FRa zx5!$roIgkE@`PCRwg}c%&3mUDF6itpTN$ik7ILa`KL2{B4cfJ}8E0-w&f6jV=x*-S zIrp}AwW#js%n3ZYC&inab#2tj9UnQi&#%*&vo30nrShMRk6-PZ>>!@vA8xwc{Fcq! zeT|CiZoYbNm8knUtG-!$p~qAvTPvL%N1sVue{e4HQf;{0|C-%R6Q9?3&)zbn(6jBd z?wA8Ux^lt)4wRWEL>Q!Ec=dwqtuLV8~dKF(K~GP;dSxz z)h`eK(5!C@@9A7%^15iH&7~(^{dQ*~l6^K^-n%`oS*`X@N=%Z~+l`a;UFBC5Jl?+I z2tUU^i}xqW%n(fbx$L>rr8VvzYdf}nIPj?Q!y@f9TMr(36Y-?(+`Gkx zKByn?o$3_nm^$U|hxyNb|C7-D7}CS7=gjtTo9>0^CF?%@nYL7~;PjdO2lv%w=^coP z=juHiws;A**A2d1Q(80^aWB%$Jt*WSD44u;mW%MZszvu?o?MT-9kwHg z-2YwWM!xg9hR$Opx8|U82nY zfRs=F$IV|9uCV=4*8Z~XJSR^?bjr2&HLox0zgK)^6T4DqW0+Of((M}YZ|=p%=*Ro= z$rQZ(t=-)k*RJ|N-D0!cdynwe>-7_*$|p>+ov85S_O$acruA0YQ73H61VW6%+kgCB zY2~=sH0yBx%QXwD_HmhMACueRrr7&zvRx9xLHj^Gk5BJ-T>H;uGiW~d>~9EvkhR+P zk>c(z!sd(Qx3uzIJrjAQG(pB!B<1VMO@-VnXWYEl_CI520N-E`Pe4xe8Y#KVNAYnCH33X745;R*?z99P7^h zdAs*rpWL?#!47jwo1Z#e$h$Iq-OQxa*$s2H-$_&nlTAA`WrA`gx1#pqS=oCYe&Q=H z=&KF7e%{AcedhA6blvZhUAFEp;@R<&{c~(C^V;_gHtwtLzfF>mj<~R9^TS^W5hC^>=Q(-Es6?K%=wi zUPqJ3v*xlMy4(3nZQjJa|2`@`di3L8r2i_xYYLykojKgmy8{y=fNz4PX9fhtC)&_fB+9dF;BF7LftRAj?DHO(7t z?UL_a1jq?*T5vsY$7_48-3~{` zxAT-~k4{Dju3V&WfgPfZ44+SLon#nFJ>^A8(W#jo6M zpYT_)N%-fV8JB7=YyMjO-{G3Xngb8oHa$#IirBAsV*ZEF)vi1*IaGg5`p)q>>|p;> z&7$24`0wB1E-o~T~1%y;m?zAWG^^zoyp?fqGL{BLQaRSCC1tZFnZQm z+3(9g^@mgJPZZPp7t=)~rfN2qKdT73{7#Kkf@}J{l^ZYIQ@`Djo%n9INaAV@xrl4!hjE$_9)(K2XnyYjv|7rCat^51u)au?XI-_GG+_#Qza#3QOdb~;U zI>&j+5zi+~T#)#!r(eGF)yyrzdHdtK=SZpv?DL50C_cKQXVnw2mtVH-*|Z|+-|f(9sQe{Y;@at$>lw2?Y{~xMD420~g{JJI)WT-HILoi{Q{=Tz>VLE4 zuKyy~o#%e$+rxEF(+@Oc%jKVQN!uCDHKBUS|B^}fKHuK(Y}pGr!^eH5OBfgZ58&&( zCbQE}RH?)+?!MSLt&h(>Jha*tWxQJQ*UZL$-P!j;OaHZnC;k31cQ?1;h2PIL!j)ID zY&`n?#>a0#4gZRcuvgU9hImi?!2L=;ZuZONLR-!;dYL6H+?Vv%)k*pPtR)Yx+sk-t zh}wT*qt>a;!>70BS7=21v{<`EUHib=Ehf6Vx-T!vjGJD!Odx2jt@X9ONl$&OC(Vvd z`4Uri>$tzh9p1!EW}dPIlcK)Zu-w<#*E`?rrtPM)EbTtw52NZ0{I)OQooKe}et?m! z|5C4%J6~^3&rw_ZWnIJ1=?)iWJnwFN=EAf})$4;7|1+n1Eiykc%2iM4xLz;nT2u47 zZclTK5^6oO!IyhzCa+R!I zbx!L1I>P*g4?3^1i3XJCADP$x-L>lMAMp#dD~>R-ynZPY@S&}~_d^!zYZtBZe(j~V zw4ZICZ8lB&BTwAfOTCM4Wy%=`a^{B@aS5JW@gDrc4jWS`R@AfPx3r`t-h5ic7!s0Q{gfxObjj0~%l=Kxc@i2T>v_VGdETVm z>J#Vf^j7>J6ubV&v@J^>e(LMZTCTUhO=-g29q+j&^XvHgYee-N{*ga-!)n7POXD?o zgtT;o+g}{!v*qtR3;Dmu$f(0~kB{4xIj%(~FZj!D5On_i&s8}7-22ah zckYNqu=};;9eVx#|F@gRZ}e#ESKZa;b^7s+k*zDT_~b#qqvu5S_!+rlEVJtn(KM@XkKuF+`XilMX78*>gQQp7ch@;<&wi0PPoOU8 z=;>gecQ0i2USQkzu77&J@y9n-6?5*_dz+TLW4Bm)NGQCjYr?NZeu1hlmPwTC$lIdy z@yg3Hvr299^DTYmaBQ_uc{)zg>THs}lN4@^{zU#psTyPU=C{hk@W*aGxc-E%%Jy|XjCL(xN+ zA?>m7-xq5FC1HYHx2ba9YVjRbQhF=HlI7`?qg1)$3AnEe8pQMvlf2&pK_r7!7Jh}ZXVy7p|)vfvDlDltT!I@6~xz{G#3+j=HQH^z;;vVwy z+0khM9w$1k9t$|zXmWkMa^kWCSGnmfFU*hFY=0hMRC#$_obtyb)v-Af^YriY9zXj0 zcA7(7tJQ+#+m`A?u9JS5$>$o%tCDWrA^qW+$lLPNvtfI~=DhRoaPIWJ?pwS2=3bpo zw`wb1iZ}Y5wq>VPVP9c~iNPFBugDJNU{P7wB~KR{zsY(p z@n%|c!i&tk%Qs1`t^eVz_rarpLs;9P*HCAYrsQ(re&zNlod(mk^VhcWUb*ZLFZgrT z^=iv!s&h3CYUWL8+jx|K@~i|#qu)^sr_Ij69Wf?B@ve4;` zo=Mzy+&eC=-PUDkYL+D+Sik*R?a8<~J$JS3T$@fPp02LjJ|l>8QjFZW6$PvFs=q%- zJW_pm^O0xAr^=K{MR1>A&z%0}-~8F-MVIR8k{|con72w_Oxm~V{F1qc+20*Y)9+Kc zDe}>RzpVVlai<%ZcQ)~<&%U>IcP3ZL@ye1^@fnw9pYE{Zo^Za%P0fj?#{9|D8Aso4 zi*fA}^f|kLQ6)LHyL7FC6w|%i1qD6$#lNYmRnobW&gJGxNEc{@2Mq%R@Mu@F3m zeBH12+4eZW2^C=Ukoq{+goAfq7q2(`9rl6FA8L(3l@bj~Rye?OVH|udQyXo3Y}p8#%vf?%ay}?Rr!t)i^HQx0#oRoR*#QhGr z53}aEOXmJ#6L&t{Cbm}MW-m-S- z$DILNq^tzPFaJ@M#!hVLi2qwKaF5i-@) zn`m<@{MVIzcf&79Xg~P>BI~El8uu89x_<%98!E0$@#d^znr&$Of@yc`wV5f3`*!}C z{Ak%a%PV@GC5#0Z+9urz@JqKic5hm^S)PYiVpK`Z_q4yo1qHE(H}bxk|H8QaZNs;n zKATtPnQBzuZTh$CXL3Vz(4p|Y5{J#LbN6&i{LZF(&SUw*9}H#N(-Lx@Z5C9Ud3V7t z|IMyXIj=f=S7QHZ`)NVeuXve*^MA>9nOkjSC@S5}S(011_UGk*r0H!ZdOui9o`0`v zN<|0Xb@d|xIk~p~*tgG9S#8g3%4-v&EH(es#sbT;R!fw_d3J2ByXvoMcx(63q<3A> zFISw4%**S3W}uO`?YPpE&+Fv=3Ypr5x!U>ORNY{^Jji>?hp-9t?_#qO5)Nz6-Mr8D zdEE?e@pDRE)syt>PF)ZxF<{#-am6#B2V*fELb%q zJ%VxVecg3BuV&r|bU3lPN#ymfqLiO*YyXNU>1g@=m3p*Q_Oj@U>zt%yTWGyg2VUF>&IuJ!!XwHqrp zxXogVvPfHHWq3f;BKE{~fsgBy%R0UJ7irDkJXu!Z*gW&C0mo(MpU-@=CFh6NyvW(k zje65uAP+*mNN;_!-!nxY9pb8fI1zbxU3Qppl4YcpRS z*nVf;0jI{(zEdY$=H=|o*>=kI(z|a$Wk+UL=gog8yxPY-zT@hr%JkY9ZOVT8l%<)? z8@ENh=XtN~Sg|;&ezDQy*DE6&>Q7x2beQ$7?N{_}qkma9roZ2MwrAqm#qAG@9UI>+ zpW2u-({7sn{DVP952tOuR~fy{dwJi}wMm_hxAk@%dJu4l$wlkR5&QL)ei6rR8pXY2 zd-GU+!__s$m!Al(i8wRYf}zRk-+2X{qwjAYoo{Kqt;BV%^mp-$TZIi;Lei(Sci$=3 zopS%wg1nzIwzV<_I|kg{yFu6D!L6;)Zw@_KGE3$dpWmsM_wR1L=GPDk6dWCoHGkRZxgGiRvy}Y4_;a@wN~9j<0z+;~lHY zlk-z=v%B)EysSU==+7ywpE)*(F~>bcdV1$xWPQ{Zntk{6zHfoh^^1PCXy{?X&t5x%1)| zqKgfWtg=}DblzFX#hq+lCUP4umOBv9RvvcVZ|~9u5UU75Z6!Tcf zo!IuZsbgKK)Y^T&#GhE6wzm4^>2X=%)TEUswmLo&-mrSl^NB~+hp+JNu6tvs{dCC% zlR~kj(f4MT&ENcd{)Z=$-51mU+stWWJ6WcuJ?g~w{;;5N@_(4)$ zfxb;Fo9n6|rG*}OCC7FKzS9y4S+Vlhp0&oUH(6i3iJf6-A<$=VuqOJjPG1JIN~Y9x z4hDy#leQlYnO>9Mm$y^zU-Ir&x0p#guk62NtusNX_JQT+{daz}PrK)n_n2koUJLiW z&C}WbGOSXV@xj#ip2|zptb|%^IfGB^2NwRwJ+;J0w)=_k+T%CR>o2=d@;YO#M@655 z?jz+6CS(1LiM3KLNB_QS^}0U4_YBYdoIhRLcb?s8_2<@x6@Cg8i|@r4RxMubG$-Gz zqx3>Bx0FJaZ1$cNT0+6*%X(+2rq9<3{AA5AQd>HOOIvK z)sM-aQ`TJR*vGu@QpeWK2cJi8Z2y_a*M4$HiqUG=rlHZeB81W>h&oH)T0@FS~w3hPjT-`X7nKi+al3RyZfm zf0=8xXYbFfFPqfj`i_2LSjqTy{nVx2t72aT$Eie4&v5;^bmp29H(ConiZ|z!9apn) zD6IN+e)IeOi1}ArHx=&@;5zs0ls@Z?+ajz=ab2PFNwCoH0`_f3|^WwF3c0c0T9?Y;UK7Jwo$90bRwyqIV=IlxKQ)2oV z$k@0u%k^5@vek1kdGDB5?$5T%>5(j9)_XP8CQwD|#~fEto}cDt!o6fK0C8A@;W zkMvv;Df8d&WmVy!lVN#zZ#TtWebBPN=Mwu0+1Rxir6Steq4U{W9;y~S_YaTzx=p!Y zU6b3?C)YPV-OG`adw!NcLNt%pC%@MlX9TZ%WP8xL{@KssGYi+Q`=)*B)4t$abAAXn zFuk0|cm3$A#wx?V;s1XNZ<=kVx9yWlzIU(n&$^A8s%JNq+KQNU-nP!tc|84<3+qwG zmJJU$41#~K{M4KF*88i=y8fwVbGL7Zd2Oot>{z&R!v453yw@gbJM1|))nJy#a+d|# z%+WU&a8|igH2xR1crowkN=w#rH;*b_PJLJ_=d-&{DNG|@Dd9y*hIH}jw{_YAEyA~+ zT-nb4<`84Fw%3=8&V?ZovyJZa&*7H)F!9#p4-#|Rum8WidV&*6->gQDsZZh-g^sy=_o#@BvWn&OiA?l~g^6izpYZ;;vSUZ{c5_jcpc8q<+IjI3Qc=gY?EAp{ZvywJNndLH&&MbF zNUas!{`jb}a>=#J$L{aBbZWljd|6i;(^-4h#K@R1v>Uv!YGi4ZkaoA* zo3-B7B}x3+*3A|RmRRtb+?sV@>*cL0|Cp$5%$oQ9&zwUG@6Al%oKdvL;8as*r0i8; zo>|QtpRavn)>y{E&D>q_x{0;4qUu5P{3XW|-dk8cl`@cUJiCAK)I&{-nG5q=HS1J3 z{Q4bgBn!oQ^45K04m9Jj-zf7*r!@DC|DhkzoNMQ9|G9C7+S?b^!nrLRujhP=oBpPp zjVnG`v}JmZ@buJo+jgxk+s>7XqP zIkIU|-^Qjz4`d~l?-jAx&gc2mtSK?R|EyH`%qF4#DTekO1&bJ1>ZevOIxqM9_dVWU z>yMWv&ulo^;5N1Itws1}>DzimsdtZVR4h;6_}t8R=W^DhJFmB-IPVC&zT{!`6vJZ0 zJK-nSJXB>5xgnf-?dMZV6_0<7zr()vu4r1u=*c2hFhlfZEQ|WZ*3*T4(lsA0*A%<{ zeDeEiT&sWi1c$?WERvPnmdsZ&R29m4RzIJUd+{?5!H#cQ=U|%O93w@%X}G*^Aa!)+Kymo3!eeAbZMrkJlUX zcsKl$-00{eFeAf3thK^a&b~i2-J&?_aAc-&=~MgC`-va*RTNfM-mEKkOWjk=-L})> zf^m;!?WskZCW`E@el2)RRD#FmX{4YNYtlMSEwQVwc@s{2WAA&rQ_ua9Ws1?8S5Gc0 zaqKM1og4a}FIVD3K~0Bkzr)W&U&YJ2`X?=O;qAO!$bO$ceBSL}KLyq*a9 zt!2iQY1$g6@()Q}DCpj-$hyI>>uAD%&cD-6h=kUt1#LNT(zpN4-=zB>Fzq zywBLV$?DG8Roi^KFTQ`#6koSIlb@WcR{-IO6xjl2Q8}E_i z&$53SruvrZ2WBQXe`(v5Cv4Vo?AB-F|Au0M%R|py+uOqGT6_QJY27~yY?by)y`Ck> zaqxnojj{r7mDj$VD!-0I80@kQOWDdR=j@uBF59_F<9u;gP|-`>sVW!WwC!2(`bt7q z$Yn7uv+$y)NrG}m@|4rFw*1sfXK&pbe(J5|_L8Uy*(*DqO?ub&t*>R5wpB34{7X$7 znGLa9)7O6InG^a*@W#LU$4`9uc)9#2t7NvwR;To*2f6q!l;@on;+nyA&aRCo@KEye zJMI7SzgF@eD6TK{h}wAZZr+6QIg0CcT~oc!sl=Pk%spva&?DaFl1EEku}_*&AyoME z`Qz?KWe0A&_k1V!&2#2WMaQ{oHttQ=tNktehGX-dcR^B)8)wh`{6kTIvnP4x$th~z z*Vn0t&k2;Dcp|D(Qf<%1Szp~h@3OCd(OtH;z3T0HThCwa(o4ewoOjpyyi{L0*$ z(fg0bRBiEen^^I+OG5R0q9NDg+Sws*7pgAb{8rS~VoTPlrG4f7tZ!{zY+L(p&9oUo zlWrVvSeAN!{rM$FUM1%q-Y=zfx?V|lfwZ#9`a~C=3a=t{b%!OhZY^y`ysKV1VWRf;RHIk>!gyY^i|5WdX(1rGW6i1~KQdD?W@>)kzCml&Q7-3~ z3NpJirF7-_Z6`-veyny$x%u+^gHxWDe-FH-?>=qX%(HbF$_pQ4F_oB`RDIr{WmQ$Z z^nmB>--qr`E$NqVUiY%Ly58vw8@r@g@!ZUJ2154#S#JBBiTnQd&p*i{dtIb29i262 z$&vG`OAhWeFH*_<^t~wTYx|6P_L&?X=atQTP?*1{s;=Ro=nQVwb=-~3{%2p`43UUW znmYf>jix(2>ppaRF8(gQ=&xd)$B6?%d`g<}hg7z>im!ScW&iSAt%0H*-=1pw9|8rl zKOXDR*vulAzCdYGqLKJc%Y_>(V{02YZ zoD#bEh@x+pQPE`27uGwkzSp?FDoXHlcfksqot1yDE#9o~Cj9G8!9O*tGaEV-XV+fI zy*W#Ls<%$#w}aAres_$F+rok#{e7x4#X`9!Vy^e$u-`{=&L5fkq3(lZomj8;%iai$ zON%xnb+=tRvM^lL-&bGxe!us3zcs$GTMW0&h>xD`;<76B_WH|tTAMDt6Ljp}T5PZI z^yl)&xp}H`H)F1?%&<9}IJ@$8_@;-h%YGi}w_Ejr@9)aSWi@+q`Pa>uuP>#!c7|Bu zw$kLk9M{;r-d6QaS-OV5(B*^fp(gL&R}4>Um?=DXB)RtZqGx=Cd09S_gYPYyyTGtl zU}@BJjb&23yXNX06I`h5-K|*QY`=MiRcH6Q#D`l#Rx_wI>|}c^_UGr`KELwoYi!qE z3kbQfamCD_GZRI$PfR%$b~kpq`IUb?h8`a0b2M`z)B~3Dm%LGR<9R9+z$=#Fm~EUU zuc&iC;78drq8PC0cW$V8O+cL}UkLB3YxvWWFaW8Y)-|PeN{u`B--W8lTXY)pjB!OF3rnBFj z;ox28QCkprO3Fw<=wW|VRpFxL>o3`sI^Ga6ys$xV+3b1+ueA0yZg127Z0n-jEM};< zvA^7S$i?<$)`BAj6L)$px$EO&!hGc`yR}Zkmgb(|ZF5v+9{%%ro7B}ELh8Q+r_W*) z+uW<0{oPS2Q=W%sCi8yY+(+AX9Xz;ERzmhy?By1}e3iD}w=VE(jH$Kwq{VpAZ`tNs zc7`Rv+h4Ahyq))=)8E?KrCa4?Q{TMc$3HJWz1n=NPEPdZ-l%g-CeKRjL?=v~o?oG= zz5WwV>+PqDq|}|t_1tD^3Z@(lGSYuh3&;L7)~oiI>7UvqJ54{~IjhL0 zbj|xqCoDedbxY}rJnR2c+hlTB=Dg31JDX~lwBGr`iVL4FHMu!+2c6yOe?94+Ztma1 zA5}kJ^m|hyqW^m*69Q(oMPIk2Edv_Q2|P}}Xmy0x0YJRg&V z+*i2d8s?`g7p+CRrM|}Z(gNmDZ20SJxRWK4MCZEKAth#|WTtX|9rN@^lrYq#6^WlzW`|OBX+B^4kA&{=t9T zEr4xFn2O$%mWx||ovisPazy3mlAc4QuBH{i|LnT=D>t)!ZZVmxlp>*|p_9Ds`!x-d zo$C@0H3z=3wOr~ncl(i`OvSTPJbS-qMIG0=@3#D%+FF(ko285e45FrQnwxAAlaZVD z;{C1vlc&v6_Eh%Lc(qGq!wPZF4eE}8ZO5+mTxX{n^T zbJ{x*U8@$!qn3XiYxe&+nW9%Gxb3usc=zk6kuTRYi|kz8V#EIQVFt%valsOQ?@cC} zTK=UD3Y&SW*uRC&zv9%hBlx;hTW2l%-fs?%7v>%jah|y3Ra8~Wy+^auDo)S3H=nh6 zTH~MJZYjO(fxLlUKXi+frf9v2-mb&i{jll%Q}0ODg9>|?3-dFb6mwFKCPwP!R9jVj zX`j!hC8R5~_u++mjdCIkcX!sYNsDjuNIg_L&FYy2mv3J6dP~bUK|7~Z6?{G_D7J_x z@Pbc6RI2^b#WMTa%s39U7jl+a9b%mLNhIecgW{n(&nKUGAF+eI=5BD3VIOzj$xBP3 zHTP`4^S~hKbfK&IhWWn6HBTPu&s?0vUBq3ZbBHzaCTmEhMW@qEF~hV)(XY~9+%POp zo+Tc&pnVrl*`*zSLpcwKaM%R&>28~HAb3|@w#pQ<3rke3&#zBf@3+sZUqX&6pruc5 zmO78O-D{C`Y3Jqp9Qmyl*3T+hrpF?^>v^rGuFJ|lHmhHDng%{GP_aGqAoPZ@QR$W5 zGx=(=3(`Iwi_C8P#JtwKg6UR!hpVZ=v?}R}-e-RE56<+fE4GTwvlJ@dv-si4jZ-u7 z-4$jjU;MK`LUZ*`E5U#$ z97#>bYd=S%Xj=2iSypVWP7r>dClSyjVgGK$=R2!3>??Z;dH&h4?A7&QyZrg|lC9k$ z@4u`3i<-3Pyc$o1YVd`|TY2_gx1Ky=iI(=y=bR&9bzD8f=aOXCLXQGo?v=-CQsyk# zb~I4o#k|(|&`aOuxtL5ovg?=VPow%^jo|L{N6u_6bcxQ%u{`we@B-guLWN7>qF-j0 z&AOwacF#@lsgoLW-?FNeFAiK({de^hKfjGg-tIe3J{0bj@JkfXS~}I`J4Za&Z=D@V5B$i=trLAZttVRgqmVPvLfUx`FwmHadK6*gs@kv z$Z&`}ws+6RcifGW4xCW2nKUsdIOu+!PeScnPKMboKi2N83N_2QUwuBZ;9s($cxbcA zCjXXMnpU5=r!5h3UaD>0NP`h#~?%Jv=G7eCtgQetcI!<0#T4}J3gWKg;>a8F&y!<;WqHk1bMU2IhmRj?~C zO7Qzv{JlSQVe8WZb;qdg3&rccuk*U#V7AWiN=yDRpNX{r_7d8= zmE?u{BIZm_UGPrq%aM;))=XY2l_ioXldH1wP`+~h{p1h6zoQP=?sHuf+;_l*ap#u9 zGgc~|taF{b{Z0N^7M(dPXEtA2>m4c`ILk(OB`?=)fnN^_gpyt}`-HlQuQ?Fgw$3fl zv)*kF#}ezC=X$kXGMPH>VL!RPZG$~uUg3K82^%tOb=+Tf?#{4syFW31c7Cx@+S6w* zA3N^p-rQwjbR##k=hauAM)NaOpPz3lTK7+`!YBHMYI5Kqy|_1@7oGepdEseY`Xl`s zjUT@1m!_%KJbNd8l6#_MO32~QYj4+>cP-cOcP-t#C9Ntv;-rwJe$;)pg_#TD|H($N z)<0tHV5|{puguQdcaHDeu6CaLz3xxl>g?O&*VQR3dXdtykFE6G*2x+7?z8=R$1<^c z!IWHA?UKmT-iumJp8sH;bz{?Nl^M4*-u>cEp6AobH7WGh`yUWc+()uasAkmTJ?_~t>y-`e!eTZ`{mi`@?COAlY0Int=uIT_&4kq zi^UB#*}BQcANO5qm>lXJ6P#83CN)g$*u=x47lQc(uH2R0ynd1Ybo=hvYMTxFK0B2! zN?4dKDyuhB?6*Z+&SU$3h0wUxlvND7JH;xM($=*_zxl$a(4c(u-_F$Qw=(LAv}O68bJoj$u-g$dCE#IE z^9QU}u{WN$l_W}FrN zRx;J~qv#=x-&&tHeBpf~{qe)zbyK!ROYKm9?s4w+Tb(54EzWI^UmYsX4^@dMlwrOj z*>EiBu>6O)_Lj#cnOc>~h?mw*+O`A_I1MbWaOXBRlsqSL9?!mqG3tln* zd#*fvIm=|)-MQ)U`!;`kX=>EKXu|A$?v^lk(;{O@Axl5+?ZS1km z+~5hOkv5kU6zdeZmQBe$|9)%zO}4&m@h^5A$~#b^cgD(ij)m6cu;p#9M0#5f$i40` zFMYYYeThkuPsW|5?bErBN^~=JK1lvCHzmElw)?lLd=U%BnXUyz@(Z7_H~cV*pE2F; zTBaxC#(O8@UaS{u+{>rlzUl7j9}kb5JuP7);OemDfB-A!#RsXDjk#X+{U36=rzt1@ zk`Uec*T-zZ-pun^-HPs^KiFznuYK^GEvVkll)c?qeB0TU8TqN|?!KG)Q+^~XJijM@ zI(_*k#v@b0rsy;7t_?o>>8o*7$+OQfIdipHoh13<=Y;OITfSN^_AGx8=3}e|DbeW3SRZpK_)pGC^VUzQVg^u}t%iy<5&+@729k z?d*ed-&tqhvVFq#;?X*b=*MMc2K)6Y)e<#-aj({%>$a?;bIGimfjJ)Er~O-)BFO$p z>yAj+boJ;jDjmn&1?=PRo0`e5W9R)ew^Z4s+egl~WU_XK^T&rDHd(M-ukoBzvS*H| z>x1BUcAm2d++V*2W(l6Pvwr7R(s%FfpR-3*XU#M<)RT?a5@fPqTj9;CJS^|iFOCuy zHD9nCYn<}`+2uv2rY(+-{U-kLn5D(D)YH1Jjb|)3SR5i3qaYryTkYQx(!Z=xE28+7 z1+Tbb6C5X%q4PvPtMAlr2NqH&G~~<^?uKOHfhstzULCY zff+{Ye=ppyNK*4&SwPpTH=9`l79<~z-EjBz=4WE5ViuN)&%7VY+=>hJInilke4XF$ z;qDbdmqe-_N6T7Vh%2kHn$vJt>1OfDMS*>Nh=muPg*fWoU~$OYG!H<;~Fa%z?cd~W`?F_ z#GbUWySPN{{4F!7+rpna)yvej%fh3*N!}@H?X|)pSxi#_l1KmRryzK&1qf5boGtc>KuxBvc2 z|EX6}nalHE(fPu)H}bzE{^xEg5ZPS7JWC_O;_u<@lbek{+)pcgu>ZK5SVq#roX_u{ z9jLeXnI7W%CTH#4|Ni~|mwa0PPol*{^oZ+`%zxWC{yi1jYP!vM;|5b^4eP&$moIES z`Csba(=dZAKgwDEvY)Qk;yUo9zBJNVot@jf!A$w@|0x`g|Hu5FSn@xA%7h7XXRFH^ zD{D9Owa(={aOBW2mIn!mU;gRuIChSY&mnqw{ltI%djBu}5A|_aAbmk1uk_}*8P+F^ zwyG|<_JzoYzlQuL>F zGmjXEbrhHwO1jD{+uid!$R{fCS@7nc%VzwKl3!NNy09%dS%ZwMxT@z<2=wBw4dd+6XgHs*GaY^#%Tr04jFPxr@9bNJWBZI%7edDkR&Q>C)c6Q^%oblCb& zLi(|%H`AkHW7|KKx6Hq6vh>}wD|<9JV;FWb{AqmNaaJ$<+^jE?CZBm<%6Pu;+}Dl! zUu9fjc`D|<`QtC?87fmJ<_dOx4(D6Wn%`%!=i2QjPF|S-ey`Pvp1)yzuub5#+RlI5 zj&m3tQdiutSUop4h?C=~PQC)a3lH<+G{&l)58F0A`}5I*`}%>*>w7hv&h@3aZ`+&V z^)WD!ds@%38I1mpW_1UTh<@8^EP9!Zqo}Pof7kvMLeD>Sm^{^dn73S%{ctG1Cj-;; zlC4+1Ch?ZbbY0rFr|Y0g-ogD^F6KLXt8HGns%|K}>&g7;g0OmrdsEf3{5cojx^It< zJwLf=!ykdYr#CS#U z+3P!&Yo~TET&t9Ei+jeKN}UTvKVPorD4+0b#bHQd#n0xl>j$Cv+7`I+|%CoiUE=z99Dj3*T9{Cs>`qsXF!O7Qg8|I#tK2`I3 z^5q(S_wKj6x2099!fO^ww8))M{T}_QK}pVH+Tx!dN`z#$vOFnC>}NTCghxeb>(t(Y zZ|hTz&OMjyaAcqSszr8D(~X?A2lu4MZhKxMQ~1~_Cdu~FvR{`z`v|{vxHHvxxzqBw z>kBshJF`_pgtM?yPpznNp^oZv;bVDwcev^O%i)`CzJ#&aQc_D;T5`($OQLTtZYWr7 zDsos`)l=a4%ysu3-fFzO$(BY00^h*3#x@??mjmxjNx#g>>EB zg7XLXPS?J^r_j_;&-2Xw?}@JwA+1jZ{~n(B$ImkCJwv0O$K!*IcHCLTR#$poCtux~ z7&#-Gzd-f)>nmT~U%4&LGn(eFus%X}@s15I{6A-&@D>u-w$|w7?xT!mF_)5yY9_cA zu2nM8&Da^)u)VRYdqqW2CtJCca$ddSY?+&@H|lzsSFWEtFHil^x_=Yu`OmKmmbXjz ze(`4bA1-5w8GrV+=joQMzZU%9=r%ENH>z7Vt%w1;t-Zpzzvg*mps&3OVGuW*7 zR(}jIFFs+XJ~MTWQ0O7{vjTr^`aLOUnf;iv=Spb$oF%?oHh)(heKOB~&DV$-+WWIu&*cdfEt7#i6ty8B+_gmt~s|9Zw>$~Szf?dj!_AE;n0+@VlY@hHo) z-bPJ{XM%}3*XGz<2RVb~Pgc78kTZ|CG`aoPi?)Uymi%)S#NGhN5t8PW^ ze7O^!R=xjUxL8|MtHxO$!3*DRhd*%A_ zeJ5x8Lr-6*wFzdhGOOR~Klg7}Z*Wihs^6CB9X_197cBMOf16`b(f`Tgdw)d<=TzMz`=?y{u-dir-C9GDPszd0svC zO3-)aRjqES(#tjl%()lMBlD^FVY_|K@}n_okJDGPI94Ao^3d;8S}El9Ql?+~#QCeP zoU8Wv8Q)XBTV8+IFnQwj1vj;nc_d46*L~154d2G{sqU(-_vtjrKLrxA{h|$9Paij& z^OB=2q9X3^qu3=EOqP95G-rQ*Vacb*3de-yt@q!R4Ql_wb~Z=q+MMsxep`P&wdFIj zKxT}$?1e8zKW|0OyS>%=mFG-7o5{!D9JM*xAlJM4OZH*USVsSz2 z%?yy1op*onw`%^)Ip5+Z@wv7YNA2Oilf!XI&_vB|%A;L7ViX_5)=t`&Dq;MIJ^!qd zkWJgmj@Y&evv2KUUo2nx|ICm0)}^~l#NKDM3g`a<@mqEWk4$K``f7ZF-&$+ZmyPcq zC-3TIog<`HK80uIuQu*=RYvDa?mk#vlT^apr(EYUG7KJNw+y z#4`2!mEQeY_YXAZ{r{x(&)3=i27_g~*Nu>S2QSLA8!Z1A`+wdnrV|mXs+N4T_^j?9 zS?T7>`>bcFY^T)A-gnkN{}#QnkjtpKC(N~Uq1&p3`<;WmHx<{rXU?)-b7T5Zr0JM2+bi1$c|52Mke!<3V^v|kyZ2)FVNJDD zu@_3k**eZB=gc^s_`=Fc-9=)$?cZnDlc)PS{?oN@5clj{#c20QwBw5N^*np?OS?JN z7BBV{z8?1AQR5{)w>Z&vy_?@oT6385!Fv(EtgkLIC4XjaWtjcRf_q-jPr;6pHKK|3 z{5v}?UrArs7q@nn+BT`eKTRS}-V`qRdTRSQGlgx}pV`c*zPY96=gEt!ISl89Oxm&W zQ()Dz9o0_$e_uBqO44?;beLEF*r0Ke);AMzkFVLq6??d!Y~I7Qd&2t2ogrqXuC=`F zmlOgozHO1rDoq*(y?Ri#F>IFH(&mCm8^=G6?BzRGWFx-x+v{q@sqk8#HLzzPH0lt_^9q; zn`4neN7MQ}q1>5G(!X8T@6@#Xt88b%IaR$hqE<2J>}s1`@sq;dE)DtLHSb<%QSuy1 zDrU2f%T93#-oEE?G-hAO;q7x)e+|%l)3Zd#b91=A zz^*^uP2A>76N3&et?{@iR45>DjN9o;XW(XKR;78dX^9k%jcxY? zYwO~hUw-Y42+r8Y-=?^4S+7T4`;j^P>v^~CEaG`tZ_u?ox z*Su1cTM*hNeY$n$42SkVwHYf91kC$(GA4U{M4DD zn?7UDZPy7#Q(tq46mGAda^anIPeYnxfF&8(FIM~^*p{V(}KY|T5_ucZqkW)!^&I~>4cbo^o9+lo8h zO%f_6@9ox}TG^HUQR-<#ab?I3-^!(vj@)k0kyYU{lQ(!A@F2QEMm=)L`DxNiGUoKi z?ueJ)qHwqKOz^VwS4?7$KmO#NEV)HC<<0ta2d;g6P&vnpspceyRAJuzumlBf@4{Z` z7srDZOLm@*4iacovz)&9#AID{)tV`J4gP08JzlHL9qmynd(mvuxd(QcM#_g?OlY_8 zWqp}@=H>;K$7<1E)n3e0a8$i{Lw4o%Z)uOZ&1zHU38hbBNG!E3mDp7Ai*rt{TJ5ZP z%%^4>>+cTsJuSU$eY_O^A`kUY<2TcM+87enFVHKLkyl!v7kR<$i-S>-WKrKP6OrC@ z7M?@BJ69ZKpRBlJ?lKQe&u<$~@11|?^yN42JzNh8Z&>r?G{TP&{yUKKp?>@!!~R^5=al}Cma-*nC)=bIS}S~&W*?q8Ex&f6)TFO2H%*^CZ522sYZQF=Q$oTc zp8Czw&*~xsg@d)`L`rt^ELuL*S*mnd6JLA@yQ0~yFIz8MPTeL^Uej&!zpyMkkGDa4 zcahm!lN_gGyZ5EMm-^1X`;94c^W*N$hMCu9-+bXJm!y4m!zxc9J>NoB<>uVA>udFN zisd^N{|#fABEz=vL&2A4w{$n`-(%&|R=xMyjI9ixjmo{WVwIh^vQ^FmzFpZo^Fyp{ z%xX)~g+Cs8+EpL)Osd(Y#Po1#tNEf&%2iJ-r#?MoHRYDZBx z+LR~6PJ56h`|!=X9RmL}@{Z3eSIX2|(sT9Ux{Wo@GeYA(hkJ`ZIvW}PddEtM_S*?N zlKZ}1`*@Mx({?A*eG82h1wvJSgaWfas%Q&+s3}@5S~_$3p@(8VMNeMFPpamAKGov> zUAYqr{>Yw4_;4z+uG~0#Hk-7-J0YGeKUVy=nb31`q42S$`_;u4b?pi?+8?eoYpp&v zF*X0xo?1{u$NKl`(63fp|fe^UQ_)k9Mj)Eu0c z_M1&S>tEXzm0NP>-fHY9_pOiEKHtP7OQb?i(c0AD&Vj9Wu1j*oiX1q=ysmiflaD;V zH+276vSR&LYauZ&j{cpi7N(uL{ZnhHrQp4NW@aD!yBBC3ea+9K8qD}mt|GU$H&tG? z!O?T?zm$!-$39KG!CI`%x_R-fr#Gs-L-#MX>Nf1SD|&6=cJ;NJ@~_6|oO7AS@p08J zSGx^!%`8nC_9&kedS0-^`{eXFo|b!$C*+2mdiZeenrDai=^ZI*FA#YBI9K~P`_qC$ zvWC*DpWm5!(A|~e<)Oy^Umr2f>|HQDb*uN;_@5;j2M(9UI!mkPMQ+$6UJ+fpOL4MT zSg%H~XA|e~&`;ZMak|Z!DN%c`*gA=Ec8%VmXh(+&SNO`lv>IPhoHutq$A`rQQ?6{` zaQyi_ZR&fs`@3(X-;xl0Z|(gfZIZ}E>#3V{uYUCX6nf&-m8%bIpPWxlo&1K+dCi}& zpS~aUDlNC)owc+Kd!Kvi`-lPt`+?QJ$mpSpF1Zo@IhCvVhD!?JfSh(G;*c|q*AQz6GLxtV=h z_)f)g-N){N?_ynb`3#a$Xjb$Jafsa}VDAVC7rp_N7~~N=Ur= znDmyU-={bu=BceWtn8So_%g14^=0|DdJ}T_UhKTM;^B*@7NR{DMStyj%y8J@+h@NZ zR?h&LxEse<{vW#Z@#z0~F*o;3WSF|O_j2e;;i&MJJNWx*ZRgI{$*-4K&s5j=XUocv z+w49o{W)2a4{wp-FFq!5a>C!NoBx^@XxGQ7#Ta(2mAf2r$LY7O^UFsQBI?ZZg8n?q z%a4;ht0OO0U%&qB%^ip3_$IzpKejR2Hvg&H&BV=hPe0{Wur~g%WLqB_`$lbUiA7mj zy7i(h9+8@ohg_1De(T;`t!HkrHtJq#>$3K9#h=?P0Gx-(h#XEX$$%`9^UL_N(VzZmrXbw7Yb06)&S#{+3lfFATD{ zUi?3F``PqUDJi$kmv2!#cWR5~tmbzGx{uaNe2x9i_TsCLWrUhk&*JWGnL}rPW z-M_Z!$y|m@4bcG(suA%K)8n&01>Qem@u28m_=717P50*qhm^0o{>5=^c!C0x>(ish z3`|^v3ys!?1>*jSjik#D*_fj(9_u^ z{gapNXI=ZeKy%%Rre_cP{o-U9mxnu_j}d>_mAXW0)yb3Hw>;-O%9l=BTyEQ`x%$*@ zP9KG~mO{gx-RHg^x%qtA_l^c(+4&1fKZQS*`@LP>c4ym*EtB?J-M2RE)%>z#=Gk3W z(&qkn>>sDH=4|5YGr@P}+!Dy%xBlCz^vCw^O((7hQd=9(^JfwBgl|vxDSgv3s$yBP zbBR*qmIvE4Q=^~OUN+%>na%jzIdN&$(afp#-}1Fyu`G~_`+Cc}mRn{1{h*G!JCFEn zceatpmMZ3&d(wN^;?rw7+YYi`xzRpx#?upincL=NBu?;s6?ydU*Obc~&HtwEbQy#vu%H4Hw>lU4>y_eQ}y{`Mk#YQ=LHUDj;%l+A|F^cQVH$VKat@g|H zBlV`cw?_xwOZa;$%XLB3%qIQ3r=D5Ui+=lR3hr8U>($aDn?+BiTGy#Y9oTDsK)dm= zlHn$v*Uu{F>k3+JTh)7D?%}@k5+C->eJC$zcicE9`MdfPM%D=)5tTd4`|pcPSt;7J zyFWhVT-Db_tM9#c7f;piVEcUU`0{Q^tzMVoM_-Fs{raV2o)+`5s@&tqRK1T)F>CLe zRtw99)gOrnosjp$t5ra$IX2jB#%&R^8Ge!vc`o19x~e(3d$Zb}V;}DGGxt}u{J$5l zwr`i*yE}V!Emi0}^67F?)xXJ{@hYi4-@{JNnAk9L@e|6`1$t!Fg?1je zmbx)wLcUmD|ILlMZ438r^8K;%w-xWoX0fU7H?I)f<5RvPt0wZt8P9J$EJdpi8nI;@ z5K0mVn-skJZgAS$JkM?op7llZk2`Pw?6YOrlZKKB4eNf_eliyOesN;d^$QP_T29M& zDTXQ(g}LnX6#f_b?c6Qhqc6kj-aq{6-g)$a@>21y^1T0SZlxT0oqi;eefhjkZ+Ae+8zeueN zDP9z|Kcq8l`=rl#?Ecnk8ZR|kzBfPJ_jtbdjby3bbxFHUm2R6}QlGi0cxTpogN+kc z?ca1M_SH!vt6ojvZ%e<{TvJ;2Ys=5t)AjrdgtFgO&M)A~yA;&jx!%A>F<{5KyIv;iEU@-%GmrRQq^U7hr#y~6ASh`*Za2$lZe}p~X@4 z8@#s4FWT9!aQgI%M~n8||1yuIf7NE^CwH2vOpBCvmYccBX?M)K@Kln=CLn+(vU^FJ ze(9x^yUqz2744C3Gbu@2WnN$B9#`^W<*xYhjC;1ro)opc_3EoCdGaw&^Vz?>le|wq z+FxoabAGG!BECJZOdtKTvW)s_Sok&km+*VXdApJX=dQZB{z3$Y?(S>x2|shY@)T<~ zn10ThvutX>gKL)8=6nlT{WIW9RPTQA;%dIeNuQz9xV8@OzRe zCu0?VOVIab+YR+T+fGe$7JU#AagM}_>rml+6+SXq=`|7H9rqn`Rq4=jC%dW53&9`jkGj%QkW-wDV0xloqTf5&EJRg z;+`DIs9UuuzRa&!AGY$p+n37LyXaTK>o$ z`lu0>-Su5yPU!8xX|q>3YkQ?R%1+{3)b+`?u`sT2-~2hulU}LqGyijytA7I%?*e63 zfr=pYCBlA5o9-u>MmFtlPRUVdj#oRA_=96(u(5lt*O_&ihxru#N6rb`H|>(x?C$R6 zKj&!Qc(>t7GHa4OcB$WD{fQksSMyXg7*Ab{SzX)leaC(d758kDc478o*X+Ee`kg+J_9H;_ z(>~XxuV-2<^ndQ1!?SixEOS-BafLbVD#!AhBfV1|&Aze0I`jDgmsW$Qf<6;r*(+*V zLS=I~Rdz)Os?-PuW^3j5S3KSIljjy& zePuq}v#5N-QU%L`#K(NL z=KXQ;62q*NlWHqB?%ve)?)MdT%ix8+9htAEUD|cQSxQ6vjAW&0P0E?}QqSA&n{6%M zwr`p!5|EUCz1#Fyle2~Xg!j9OZ!^UF*jVXzm7{6fm#P(s(}QKBw&~y5Da?9MkDKjO zW$n6|v)jX8x(9ywr@z_%*or4gIo~~>>fGR6nmnr^=80Ftv6RzUXZ%!ix4BfPH*ff* zZxW^<_*MA!l7&l-9&!Bi^*68Jdf7Aa5++ZDc8fD<&M(i1^PK-PvE27oH8>QGzx?f_whY@bu4E~g-x0@SQNL=SBZ<%bgikr>!*RM~1 ziZrHg=VU7s&i=rnsrk87cS`%R@T=2APWJWjSR654c|hr?*hRI6EHSU1_xvzR6BBU{ zTK#O()AUt*E3YUR{@an|z4UHyuUdc0+_0R>9ru+_mwJBvWb0PJYoYY)`ozN=@z)NT zCfcuh!I0_DpZC*Te4on6Wh>`jy!Il0y~4sRcYbrPj~6YuRO-IeY5n8QtjnM8Y_)tU zF@>wt(pPQL=6v6X7e;1=0uMG_)9uUQSDAHrM__xw#-}bbpRt<0$n>4@@s1v;WA~*O+ng3mu!^alFL#FZargafrcle3`C)$}{0>`uyL)0mJ5CRg#cLhsYRGSWXD^O;!JJda;2cIkxki!|Jrx(wc&@%VFo{l~b5 zBQsp|c0BrYJ4bojs##zBZm09M{onL{<@B6IPd3Q!Jy-r{=FOhJ{Ld~2-L^lW*P-`H zqkn6rqWCZV)C)R#XKPn=I-9q3&kA5&C3f_9`TWWTpIw^SOP5YmzJGCXZRx#f<#VS? zdlXE)?EPX2UzK`NtjDSu?6o}4R{cp^l2G;c=zXX2Zo3zp-oT-0;}q1Vc5;4p-@N53 zUSEBDl)qf+&#@yP8D8++k6jfj6*D8RUddB-%g?UmXH8@q+or6F)!tm0voUAqOItgi z{Z=asM1P-camc#F$T{)cx;BpcjT2Zu+*+328(ec`pRDm&i9H_0>1FfwJe{=DulhjV zE=>uE(~~aPt@~A;dBo$)&l~NPuK71tRc<|`p0qmN&u3=Rqo0nvn@-!V;y+|#7`UNk z>6Sh08lr6zZxl*|#5c_rBF%6`L0Se8PvhZYQ(-XYDDm-Lu+QDv2Tbz%#DI+y46}JYVAW z^pE@j7)nbN+~mi(n z6Yc$*H*eT$mK$T&Ei}bAZ{FEgPxnt{%R0C1D|gdJ-L5&7at9|&*=tdu&}vyddvoBO z--{Cqb=UqheCNI*OLy(w+pD8K#vBpeyWjBEwckE` zYv5JZ*?yjJU0`X*<5-p&g;Rd(LKHddWi-wiipRWoI@jn*VPwMg?`O3tQd&Ooc}Ry& zyu!5F!Fc!VlmnhA_LW{Ae+2)WaDe5wU%PhjnpcYywpCBeEzHyXmN9aq<%a9p9n@qLe{ z{VyAC_qEH{t`M~g)w_Ex{oUi{!^(V*_#>qYHl`-tD&z@u(vd7(q%mXC7sl(`l7AlG zdf*7pmD4dn&*t2J8n@?8@RhmmI)7))KHWPjXY<@!n$Mo>i)&hP-N@$Z-{Wyp938B; z?$CXsbba?$S4Vc$ExXUZGrIgu&m$<|w9HKP8#OkDEL+naG;VplH&K_jZ2L!LS-FZQ zqAxGk7{6Y%`PB<^xjD&3skg2On?2YX_*8j~f4!m7nAQC_K07>z1}|Q6*(vM`p#Af?C5VclBkaUpe#om{e+|xN>sHSJi_Tb_BdplDH+W z5$&5>*uxoVUNj@_v(waw4U=4dgc}72G%vAP#Z%O_Z?@O#P4)AAgO@cNj8gvFx?{4> zY7oEHyWoIZjKP!dwIckKi6x=?`eGg=fW(<^f>7Jjdjd< zPy0ndytGHujz|kA+ zrp^^SPc9d34`w|xKe@Z^eZ$SeEB&lh z9W*sGpKY8Zb8qpp`{6vx`fbw!Gyd$p`Egr%Z05YF0Tqdx8n*A;s;xiWzKD_QJ4yZVJw z$ue_axw|~IwkqrInNC^0=UC@Cqw^;fYwk}e{?TWCW1U;&+7Ig#-OSxh7 zOIq|N_1|4i&#v9yAL#wxbYa_ME?f}HR+GxZ}2*Kw}A7JHW6{8sUI+bg?H|NK7J zpCdNlc2mKbd&v(HK4u@Cenuy~{lu!n4E;@hoo6@=E1Y%rK1_OZMNIbgaoN9>ADZO0 zXgrAK@o=cgT@2Va3(?FCr?W&tJXzqFCgn_3n*a zv&Alc+~pwk#_sgCZ|&!76W?!{Tm0GO@=f(a9Hv{R?a267bh&P)#!3EjX1ATaw>q!e z*p-w1&j0v_9}5*Z@?NlCt+V{M`^<+apO*+q=WgGj^{n{N!S7L9%2rD5+iW%eM}=l% z)pvQR&hp9XyEc`qXYi}YwDO5w-hXV-mA@u)rp~|hT>P$w;fYPpT^To=*!nl*Zr7`n zt))7D1DWE@-+wr9KxMsShuZ3gJqD{UWG^w3l>GjWbw8_?zA#(qw%uo+I8{$N;VaIh zW^7U5ca>ABQCv*9l;e_cSfBE;|KBH0asSM=A=+Z~?$AF`vdX_!%Nm@WvG?BELjTuB z-YpjuuGin&>diDmd({jRU8_j#r;-Jec9u?1m~WiK#H)NzYZq7bZrNSz=^ua88l7%f zvQZ@Ko_Xy<9cOXwmW4)wLV@}fvnRRPZJI29=#h_CUf#_U`-K7(SUFbQtgc_SjrDDN zYl=0?Oi6_)$Chji_YKNC&%bw($$t^m=wt4_m#pY2JNOBlTkGQ%8!3vM<*iDn z-#&w7y-V6t!^-O&diy1RZO*RrnlyRYq~MIr(--%dAN09(kG*BWv^^Vd{&=tQWM*u` zqeWR$|7PiC9iHSnug5{qE^Wh+6Xn%x&+m#X<72AR%lIP{(GeM7@q4~|xc)`u=L)}; z9N^Bqw`^M3fv)Z&`-DHAQEDsQ6VzyX!>~?djd*R< zrYfHfUD2{EhQEFO#cU(Ct6SE$q#QE;Dtc+Rz32R8d+w~9Qor%RnaK0Ab2X=5;O%;G zPdM^dDa`i>{3fZ}jT{k^r z_MK4bmf7M~VVWfT+%QG;*rFNyi>^-mUgpVjo6sD%!dVYF|sA0JO z5jXp(?4K^TZT+=}-FB&|B2Rj&RKeptyZ*DiVd+1k!#9=p?WuQFYg3+_o+SDw;DzDN zHT!sLZi({mt=pI>{`KMXk|}-VUwlkzI+nI6%Fe8Lzdb2iIQ99PeAm;Hj#M6a(IXi4 zlvgMvU+TD60sHPk;aOMLOB7A^Q{)R~ZDdvU<!i=Dn}T!}GsbB!32Q$?Xu|=l5#c{7bhwbk^8=?)s*d znPJ@_up{k$z(qYNkv)zJ)(Ei`I;?*jcb!MVB;(LQ8~+6=<_;QGdt;Ajdilh6*xy@n zY=>gc^|_BYzSinLxW7hQ;h_ib$=!LOeR`*N-TN8!%3@=+pwB!J^eN6SX`?fh+wAmylH|_3-iI%ST|76lD%}2hwPm7&fGNY)n zUAb{TV|YVM=*Gn_#Vhg;oheykRO;q%=xYm~_J$26RXI|@%mSXC`!}eakz_71QZm2) zfPdYE+N2f!+>1q=yz)6-OEt(Uxmf@C{p?UD_qCuK>zwOFOIf~XewAb1+T5h}X!5cblp=ohZqlen8q-!{x1~ z+max?r^or0BrSe^;Q2$>Q1)^~`wXw(+2{H`OJ~&|lTcaWzO7}U^t!&QiBS`eNT}Az z?R{zKxBN=OnM-X3EWclB9GiK{@5o$h|7nvxo$h#1{b`#6KaWIU{=+%(yZJNg%U5mE z5NAEL>#d#b?D)i;DeuFLuj&SD_nH%8+;)4t!2BKGQeWTYociyZuEaB!=jSx`T%YD3 z>KWx-lB2=#B}6sy*X{Us9P`{~sD|0^?D>3rmgJ39sVj~MznW2Gb8uek=2eaJLz&y= zh-Q7URX-E>J%}gdre69y#f{$YIG4_B;oV)eyH@q?wz_){-_EFp!Sw9n78 zP34sKOBApQ1uhW_;^}$hC;CQH$LZ)=^;0t?8-BZMY`>X$f!C5-bCHDn=lq;QGmHPe zopgG7+wCg3H#H9{cLb`|yb4?SewOzMEy0xKtFE#5ar-riDQ5icaQSvnBzek)sfmBf zl{9~TORL-B`i4#P^UF7muj6emzK>+L7JTu3|GHA8cTV~bBGj4ZR?~T)|>Kq z`1dTDDKp7X>)D^nSGLajv~{V<@p;FkuiyRo>e_{#>0f`9EnyJ6e&)>g=y@zM8J#^yv@#duwt2)#7`8Zhms{N@j4tyhoEH zMP5F-!?>jUtn12nTc)dCMGsuJe7rv?-E?B^(c<10m-1Ac56$>E_2BnUf>B>r*%zO> z)1Mk>aM&o=`OE90%hVS|Jgm==lc+rJ!7B54d(6?dTlS?bN~@DCjGAe==D!d30*Qyk zW!ERYo^m)?VSP`@kqA%qsnWgA(-yHGx48H8rh4hO%nG-ppezl82~(4g+;jY8RT;M^ zX13$8%_1A`htEpNn#igkkeKhhqLnYvEbT#yb=fQKPGhH+$4;L&(BI^p>brX3)7Dbi z3$-zx$)`EJcy2ZFY8oF4H*9UvPt#N}*6HJW-q*w7>E5yVZtsy#hPmvXziZXn^P0~# zo13-ds!kk)%Q~ITTV^oQu-gneEF#C!P*}tQ!7tg-}Y6<`B?pb$;SWM zX>Q?{!n$4=!-t6rCvMj3o4UF$Wb@_)Q>M>&#H@GP;HTq^$39i( zGQ9d+I8!@yYsG4`U7N~Xw`pxK?A)^bP0QiVe#e5JGjACx#5rAR(Pr;w___9pWwW$2 z&!%*S?8LwKer30$NuIc#eLmeXRn~{WwyuZyOT>>weLX(m=`XL$zB=`RU&k?rUyFUN z)_D48Z%<)(=w5xX&OX~~g7yDd%^D25UPfm#+?`Q)n5A~g2F}k%7c$y5r$;kb3Cgv2 zT-IK3r|048$EV|GU)j!hYX-|MB}?mT$1ZkybSX^m$`@AqceU_j^4Y4lcIJEJN{W?V z>$+J4u00!|lR8&jK}aaW+x~9uv=0xg`#7IYoW4=jpK<5+Ps{Cp-A(~7Gh0}!!)(gvpmTOhf*I5Skv)^a+}Z{tv< zO;WY%`roejnApXBXT6~M(I+BnGLyRQo;fh(fgQWzx4>l=autjWBD7DH33``XY2Cdm z@{jZU6{eu3Uf)C=la_rQwE@BBOWtmnown(xxa;Y5^Oot+d1(?t^932c+8t(DyGY!q zn(gvaL-xsw%0#*uSFUjtYt`B(qk?*3T-S0_1etI%oiF=S!dA4Km zmfz1p=Jh_0pCJ`myy^(oy{|6)t$)I*j74lz>J~4w+r%hc{q03sc0^g@q;D?{PwuqPT-TK(sVy2@~_D}31&uBa80*%yavI!#oV*KsXW zQda7y>)S_}rFQMcx1LV8{b1$fvdHBp=DeArRQ5S-vx3vFIwzLnZP$!)S8;NzGIsuU zUuoLzjgq$dhAXeLgqVD@zWc!HOosPOufv)Xo-H}_v{k(EvG%Ftz26r;yD}~Bv{=Db z<)b_Q|MPva>(!;z*BIT~WZUEJ*8biT(&H=6t7ZJC1Xb|LHBA8wO_a~nUd_TxOKQnhE{xBJ3;58cfJQ}@RGzfzuiVvUk=kuLNBVQiaraYh59@#ur z4?cF{#3rM{OL|WaI2mfJoLPM3!ls3xE7t`*RaD=x>ZR_s=Ag}WU2~6kH)YS7k)YJ0 z5LESyb*{S6(d#J;Ur%1&ZJxKWt!#?O-gEW;zscN57Q5VHd3W~FuMd>Z+|Ku9y{6&U zHe>FeJuIF&QeNebD>=kA&dEOFH}Uq;O0hL>qvnb$YcEwSC|q^@)k?7|)6>?<{9lnY zBjqQT>JCx&{WWKQ>n>b;yUYD+_213XuPPqjYpTk=>2&zzu{?q6r6-~`zf7%pyrk{N z6c?Y;SY5}~%CvR~Ii+2XcRY=rz45G$ouBZ0r>%)1k4lcJ@Mj+j(bvF)~kZJAy5&-_)FOBz-d z%w}bsabx*y4PTB=oj(;WZSAvqKXaYQgU;d~;=-~HL8*MtEUP!!v#O{c5PKCYyXb-S z-$yg|JTKOoE47{Pg_F@a%Llca{?6BblyBd^x6ye<#+9&iEVP{JCxF%1tX?h&n5$pI+-JS*3Jo$rRUsp8Qb=~nlN+vjqrmn47jB3M&~P-UVOe)UMs}!Zri=!??z7#O3XZKKkMtG z4V7;h;v=ok*IMach<@T&@SE58m(4F;rM7dEA|?M#Kc?`yrol7cv73+g5$o@#KXunl zRTGkbJ7GOnxw*aabB83cohuuPPIF#2Vq8CuTPXYb%7*V}mezijhzj2y1 zyGP!eX=Y)Z`-gkGrEct0Q(@SA?CtGrt-DNaN$Y1#v0A#2>s0GR#nmp1yzQqh|5|eG zy7>*Ock=JF&Yh6vFnUvbO7YJ7@7ESB7V=qHy#1XiljWPkb3Mze+jLnOjn8*Thrijq z&gALT85&|+>ar_8h^=E=_wW{HV1SY3q4%;UIZoYt6=zy=%Jl~#zr2@ zN~T^uHw20wb&I@{;@a<_8^?3W`CwF+ztQRCORn0ivt09RR(=cn#Z0MNyW9^OdA4u- zAGmw=(&RZ>IrBHXyt?E&Yqe4Lwy8D#>)knQmmSb`bNPQav?A5DJwsHv(8i<7&mj`11A2 zWQ^@g4CAD0U*5T+M~%#nND4UbA*Gu{1s z;z|y$k2gJ5FkZRHVK?!g=MBY4^7kw{4P6YF7zkg9PNLhBxphySdl2XrYO-!JC-2*v;@Jn^{krs5NM~Pr^{({+ zVH1yCxbcEXM8bu)`T)!62Z#3ATFdcFZhS3uT<=G;+NC{S{qa0fJ?x?3rIXJ01 z$~CAoL3M>p<8CX~GnvcxuGP_#D_qWfZ#|=vXG>f9!b20!EkD#P5OghK&RN$d+Wc2u z{CjlVX?^~}%3c4~OsW5{z*8q}zR2P`tur!~JiXcGs8FK4P3kcOWUz2r< zQ~id<;_D|$>`UWrJiE4iUfP|Cj+=fn`St{Ms=G<3NPOFIrrzha#)}hA;}_;no47V0 zV(NAYsx z^Md(Z%F~RwLxp|G6HnF>C=p zLwD^JV!Q5k_1cpFu4Ol0aI$PYss8CQx6+y8Ekc4$$EUj93RtdE?fPTRcVB*ClOtvY zf|J%VrtUG*Uc2^A_ryO^mZvW$u9n+p_3R?GWheN>w}%*BRAF-@iGqTGk@2_Op8w~}R-JO|bMR`#NPpI?>t429o#&Z;pPueCj(aPf{O(cvcJ;-T_xYXsBV-GvoPSh1Q;y|w%C?OA@p;lN z@pHI@Y$ZZGC(P{7BUp;@XlufPwkhOa09*yX$ z$v>EPJM!#J>c1FO$@xKUUx(0#!iOPKc2=oBz58_HX&uh;+v5EXHY~bhx^?^gLiT;K zUrsvi>q+U{)xE>@MK5QuuDKTfn}%OI62)cimGN9!mNz@QbX9pacmBJL$19sw?|7H! zu=9qP3bTHPpM|o@H~&gbfn8}cjxzBap0e-uKj)dcH&=7sa(NZ>cQw}y-bfyvw+B`| zdba+l$mxZL+|Ry`5u9PX(eLs?k_sGyFVRhJ@4`Ru?O)Fuots^0^+jdU_tfe48y1;yUp3Wzwm4_`f;ET5%v;X3 zhrd>cdie3u%eA|u4FB>uFs?J&|E;(_>k)HlsjuXv;A)-iUz*xKs(g^DyJ62*{91#p z+GOp`Jk10q{>5hxcRp^vrfYaMep%~LrxVxo-&`#H+tV^Te0c=p`{XIdnz|RcZ559T zvwkc6dg_X^S60+@?t8ZWy;Yao+v054MQdy=*6)r3FwJ32C%moj@_GLuU?8Ot`A zHNM44DE1;(#u~$#15=*tdpPguUqQubekMLyf;Prp~ajIdWl1$>bH&s=Sr`ey{re z?5*KX+k+bue*AZ4POVV9)qCB-Ufom4d$+b}z?x~kk*AxawSFyJWWN62nZ-tN^8#Xo zOQkXzzIwcN%FH|<_HLzmPh`h!^Ny_@`<`zud@T55-G`Y{ejD{py7`Mdh+C@k%h-U0 zX~vPAhVwot?Z`}7S){ed_g;<&}Nr(ARXa!RCa-`RyH{$xMS zS;JhYlVfIKmT}vDYjXDz%?}<=-z3N1owOir`Gk}U8|~gCn9Wbzb|ghe`r*S>kNV`* z7KJN*u{Qc4l4Q2%qO*Vq`#Y}5FZ@Jr%I#2-hlvFDxwSf7L_go0(+xFeI>GH2zkDh22 zhl@w%YU?|#)%mATI?-TLi@4;mHSg;9uO6NH{!QtVrP``NhqMECzj_w3cFUiT`Ku18 zNQCa37-2SH-RjrHfy|)-?3=oG>E+wbpZ8Mw>t0WX>?)}jsjVE*hf-Fy@_Wv7p8nPE z@6p4&7H{3utCJp>XCBDi&ZVZd%}B!XZiTJpi`)qb_VW)!mo2GXa7va}Xk#Ap(?5Ei z&F$@fc^KI~=dt!}{yO1x|HP<&Kg$Z5?VB!q{pJ)J^4DPVsol1p-fca)ULq`Wt#;KT z-HZ2K&%~vRvz4A!{P=OQYWkI`*9=u}oKwy%{+}5es=bqCs|tm3m&%{|_gSsjV&9hN zvfeWy0;SvCKWl6^*WTUtXCA{7u~|)g#sQ5@XGE4A>N>C`W2O4)NU?*LpVi%eUu!zZ-Z=l1p6GtGWFT>MiVVER}wm-G9(%kP+0yh>qDUL}2g-K=fy`ad^Y z*V-rZckYOK$l}p(!KQ4{hL;=gHcn|mD~L<&)$ycOP=&c zx_R}hbLKTVLCHU26>~pl)_<@Ld=U4-_6o#_)UxX*A#~xPopjEkGykVvavH}PuliF zeRJ$>XQV{zS)gUGw`}W^W8Ed$ktJX6&%gMgbHlulAfw~n)zi-|I&rMTBD0Y%TPoRk zW9}!1Y7@_67aJd19zB^@cOsh6)5t$GsHMpF{k!*<7n~7)wDo|&@=ITmf0)gQ6y3g9 zxI4;n?{B^PwHZQ-qC_@Xnz3^oQx{oKbyoh*{F-e^JEY7s)VXXYfAOt9%Mf9`u3N^< z`_*a3E9^0~_Ghky2QHl#6gs_m#icdB!XMgfIJ0rulBC6*Kc`luck&gk+1luFd$Gla znMXA>`%EMr#>$(#6-r#3!1{2~JL?JUzO%}$Jgtshf5v>($7^9plH0wP`sWs!eHFi* z`0z6Gyojb_e~vV|m?-?4&b#`KvSP)8+JhViCmvY;)F^W4T&b?>OJ=@{XDOU4`Qg6G z(~QZ9$$#zFU-7x};r5M!NJ}5ir`5L?$1u*Exx&_0!1rKTLlb+am&&_4{-)FVj%``2 z6Jyx0b8g1#kHWTMP0gm#AMBo3d|iIGL-VbzUay2vhoY~X=i!1+Yh~h(WZJ!M6*^cn zfpufM?mIum?4Y_&W>41(2bGj(@Fg_1Dr==O{b8;NJ7M z+l(XbUjN^!5%bTx=% zT#>Cc61zJeDlhI|b^nr9ozu~GdGFiL&t7-6q^a@gdVV?oPMeACOZESnpU+)8!}d}9 zge6y=9M=AD*LAw`>MvWp?QFhmzSZ(;#;s-SMQK}i-f6qp|H6B*wzA~K`$<-+CSDJO zp36pFoEMn7ZjF?Nq;fr)kU$v^bOUHeyWZP1#g{#(z=@4D&DD&@zsqLhSfJ0CaCdwT3lXH5Hnd1bL5 z;}5L}6W=n+qVUw4W4S->guJPG8me2SDKO!tRduY<$5<84-S;NxX1>m`yz{K$L`hV3 z(Td0Z?`t1K>wINe%H$ToC3R&De_s5tLoM4M#rwHftlh2=mKthGCEW1i53^}na? zTWNFuf01$0*_=5mUtV}r_4=^V#uqP7n!WjaI$y>3$CvwOUiGfmDx1>goi1Hyxa|A1 zsS7T#bY?90@OS2awZN4(Y*m(Ci1@kYbL@@cc|mUq?--u$e&>B{;*O5}8SJvBPVBfp z!~Wbv1#71~4V%?m`{MS-Kf07(ZgAON;m`jdv6jgboJ}KRH<{#>cIPiKvAIgb{vb>D zuj1(!lxlL8-V<3L&90c{c|&ALA6Hg^&>WsaF{i!sLW);fJfIpJ)8oFjsqS zN$WoM^Cm5qzDD)#{$g^}G^s2~Be$gX#l2esS=+Spr8MSBna<+AfrJw&IstXR6-smaY^@6|UP zoC3 za%=Ft${AC_3NC+9{KwaLpn&`TKDpyh1n+#?Q}oH(zvlkS3s*BAFS;#g5y$ASS?@G44Q>u-`zZKoj6P~@=+IHvV3x#84Ya<986c5!hW)2Y=yY#M*1+wSr^lZiz${&E(4Ha_#TqaaS++$rl`cUQ~w zABEupj9<5w*#s3`-F-F5yw3FA4dut-VLrn7hXYf-d{Wo=wZVsf{!1A_m9T{?bpE`2 zR(ba1X~&DpDu1fHul*>)ziHN|T+g0Frn`D}b?;0=A8g}ydphNN`3f1!E`hqkyUxy8 zahHenP;0z@gGqXk`LQYIGG+Sr`$c|Bex0-Nu3AO!&xcQ*Z2kY&=0>~BjH&j_#!f9Z zlk(%UHWwF2D!i{>FZ5~Unt8v(N(~rWxi3p~do}+HE&3kqAndZuNa+4Y!KUYZOAdcs zvgWSww_Uef__>}io_-zktK)Ij?^Qzof49Bo%Re~tQli+h%AdQ}uDEe5x6OCKI$e9tNRSo4;-a6QW{-T$n&AEzuadiyB3|9wHqRzdseh3;&FwJdozkA|dI7YgmaD>qf~$;Kn;XP<7r_~`$Rzyu>L3Hv4Q?zqlsFyH(*Ds$Dk zIe+fVRD87mTDV`6`0`7;pGde&{*!a9AZK@IfBvq-lc65x<6Y0pzI&6wL~6n{$JGZ? zKdyaw$7e>zTD~&1G>Hqz&)oDrzpSNC}Kk1%%=K-m`B~#Li zbT+ruL1fd#Nf(0lFZelA>9^%9zv;E-lNY>Q=o-A|K%exa zLyz3NT+LFhe{@%6J>_$MQk&ZJ6GaPC_D&_HKJadzZ!iMTQ=vR zdIGCPslto3Vy=N-yFCACObe0OD=hWUQf>Xs^yA>_4)t3>GA}z_zI?c|EOqC) z*X;in3FvN+J@uod;9`jVl?(3tyXRJ{nXA84w`M_yl!(K=^@n2T+P!pG-akXIyi#Z0 zz0*uquRre8J63l@d%uUA%i=e2|4&VRFa2MJyIQPt?!Q_F9feoFyLk36Nnec!sU zu%u}l7z*ZF7~5anJ)vW}dbPXeZkJiA*X*VjXHC8KVasBL3Zd0mG6{2f-5<7H7E)o* zoF^Ng<9}4@{hO_Z_PZ7C)-j9SZWH$`{`pt#;Gq@{<$`u=JNFNFxguBm-F`I3Uz9B) z?dmzzTWuW;pOsY_wd^g~J*J%r6*_CHvzM_x{EcAMx5-c6FWR#$!#DFFk1&^Ken-sy z{U1AOe&2s?ckb!of|XSj%kJN4S9hF|wfpab-oFwh4_10;=JjN`nkGDw{~O3=ervnU z{RKPAtKTf)n0hL+=%<2C=^pE_au*&I!)~<&74z@<^zZH1nU~yHrqblld-N}Ji*;k5 z>t)@bE%Hw<7&v9L6&g+d-LRN-cKVE{*({1H^@=ZT=9>DVZ_D0^ffoNZ`o}#x_vKvB zk%wYWjsE>EP4j9v?|XZz=c%VVjTfv@=q*mW5LMf!efGo5ds{YtVP5fBwlF1_>E5@q zc3ys~5AE(*eRgBp>bu8UE6#7`y?3)G{-vYqUqj{2zq{nmd#f8ZNLO*zCNayToT=Gb zc3CBU$Lmi5(HTLeMl;)OVe(tG()O+>6P3YPaX^Tk%)+!=s5W)>dg4tmauB zDdZUicuL zeKsau{DO%u$G@GIXKk9`*z|AlGTvREuNyVLn;2j?%WFyLadF$C#d7-JY&>Vg{qvlZ z&+CM(oMJwsW6g5Cc_Q~d&gG8e3TRlyI9qq=w)TtHzaD#= zvMI85-n6U$y)#~$l0Nr&RVvy1Sg>ow;nlk(1#hI!Ry`;@JN4VepkA%j7fg;m|1yJj zb@cwzw+>i5T*LeEYC99-$M;Ku`>(qRN^9=ylK2`W>`;C|F7(Iz$8%rwvRiG_U%yf` za^94C{|}|HN}2z9-f~4#< zU2)|7npZMjcHa^cr`$eZH1DIZaqSlOs1#%7K7qRiX~&=U?or%$IB4FgZ416Gs>;hZ z`(;19cd5&M-gc(T=iaG2pZ8GM&9kdI=v|(ig}Skm^c1xv_5xdvA6ps5H{`Tld9y7Ik;BDA@ zv9V9{pO3QK(~Gxf?aAEyu78^Bggw!*-Fup5T~T%`xBFPzu*E&+UwV4>TD#C<35^M+ zg12W0X!d5e%{<|~{?k6z#^T;RYKl>{SMPYOj}m>lH==6x#B;$WIZ=lW=IY4DUFVEG zm65sg+<`lbJ5Kcntv7#l{7A)pDgDs7rQN12o^Lptu0Oci{!Vxw?^y$0OQpSW%a3${KWnO*h<*JIS?J55=15Z0jI5l01^%B!po3nbskA^$y!g4h$UhQAB zo&TQY;teZKWaK}5`)W(JHAng4IkVsPdaM`rKjyRl=h=&!ewYL;Jo&4-ym{%w8?}L@ z@-Odh@pzFTzw%Jh@gs6R2X|bbbs%p8x7(v-f0TCHR%{b_F}JGZtN32)5-SEN4_%oV zH>5Xctcm=WXW?zpJb}Nh&cBG^_{|651|^RLmK^6@A31r+q8Xmu&p#>2z7aZisAlf9 zceDGxik>)%eG{sznlA^U9ENHa?Y2R+CR)$!O@`p^l0FpwMWC3%avf<0; zyUKfg+O!fIqD(8_+^dcdoe&wfYrZT;)zOvvJ-A!voZ2q=f zxQaXfi(j?aXYJW*ZDl^3|7`bv0>icL&Dw73ihOKk6^b4hY4FRM96Z1(uHTbN)LShyy`*g|6Y#hl8FAF*HK*KU~iZ|5Y5O#$!zrR?-6 z=DT@6=b`m)nH6U{a;tyaFIza(=j(ah6E7Ubx( zJ7v4LfF0p!V#74p|132Q|Nz>R3JAl>L5Qo+j^uA8Oi%os4JR z70qBey(8?4)co+h?!OZjon)OhQzXc{`k$oVM^A|Nn(+Q_C(F95!oGJp6Of;^`AhMP{!pidPi96-SmThN2VY z{z@D{pWNR|=w3f}^U1;a&S4b*P2bVEaD_vCI+qL2W$1`bn>8XrD-&ZQk zKB*n|`OJo(?&@@g0KMy}-Ty8Wdwajpojz&frcR$Li_P6V&Ddrg_+C9Lw0G90HSgD$ z9({5;AU1iG;M2;! zhr-2#$`{R^q4IG5st-N?o}?c>U_*w- zzC}kq8d=Xy{wt&!|Eq@gM*;_5NtLPdt_i2!lzyMXwWj8Bvew^q%P;r%ozSdEsa5oI zSZoq~kyq^c*G&5_WgH0tPn0Y+naP=aS|zGh=ujh$T>fk zOx^l^zLE{Id%~J!^9n97_~+Fx=iOL;srIATvX{?~#aQYlCwxm!t!>+(E-Uy`@4%kl zA2kFu&;5QCw0CReQML}jX2#@C5fRJpXu9kD-^RFt_2IM)nlIuXZJ8OS@IfZ&AMcLq z_cj+8m2K@m$?veF+IIni*(u>!YuE*%Qa{G5TYgmZXP}YZ+95&@BcAEzr zc=Gm)U;Vk~8K3wr?Z0>7&dgU_8Gc(B*|vWV>{+0`XsU&4(XMj^*(L`Ab}u!0V}4Wb z{Gprg*Um7w6!5Uo(W~+k*JNuY`|4{_dZAN7vTQHDe6^J8;`8@&y$h!*-aW2;$1_}J zAy3)ECDnFqB9FU-)-~4Y?%3&8%VN`JI7jaCOQrBQb^ZqBiG5u=I?8$y1@5dgcb%N1 zdiVCq)fb(1)>Yiz7ievxk*Oi>G{|G{`ZP~in*(S`lXIrICIPba2^?dN`w%0FXcW!T!Jk7)W@=1rq!>cRZ z@ASvAN;BS>9Q~9C-79Uu>GRT?RV#?Urjx+ z*RsLnmw7!_?zM#m0M{xCI3R{OaeC&?XX z-gQxrab|Pp^fSNT$3^{E$h~Bzl~Md1xgU;;8Nd6zzrTO~o6VjdR|$ zRj(x1Y!AshIA!yy+Aqd0ybp9P)=fO}Cq`yj?#i5NOP<(Im{%#IA}Z$*;CJ)!g!`&9 z#G1{H^(jqev~B&icbeHgoeB1)4a&}knhn(t#C`uH7jHh9&6tZp=2dgDQ(Sgb)$iL? zyiNbD|HYi;%jB>x+5AL5Z~ugSMFJBX?XIXrChuR#@x#6Pm!$*8gml*}R+IbGOKR0w z-aF5I^!bhW%lBV|STFwnUoNEOV=1^`_DO{$yR>EP=4rjTuYPXXl)5#!@l0PQWWQWs z>h$`o)yDbhUeFE?+_u^M%U|`(-=)bZbFH@|Y`Gry`>}<_3jdk6f&Ra)<`3Z*+5G%UJ&dP+geA+;BiG}E0AXzvbtv|-||*^wKvlr;Dg5*%-K z#7SFDk+_s{=kp!kf*1|S*{hp==J#EDTF7vg@A5f|HRlfg@+-boC91=`YE!t#n?MGE?EIf*5yE~&}+DXCm`c3ex-e= zw+nwgadWn9`Sg8TCcpXqPUP<0r?HipIo3AO(KoYfZ0$E*->1F3EaCf2wfkGXet2+V z_BNY1E$dBnYLdSLw>LJ~z4>?d-`pv_!Q6H?<6k`v*e=ZXsoGXX_T};7XAa*)Q>J`5 z{_Xj$?D;b)p3JdMxEmIEJ)x)AWUp7^<-j`&^H%>`)&6#&p3tPwQp=e8FCxv}*-hB< z*M@)F%`NSEQF=GOoRyu|{%^90oy+Cv`!?0yt=sT>{iQn>zZF@@>ZTaTtqohVi9P({ z+5da8b!Pvwc-;H>U*#sBOS?bpI<;=o^ULeD{9X5V!^KITMWe-zYHiB>`qrmt{wDjL zJ68&S%J46JJe8T}ktw5_g~Nhb9kvq~9J)Ses7yZ^o73Flr?cw)k& z#oE*5<|}`jD#rHl%<=3a_n3Hj^*WPQ70>N2dMVbrWESf~)@Nczp0_2v&+Uu&wXend zzWMR39{0`NWncalYx%t|FG+m4of==(sT&ivJ}I5kxPFhM(66Z<4ex}_{66*3oyV+? zwjS^FFIBlZzpy_1g>SG+YcJXTH*xiIb7yyo3rEBVeho?l}jZ;@UN;pEGG&}$In=5lCxY|dxJbrfcwzuG4_QJQ#M?k3`nuJsH zQo#AZ5HlZ`8(V^JU?M6Xgo5&c$R1ceDDz+nZAp3V{AfdN=&Gx6iiUSRCM*!(`}_U% zN9Br}-x#Fq`{$>>Ie6!9MXZ0w-Q2S(HBa80owKVrex~QQ;$oh6?>?=wlJ~K;kq(|+ zHOJO=BNFtn8b_gpa>Io6I=8>TapytW7Ux&$Z$GyFB=ZfKU9dTVH&C zAAFZT<>t(xLZmcJ3LPGxD{38C=CMH4BJz2AoM`tA; ztBuN<#`G5M2OVV(4j3k0f4*sRH22&fkL#0tju_fWq}S~^VDbGi&*Mk(|4wM;XFuS4 z?$~0%&B*^vML5AT=7sP%=Ih1@&mGhH9^0IdiDHdyKBU;)@`|g%FI)C_<>Q@?FUX2~ zP?}>dcyPZ${L;shm!B!*dgPJt>EXAjO?lG4mM+OY(wKLcHwllEvd~cAQdDo^z3*2M(Sl7M#yrk>4&B{+^{yQ{|;w&pkm>-zzV*o}a8&JJ0Cd=P8`?m;3y( zN!|QFO9yGOA3DVv%kL2__J$Q{Kp;k{;_jR?{8~=^lshV z^5?NK{`ZsLB-h8<)`{9Lul+9J|7c%jhWxRIUo2Jad+y%e*?)aa|752c*<*8>>>mBo z{Ac~T?0C6q`uXP%-epr-kDeF5ZfEJKslLB1Rt2u@T6#${ ztgYb|lLli5%MGCh)&~p~`xzfFvfNw5xL{sZWjFf_yJ?ZeAO>A?ilmWQeEJey6wtR|-<5qb zuHjHrVUJZ*anIgamQzv|%v$U8le7T34PA#q~EThWJSA{*;Z z&XRZ%GG~2aYuEer$8<#FcT3IDoj;w~|Fs31`RQ8OSGT=ouWY$9-6v;fzW2vjpR`Y< zuk||fNN*n#yL(h6^XFaNVITUF*P2-DnDm}y&yySBB|l@&S_RZ4^gry8`M7afQB+@{ zUfx;5*yFs%9|Zq@CaJ%Y?|#74zwb-G?Ki*qf8UvZ-$TFc-+uG|z107|t$y2|c=Lb3 zrvJ_7{_(5*wx4qIzhcV&cD3L84J)TD+jG`q`)#*?%FGTw{q5{$xiP@_li^~ zw;A4>x8?A^hS)Fe`47K-JbJy~_oMx~h*xr0^0cvnfdZ&Lw6TF-MQCAaM0B364fV~w z?I5uCb$AYc{hfka-|x;f+8&iHA5oTjQ{Lc)=8P^2Q`x8QzQtO1 zIBjjccc5j}UGwzFi}l4H_!KMumRapSyz2JXgEi}x`PY3ek-O*d-q)a3BFg;DZt>E; zGadXR;`@$=vm1J`ceiHUJ$L={F?joPg#l9lC6oozV~-sF1)-W@$%js z3G2Q(oqb&;xMSVl{PP~C%FK(V&s&}SU;LFuJWFwNig3_@DI7;QRAf486ig0qWW3$T zpCWhMl-)?)20i<0 zUu0JIn_i9lcU0c;>wd!zP8H(koT@IZIovQiXiP74n{wKUx7O^<=A$}cHOG3wYWf5jpZ?cy(C=W#k(Dns%D2D2-NZdLhBFArbXm3V*eir42^st)}sve{?V5oi^m6Y{!j-@5Nl z>xv7qejUB?{>=03i-Q%{@@D7!x;D3O_A%bs?~bw-uNBXVyWV}E^lg2$ThO-M6L)`! ziT%Al!2PGv3~80w6PT8{D7Yy+ba=wNkkQQ{yT4Z9v&A~g2|pc}+`OiiGP&`&%~MVY zGVm%{xufm)!97fiA5G!vQRO|@qbgx4VQOr1tl+W8&zw1{er}aK!f;>gVX|7ePgeuH+Ikg4yH zogLEG0tEaz7oV&v({1W)d+mN9VMpDh2koUlH!gb~QM+d4xlj84POSXj+bDi$cY)ZY z$!W4|cU+8**{rn5u9!0M`myNO8xwifZ=PVdB~>u_%K5aO=?9){Rn*_qV)!auGx<@9 zjlD_ABi65~`e%6drLZPvobx*NL1VQZ4>`)W?|?kBrl{KQjIj{ZZ0t?T?(TTV+aDR1h&?j?CHBbpN9zxsIz>BYe?`0Cbw7G;a(|rp?NX)1J+dTp#5( zi#)Qwci8FA@>ze@Myxt{-_x=5NPU6UJJG}KU5^V}tWGR*t%!_ zm$Ru7e^ed5^UQr^asK<<>iu1Pe+47IEVjJCMYH`goBLm}dDM`Edh~SO zZ3BTlueEPDH#~VTW6GNF1c?PI+#eSD3b4Db?{itslyq{!TjziK=G+avB<9Fx)^_^l z-J26#;%cjJoXfGc*&SK3`s!k9-su|)H-Gy54pfgi7hCT5_vi4=Yg;eBd+BG}+qWr%Uy+KX2!i! zmcRS+YGwR}Dfffs=W1$wxZJxu@5Osa7TuM9`XMNb#vEDsQ>Fa=*S8v6SB*hgH23

X&ijybXJ0`q%R% zP2mgEzPfAg`q#BTH(Fbm{!e;U{_OJYiz_EwYcn--e(iTW_VKaU|BsrMUen&X=5^?U zU*GoIDr=tq-MRZ4G>d9QNRgaHH$k$fDeu7^Q&<+gEb=pH)~cU-rH?|hs2EZfjT4|^ z7X79F?+7f53KGnsVm;S!Wl^RPmPKX$!m{Y@dwb(uk3a0t`E^m&EOv3k-RlSCqe36( zV9BCp!zPP5txZ3hShh>%u7&mNnQo_o%Ta34m&bz5zm%W4leM-s;qLaQ1qTwAC+I!8 zQZs4y`(I@ut*<1jn1xqu%RaYh(f?-;WSu^Jds|Z0?z>;U>1ohe`M=Lz+U%QnZ+1eR z{kFU}zaTB$8*$KDbN2NiLG9@?r;2x#WkWjypw!A7=x7rlqVD@d}_SFpuAw~ zak~kXGS_8J)F?12FFj?&sLZZ>UeG{OLUmV2%;Cogk&S_cUaZGvwIv*r>XGW1B`KG@ zBeSc<(D&+}d%Z~w`MoB&9OB#wJxdQ8G4^qUO9bk7Bwq|aF0;Nt_?Vc*(>o#-k1akH zpIh6gd;H;Iy&d|6UVY*RM6Ek#sXdB0!kewZvHZxz6#Ly`2i*>TRn9PovG@FNc-NnZ z%f)N#u7#xk6|aAE<^Qn*+z(@SaJ=-~%*UL!NHTd|$UIYq zIt*W>b05o2_;hQ6c;q38ubZbB78=cymooa;^lOrM8e{yXCPR~S)#QpPp*<_@&gLiW z5so}7VO4xhesTV}U&$Yeulc_ZIQJ|0#mUHer=4r;55BQ{?caI+m++&_=R{@|Uz_-ac$tE_xQ`v6ubkX@Adg-DH zDb1n>^A;Nj?ENfy&w1&$3CG$PmUSsfas=`1UOOvm>vfSic}v)oCdvHz{@UC)vphVM zzjNO4{Iq*E2loB?wqf3myozs=pM@}+;D)ce+0zw?#5?YVot z%z1WuKfkm^6F+US-plq%Tt{@bHdH?s~e6d9M8~tbmfau`R>=d z14UM)zv%T@vn#fGlIY*k8Vzy?ZtW~{DPLzG# zFLC*^TjN$#Ue-~%U;h8Cq-W*5xE-etT=fNQy3$#+({WR$W`Y(=5Q`C?ilTsY0?QUY z3znP%nTHvrnIt7FL$66nuu8Z#Hk>@T;=@tnC=__yDpB>18-7x!&2(HmSf*#`oLiY|b2$82d)H!(TV^*sodL zZ)$t|SF&&EwEBhg`#nGU-Doo` z5nE&LdcW!G@(1FehHlf>Ge_meWE5fi^_nq z=n_yCHT~}O(E02~lY`JKx@#g*7X4<^_Yjsvci-C|@7n&b0aS~Y?R49?D}Ryw{(TRu zv1CyTO0y`=hVBFwa6^|Z=j4PpSR1+(vu-eX6o7R7s{kXCM z($LMgyWxG@)vxJHwhvzxS;@*A(U4sewyM-R{`&7v$<-xU{~&$Q$*{g?@ABNoZMolH zHNhIXyTA=y{oS-{=*q(SqN5F6_nJZ77xnwg3GR#Ta@)9TeY1U36xN2WCC#!ZQeX5b zIE$9z>x(`|?u**(sQdLW=Jl=9u)gTzU3%tMm%U#m?SJpf+1EQu#jibIa%gYKUv}2o zD_FYe328`|o0>zq|Bvo3cvYYLp!I`ZOv{%gk?oA;7kdo-wa!b)r9RpE z@mf`m#NpREDLlE6Mw8TPLySSLCS~7Lw=rd1qEQ)}G|v+@K$MP-52R zNrpD3w2p<$e`aoYuX9Zr&s@vb{TI#C{~G?Ve7(F}BmJ-8mnUoN7sgzhpYUzY*X2jj z|8jneOy@dl`P%1WPw_QSBNsHREA=bqMtXPTnjbxqYk$Zvcb`8ZIRE15uJaZ8Yk&0Y z3#)0HA6BE*2N@y)jowtZWF^z4HS6*b3qoWBs; z9G~MtPjkAe3-KkzD85&(EtYey=e%I+yxi*C=XK@p!!H(EfQNKrp$%QJ%@33?Yf*D7 zt8gq#sX1K4mUMCgB#UAhF1l^M8!}w<9a4+FgVmyWe?VC@^Lq`b7QMMEFn0Rvtjn^; zr2X%eoPE8tRQPpq(8D;syNE1mAqC2!7S{28c{6%JS+qnV-u5f^v`^8mHtV{w*6n&& z^J2GkYTnjsb{pQ^+GL-!q1ZsYFw5@bUHM&Q0?@wbw+lU>zUT{ZU({yT<7KzMA1qq= ztiSHF4PX9}?`kvd^RJcWyW73%pU(pI9R1~&S2s&6ZNBQYHShiFs`$D$eST;6gJxa6 zloi2dT|Q@C-;sEI?~a6(U%hl+SBXMrT|U=6T4x)6{h$7oz$r4w@^LK{h({Ei?48@-lH~Ck(S^`8Jp(Eb|)-;_)E}4 zV%>a|ABnMbYhGH0$!D+H{IA=-a5Rhl=qELcO0vPTsPprC>lX#rJ0bT)yS_Y##F9mk zS33k0<)@S;rxqz_6r`kuq(X{hm8JTEu={pytCYIzEDQJYGM!>k4`FSphC8-J; zE>?z?76t}}28IS;5T(hb@0*{3TQa05v7jI|MM2*!F{e0{OFtmQHA2s=G$$u1F)t5f ze@I4Vu|j6C0>m9U3Sp^5#hLke3dVYdCWfY#MrNkQx<-0tFb9I2rQnlUma1T6U}U79 zmsyctte0PuuBnh+kXVvYoSLXm1~tM=&sfhy6SUe7x<<+nc~Co~vLIDK-#;lUxFnZL z-%r8B1hiPNsJKMI*w_?4cWh)~ZVDOn2Fc=IO87P^I$wIbP~G?S4<1`;DCxad5fJH^ ze5+81ecj_-I~Dl5_HHZ9ie9H;o?BnLe`ciTl$4`^m!3Tp@i-P!WMTceFmFmq=;9tN z&zWm-cuuK2T@-#zBfe`>FBdC!oNDrvQmxr+Ia-&czM1&m+~g`bzo|$d#Nhpb7i&ZL z{!8UgDgH72!*%DPh93*|WPXsD+P^VSZ{>mWuB_sh#kRFf*!;<_HK*&7<59Kb;Gm0+ z!to(Ig57RMg>1}Lrtr>d_PUqa8onfjStNXA%Z}8|r_3r@r^y)otC}jD)1Yd3d`Xv< zfpcmo&z7E578x=jA6egrw1%|3WnGoiC|N&st*;B?p5<>WIXf{lZ4GNO+kxq~M8a~4?w?wA{>tCE zr+2oS95FHB-Q@U6vE9%$=X;F#vaRR;=4(qjMZWsIwtOFFMSuCq_6VJc89KI4c0G9U zSM!_BCyBkLX45Kbj>`(A9RBHSWIL02dHw;<7pbDTFBG4%M)gkne(c0*lgYX7B=5an zr26hb^_1xg-UzMSdhf`y)ZLeT4%LXnFl!5+Q)|7m*yY7S<4?M0ck%QtD!*WydPvcl z`R`tBTNUjW(huZYC!FL>^U69fQ`)`gh+6){!K*3wB_jaW!kL~H(Tkm(xy1kgZHj0o78fzKIFgoV3nWRM(!~CyP<{L{m#1>bf@t= zFWl?ZcA`VGPxJ2NWkFj%WuDrZIP0%n{q1y))S~ZizSMemR?pOxYG%>=;uqF!7Gt4o zx$(l8PJfN*&jfC$c5t!J?qW(_z9lH=-ZZYIVO#F@Sc>jE;;MZ^<+)=}*YfWbUauQ7 zMJxsNW^!Bf<>bx}lu^EqL0Qa}$_kTYEMqwqDR#c0%IOsu>q21pI%&)O@Sp`o)5< zCBlbOd+$yTn6U9odP{SBgz84SbWX;P{JWCQUTc~Dyx`R3y+;dnEs-_$i~Md^^#1XQ zs21N<*MbyPQqG9H*x?YK_3`|Xd*7diJmK)|$@XnsKD)4U@uaHLR|MX4z7|;M@;4%h zlVx|oE}hJsiRH`WrdowQn8_VJe`m_X3ww_S^@}sPZ`tE&F>{*H^(B{=pEUlP-JKGb za&5I;L1$9bc@BTucxC0!W)tqGC+|@46q})Z)6?ur+^atqYoon#58hnK@=C$D{G&$X z%Egi~%NCa=PTeSSxGHA)t#uMcqVrlq*L~Q!W&OhcWqS8F6))U=C{`y+^U}oL8q=j4 z-G8*KU!>%o(baZ1#jjT7?=DF{&y73QO;Me{#5myMM@Kh5wll8Nqi)=en0TsH@LX)r zc0HlYeD&K!UZ3||JF{cPqCn2g>7`eVHp+6>H?AW$~IiWVPGB*0M z`_7~|Ta|#~sc>hal;!1%JEE3uo2;EQN#;;O<-T&Y;@)^5pjwm(m&^?A64{toyCz4f!(|NHo5H2#VgL_ zd0)=Xc-y$}=w8qNMFpQ;{Q9%$D34m4@2%Cz6%VG>-F^G%oWlv%dKY<_zwYy2d`q+0 zArmKEYnSzVa@m*oi)rZ$l6u$YhulrS^X}febGPLa?mV=*U1Pj;t!8|3wDDG*X~~&}-(axsO@F4zrSRt0 zsw!{PJY;Nsf4uqeVEOv8ZSj}4rtykhTgl$HPxXN0>Llmd7u^XL9;eGxtyuVBU)!UN zbqo1R^K<0wY}QVoBNnsX}dzM5_NlIfwb&DH&{;`7@lPYbV9S>5#Y zNz#>VRi6quuH>)xzkTsXibdAV#|0d}&bKDt&{!>(zyId{k2_@!-%>EP^yz1OA}w>6 zufhIhL*Da>IHPIi3`^UdnEy?;mbxa;(rfhY_Vadk|9CEzlg~^ARQwy;=bifLazEzZ zWPvw_zH5AmDpUWoVB)@5gM!5_zg|3lyf|GXYkgde(iMiN@?!>Hwa@)<{K>AY zd4Y8OFOK5L$LHkuS>8R9l)2#lb`h7=f*%VlgK``q51(Z;>{^+V0NF2Cd# z$+Ps`(&LKXH?}7wJo`PVEHGK@%pHw~dHXGI)Nb-llUr+k*(^nUo$N7IXZhD5Wm20H z)NRkb*>WxK-7}9>FH}^Xe)I^sXL5dCSZn*^f5A744U_wBuWsa+dFAJ)$4ph_Pfp6O z^KV<;{JJ>8%)&bRqu8&1qTAg)Kkg{GmcPqe@yZ3g{8DvwE+y^aX-V>G>qY;onzt*> zJ!rg^aorU$QRnb!8WCwrIlr5%^wTo`#c(~fL^YOYrBGJ)b5mEX83|UrYbtAZIsTnF z?Q3M{O!<$byuGk+}SR#_QzxLhu*jUc0A3WAHGhNThGhh>tX)(a<;`ETjn@R zT0HNr`yL?RXV34aE}s0$lBZaXw|*B}!1A?S*+PGpZ;9OHuA}w%>?WftooAKiW;Y~}vY z)s|Px8$SDqD(~e@Z70`UzHoQ_!uv6YukI`JJS+^UA$)6KvO`Y!<*_N>Ko$b5D4<+a2cg}g$9$wEFpry71OJ@an87HKr9ubt9 z#-;C>my%kc5N)7fZW7C-ADmg0s$g!yr5~;kZKzM7#AC#Y8qF@f%4G{!Vo|dm* z4(j=UI4%m&Hm>HTmQE%{E@o!tCI(K1hK|l|E>4avW{xhd#;zt7#&!yXmBb>t2gU}F z-hl$)?t$!Cd+$SuB1bv%?HPF{gQ4ZAMy+0yf|b~W!?f7>v85O2_7)d(rwsQ=9+_)XWW6n|em5u$Jg3JFtP7c!P$la(Bq@+8|#Vy6vPp8{v;_DyG+D8&^Wly#E z`9Vt{TzI|dqmS2Dd(`mlxpuPbdUo?3jmoJfUfju^{70%P*D%C5F10O#r|ot4<7c;b z)S6dKKURCGLPGMdaq@>`o4b;WmG|cw+xX|!bbsL2Xjfi_8I#2&iA5z9MX70AhUS(A N=9XNls;>TSTmbwXtM32+ literal 0 HcmV?d00001 diff --git a/Grammar.tex b/Grammar.tex deleted file mode 100644 index 4a16b00..0000000 --- a/Grammar.tex +++ /dev/null @@ -1,215 +0,0 @@ -%% File generated by the BNF Converter (bnfc 2.9.4.1). - -\batchmode - -\documentclass[a4paper,11pt]{article} -\usepackage[T1]{fontenc} -\usepackage[utf8x]{inputenc} -\setlength{\parindent}{0mm} -\setlength{\parskip}{1mm} - -\title{The Language Grammar} -\author{BNF-converter} - -\begin{document} -\maketitle - - -\newcommand{\emptyP}{\mbox{$\epsilon$}} -\newcommand{\terminal}[1]{\mbox{{\texttt {#1}}}} -\newcommand{\nonterminal}[1]{\mbox{$\langle \mbox{{\sl #1 }} \! \rangle$}} -\newcommand{\arrow}{\mbox{::=}} -\newcommand{\delimit}{\mbox{$|$}} -\newcommand{\reserved}[1]{\mbox{{\texttt {#1}}}} -\newcommand{\literal}[1]{\mbox{{\texttt {#1}}}} -\newcommand{\symb}[1]{\mbox{{\texttt {#1}}}} - -This document was automatically generated by the {\em BNF-Converter}. -It was generated together with the lexer, the parser, and the -abstract syntax module, which guarantees that the document -matches with the implementation of the language -(provided no hand-hacking has taken place). - -\section*{The lexical structure of Grammar} - -\subsection*{Literals} -Character literals \nonterminal{Char}\ have the form -\terminal{'}$c$\terminal{'}, where $c$ is any single character. - -Integer literals \nonterminal{Int}\ are nonempty sequences of digits. - - - -UIdent literals are recognized by the regular expression -\({\nonterminal{upper}} (\mbox{`\_'} \mid {\nonterminal{digit}} \mid {\nonterminal{letter}})*\) - -LIdent literals are recognized by the regular expression -\({\nonterminal{lower}} (\mbox{`\_'} \mid {\nonterminal{digit}} \mid {\nonterminal{letter}})*\) - -\subsection*{Reserved words and symbols} -The set of reserved words is the set of terminals appearing in the grammar. Those reserved words that consist of non-letter characters are called symbols, and they are treated in a different way from those that are similar to identifiers. The lexer follows rules familiar from languages like Haskell, C, and Java, including longest match and spacing conventions. - -The reserved words used in Grammar are the following: \\ - -\begin{tabular}{lll} -{\reserved{case}} &{\reserved{data}} &{\reserved{forall}} \\ -{\reserved{in}} &{\reserved{let}} &{\reserved{of}} \\ -{\reserved{where}} & & \\ -\end{tabular}\\ - -The symbols used in Grammar are the following: \\ - -\begin{tabular}{lll} -{\symb{:}} &{\symb{{$=$}}} &{\symb{(}} \\ -{\symb{)}} &{\symb{{$-$}{$>$}}} &{\symb{.}} \\ -{\symb{\{}} &{\symb{\}}} &{\symb{{$+$}}} \\ -{\symb{$\backslash$}} &{\symb{{$=$}{$>$}}} &{\symb{\_}} \\ -{\symb{;}} & & \\ -\end{tabular}\\ - -\subsection*{Comments} -Single-line comments begin with {\symb{{$-$}{$-$}}}. \\Multiple-line comments are enclosed with {\symb{\{{$-$}}} and {\symb{{$-$}\}}}. - -\section*{The syntactic structure of Grammar} - -Non-terminals are enclosed between $\langle$ and $\rangle$. -The symbols {\arrow} (production), {\delimit} (union) -and {\emptyP} (empty rule) belong to the BNF notation. -All other symbols are terminals.\\ - -\begin{tabular}{lll} -{\nonterminal{Program}} & {\arrow} &{\nonterminal{ListDef}} \\ -\end{tabular}\\ - -\begin{tabular}{lll} -{\nonterminal{Def}} & {\arrow} &{\nonterminal{Bind}} \\ - & {\delimit} &{\nonterminal{Sig}} \\ - & {\delimit} &{\nonterminal{Data}} \\ -\end{tabular}\\ - -\begin{tabular}{lll} -{\nonterminal{Sig}} & {\arrow} &{\nonterminal{LIdent}} {\terminal{:}} {\nonterminal{Type}} \\ -\end{tabular}\\ - -\begin{tabular}{lll} -{\nonterminal{Bind}} & {\arrow} &{\nonterminal{LIdent}} {\nonterminal{ListLIdent}} {\terminal{{$=$}}} {\nonterminal{Exp}} \\ -\end{tabular}\\ - -\begin{tabular}{lll} -{\nonterminal{Type1}} & {\arrow} &{\nonterminal{UIdent}} \\ - & {\delimit} &{\nonterminal{TVar}} \\ - & {\delimit} &{\nonterminal{UIdent}} {\terminal{(}} {\nonterminal{ListType}} {\terminal{)}} \\ - & {\delimit} &{\terminal{(}} {\nonterminal{Type}} {\terminal{)}} \\ -\end{tabular}\\ - -\begin{tabular}{lll} -{\nonterminal{Type}} & {\arrow} &{\nonterminal{Type1}} {\terminal{{$-$}{$>$}}} {\nonterminal{Type}} \\ - & {\delimit} &{\terminal{forall}} {\nonterminal{TVar}} {\terminal{.}} {\nonterminal{Type}} \\ - & {\delimit} &{\nonterminal{Type1}} \\ -\end{tabular}\\ - -\begin{tabular}{lll} -{\nonterminal{TVar}} & {\arrow} &{\nonterminal{LIdent}} \\ -\end{tabular}\\ - -\begin{tabular}{lll} -{\nonterminal{Data}} & {\arrow} &{\terminal{data}} {\nonterminal{Type}} {\terminal{where}} {\terminal{\{}} {\nonterminal{ListInj}} {\terminal{\}}} \\ -\end{tabular}\\ - -\begin{tabular}{lll} -{\nonterminal{Inj}} & {\arrow} &{\nonterminal{UIdent}} {\terminal{:}} {\nonterminal{Type}} \\ -\end{tabular}\\ - -\begin{tabular}{lll} -{\nonterminal{Exp4}} & {\arrow} &{\terminal{(}} {\nonterminal{Exp}} {\terminal{:}} {\nonterminal{Type}} {\terminal{)}} \\ - & {\delimit} &{\terminal{(}} {\nonterminal{Exp}} {\terminal{)}} \\ -\end{tabular}\\ - -\begin{tabular}{lll} -{\nonterminal{Exp3}} & {\arrow} &{\nonterminal{LIdent}} \\ - & {\delimit} &{\nonterminal{UIdent}} \\ - & {\delimit} &{\nonterminal{Lit}} \\ - & {\delimit} &{\nonterminal{Exp4}} \\ -\end{tabular}\\ - -\begin{tabular}{lll} -{\nonterminal{Exp2}} & {\arrow} &{\nonterminal{Exp2}} {\nonterminal{Exp3}} \\ - & {\delimit} &{\nonterminal{Exp3}} \\ -\end{tabular}\\ - -\begin{tabular}{lll} -{\nonterminal{Exp1}} & {\arrow} &{\nonterminal{Exp1}} {\terminal{{$+$}}} {\nonterminal{Exp2}} \\ - & {\delimit} &{\nonterminal{Exp2}} \\ -\end{tabular}\\ - -\begin{tabular}{lll} -{\nonterminal{Exp}} & {\arrow} &{\terminal{let}} {\nonterminal{Bind}} {\terminal{in}} {\nonterminal{Exp}} \\ - & {\delimit} &{\terminal{$\backslash$}} {\nonterminal{LIdent}} {\terminal{.}} {\nonterminal{Exp}} \\ - & {\delimit} &{\terminal{case}} {\nonterminal{Exp}} {\terminal{of}} {\terminal{\{}} {\nonterminal{ListBranch}} {\terminal{\}}} \\ - & {\delimit} &{\nonterminal{Exp1}} \\ -\end{tabular}\\ - -\begin{tabular}{lll} -{\nonterminal{Lit}} & {\arrow} &{\nonterminal{Integer}} \\ - & {\delimit} &{\nonterminal{Char}} \\ -\end{tabular}\\ - -\begin{tabular}{lll} -{\nonterminal{Branch}} & {\arrow} &{\nonterminal{Pattern}} {\terminal{{$=$}{$>$}}} {\nonterminal{Exp}} \\ -\end{tabular}\\ - -\begin{tabular}{lll} -{\nonterminal{Pattern1}} & {\arrow} &{\nonterminal{LIdent}} \\ - & {\delimit} &{\nonterminal{Lit}} \\ - & {\delimit} &{\terminal{\_}} \\ - & {\delimit} &{\nonterminal{UIdent}} \\ - & {\delimit} &{\terminal{(}} {\nonterminal{Pattern}} {\terminal{)}} \\ -\end{tabular}\\ - -\begin{tabular}{lll} -{\nonterminal{Pattern}} & {\arrow} &{\nonterminal{UIdent}} {\nonterminal{ListPattern1}} \\ - & {\delimit} &{\nonterminal{Pattern1}} \\ -\end{tabular}\\ - -\begin{tabular}{lll} -{\nonterminal{ListDef}} & {\arrow} &{\emptyP} \\ - & {\delimit} &{\nonterminal{Def}} \\ - & {\delimit} &{\nonterminal{Def}} {\terminal{;}} {\nonterminal{ListDef}} \\ -\end{tabular}\\ - -\begin{tabular}{lll} -{\nonterminal{ListBranch}} & {\arrow} &{\emptyP} \\ - & {\delimit} &{\nonterminal{Branch}} \\ - & {\delimit} &{\nonterminal{Branch}} {\terminal{;}} {\nonterminal{ListBranch}} \\ -\end{tabular}\\ - -\begin{tabular}{lll} -{\nonterminal{ListInj}} & {\arrow} &{\emptyP} \\ - & {\delimit} &{\nonterminal{Inj}} \\ - & {\delimit} &{\nonterminal{Inj}} {\terminal{;}} {\nonterminal{ListInj}} \\ -\end{tabular}\\ - -\begin{tabular}{lll} -{\nonterminal{ListLIdent}} & {\arrow} &{\emptyP} \\ - & {\delimit} &{\nonterminal{LIdent}} {\nonterminal{ListLIdent}} \\ -\end{tabular}\\ - -\begin{tabular}{lll} -{\nonterminal{ListType}} & {\arrow} &{\emptyP} \\ - & {\delimit} &{\nonterminal{Type}} {\nonterminal{ListType}} \\ -\end{tabular}\\ - -\begin{tabular}{lll} -{\nonterminal{ListTVar}} & {\arrow} &{\emptyP} \\ - & {\delimit} &{\nonterminal{TVar}} {\nonterminal{ListTVar}} \\ -\end{tabular}\\ - -\begin{tabular}{lll} -{\nonterminal{ListPattern1}} & {\arrow} &{\nonterminal{Pattern1}} \\ - & {\delimit} &{\nonterminal{Pattern1}} {\nonterminal{ListPattern1}} \\ -\end{tabular}\\ - - - -\end{document} - diff --git a/Makefile b/Makefile index ccd1325..eef33fd 100644 --- a/Makefile +++ b/Makefile @@ -1,6 +1,6 @@ .PHONY : sdist clean -language : src/Grammar/Test Grammar.tex +language : src/Grammar/Test Grammar.pdf cabal install --installdir=. --overwrite-policy=always src/Grammar/Test.hs src/Grammar/Lex.x src/Grammar/Par.y src/Grammar/Layout : Grammar.cf @@ -21,6 +21,10 @@ src/Grammar/Test : src/Grammar/Test.hs src/Grammar/Par.hs src/Grammar/Lex.hs src Grammar.tex : bnfc --latex Grammar.cf +Grammar.pdf : Grammar.tex + pdflatex Grammar.tex + rm Grammar.aux Grammar.dvi Grammar.fdb_latexmk Grammar.fls Grammar.log + clean : rm -r src/Grammar rm language From 077f76eb12d74535c3a0c91af11538d03b303253 Mon Sep 17 00:00:00 2001 From: Martin Fredin Date: Mon, 3 Apr 2023 12:24:22 +0200 Subject: [PATCH 281/372] Separate make file actions --- .gitignore | 2 ++ Makefile | 8 +++++--- shell.nix | 22 +++++++++++++--------- 3 files changed, 20 insertions(+), 12 deletions(-) diff --git a/.gitignore b/.gitignore index fd90be9..3a31ecd 100644 --- a/.gitignore +++ b/.gitignore @@ -9,3 +9,5 @@ test_program_result output/ *.o *.out +*.aux +*.log diff --git a/Makefile b/Makefile index eef33fd..6c1ebde 100644 --- a/Makefile +++ b/Makefile @@ -1,6 +1,6 @@ .PHONY : sdist clean -language : src/Grammar/Test Grammar.pdf +language : src/Grammar/Test cabal install --installdir=. --overwrite-policy=always src/Grammar/Test.hs src/Grammar/Lex.x src/Grammar/Par.y src/Grammar/Layout : Grammar.cf @@ -23,13 +23,15 @@ Grammar.tex : Grammar.pdf : Grammar.tex pdflatex Grammar.tex - rm Grammar.aux Grammar.dvi Grammar.fdb_latexmk Grammar.fls Grammar.log + rm Grammar.aux Grammar.log + +pdf : Grammar.pdf clean : rm -r src/Grammar rm language rm -rf dist-newstyles - rm Grammar.aux Grammar.fdb_latexmk Grammar.fls Grammar.log Grammar.pdf Grammar.synctex.gz Grammar.tex + rm Grammar.aux Grammar.fdb_latexmk Grammar.fls Grammar.log Grammar.synctex.gz Grammar.tex test : cabal v2-test diff --git a/shell.nix b/shell.nix index 0af8c7b..cbc2899 100644 --- a/shell.nix +++ b/shell.nix @@ -6,15 +6,19 @@ pkgs.haskellPackages.developPackage { withHoogle = true; modifier = drv: pkgs.haskell.lib.addBuildTools drv ( - (with pkgs; [ hlint haskell-language-server ghc jasmin llvmPackages_15.libllvm]) + (with pkgs; [ hlint + haskell-language-server + ghc + jasmin + llvmPackages_15.libllvm + texlive.combined.scheme-full + ]) ++ - (with pkgs.haskellPackages; [ - cabal-install - stylish-haskell - BNFC - alex - happy - ]) - ); + (with pkgs.haskellPackages; [ cabal-install + stylish-haskell + BNFC + alex + happy + ])); } From 5e5d258bb16531675b11b1c67bb533317c035f42 Mon Sep 17 00:00:00 2001 From: Martin Fredin Date: Mon, 3 Apr 2023 12:31:29 +0200 Subject: [PATCH 282/372] Update readme with identation syntax --- README.md | 38 +++++++++++++++++++------------------- 1 file changed, 19 insertions(+), 19 deletions(-) diff --git a/README.md b/README.md index 7266b86..08e5d2f 100644 --- a/README.md +++ b/README.md @@ -16,6 +16,8 @@ Using the bidirectional type checker: `./language -t bi example.crf` The program to compile has to have the file extension `.crf` # Syntax and quirks +See Grammar.pdf for the full syntax. + The syntactic requirements differ a bit using the different type checkers. The bidirectional type checker require explicit `forall` everywhere a type forall quantified type variable is declared. In the Hindley-Milner type checker @@ -28,17 +30,18 @@ or inferrable. Single line comments are written using `--` Multi line comments are written using `{-` and `-}` +Braches and semicolons are optional. + ## Program A program is a list of defs separated by semicolons, which in turn is either a bind, a signature, or a data types `Program ::= [Def]` ```hs -data Test () where { +data Test () where Test : Test () -}; -test : Int ; -test = 0 ; +test : Int +test = 0 ``` ## Bind @@ -49,7 +52,7 @@ Both name and arguments have to start with lower case letters `Bind ::= LIdent [LIdent] "=" Exp` ```hs -example x y = x + y ; +example x y = x + y ``` ## Signature @@ -59,7 +62,7 @@ The name has to start with a lowe case letter `Sig ::= LIdent ":" Type` ```hs -const : a -> b -> a ; +const : a -> b -> a ``` ## Data type @@ -72,12 +75,10 @@ The type can be any type for parsing, but only `TData` will type check. The list of Inj is separated by white space. Using new lines is recommended for ones own sanity. - ```hs -data Maybe (a) where { +data Maybe (a) where Nothing : Maybe (a) - Just : a -> Maybe (a) -}; + Just : a -> Maybe (a) ``` The parens are necessary for every data type to make the grammar unambiguous. Thus in `data Bool () where ...` the parens *do* *not* represent Unit @@ -108,11 +109,11 @@ and foralls take one type variable followed by a type. `TAll ::= "forall" LIdent "." Type` ```hs -exampleLit : Int ; -exampleVar : a ; -exampleData : Maybe (a) ; -exampleFun : Int -> a ; -exampleAll : forall a. forall b. a -> b ; +exampleLit : Int +exampleVar : a +exampleData : Maybe (a) +exampleFun : Int -> a +exampleAll : forall a. forall b. a -> b ``` ## Expressions @@ -177,10 +178,9 @@ Case expression consist of a list semicolon separated list of Branches `ECase ::= "case" Exp "of" "{" [Branch] "}"` ```hs -case xs of { - Cons x xs => 1; - Nil => 0; -}; +case xs of + Cons x xs => 1 + Nil => 0 ``` ### Branch From c6e0e40ef16b83b9ff2b98c52779d5297af32706 Mon Sep 17 00:00:00 2001 From: Rakarake Date: Wed, 5 Apr 2023 03:03:42 +0200 Subject: [PATCH 283/372] Monomorphizer now monomorphizes data --- sample-programs/mono-2.crf | 12 ++- src/Monomorphizer/Monomorphizer.hs | 117 ++++++++++++++++++++--------- 2 files changed, 86 insertions(+), 43 deletions(-) diff --git a/sample-programs/mono-2.crf b/sample-programs/mono-2.crf index ade504b..9325b4a 100644 --- a/sample-programs/mono-2.crf +++ b/sample-programs/mono-2.crf @@ -1,13 +1,11 @@ -data Either(a b) where { +data Either(a b) where Left: a -> Either (a b) Right: b -> Either (a b) -}; -unwrapLeft x = case x of { - Left y => y; -}; +unwrapLeft x = case x of + Left y => y -wow = Left 5; +wow = Left 5 -main = unwrapLeft wow; +main = unwrapLeft wow diff --git a/src/Monomorphizer/Monomorphizer.hs b/src/Monomorphizer/Monomorphizer.hs index 6bbbdcd..929d009 100644 --- a/src/Monomorphizer/Monomorphizer.hs +++ b/src/Monomorphizer/Monomorphizer.hs @@ -46,7 +46,7 @@ newtype EnvM a = EnvM (StateT Output (Reader Env) a) 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 | Data M.Data +data Outputted = Incomplete | Complete M.Bind | Data M.Type T.Data -- Static environment data Env = Env { @@ -124,7 +124,7 @@ morphBind expectedType b@(T.Bind (Ident _, btype) args (exp, expt)) = 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 + let name' = newFuncName expectedType b bindMarked <- isBindMarked (coerce name') -- Return with right name if already marked if bindMarked then return name' else do @@ -151,8 +151,8 @@ morphApp node expectedType (e1, t1) (e2, t2)= do e1' <- morphExp (M.TFun t2' expectedType) e1 return $ node (e1', M.TFun t2' expectedType) (e2', t2') -addOutputData :: M.Data -> EnvM () -addOutputData d@(M.Data (M.TData ident _) _) = modify $ Map.insert ident (Data d) +--addOutputData :: M.Data -> EnvM () +--addOutputData d@(M.Data (M.TData ident _) _) = modify $ Map.insert ident (Data d) -- Gets data bind from the name of a constructor getInputData :: Ident -> EnvM (Maybe T.Data) @@ -161,13 +161,13 @@ getInputData ident = do env <- ask -- | Expects polymorphic types in data definition to be mapped -- in environment. -morphData :: T.Data -> EnvM () -morphData (T.Data t cs) = do - t' <- getMonoFromPoly t - output <- get - cs' <- mapM (\(T.Inj ident t) -> do t' <- getMonoFromPoly t - return (M.Inj ident t')) cs - addOutputData $ M.Data t' cs' +--morphData :: T.Data -> EnvM () +--morphData (T.Data t cs) = do +-- t' <- getMonoFromPoly t +-- output <- get +-- cs' <- mapM (\(T.Inj ident t) -> do t' <- getMonoFromPoly t +-- return (M.Inj ident t')) cs +-- addOutputData $ M.Data t' cs' morphCons :: M.Type -> Ident -> EnvM () morphCons expectedType ident = do @@ -175,18 +175,18 @@ morphCons expectedType ident = do case maybeD of Nothing -> error $ "identifier '" ++ show ident ++ "' not found" Just d -> do + modify (\output -> Map.insert ident (Data expectedType d) output ) -- Find the polymorphic type of cons - case findConsType d ident of - Nothing -> error "didn't find constructor" - Just consType -> do - -- Map polymorphic types - local (\env -> env { - polys = Map.fromList (mapTypes consType expectedType) }) $ do - morphData d +-- case findConsType d ident of +-- Nothing -> error "didn't find constructor" +-- Just consType -> do +-- -- Map polymorphic types +-- local (\env -> env { +-- polys = Map.fromList (mapTypes consType expectedType) }) $ do -- TODO: detect internal errors here -findConsType :: T.Data -> Ident -> Maybe T.Type -findConsType (T.Data _ cs) name1 = foldl (\maybe (T.Inj name2 t) -> if name2 == name1 then Just t else maybe) Nothing cs +--findConsType :: T.Data -> Ident -> Maybe T.Type +--findConsType (T.Data _ cs) name1 = foldl (\maybe (T.Inj name2 t) -> if name2 == name1 then Just t else maybe) Nothing cs -- TODO: Change in tree so that these are the same. -- Converts Lit @@ -255,16 +255,19 @@ morphPattern ls = \case return (M.PInj ident (map fst pairs), Set.unions (map snd pairs)) -- | Creates a new identifier for a function with an assigned type -newName :: M.Type -> T.Bind -> Ident -newName t (T.Bind (Ident bindName, _) _ _) = - if bindName == "main" then - Ident bindName - else Ident (bindName ++ "$" ++ newName' t) - where - newName' :: M.Type -> String - newName' (M.TLit (Ident str)) = str - newName' (M.TFun t1 t2) = newName' t1 ++ "_" ++ newName' t2 - newName' (M.TData (Ident str) ts) = str ++ foldl (\s t -> s ++ "." ++ newName' t) "" ts +newFuncName :: M.Type -> T.Bind -> Ident +newFuncName t (T.Bind (ident@(Ident bindName), _) _ _) = + if bindName == "main" + then Ident bindName + else newName t ident + +newName :: M.Type -> Ident -> Ident +newName t (Ident str) = Ident $ str ++ "$" ++ newName' t + where + newName' :: M.Type -> String + newName' (M.TLit (Ident str)) = str + newName' (M.TFun t1 t2) = newName' t1 ++ "_" ++ newName' t2 + newName' (M.TData (Ident str) ts) = str ++ foldl (\s t -> s ++ "." ++ newName' t) "" ts -- Monomorphization step monomorphize :: T.Program -> O.Program @@ -308,12 +311,54 @@ getBindsFromDefs = foldl (\bs -> \case T.DData _ -> bs) [] getDefsFromOutput :: Output -> [M.Def] -getDefsFromOutput outputMap = (map snd . Map.toList) $ fmap - (\case - Incomplete -> error "Internal bug in monomorphizer" - Complete b -> M.DBind b - Data d -> M.DData d) - outputMap +getDefsFromOutput o = + map M.DBind binds ++ + (map (M.DData . snd) . Map.toList) (createNewData dataInput Map.empty) + where + (binds, dataInput) = splitBindsAndData o + +-- | Splits the output into binds and data declaration components (used in createNewData) +splitBindsAndData :: Output -> ([M.Bind], [(Ident, M.Type, T.Data)]) +splitBindsAndData output = foldl + (\(oBinds, oData) (ident, o) -> case o of + Incomplete -> error "internal bug in monomorphizer" + Complete b -> (b:oBinds, oData) + Data t d -> (oBinds, (ident, t, d):oData)) + ([], []) + (Map.toList output) + +-- | Converts all found constructors to monomorphic data declarations. +createNewData :: [(Ident, M.Type, T.Data)] -> Map.Map Ident M.Data -> Map.Map Ident M.Data +createNewData [] o = o +createNewData ((consIdent, consType, polyData):input) o = + createNewData input $ + Map.insertWith (\_ (M.Data _ cs) -> M.Data newDataType (newCons:cs)) + newDataName (M.Data newDataType [newCons]) o + where + T.Data (T.TData polyDataIdent _) _ = polyData + newDataType = getDataType consType + newDataName = newName newDataType polyDataIdent + newCons = M.Inj consIdent consType + +getDataType :: M.Type -> M.Type +getDataType (M.TFun t1 t2) = getDataType t2 +getDataType tData@(M.TData _ _) = tData +getDataType _ = error "???" + +-- | Converts all found constructors to monomorphic data declarations. +-- cons->data process data.name -> data +--createNewData :: [(Ident, M.Type, T.Data)] -> Map.Map Ident M.Data -> EnvM (Map.Map Ident M.Data) +--createNewData [] o = return o +--createNewData ((ident, expectedType, T.Data dt pcs):cs) o = case dt of +-- T.TData dIdent _ -> do +-- let newCons = M.Inj (newName expectedType ident) expectedType +-- case Map.lookup dIdent o of +-- Nothing -> do +-- createNewData cs $ Map.insert ident (M.Data (M.TLit $ Ident "void") [newCons]) o +-- Just _ -> do +-- createNewData cs $ Map.adjust (\(M.Data _ pcs') -> +-- M.Data expectedType (newCons : pcs')) ident o +-- _ -> error "internal bug in monomorphizer" getBindName :: T.Bind -> Ident getBindName (T.Bind (ident, _) _ _) = ident From 12bca1c32d6655ed612938bfd4031ea488cef7e3 Mon Sep 17 00:00:00 2001 From: sebastianselander Date: Wed, 5 Apr 2023 12:56:57 +0200 Subject: [PATCH 284/372] Added small comment about incorrect subtyping --- src/TypeChecker/TypeCheckerHm.hs | 13 +++++++++++++ 1 file changed, 13 insertions(+) diff --git a/src/TypeChecker/TypeCheckerHm.hs b/src/TypeChecker/TypeCheckerHm.hs index 1b6ae4d..38582e5 100644 --- a/src/TypeChecker/TypeCheckerHm.hs +++ b/src/TypeChecker/TypeCheckerHm.hs @@ -595,6 +595,19 @@ fresh = do modify (\st -> st{count = succ (count st)}) return $ TVar $ MkTVar $ LIdent $ show n +{- + +The following definition of id should type check +id : forall a. a -> a +id x = (x : a) + +but not this one, according to haskell atleast + +id : a -> a +id x = (x : a) + +currently this is not the case, the TAll pattern match is incorrectly implemented. +-} -- Is the left a subtype of the right (<<=) :: Type -> Type -> Bool (<<=) (TVar _) _ = True From 9870802371b82668e55718ac3e8be651bbb465f1 Mon Sep 17 00:00:00 2001 From: Martin Fredin Date: Mon, 3 Apr 2023 17:34:33 +0200 Subject: [PATCH 285/372] Add implicit foralls for bidir, update and unify pipeline --- Grammar.cf | 3 +- Session.vim | 219 ----------------- language.cabal | 17 +- pipeline.txt | 27 ++ sample-programs/{basic-0 => basic-0.crf} | 4 + sample-programs/basic-1.crf | 18 +- sample-programs/basic-10.crf | 10 + sample-programs/basic-6.crf | 14 +- sample-programs/basic-7.crf | 14 +- sample-programs/basic-8.crf | 24 +- sample-programs/basic-9.crf | 10 +- shell.nix | 3 +- src/AnnForall.hs | 100 ++++++++ src/Auxiliary.hs | 28 ++- src/LambdaLifter.hs | 32 +-- src/Main.hs | 87 ++----- src/Monomorphizer/Monomorphizer.hs | 65 ++--- src/Renamer/Renamer.hs | 298 +++++++---------------- src/Renamer/RenamerOld.hs | 206 ---------------- src/ReportForall.hs | 70 ++++++ src/TypeChecker/RemoveForall.hs | 48 ++++ src/TypeChecker/RemoveTEVar.hs | 71 ------ src/TypeChecker/ReportTEVar.hs | 81 ++++++ src/TypeChecker/TypeChecker.hs | 22 +- src/TypeChecker/TypeCheckerBidir.hs | 16 +- src/TypeChecker/TypeCheckerHm.hs | 148 +++++------ src/TypeChecker/TypeCheckerIr.hs | 32 ++- tests/{Tests.hs => Main.hs} | 6 + tests/TestAnnForall.hs | 113 +++++++++ tests/TestRenamer.hs | 96 ++++++++ tests/TestReportForall.hs | 47 ++++ tests/TestTypeCheckerBidir.hs | 62 +++-- tests/TestTypeCheckerHm.hs | 74 +++--- 33 files changed, 1010 insertions(+), 1055 deletions(-) delete mode 100644 Session.vim create mode 100644 pipeline.txt rename sample-programs/{basic-0 => basic-0.crf} (77%) create mode 100644 sample-programs/basic-10.crf create mode 100644 src/AnnForall.hs delete mode 100644 src/Renamer/RenamerOld.hs create mode 100644 src/ReportForall.hs create mode 100644 src/TypeChecker/RemoveForall.hs delete mode 100644 src/TypeChecker/RemoveTEVar.hs create mode 100644 src/TypeChecker/ReportTEVar.hs rename tests/{Tests.hs => Main.hs} (51%) create mode 100644 tests/TestAnnForall.hs create mode 100644 tests/TestRenamer.hs create mode 100644 tests/TestReportForall.hs diff --git a/Grammar.cf b/Grammar.cf index 586140c..59e6897 100644 --- a/Grammar.cf +++ b/Grammar.cf @@ -75,8 +75,7 @@ PInj. Pattern ::= UIdent [Pattern1]; -- * AUX ------------------------------------------------------------------------------- -layout "of", "where", "let"; -layout stop "in"; +layout "of", "where"; layout toplevel; separator Def ";"; diff --git a/Session.vim b/Session.vim deleted file mode 100644 index 1db0ec6..0000000 --- a/Session.vim +++ /dev/null @@ -1,219 +0,0 @@ -let SessionLoad = 1 -let s:so_save = &g:so | let s:siso_save = &g:siso | setg so=0 siso=0 | setl so=-1 siso=-1 -let v:this_session=expand(":p") -silent only -silent tabonly -cd ~/Documents/bachelor_thesis/language -if expand('%') == '' && !&modified && line('$') <= 1 && getline(1) == '' - let s:wipebuf = bufnr('%') -endif -let s:shortmess_save = &shortmess -if &shortmess =~ 'A' - set shortmess=aoOA -else - set shortmess=aoO -endif -badd +1 ~/Documents/bachelor_thesis/language -badd +298 src/TypeChecker/TypeChecker.hs -badd +7 test_program -badd +46 src/TypeChecker/TypeCheckerIr.hs -badd +6 Grammar.cf -badd +1 src/Grammar/Abs.hs -argglobal -%argdel -$argadd ~/Documents/bachelor_thesis/language -set stal=2 -tabnew +setlocal\ bufhidden=wipe -tabnew +setlocal\ bufhidden=wipe -tabnew +setlocal\ bufhidden=wipe -tabrewind -edit src/TypeChecker/TypeChecker.hs -let s:save_splitbelow = &splitbelow -let s:save_splitright = &splitright -set splitbelow splitright -wincmd _ | wincmd | -vsplit -1wincmd h -wincmd w -let &splitbelow = s:save_splitbelow -let &splitright = s:save_splitright -wincmd t -let s:save_winminheight = &winminheight -let s:save_winminwidth = &winminwidth -set winminheight=0 -set winheight=1 -set winminwidth=0 -set winwidth=1 -exe 'vert 1resize ' . ((&columns * 99 + 86) / 173) -exe 'vert 2resize ' . ((&columns * 73 + 86) / 173) -argglobal -setlocal fdm=manual -setlocal fde=0 -setlocal fmr={{{,}}} -setlocal fdi=# -setlocal fdl=0 -setlocal fml=1 -setlocal fdn=20 -setlocal fen -silent! normal! zE -let &fdl = &fdl -let s:l = 298 - ((18 * winheight(0) + 21) / 42) -if s:l < 1 | let s:l = 1 | endif -keepjumps exe s:l -normal! zt -keepjumps 298 -normal! 029| -lcd ~/Documents/bachelor_thesis/language -wincmd w -argglobal -if bufexists(fnamemodify("~/Documents/bachelor_thesis/language/Grammar.cf", ":p")) | buffer ~/Documents/bachelor_thesis/language/Grammar.cf | else | edit ~/Documents/bachelor_thesis/language/Grammar.cf | endif -if &buftype ==# 'terminal' - silent file ~/Documents/bachelor_thesis/language/Grammar.cf -endif -balt ~/Documents/bachelor_thesis/language/src/TypeChecker/TypeChecker.hs -setlocal fdm=manual -setlocal fde=0 -setlocal fmr={{{,}}} -setlocal fdi=# -setlocal fdl=0 -setlocal fml=1 -setlocal fdn=20 -setlocal fen -silent! normal! zE -let &fdl = &fdl -let s:l = 7 - ((6 * winheight(0) + 21) / 42) -if s:l < 1 | let s:l = 1 | endif -keepjumps exe s:l -normal! zt -keepjumps 7 -normal! 0 -lcd ~/Documents/bachelor_thesis/language -wincmd w -exe 'vert 1resize ' . ((&columns * 99 + 86) / 173) -exe 'vert 2resize ' . ((&columns * 73 + 86) / 173) -tabnext -edit ~/Documents/bachelor_thesis/language/src/TypeChecker/TypeCheckerIr.hs -let s:save_splitbelow = &splitbelow -let s:save_splitright = &splitright -set splitbelow splitright -wincmd _ | wincmd | -vsplit -1wincmd h -wincmd w -let &splitbelow = s:save_splitbelow -let &splitright = s:save_splitright -wincmd t -let s:save_winminheight = &winminheight -let s:save_winminwidth = &winminwidth -set winminheight=0 -set winheight=1 -set winminwidth=0 -set winwidth=1 -exe 'vert 1resize ' . ((&columns * 86 + 86) / 173) -exe 'vert 2resize ' . ((&columns * 86 + 86) / 173) -argglobal -balt ~/Documents/bachelor_thesis/language/test_program -setlocal fdm=manual -setlocal fde=0 -setlocal fmr={{{,}}} -setlocal fdi=# -setlocal fdl=0 -setlocal fml=1 -setlocal fdn=20 -setlocal fen -silent! normal! zE -let &fdl = &fdl -let s:l = 1 - ((0 * winheight(0) + 21) / 42) -if s:l < 1 | let s:l = 1 | endif -keepjumps exe s:l -normal! zt -keepjumps 1 -normal! 0 -lcd ~/Documents/bachelor_thesis/language -wincmd w -argglobal -if bufexists(fnamemodify("~/Documents/bachelor_thesis/language/src/Grammar/Abs.hs", ":p")) | buffer ~/Documents/bachelor_thesis/language/src/Grammar/Abs.hs | else | edit ~/Documents/bachelor_thesis/language/src/Grammar/Abs.hs | endif -if &buftype ==# 'terminal' - silent file ~/Documents/bachelor_thesis/language/src/Grammar/Abs.hs -endif -balt ~/Documents/bachelor_thesis/language/src/TypeChecker/TypeCheckerIr.hs -setlocal fdm=manual -setlocal fde=0 -setlocal fmr={{{,}}} -setlocal fdi=# -setlocal fdl=0 -setlocal fml=1 -setlocal fdn=20 -setlocal fen -silent! normal! zE -let &fdl = &fdl -let s:l = 1 - ((0 * winheight(0) + 21) / 42) -if s:l < 1 | let s:l = 1 | endif -keepjumps exe s:l -normal! zt -keepjumps 1 -normal! 0 -lcd ~/Documents/bachelor_thesis/language -wincmd w -exe 'vert 1resize ' . ((&columns * 86 + 86) / 173) -exe 'vert 2resize ' . ((&columns * 86 + 86) / 173) -tabnext -edit ~/Documents/bachelor_thesis/language/Grammar.cf -argglobal -balt ~/Documents/bachelor_thesis/language/src/Grammar/Abs.hs -setlocal fdm=manual -setlocal fde=0 -setlocal fmr={{{,}}} -setlocal fdi=# -setlocal fdl=0 -setlocal fml=1 -setlocal fdn=20 -setlocal fen -silent! normal! zE -let &fdl = &fdl -let s:l = 40 - ((12 * winheight(0) + 21) / 42) -if s:l < 1 | let s:l = 1 | endif -keepjumps exe s:l -normal! zt -keepjumps 40 -normal! 0 -lcd ~/Documents/bachelor_thesis/language -tabnext -edit ~/Documents/bachelor_thesis/language/test_program -argglobal -balt ~/Documents/bachelor_thesis/language/src/TypeChecker/TypeChecker.hs -setlocal fdm=manual -setlocal fde=0 -setlocal fmr={{{,}}} -setlocal fdi=# -setlocal fdl=0 -setlocal fml=1 -setlocal fdn=20 -setlocal fen -silent! normal! zE -let &fdl = &fdl -let s:l = 7 - ((6 * winheight(0) + 21) / 42) -if s:l < 1 | let s:l = 1 | endif -keepjumps exe s:l -normal! zt -keepjumps 7 -normal! 010| -lcd ~/Documents/bachelor_thesis/language -tabnext 1 -set stal=1 -if exists('s:wipebuf') && len(win_findbuf(s:wipebuf)) == 0 && getbufvar(s:wipebuf, '&buftype') isnot# 'terminal' - silent exe 'bwipe ' . s:wipebuf -endif -unlet! s:wipebuf -set winheight=1 winwidth=20 -let &shortmess = s:shortmess_save -let s:sx = expand(":p:r")."x.vim" -if filereadable(s:sx) - exe "source " . fnameescape(s:sx) -endif -let &g:so = s:so_save | let &g:siso = s:siso_save -set hlsearch -nohlsearch -doautoall SessionLoadPost -unlet SessionLoad -" vim: set ft=vim : diff --git a/language.cabal b/language.cabal index 82e1492..a290bc3 100644 --- a/language.cabal +++ b/language.cabal @@ -35,10 +35,12 @@ executable language Auxiliary Renamer.Renamer TypeChecker.TypeChecker + AnnForall TypeChecker.TypeCheckerHm TypeChecker.TypeCheckerBidir TypeChecker.TypeCheckerIr - TypeChecker.RemoveTEVar + TypeChecker.ReportTEVar + TypeChecker.RemoveForall LambdaLifter Monomorphizer.Monomorphizer Monomorphizer.MonomorphizerIr @@ -72,11 +74,14 @@ executable language Test-suite language-testsuite type: exitcode-stdio-1.0 - main-is: Tests.hs + main-is: Main.hs other-modules: TestTypeCheckerBidir TestTypeCheckerHm + TestAnnForall + TestReportForall + TestRenamer Grammar.Abs Grammar.Lex @@ -90,13 +95,16 @@ Test-suite language-testsuite Monomorphizer.MonomorphizerIr Renamer.Renamer TypeChecker.TypeChecker + AnnForall + ReportForall TypeChecker.TypeCheckerHm TypeChecker.TypeCheckerBidir - TypeChecker.RemoveTEVar + TypeChecker.ReportTEVar + TypeChecker.RemoveForall TypeChecker.TypeCheckerIr Compiler - hs-source-dirs: src, tests, tests/TypecheckingHM + hs-source-dirs: src, tests build-depends: base >=4.16 @@ -110,6 +118,7 @@ Test-suite language-testsuite , process , bytestring , hspec + , directory default-language: GHC2021 diff --git a/pipeline.txt b/pipeline.txt new file mode 100644 index 0000000..1872562 --- /dev/null +++ b/pipeline.txt @@ -0,0 +1,27 @@ + + Parser + | + ReportForall Report unnecessary foralls. Hm: report rank>2 foralls + | + AnnotateForall Annotate all unbound type variables with foralls + | + Renamer Rename type variables and term variables + | + / \ + / \ + TypeCheckHm TypeCheckBi + \ / + \ / + | + ReportTEVar Report type existential variables and change type AST + | + RemoveForall RemoveForall and change type AST + | + Monomorpher + | + Desugar + | + CodeGen + + + diff --git a/sample-programs/basic-0 b/sample-programs/basic-0.crf similarity index 77% rename from sample-programs/basic-0 rename to sample-programs/basic-0.crf index bc71161..d9adeda 100644 --- a/sample-programs/basic-0 +++ b/sample-programs/basic-0.crf @@ -10,6 +10,10 @@ even : Int -> Bool () even x = not (odd x) odd x = not (even x) +main = case even 64 of + True => 1 + False => 0 + diff --git a/sample-programs/basic-1.crf b/sample-programs/basic-1.crf index a5e2ae4..59862d6 100644 --- a/sample-programs/basic-1.crf +++ b/sample-programs/basic-1.crf @@ -1,9 +1,13 @@ -data Bool () where { - True : Bool () +data Bool () where + True : Bool () False : Bool () -}; -toBool = case 0 of { - 0 => False; - _ => True; -}; +toBool x = case x of + 0 => False + _ => True + +fromBool b = case b of + False => 0 + True => 1 + +main = fromBool (toBool 10) diff --git a/sample-programs/basic-10.crf b/sample-programs/basic-10.crf new file mode 100644 index 0000000..f99e2c8 --- /dev/null +++ b/sample-programs/basic-10.crf @@ -0,0 +1,10 @@ + + + +applyId : (forall a. a -> a) -> a -> a +applyId f x = f x + +id : a -> a +id x = x + +main = applyId id 4 diff --git a/sample-programs/basic-6.crf b/sample-programs/basic-6.crf index 082cc6b..bc8bebe 100644 --- a/sample-programs/basic-6.crf +++ b/sample-programs/basic-6.crf @@ -1,10 +1,8 @@ -data Bool () where { - True : Bool () +data Bool () where + True : Bool () False : Bool () -}; -main : Bool () -> a -> Int ; -main b = case b of { - False => (\x. 1); - True => \x. 0; -}; +main : Bool () -> a -> Int +main b = case b of + False => (\x. 1) + True => (\x. 0) diff --git a/sample-programs/basic-7.crf b/sample-programs/basic-7.crf index 9ae2bdf..6fed9b7 100644 --- a/sample-programs/basic-7.crf +++ b/sample-programs/basic-7.crf @@ -1,10 +1,8 @@ -data Bool () where { - True : Bool () +data Bool () where + True : Bool () False : Bool () -}; -ifThenElse : forall a. Bool () -> a -> a -> a; -ifThenElse b if else = case b of { - True => if; - False => else - } +ifThenElse : forall a. Bool () -> a -> a -> a +ifThenElse b if else = case b of + True => if + False => else diff --git a/sample-programs/basic-8.crf b/sample-programs/basic-8.crf index 92dd863..958459b 100644 --- a/sample-programs/basic-8.crf +++ b/sample-programs/basic-8.crf @@ -1,24 +1,20 @@ -data Maybe (a) where { +data Maybe (a) where Nothing : Maybe (a) - Just : a -> Maybe (a) -}; + Just : a -> Maybe (a) -fromJust : Maybe (a) -> a ; +fromJust : Maybe (a) -> a fromJust a = - case a of { + case a of Just a => a - }; -fromMaybe : a -> Maybe (a) -> a ; +fromMaybe : a -> Maybe (a) -> a fromMaybe a b = - case b of { - Just a => a; + case b of + Just a => a Nothing => a - }; -maybe : b -> (a -> b) -> Maybe (a) -> b; +maybe : b -> (a -> b) -> Maybe (a) -> b maybe b f ma = - case ma of { - Just a => f a; + case ma of + Just a => f a Nothing => b - } diff --git a/sample-programs/basic-9.crf b/sample-programs/basic-9.crf index 2a7ef99..9e76336 100644 --- a/sample-programs/basic-9.crf +++ b/sample-programs/basic-9.crf @@ -1,13 +1,9 @@ -data List (a) where { +data List (a) where Nil : List (a) Cons : a -> List (a) -> List (a) -}; - -test xs = case xs of { - Cons Nil _ => 0 ; -}; - +test xs = case xs of + Cons Nil _ => 0 List a /= List (List a) diff --git a/shell.nix b/shell.nix index cbc2899..a2e6844 100644 --- a/shell.nix +++ b/shell.nix @@ -11,7 +11,8 @@ pkgs.haskellPackages.developPackage { ghc jasmin llvmPackages_15.libllvm - texlive.combined.scheme-full + clang +# texlive.combined.scheme-full ]) ++ (with pkgs.haskellPackages; [ cabal-install diff --git a/src/AnnForall.hs b/src/AnnForall.hs new file mode 100644 index 0000000..16222bd --- /dev/null +++ b/src/AnnForall.hs @@ -0,0 +1,100 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedRecordDot #-} + +module AnnForall (annotateForall) where + +import Auxiliary (partitionDefs) +import Control.Applicative (Applicative (liftA2)) +import Control.Monad.Except (throwError) +import Data.Function (on) +import Data.Set (Set) +import qualified Data.Set as Set +import Grammar.Abs +import Grammar.ErrM (Err) + +annotateForall :: Program -> Err Program +annotateForall (Program defs) = do + ds' <- mapM (fmap DData . annData) ds + bs' <- mapM (fmap DBind . annBind) bs + pure $ Program (ds' ++ ss' ++ bs') + where + ss' = map (DSig . annSig) ss + (ds, ss, bs) = partitionDefs defs + + +annData :: Data -> Err Data +annData (Data typ injs) = do + (typ', tvars) <- annTyp typ + pure (Data typ' $ map (annInj tvars) injs) + + where + annTyp typ = do + (bounded, ts) <- boundedTVars mempty typ + unbounded <- Set.fromList <$> mapM assertTVar ts + let diff = unbounded Set.\\ bounded + typ' = foldr TAll typ diff + (typ', ) . fst <$> boundedTVars mempty typ' + where + boundedTVars tvars typ = case typ of + TAll tvar t -> boundedTVars (Set.insert tvar tvars) t + TData _ ts -> pure (tvars, ts) + _ -> throwError "Misformed data declaration" + + assertTVar typ = case typ of + TVar tvar -> pure tvar + _ -> throwError $ unwords [ "Misformed data declaration:" + , "Non type variable argument" + ] + annInj tvars (Inj n t) = + Inj n $ foldr TAll t (unboundedTVars t Set.\\ tvars) + +annSig :: Sig -> Sig +annSig (Sig name typ) = Sig name $ annType typ + +annBind :: Bind -> Err Bind +annBind (Bind name vars exp) = Bind name vars <$> annExp exp + where + annExp = \case + EAnn e t -> flip EAnn (annType t) <$> annExp e + EApp e1 e2 -> liftA2 EApp (annExp e1) (annExp e2) + EAdd e1 e2 -> liftA2 EAdd (annExp e1) (annExp e2) + ELet bind e -> liftA2 ELet (annBind bind) (annExp e) + EAbs x e -> EAbs x <$> annExp e + ECase e bs -> liftA2 ECase (annExp e) (mapM annBranch bs) + e -> pure e + annBranch (Branch p e) = Branch p <$> annExp e + +annType :: Type -> Type +annType typ = go $ unboundedTVars typ + where + go us + | null us = typ + | otherwise = foldr TAll typ us + +unboundedTVars :: Type -> Set TVar +unboundedTVars = unboundedTVars' mempty + +unboundedTVars' :: Set TVar -> Type -> Set TVar +unboundedTVars' bs typ = tvars.unbounded Set.\\ tvars.bounded + where + tvars = gatherTVars typ + gatherTVars = \case + TAll tvar t -> TVars { bounded = Set.singleton tvar + , unbounded = unboundedTVars' (Set.insert tvar bs) t + } + TVar tvar -> uTVars $ Set.singleton tvar + TFun t1 t2 -> uTVars $ on Set.union (unboundedTVars' bs) t1 t2 + TData _ typs -> uTVars $ foldr (Set.union . unboundedTVars' bs) mempty typs + _ -> TVars { bounded = mempty, unbounded = mempty } + +data TVars = TVars + { bounded :: Set TVar + , unbounded :: Set TVar + } deriving (Eq, Show, Ord) + +uTVars :: Set TVar -> TVars +uTVars us = TVars + { bounded = mempty + , unbounded = us + } + diff --git a/src/Auxiliary.hs b/src/Auxiliary.hs index b4972a7..cfdd828 100644 --- a/src/Auxiliary.hs +++ b/src/Auxiliary.hs @@ -1,14 +1,16 @@ -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE Rank2Types #-} module Auxiliary (module Auxiliary) where -import Control.Monad.Error.Class (liftEither) -import Control.Monad.Except (MonadError) -import Data.Either.Combinators (maybeToRight) -import Data.List (foldl') -import Grammar.Abs -import Prelude hiding ((>>), (>>=)) +import Control.Applicative (Applicative (liftA2)) +import Control.Monad.Error.Class (liftEither) +import Control.Monad.Except (MonadError) +import Data.Either.Combinators (maybeToRight) +import Data.List (foldl') +import Grammar.Abs +import Prelude hiding ((>>), (>>=)) (>>) a b = a ++ " " ++ b (>>=) a f = f a @@ -29,6 +31,9 @@ mapAccumM f = go (acc'', xs') <- go acc' xs pure (acc'', x' : xs') +onM :: Monad m => (b -> b -> c) -> (a -> m b) -> a -> a -> m c +onM f g x y = liftA2 f (g x) (g y) + unzip4 :: [(a, b, c, d)] -> ([a], [b], [c], [d]) unzip4 = foldl' @@ -38,7 +43,7 @@ unzip4 = ([], [], [], []) litType :: Lit -> Type -litType (LInt _) = int +litType (LInt _) = int litType (LChar _) = char int = TLit "Int" @@ -53,3 +58,10 @@ trd_ :: (a, b, c) -> c snd_ (_, a, _) = a fst_ (a, _, _) = a trd_ (_, _, a) = a + +partitionDefs :: [Def] -> ([Data], [Sig], [Bind]) +partitionDefs defs = (datas, sigs, binds) + where + datas = [ d | DData d <- defs ] + sigs = [ s | DSig s <- defs ] + binds = [ b | DBind b <- defs ] diff --git a/src/LambdaLifter.hs b/src/LambdaLifter.hs index d6d1945..67af030 100644 --- a/src/LambdaLifter.hs +++ b/src/LambdaLifter.hs @@ -178,27 +178,14 @@ abstractExp (free, (exp, typ)) = case exp of names = snoc parm freeList applyVars (e, t) name = (EApp (e, t) (EVar name, t_var), t_return) where - (t_var, t_return) = applyVarType t + (t_var, t_return) = case t of + TFun t1 t2 -> (t1, t2) + abstractBranch :: AnnBranch -> State Int Branch abstractBranch (_, AnnBranch patt exp) = Branch patt <$> abstractExp exp -applyVarType :: Type -> (Type, Type) -applyVarType typ = (t1, foldr ($) t2 foralls) - - where - (t1, t2) = case typ' of - TFun t1 t2 -> (t1, t2) - _ -> error "Not a function!" - - (foralls, typ') = skipForalls [] typ - - - skipForalls acc = \case - TAll tvar t -> skipForalls (snoc (TAll tvar) acc) t - t -> (acc, t) - nextNumber :: State Int Int nextNumber = do i <- get @@ -270,20 +257,9 @@ getVars :: Type -> [Type] getVars = fst . partitionType partitionType :: Type -> ([Type], Type) -partitionType = go [] . skipForalls' +partitionType = go [] where - go acc t = case t of TFun t1 t2 -> go (snoc t1 acc) t2 _ -> (acc, t) -skipForalls' :: Type -> Type -skipForalls' = snd . skipForalls - -skipForalls :: Type -> ([Type -> Type], Type) -skipForalls = go [] - where - go acc typ = case typ of - TAll tvar t -> go (snoc (TAll tvar) acc) t - _ -> (acc, typ) - diff --git a/src/Main.hs b/src/Main.hs index 3e21803..9345f4a 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -1,11 +1,12 @@ {-# LANGUAGE OverloadedRecordDot #-} + module Main where +import AnnForall (annotateForall) import Codegen.Codegen (generateCode) import Compiler (compile) -import Control.Monad (when) -import Data.Bool (bool) +import Control.Monad (when, (<=<)) import Data.List.Extra (isSuffixOf) import Data.Maybe (fromJust, isNothing) import Desugar.Desugar (desugar) @@ -13,10 +14,11 @@ import GHC.IO.Handle.Text (hPutStrLn) import Grammar.ErrM (Err) import Grammar.Layout (resolveLayout) import Grammar.Par (myLexer, pProgram) -import Grammar.Print (printTree) +import Grammar.Print (Print, printTree) import LambdaLifter (lambdaLift) import Monomorphizer.Monomorphizer (monomorphize) import Renamer.Renamer (rename) +import ReportForall (reportForall) import System.Console.GetOpt (ArgDescr (NoArg, ReqArg), ArgOrder (RequireOrder), OptDescr (Option), getOpt, @@ -87,35 +89,40 @@ data Options = Options } main' :: Options -> String -> IO () -main' opts s = do +main' opts s = + let + log :: (Print a, Show a) => a -> IO () + log = printToErr . if opts.debug then show else printTree + in do file <- readFile s printToErr "-- Parse Tree -- " - parsed <- fromSyntaxErr . pProgram . resolveLayout True $ myLexer file - bool (printToErr $ printTree parsed) (printToErr $ show parsed) opts.debug + parsed <- fromErr . pProgram . resolveLayout True $ myLexer file + log parsed printToErr "-- Desugar --" let desugared = desugar parsed - bool (printToErr $ printTree desugared) (printToErr $ show desugared) opts.debug + log desugared printToErr "\n-- Renamer --" - renamed <- fromRenamerErr . rename $ desugared - bool (printToErr $ printTree renamed) (printToErr $ show renamed) opts.debug + _ <- fromErr $ reportForall (fromJust opts.typechecker) desugared + renamed <- fromErr $ (rename <=< annotateForall) desugared + log renamed printToErr "\n-- TypeChecker --" - typechecked <- fromTypeCheckerErr $ typecheck (fromJust opts.typechecker) renamed - bool (printToErr $ printTree typechecked) (printToErr $ show typechecked) opts.debug + typechecked <- fromErr $ typecheck (fromJust opts.typechecker) renamed + log typechecked printToErr "\n-- Lambda Lifter --" let lifted = lambdaLift typechecked - bool (printToErr $ printTree lifted) (printToErr $ show lifted) opts.debug + log lifted printToErr "\n -- Monomorphizer --" let monomorphized = monomorphize lifted - bool (printToErr $ printTree monomorphized) (printToErr $ show monomorphized) opts.debug + log lifted printToErr "\n -- Compiler --" - generatedCode <- fromCompilerErr $ generateCode monomorphized + generatedCode <- fromErr $ generateCode monomorphized check <- doesPathExist "output" when check (removeDirectoryRecursive "output") @@ -143,55 +150,9 @@ debugDotViz = do spawnWait :: String -> IO ExitCode spawnWait s = spawnCommand s >>= waitForProcess + printToErr :: String -> IO () printToErr = hPutStrLn stderr -fromCompilerErr :: Err a -> IO a -fromCompilerErr = - either - ( \err -> do - putStrLn "\nCOMPILER ERROR" - putStrLn err - exitFailure - ) - pure - -fromSyntaxErr :: Err a -> IO a -fromSyntaxErr = - either - ( \err -> do - putStrLn "\nSYNTAX ERROR" - putStrLn err - exitFailure - ) - pure - -fromTypeCheckerErr :: Err a -> IO a -fromTypeCheckerErr = - either - ( \err -> do - putStrLn "\nTYPECHECKER ERROR" - putStrLn err - exitFailure - ) - pure - -fromRenamerErr :: Err a -> IO a -fromRenamerErr = - either - ( \err -> do - putStrLn "\nRENAMER ERROR" - putStrLn err - exitFailure - ) - pure - -fromInterpreterErr :: Err a -> IO a -fromInterpreterErr = - either - ( \err -> do - putStrLn "\nINTERPRETER ERROR" - putStrLn err - exitFailure - ) - pure +fromErr :: Err a -> IO a +fromErr = either (\s -> printToErr s >> exitFailure) pure diff --git a/src/Monomorphizer/Monomorphizer.hs b/src/Monomorphizer/Monomorphizer.hs index 929d009..60607ca 100644 --- a/src/Monomorphizer/Monomorphizer.hs +++ b/src/Monomorphizer/Monomorphizer.hs @@ -7,37 +7,40 @@ -- 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 (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 +-- expected type in this context. The result of this computation (a monomorphic -- bind) is added to the resulting set of binds. - + {-# LANGUAGE LambdaCase #-} module Monomorphizer.Monomorphizer (monomorphize, morphExp, morphBind) where -import qualified TypeChecker.TypeCheckerIr as T -import TypeChecker.TypeCheckerIr (Ident (Ident)) -import qualified Monomorphizer.MorbIr as M +import Monomorphizer.DataTypeRemover (removeDataTypes) import qualified Monomorphizer.MonomorphizerIr as O -import Monomorphizer.DataTypeRemover (removeDataTypes) +import qualified Monomorphizer.MorbIr as M +import qualified TypeChecker.TypeCheckerIr as T +import TypeChecker.TypeCheckerIr (Ident (Ident)) -import Debug.Trace -import Control.Monad.State (MonadState (get), gets, modify, StateT (runStateT)) -import qualified Data.Map as Map -import qualified Data.Set as Set -import Data.Maybe (fromJust) -import Control.Monad.Reader (Reader, MonadReader (local, ask), asks, runReader) -import Data.Coerce (coerce) -import Grammar.Print (printTree) +import Control.Monad.Reader (MonadReader (ask, local), + Reader, asks, runReader) +import Control.Monad.State (MonadState (get), + StateT (runStateT), gets, + modify) +import Data.Coerce (coerce) +import qualified Data.Map as Map +import Data.Maybe (fromJust) +import qualified Data.Set as Set +import Debug.Trace +import Grammar.Print (printTree) -- | State Monad wrapper for "Env". newtype EnvM a = EnvM (StateT Output (Reader Env) a) @@ -90,9 +93,9 @@ getMain = asks (\env -> fromJust $ Map.lookup (T.Ident "main") (input env)) mapTypes :: T.Type -> M.Type -> [(Ident, M.Type)] mapTypes (T.TLit _) (M.TLit _) = [] mapTypes (T.TVar (T.MkTVar i1)) tm = [(i1, tm)] -mapTypes (T.TFun pt1 pt2) (M.TFun mt1 mt2) = mapTypes pt1 mt1 ++ +mapTypes (T.TFun pt1 pt2) (M.TFun mt1 mt2) = mapTypes pt1 mt1 ++ mapTypes pt2 mt2 -mapTypes (T.TData tIdent pTs) (M.TData mIdent mTs) = if tIdent /= mIdent +mapTypes (T.TData tIdent pTs) (M.TData mIdent mTs) = if tIdent /= mIdent then error "nuh uh" else foldl (\xs (p, m) -> mapTypes p m ++ xs) [] (zip pTs mTs) mapTypes t1 t2 = error $ "structure of types not the same: '" ++ printTree t1 ++ "', '" ++ printTree t2 ++ "'" @@ -111,8 +114,6 @@ getMonoFromPoly t = do env <- ask Nothing -> M.TLit (Ident "void") --error $ "type not found! type: " ++ show ident ++ ", error in previous compilation steps" (T.TData ident args) -> M.TData ident (map (getMono polys) args) - -- TODO: TAll should work different/should not exist in this tree - (T.TAll _ t) -> getMono polys t -- | If ident not already in env's output, morphed bind to output -- (and all referenced binds within this bind). @@ -128,14 +129,14 @@ morphBind expectedType b@(T.Bind (Ident _, btype) args (exp, expt)) = 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 + -- Mark so that this bind will not be processed in recursive or cyclic -- function calls markBind (coerce name') expt' <- getMonoFromPoly expt exp' <- morphExp expt' exp -- Get monomorphic type sof args args' <- mapM convertArg args - addOutputBind $ M.Bind (coerce name', expectedType) + addOutputBind $ M.Bind (coerce name', expectedType) args' (exp', expectedType) return name' @@ -162,7 +163,7 @@ getInputData ident = do env <- ask -- | Expects polymorphic types in data definition to be mapped -- in environment. --morphData :: T.Data -> EnvM () ---morphData (T.Data t cs) = do +--morphData (T.Data t cs) = do -- t' <- getMonoFromPoly t -- output <- get -- cs' <- mapM (\(T.Inj ident t) -> do t' <- getMonoFromPoly t @@ -170,7 +171,7 @@ getInputData ident = do env <- ask -- addOutputData $ M.Data t' cs' morphCons :: M.Type -> Ident -> EnvM () -morphCons expectedType ident = do +morphCons expectedType ident = do maybeD <- getInputData ident case maybeD of Nothing -> error $ "identifier '" ++ show ident ++ "' not found" @@ -191,7 +192,7 @@ morphCons expectedType ident = do -- TODO: Change in tree so that these are the same. -- Converts 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 morphExp :: M.Type -> T.Exp -> EnvM M.Exp @@ -204,7 +205,7 @@ morphExp expectedType exp = case exp of morphApp M.EApp expectedType e1 e2 T.EAdd e1 e2 -> do morphApp M.EAdd expectedType e1 e2 - T.EAbs ident (exp, t) -> local (\env -> env { locals = Set.insert ident (locals env) }) $ do + T.EAbs ident (exp, t) -> local (\env -> env { locals = Set.insert ident (locals env) }) $ do t' <- getMonoFromPoly t morphExp t' exp T.ECase (exp, t) bs -> do @@ -256,7 +257,7 @@ morphPattern ls = \case -- | Creates a new identifier for a function with an assigned type newFuncName :: M.Type -> T.Bind -> Ident -newFuncName t (T.Bind (ident@(Ident bindName), _) _ _) = +newFuncName t (T.Bind (ident@(Ident bindName), _) _ _) = if bindName == "main" then Ident bindName else newName t ident @@ -286,7 +287,7 @@ runEnvM o env (EnvM stateM) = snd $ runReader (runStateT stateM o) env -- | Creates the environment based on the input binds. createEnv :: [T.Def] -> Env -createEnv defs = Env { input = Map.fromList bindPairs, +createEnv defs = Env { input = Map.fromList bindPairs, dataDefs = Map.fromList dataPairs, polys = Map.empty, locals = Set.empty } @@ -312,7 +313,7 @@ getBindsFromDefs = foldl (\bs -> \case getDefsFromOutput :: Output -> [M.Def] getDefsFromOutput o = - map M.DBind binds ++ + map M.DBind binds ++ (map (M.DData . snd) . Map.toList) (createNewData dataInput Map.empty) where (binds, dataInput) = splitBindsAndData o @@ -323,7 +324,7 @@ splitBindsAndData output = foldl (\(oBinds, oData) (ident, o) -> case o of Incomplete -> error "internal bug in monomorphizer" Complete b -> (b:oBinds, oData) - Data t d -> (oBinds, (ident, t, d):oData)) + Data t d -> (oBinds, (ident, t, d):oData)) ([], []) (Map.toList output) @@ -339,7 +340,7 @@ createNewData ((consIdent, consType, polyData):input) o = newDataType = getDataType consType newDataName = newName newDataType polyDataIdent newCons = M.Inj consIdent consType - + getDataType :: M.Type -> M.Type getDataType (M.TFun t1 t2) = getDataType t2 getDataType tData@(M.TData _ _) = tData @@ -356,7 +357,7 @@ getDataType _ = error "???" -- Nothing -> do -- createNewData cs $ Map.insert ident (M.Data (M.TLit $ Ident "void") [newCons]) o -- Just _ -> do --- createNewData cs $ Map.adjust (\(M.Data _ pcs') -> +-- createNewData cs $ Map.adjust (\(M.Data _ pcs') -> -- M.Data expectedType (newCons : pcs')) ident o -- _ -> error "internal bug in monomorphizer" diff --git a/src/Renamer/Renamer.hs b/src/Renamer/Renamer.hs index d30412f..e92e12f 100644 --- a/src/Renamer/Renamer.hs +++ b/src/Renamer/Renamer.hs @@ -1,224 +1,112 @@ -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedRecordDot #-} module Renamer.Renamer (rename) where -import Auxiliary (mapAccumM) -import Control.Applicative (Applicative (liftA2)) -import Control.Monad (when) -import Control.Monad.Except ( - ExceptT, - MonadError (catchError, throwError), - runExceptT, - ) -import Control.Monad.State ( - MonadState, - State, - StateT, - evalState, - evalStateT, - get, - gets, - lift, - mapAndUnzipM, - modify, - put, - ) -import Data.Function (on) -import Data.Map (Map) -import Data.Map qualified as Map -import Data.Maybe (fromMaybe) -import Data.Set (Set) -import Data.Set qualified as Set -import Data.Tuple.Extra (dupe, second) -import Grammar.Abs -import Grammar.ErrM (Err) -import Grammar.Print (printTree) +import Auxiliary (maybeToRightM, onM, partitionDefs) +import Control.Applicative (liftA2) +import Control.Monad.Except (ExceptT, MonadError, runExceptT) +import Control.Monad.State (MonadState, State, evalState, gets, + modify) +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Tuple.Extra (dupe) +import Grammar.Abs +import Grammar.ErrM (Err) +import Grammar.Print (printTree) -- | Rename all variables and local binds rename :: Program -> Err Program -rename (Program defs) = Program <$> renameDefs defs +rename (Program defs) = rename' $ do + ds' <- mapM (fmap DData . rnData) ds + ss' <- mapM (fmap DSig . rnSig) ss + bs' <- mapM (fmap DBind . rnTopBind) bs + pure $ Program (ds' ++ ss' ++ bs') + where + (ds, ss, bs) = partitionDefs defs + rename' = flip evalState initCxt + . runExceptT + . runRn + initCxt = Cxt + { counter = 0 + , names = Map.fromList $ [ dupe n | Sig n _ <- ss ] + ++ [ dupe n | Bind n _ _ <- bs ] + } +rnData :: Data -> Rn Data +rnData (Data typ injs) = liftA2 Data (rnType typ) (mapM rnInj injs) + where + rnInj (Inj name t) = Inj name <$> rnType t -initCxt :: Cxt -initCxt = Cxt 0 0 +rnSig :: Sig -> Rn Sig +rnSig (Sig name typ) = liftA2 Sig (getName name) (rnType typ) + +rnType :: Type -> Rn Type +rnType = \case + TVar (MkTVar name) -> TVar . MkTVar <$> getName name + TData name ts -> TData name <$> localNames (mapM rnType ts) + TFun t1 t2 -> onM TFun (localNames . rnType) t1 t2 + TAll (MkTVar name) t -> liftA2 (TAll . MkTVar) (newName name) (rnType t) + typ -> pure typ + +rnTopBind :: Bind -> Rn Bind +rnTopBind = rnBind' False + +rnLocalBind :: Bind -> Rn Bind +rnLocalBind = rnBind' True + +rnBind' :: Bool -> Bind -> Rn Bind +rnBind' isLocal (Bind name vars rhs) = do + name' <- if isLocal then newName name else getName name + (vars', rhs') <- localNames $ liftA2 (,) (mapM newName vars) (rnExp rhs) + pure (Bind name' vars' rhs') + +rnExp :: Exp -> Rn Exp +rnExp = \case + EVar x -> EVar <$> getName x + EInj x -> pure (EInj x) + ELit lit -> pure (ELit lit) + EApp e1 e2 -> onM EApp (localNames . rnExp) e1 e2 + EAdd e1 e2 -> onM EAdd (localNames . rnExp) e1 e2 + ELet bind e -> liftA2 ELet (rnLocalBind bind) (rnExp e) + EAbs x e -> liftA2 EAbs (newName x) (rnExp e) + EAnn e t -> liftA2 EAnn (rnExp e) (rnType t) + ECase e bs -> liftA2 ECase (rnExp e) (mapM (localNames . rnBranch) bs) + +rnBranch :: Branch -> Rn Branch +rnBranch (Branch p e) = liftA2 Branch (rnPattern p) (rnExp e) + +rnPattern :: Pattern -> Rn Pattern +rnPattern = \case + PVar x -> PVar <$> newName x + PLit lit -> pure (PLit lit) + PCatch -> pure PCatch + PEnum name -> pure (PEnum name) + PInj name ps -> PInj name <$> mapM rnPattern ps data Cxt = Cxt - { var_counter :: Int - , tvar_counter :: Int + { counter :: Int + , names :: Map LIdent LIdent } -- | Rename monad. State holds the number of renamed names. newtype Rn a = Rn {runRn :: ExceptT String (State Cxt) a} deriving (Functor, Applicative, Monad, MonadState Cxt, MonadError String) --- | Maps old to new name -type Names = Map String String +getName :: LIdent -> Rn LIdent +getName name = maybeToRightM err =<< gets (Map.lookup name . names) + where err = "Can't find new name " ++ printTree name -renameDefs :: [Def] -> Err [Def] -renameDefs defs = evalState (runExceptT (runRn $ mapM renameDef defs)) initCxt +newName :: LIdent -> Rn LIdent +newName name = do + name' <- gets (mk name . counter) + modify $ \cxt -> cxt { counter = succ cxt.counter + , names = Map.insert name name' cxt.names + } + pure name' where - initNames = Map.fromList [dupe s | DBind (Bind (LIdent s) _ _) <- defs] + mk (LIdent name) i = LIdent ("#" ++ show i ++ name) - renameDef :: Def -> Rn Def - renameDef = \case - DSig (Sig name typ) -> DSig . Sig name <$> renameTVars typ - DBind (Bind name vars rhs) -> do - (new_names, vars') <- newNamesL initNames vars - rhs' <- snd <$> renameExp new_names rhs - pure . DBind $ Bind name vars' rhs' - DData (Data typ injs) -> do - tvars <- collectTVars [] typ - tvars' <- mapM nextNameTVar tvars - let tvars_lt = zip tvars tvars' - typ' = substituteTVar tvars_lt typ - injs' = map (renameInj tvars_lt) injs - pure . DData $ Data typ' injs' - where - collectTVars tvars = \case - TAll tvar t -> collectTVars (tvar : tvars) t - TData _ _ -> pure tvars - _ -> throwError ("Bad data type definition: " ++ printTree typ) - - renameInj :: [(TVar, TVar)] -> Inj -> Inj - renameInj new_types (Inj name typ) = - Inj name $ substituteTVar new_types typ - -substituteTVar :: [(TVar, TVar)] -> Type -> Type -substituteTVar new_names typ = case typ of - TLit _ -> typ - TVar tvar - | Just tvar' <- lookup tvar new_names -> - TVar tvar' - | otherwise -> - typ - TFun t1 t2 -> on TFun substitute' t1 t2 - TAll tvar t - | Just tvar' <- lookup tvar new_names -> - TAll tvar' $ substitute' t - | otherwise -> - TAll tvar $ substitute' t - TData name typs -> TData name $ map substitute' typs - _ -> error ("Impossible " ++ show typ) - where - substitute' = substituteTVar new_names - -renameExp :: Names -> Exp -> Rn (Names, Exp) -renameExp old_names = \case - EVar (LIdent n) -> pure (old_names, EVar . LIdent . fromMaybe n $ Map.lookup n old_names) - EInj (UIdent n) -> pure (old_names, EInj . UIdent . fromMaybe n $ Map.lookup n old_names) - ELit lit -> pure (old_names, ELit lit) - EApp e1 e2 -> do - (env1, e1') <- renameExp old_names e1 - (env2, e2') <- renameExp old_names e2 - pure (Map.union env1 env2, EApp e1' e2') - EAdd e1 e2 -> do - (env1, e1') <- renameExp old_names e1 - (env2, e2') <- renameExp old_names e2 - pure (Map.union env1 env2, EAdd e1' e2') - - -- TODO fix shadowing - ELet (Bind name vars rhs) e -> do - (new_names, name') <- newNameL old_names name - (new_names', vars') <- newNamesL new_names vars - (new_names'', rhs') <- renameExp new_names' rhs - (new_names''', e') <- renameExp new_names'' e - pure (new_names''', ELet (Bind name' vars' rhs') e') - EAbs par e -> do - (new_names, par') <- newNameL old_names par - (new_names', e') <- renameExp new_names e - pure (new_names', EAbs par' e') - EAnn e t -> do - (new_names, e') <- renameExp old_names e - t' <- renameTVars t - pure (new_names, EAnn e' t') - ECase e injs -> do - (new_names, e') <- renameExp old_names e - (new_names', injs') <- renameBranches new_names injs - pure (new_names', ECase e' injs') - -renameBranches :: Names -> [Branch] -> Rn (Names, [Branch]) -renameBranches ns xs = do - (new_names, xs') <- mapAndUnzipM (renameBranch ns) xs - if null new_names then return (mempty, xs') else return (head new_names, xs') - -renameBranch :: Names -> Branch -> Rn (Names, Branch) -renameBranch ns b@(Branch patt e) = do - (new_names, patt') <- catchError (evalStateT (renamePattern ns patt) mempty) (\x -> throwError $ x ++ " in pattern '" ++ printTree b ++ "'") - (new_names', e') <- renameExp new_names e - return (new_names', Branch patt' e') - -renamePattern :: Names -> Pattern -> StateT (Set LIdent) Rn (Names, Pattern) -renamePattern ns p = case p of - PInj cs ps -> do - (ns_new, ps') <- mapAccumM renamePattern ns ps - return (ns_new, PInj cs ps') - PVar name -> do - vs <- get - when (name `Set.member` vs) (throwError $ "Conflicting definitions of '" ++ printTree name ++ "'") - put (Set.insert name vs) - nn <- lift $ newNameL ns name - return $ second PVar nn - _ -> return (ns, p) - -renameTVars :: Type -> Rn Type -renameTVars typ = case typ of - TAll tvar t -> do - tvar' <- nextNameTVar tvar - t' <- renameTVars $ substitute tvar tvar' t - pure $ TAll tvar' t' - TFun t1 t2 -> liftA2 TFun (renameTVars t1) (renameTVars t2) - _ -> pure typ - -substitute :: - TVar -> -- α - TVar -> -- α_n - Type -> -- A - Type -- [α_n/α]A -substitute tvar1 tvar2 typ = case typ of - TLit _ -> typ - TVar tvar - | tvar == tvar1 -> TVar tvar2 - | otherwise -> typ - TFun t1 t2 -> on TFun substitute' t1 t2 - TAll tvar t - | tvar == tvar1 -> TAll tvar2 $ substitute' t - | otherwise -> TAll tvar $ substitute' t - TData name typs -> TData name $ map substitute' typs - _ -> error "Impossible" - where - substitute' = substitute tvar1 tvar2 - --- | Create multiple names and add them to the name environment -newNamesL :: Names -> [LIdent] -> Rn (Names, [LIdent]) -newNamesL = mapAccumM newNameL - --- | Create a new name and add it to name environment. -newNameL :: Names -> LIdent -> Rn (Names, LIdent) -newNameL env (LIdent old_name) = do - new_name <- makeName old_name - pure (Map.insert old_name new_name env, LIdent new_name) - --- | Create multiple names and add them to the name environment -newNamesU :: Names -> [UIdent] -> Rn (Names, [UIdent]) -newNamesU = mapAccumM newNameU - --- | Create a new name and add it to name environment. -newNameU :: Names -> UIdent -> Rn (Names, UIdent) -newNameU env (UIdent old_name) = do - new_name <- makeName old_name - pure (Map.insert old_name new_name env, UIdent new_name) - --- | Annotate name with number and increment the number @prefix ⇒ prefix_number@. -makeName :: String -> Rn String -makeName prefix = do - i <- gets var_counter - let name = prefix ++ "_" ++ show i - modify $ \cxt -> cxt{var_counter = succ cxt.var_counter} - pure name - -nextNameTVar :: TVar -> Rn TVar -nextNameTVar (MkTVar (LIdent s)) = do - i <- gets tvar_counter - let tvar = MkTVar . LIdent $ s ++ "_" ++ show i - modify $ \cxt -> cxt{tvar_counter = succ cxt.tvar_counter} - pure tvar +localNames :: MonadState Cxt m => m b -> m b +localNames m = do + old_names <- gets names + m <* modify ( \cxt' -> cxt' { names = old_names }) diff --git a/src/Renamer/RenamerOld.hs b/src/Renamer/RenamerOld.hs deleted file mode 100644 index bf21c9f..0000000 --- a/src/Renamer/RenamerOld.hs +++ /dev/null @@ -1,206 +0,0 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedRecordDot #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PatternSynonyms #-} -{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} - -{-# HLINT ignore "Use mapAndUnzipM" #-} - -module Renamer.Renamer (rename) where - -import Auxiliary (mapAccumM) -import Control.Applicative (Applicative (liftA2)) -import Control.Monad (foldM) -import Control.Monad.Except (ExceptT, MonadError, runExceptT, - throwError) -import Control.Monad.Identity (Identity, runIdentity) -import Control.Monad.State (MonadState, StateT, evalStateT, gets, - modify) -import Data.Coerce (coerce) -import Data.Function (on) -import Data.Map (Map) -import qualified Data.Map as Map -import Data.Maybe (fromMaybe) -import Data.Tuple.Extra (dupe) -import Grammar.Abs - --- | Rename all variables and local binds -rename :: Program -> Either String Program -rename (Program defs) = Program <$> renameDefs defs - -renameDefs :: [Def] -> Either String [Def] -renameDefs defs = runIdentity $ runExceptT $ evalStateT (runRn $ mapM renameDef defs) initCxt - where - initNames = Map.fromList [dupe (coerce name) | DBind (Bind name _ _) <- defs] - - renameDef :: Def -> Rn Def - renameDef = \case - DSig (Sig name typ) -> DSig . Sig name <$> renameTVars typ - DBind bind -> DBind . snd <$> renameBind initNames bind - DData (Data (TData cname types) constrs) -> do - tvars_ <- tvars - tvars' <- mapM nextNameTVar tvars_ - let tvars_lt = zip tvars_ tvars' - typ' = map (substituteTVar tvars_lt) types - constrs' = map (renameConstr tvars_lt) constrs - pure . DData $ Data (TData cname typ') constrs' - where - tvars = concat <$> mapM (collectTVars []) types - collectTVars :: [TVar] -> Type -> Rn [TVar] - collectTVars tvars = \case - TAll tvar t -> collectTVars (tvar : tvars) t - TData _ _ -> return tvars - -- Should be monad error - TVar v -> return [v] - _ -> throwError ("Bad data type definition: " ++ show types) - DData (Data types _) -> throwError ("Bad data type definition: " ++ show types) - - renameConstr :: [(TVar, TVar)] -> Inj -> Inj - renameConstr new_types (Inj name typ) = - Inj name $ substituteTVar new_types typ - -renameBind :: Names -> Bind -> Rn (Names, Bind) -renameBind old_names (Bind name vars rhs) = do - (new_names, vars') <- newNames old_names (coerce vars) - (newer_names, rhs') <- renameExp new_names rhs - pure (newer_names, Bind name (coerce vars') rhs') - -substituteTVar :: [(TVar, TVar)] -> Type -> Type -substituteTVar new_names typ = case typ of - TLit _ -> typ - TVar tvar - | Just tvar' <- lookup tvar new_names -> - TVar tvar' - | otherwise -> - typ - TFun t1 t2 -> on TFun substitute' t1 t2 - TAll tvar t - | Just tvar' <- lookup tvar new_names -> - TAll tvar' $ substitute' t - | otherwise -> - TAll tvar $ substitute' t - TData name typs -> TData name $ map substitute' typs - _ -> error ("Impossible " ++ show typ) - where - substitute' = substituteTVar new_names - -initCxt :: Cxt -initCxt = Cxt 0 0 - -data Cxt = Cxt - { var_counter :: Int - , tvar_counter :: Int - } - --- | Rename monad. State holds the number of renamed names. -newtype Rn a = Rn {runRn :: StateT Cxt (ExceptT String Identity) a} - deriving (Functor, Applicative, Monad, MonadState Cxt, MonadError String) - --- | Maps old to new name -type Names = Map LIdent LIdent - -renameExp :: Names -> Exp -> Rn (Names, Exp) -renameExp old_names = \case - EVar n -> pure (coerce old_names, EVar . fromMaybe n $ Map.lookup n old_names) - EInj n -> pure (old_names, EInj n) - ELit lit -> pure (old_names, ELit lit) - EApp e1 e2 -> do - (env1, e1') <- renameExp old_names e1 - (env2, e2') <- renameExp old_names e2 - pure (Map.union env1 env2, EApp e1' e2') - EAdd e1 e2 -> do - (env1, e1') <- renameExp old_names e1 - (env2, e2') <- renameExp old_names e2 - pure (Map.union env1 env2, EAdd e1' e2') - - -- TODO fix shadowing - ELet bind e -> do - (new_names, bind') <- renameBind old_names bind - (new_names', e') <- renameExp new_names e - pure (new_names', ELet bind' e') - EAbs par e -> do - (new_names, par') <- newName old_names (coerce par) - (new_names', e') <- renameExp new_names e - pure (new_names', EAbs (coerce par') e') - EAnn e t -> do - (new_names, e') <- renameExp old_names e - t' <- renameTVars t - pure (new_names, EAnn e' t') - ECase e injs -> do - (new_names, e') <- renameExp old_names e - (new_names', injs') <- renameBranches new_names injs - pure (new_names', ECase e' injs') - -renameBranches :: Names -> [Branch] -> Rn (Names, [Branch]) -renameBranches ns xs = do - (new_names, xs') <- unzip <$> mapM (renameBranch ns) xs - if null new_names then return (mempty, xs') else return (head new_names, xs') - -renameBranch :: Names -> Branch -> Rn (Names, Branch) -renameBranch ns (Branch init e) = do - (new_names, init') <- renamePattern ns init - (new_names', e') <- renameExp new_names e - return (new_names', Branch init' e') - -renamePattern :: Names -> Pattern -> Rn (Names, Pattern) -renamePattern ns i = case i of - PInj cs ps -> do - (ns_new, ps) <- renamePatterns ns ps - return (ns_new, PInj cs ps) - rest -> return (ns, rest) - -renamePatterns :: Names -> [Pattern] -> Rn (Names, [Pattern]) -renamePatterns ns xs = do - (new_names, xs') <- unzip <$> mapM (renamePattern ns) xs - if null new_names then return (mempty, xs') else return (head new_names, xs') - -renameTVars :: Type -> Rn Type -renameTVars typ = case typ of - TAll tvar t -> do - tvar' <- nextNameTVar tvar - t' <- renameTVars $ substitute tvar tvar' t - pure $ TAll tvar' t' - TFun t1 t2 -> liftA2 TFun (renameTVars t1) (renameTVars t2) - _ -> pure typ - -substitute :: - TVar -> -- α - TVar -> -- α_n - Type -> -- A - Type -- [α_n/α]A -substitute tvar1 tvar2 typ = case typ of - TLit _ -> typ - TVar tvar' - | tvar' == tvar1 -> TVar tvar2 - | otherwise -> typ - TFun t1 t2 -> on TFun substitute' t1 t2 - TAll tvar t -> TAll tvar $ substitute' t - TData name typs -> TData name $ map substitute' typs - _ -> error "Impossible" - where - substitute' = substitute tvar1 tvar2 - --- | Create a new name and add it to name environment. -newName :: Names -> LIdent -> Rn (Names, LIdent) -newName env old_name = do - new_name <- makeName old_name - pure (Map.insert old_name new_name env, new_name) - --- | Create multiple names and add them to the name environment -newNames :: Names -> [LIdent] -> Rn (Names, [LIdent]) -newNames = mapAccumM newName - --- | Annotate name with number and increment the number @prefix ⇒ prefix_number@. -makeName :: LIdent -> Rn LIdent -makeName (LIdent prefix) = do - i <- gets var_counter - let name = LIdent $ prefix ++ "_" ++ show i - modify $ \cxt -> cxt{var_counter = succ cxt.var_counter} - pure name - -nextNameTVar :: TVar -> Rn TVar -nextNameTVar (MkTVar (LIdent s)) = do - i <- gets tvar_counter - let tvar = MkTVar $ coerce $ s ++ "_" ++ show i - modify $ \cxt -> cxt{tvar_counter = succ cxt.tvar_counter} - pure tvar diff --git a/src/ReportForall.hs b/src/ReportForall.hs new file mode 100644 index 0000000..978dde5 --- /dev/null +++ b/src/ReportForall.hs @@ -0,0 +1,70 @@ +{-# LANGUAGE LambdaCase #-} + +module ReportForall (reportForall) where + +import Auxiliary (partitionDefs) +import Control.Monad (unless, void, when) +import Control.Monad.Except (MonadError (throwError)) +import Data.Either.Combinators (mapRight) +import Data.Foldable (foldlM) +import Data.Function (on) +import Data.List (delete) +import Grammar.Abs +import Grammar.ErrM (Err) +import TypeChecker.TypeChecker (TypeChecker (Bi, Hm)) + +reportForall :: TypeChecker -> Program -> Err () +reportForall tc p = do + when (tc == Hm) $ rpProgram rpaType p + rpProgram rpuType p + +rpuType :: Type -> Err () +rpuType typ = do + tvars <- go [] typ + unless (null tvars) $ throwError "Unused forall" + where + go tvars = \case + TAll tvar t + | tvar `elem` tvars -> throwError "Duplicate forall" + | otherwise -> go (tvar : tvars) t + TVar tvar -> pure (delete tvar tvars) + TFun t1 t2 -> go tvars t1 >>= (`go` t2) + TData _ typs -> foldlM go tvars typs + _ -> pure tvars + + +rpaType :: Type -> Err () +rpaType = rpForall . skipForall + where + skipForall = \case + TAll _ t -> skipForall t + t -> t + rpForall = \case + TAll {} -> throwError "Higher rank forall not allowed" + TFun t1 t2 -> on (>>) rpForall t1 t2 + TData _ typs -> mapM_ rpForall typs + _ -> pure () + +rpProgram :: (Type -> Err ()) -> Program -> Err () +rpProgram rf (Program defs) = do + mapM_ rpuBind bs + mapM_ rpuData ds + mapM_ rpuSig ss + where + (ds, ss, bs) = partitionDefs defs + rpuSig (Sig _ typ) = rf typ + rpuData (Data typ injs) = rf typ >> mapM rpuInj injs + rpuInj (Inj _ typ) = rf typ + rpuBind (Bind _ _ rhs) = rpuExp rhs + rpuBranch (Branch _ e) = rpuExp e + rpuExp = \case + EAnn e t -> rpuExp e >> rf t + EApp e1 e2 -> on (>>) rpuExp e1 e2 + EAdd e1 e2 -> on (>>) rpuExp e1 e2 + ELet bind e -> rpuBind bind >> rpuExp e + EAbs _ e -> rpuExp e + ECase e bs -> rpuExp e >> mapM_ rpuBranch bs + _ -> pure () + +reportAnyForall :: Program -> Err () +reportAnyForall = undefined diff --git a/src/TypeChecker/RemoveForall.hs b/src/TypeChecker/RemoveForall.hs new file mode 100644 index 0000000..d4cdd81 --- /dev/null +++ b/src/TypeChecker/RemoveForall.hs @@ -0,0 +1,48 @@ +{-# LANGUAGE LambdaCase #-} + +module TypeChecker.RemoveForall (removeForall) where + +import Auxiliary (onM) +import Control.Applicative (Applicative (liftA2)) +import Data.Function (on) +import Data.List (partition) +import Data.Tuple.Extra (second) +import Grammar.ErrM (Err) +import qualified TypeChecker.ReportTEVar as R +import TypeChecker.TypeCheckerIr + +removeForall :: Program' R.Type -> Program +removeForall (Program defs) = Program $ map (DData . rfData) ds + ++ map (DBind . rfBind) bs + where + (ds, bs) = ([d | DData d <- defs ], [ b | DBind b <- defs ]) + rfData (Data typ injs) = Data (rfType typ) (map rfInj injs) + rfInj (Inj name typ) = Inj name (rfType typ) + rfBind (Bind name vars rhs) = Bind (rfId name) (map rfId vars) (rfExpT rhs) + rfId = second rfType + rfExpT (e, t) = (rfExp e, rfType t) + rfExp = \case + EApp e1 e2 -> on EApp rfExpT e1 e2 + EAdd e1 e2 -> on EAdd rfExpT e1 e2 + ELet bind e -> ELet (rfBind bind) (rfExpT e) + EAbs name e -> EAbs name (rfExpT e) + ECase e bs -> ECase (rfExpT e) (map rfBranch bs) + ELit lit -> ELit lit + EVar name -> EVar name + EInj name -> EInj name + rfBranch (Branch (p, t) e) = Branch (rfPattern p, rfType t) (rfExpT e) + rfPattern = \case + PVar id -> PVar (rfId id) + PLit (lit, t) -> PLit (lit, rfType t) + PCatch -> PCatch + PEnum name -> PEnum name + PInj name ps -> PInj name (map rfPattern ps) + +rfType :: R.Type -> Type +rfType = \case + R.TAll _ t -> rfType t + R.TFun t1 t2 -> on TFun rfType t1 t2 + R.TData name ts -> TData name (map rfType ts) + R.TLit lit -> TLit lit + R.TVar tvar -> TVar tvar + diff --git a/src/TypeChecker/RemoveTEVar.hs b/src/TypeChecker/RemoveTEVar.hs deleted file mode 100644 index e709456..0000000 --- a/src/TypeChecker/RemoveTEVar.hs +++ /dev/null @@ -1,71 +0,0 @@ -{-# LANGUAGE LambdaCase #-} - -module TypeChecker.RemoveTEVar where - -import Control.Applicative (Applicative (liftA2), liftA3) -import Control.Monad.Except (MonadError (throwError)) -import Data.Coerce (coerce) -import Data.Tuple.Extra (secondM) -import Grammar.Abs -import Grammar.ErrM (Err) -import TypeChecker.TypeCheckerIr qualified as T - -class RemoveTEVar a b where - rmTEVar :: a -> Err b - -instance RemoveTEVar (T.Program' Type) (T.Program' T.Type) where - rmTEVar (T.Program defs) = T.Program <$> rmTEVar defs - -instance RemoveTEVar (T.Def' Type) (T.Def' T.Type) where - rmTEVar = \case - T.DBind bind -> T.DBind <$> rmTEVar bind - T.DData dat -> T.DData <$> rmTEVar dat - -instance RemoveTEVar (T.Bind' Type) (T.Bind' T.Type) where - rmTEVar (T.Bind id vars rhs) = liftA3 T.Bind (rmTEVar id) (rmTEVar vars) (rmTEVar rhs) - -instance RemoveTEVar (T.Exp' Type) (T.Exp' T.Type) where - rmTEVar exp = case exp of - T.EVar name -> pure $ T.EVar name - T.EInj name -> pure $ T.EInj name - T.ELit lit -> pure $ T.ELit lit - T.ELet bind e -> liftA2 T.ELet (rmTEVar bind) (rmTEVar e) - T.EApp e1 e2 -> liftA2 T.EApp (rmTEVar e1) (rmTEVar e2) - T.EAdd e1 e2 -> liftA2 T.EAdd (rmTEVar e1) (rmTEVar e2) - T.EAbs name e -> T.EAbs name <$> rmTEVar e - T.ECase e branches -> liftA2 T.ECase (rmTEVar e) (rmTEVar branches) - -instance RemoveTEVar (T.Branch' Type) (T.Branch' T.Type) where - rmTEVar (T.Branch (patt, t_patt) e) = liftA2 T.Branch (liftA2 (,) (rmTEVar patt) (rmTEVar t_patt)) (rmTEVar e) - -instance RemoveTEVar (T.Pattern' Type) (T.Pattern' T.Type) where - rmTEVar = \case - T.PVar (name, t) -> T.PVar . (name,) <$> rmTEVar t - T.PLit (lit, t) -> T.PLit . (lit,) <$> rmTEVar t - T.PCatch -> pure T.PCatch - T.PEnum name -> pure $ T.PEnum name - T.PInj name ps -> T.PInj name <$> rmTEVar ps - -instance RemoveTEVar (T.Data' Type) (T.Data' T.Type) where - rmTEVar (T.Data typ injs) = liftA2 T.Data (rmTEVar typ) (rmTEVar injs) - -instance RemoveTEVar (T.Inj' Type) (T.Inj' T.Type) where - rmTEVar (T.Inj name typ) = T.Inj name <$> rmTEVar typ - -instance RemoveTEVar (T.Id' Type) (T.Id' T.Type) where - rmTEVar = secondM rmTEVar - -instance RemoveTEVar (T.ExpT' Type) (T.ExpT' T.Type) where - rmTEVar (exp, typ) = liftA2 (,) (rmTEVar exp) (rmTEVar typ) - -instance RemoveTEVar a b => RemoveTEVar [a] [b] where - rmTEVar = mapM rmTEVar - -instance RemoveTEVar Type T.Type where - rmTEVar = \case - TLit lit -> pure $ T.TLit (coerce lit) - TVar (MkTVar i) -> pure $ T.TVar (T.MkTVar $ coerce i) - TData name typs -> T.TData (coerce name) <$> rmTEVar typs - TFun t1 t2 -> liftA2 T.TFun (rmTEVar t1) (rmTEVar t2) - TAll (MkTVar i) t -> T.TAll (T.MkTVar $ coerce i) <$> rmTEVar t - TEVar _ -> throwError "NewType TEVar!" diff --git a/src/TypeChecker/ReportTEVar.hs b/src/TypeChecker/ReportTEVar.hs new file mode 100644 index 0000000..e69c8b6 --- /dev/null +++ b/src/TypeChecker/ReportTEVar.hs @@ -0,0 +1,81 @@ +{-# LANGUAGE LambdaCase #-} + +module TypeChecker.ReportTEVar where + +import Auxiliary (onM) +import Control.Applicative (Applicative (liftA2), liftA3) +import Control.Monad.Except (MonadError (throwError)) +import Data.Coerce (coerce) +import Data.Tuple.Extra (secondM) +import qualified Grammar.Abs as G +import Grammar.ErrM (Err) +import TypeChecker.TypeCheckerIr hiding (Type (..)) + + +data Type + = TLit Ident + | TVar TVar + | TData Ident [Type] + | TFun Type Type + | TAll TVar Type + deriving (Eq, Ord, Show, Read) + +class ReportTEVar a b where + reportTEVar :: a -> Err b + +instance ReportTEVar (Program' G.Type) (Program' Type) where + reportTEVar (Program defs) = Program <$> reportTEVar defs + +instance ReportTEVar (Def' G.Type) (Def' Type) where + reportTEVar = \case + DBind bind -> DBind <$> reportTEVar bind + DData dat -> DData <$> reportTEVar dat + +instance ReportTEVar (Bind' G.Type) (Bind' Type) where + reportTEVar (Bind id vars rhs) = liftA3 Bind (reportTEVar id) (reportTEVar vars) (reportTEVar rhs) + +instance ReportTEVar (Exp' G.Type) (Exp' Type) where + reportTEVar exp = case exp of + EVar name -> pure $ EVar name + EInj name -> pure $ EInj name + ELit lit -> pure $ ELit lit + ELet bind e -> liftA2 ELet (reportTEVar bind) (reportTEVar e) + EApp e1 e2 -> onM EApp reportTEVar e1 e2 + EAdd e1 e2 -> onM EAdd reportTEVar e1 e2 + EAbs name e -> EAbs name <$> reportTEVar e + ECase e branches -> liftA2 ECase (reportTEVar e) (reportTEVar branches) + +instance ReportTEVar (Branch' G.Type) (Branch' Type) where + reportTEVar (Branch (patt, t_patt) e) = liftA2 Branch (liftA2 (,) (reportTEVar patt) (reportTEVar t_patt)) (reportTEVar e) + +instance ReportTEVar (Pattern' G.Type) (Pattern' Type) where + reportTEVar = \case + PVar (name, t) -> PVar . (name,) <$> reportTEVar t + PLit (lit, t) -> PLit . (lit,) <$> reportTEVar t + PCatch -> pure PCatch + PEnum name -> pure $ PEnum name + PInj name ps -> PInj name <$> reportTEVar ps + +instance ReportTEVar (Data' G.Type) (Data' Type) where + reportTEVar (Data typ injs) = liftA2 Data (reportTEVar typ) (reportTEVar injs) + +instance ReportTEVar (Inj' G.Type) (Inj' Type) where + reportTEVar (Inj name typ) = Inj name <$> reportTEVar typ + +instance ReportTEVar (Id' G.Type) (Id' Type) where + reportTEVar = secondM reportTEVar + +instance ReportTEVar (ExpT' G.Type) (ExpT' Type) where + reportTEVar (exp, typ) = liftA2 (,) (reportTEVar exp) (reportTEVar typ) + +instance ReportTEVar a b => ReportTEVar [a] [b] where + reportTEVar = mapM reportTEVar + +instance ReportTEVar G.Type Type where + reportTEVar = \case + G.TLit lit -> pure $ TLit (coerce lit) + G.TVar (G.MkTVar i) -> pure $ TVar (MkTVar $ coerce i) + G.TData name typs -> TData (coerce name) <$> reportTEVar typs + G.TFun t1 t2 -> liftA2 TFun (reportTEVar t1) (reportTEVar t2) + G.TAll (G.MkTVar i) t -> TAll (MkTVar $ coerce i) <$> reportTEVar t + G.TEVar _ -> throwError "NewType TEVar!" diff --git a/src/TypeChecker/TypeChecker.hs b/src/TypeChecker/TypeChecker.hs index b7e4b9c..7f3d67a 100644 --- a/src/TypeChecker/TypeChecker.hs +++ b/src/TypeChecker/TypeChecker.hs @@ -1,17 +1,19 @@ module TypeChecker.TypeChecker (typecheck, TypeChecker (..)) where -import Control.Monad ((<=<)) -import Grammar.Abs -import Grammar.ErrM (Err) -import TypeChecker.RemoveTEVar (RemoveTEVar (rmTEVar)) -import TypeChecker.TypeCheckerBidir qualified as Bi -import TypeChecker.TypeCheckerHm qualified as Hm -import TypeChecker.TypeCheckerIr qualified as T +import Control.Monad ((<=<)) +import qualified Grammar.Abs as G +import Grammar.ErrM (Err) +import TypeChecker.RemoveForall (removeForall) +import qualified TypeChecker.ReportTEVar as R +import TypeChecker.ReportTEVar (reportTEVar) +import qualified TypeChecker.TypeCheckerBidir as Bi +import qualified TypeChecker.TypeCheckerHm as Hm +import TypeChecker.TypeCheckerIr -data TypeChecker = Bi | Hm +data TypeChecker = Bi | Hm deriving Eq -typecheck :: TypeChecker -> Program -> Err T.Program -typecheck tc = rmTEVar <=< f +typecheck :: TypeChecker -> G.Program -> Err Program +typecheck tc = fmap removeForall . (reportTEVar <=< f) where f = case tc of Bi -> Bi.typecheck diff --git a/src/TypeChecker/TypeCheckerBidir.hs b/src/TypeChecker/TypeCheckerBidir.hs index 66ef087..9569a27 100644 --- a/src/TypeChecker/TypeCheckerBidir.hs +++ b/src/TypeChecker/TypeCheckerBidir.hs @@ -121,6 +121,7 @@ typecheckBind (Bind name vars rhs) = do , "Did you forget to add type annotation to a polymorphic function?" ] +-- TODO remove some checks typecheckDataType :: Data -> Err (T.Data' Type) typecheckDataType (Data typ injs) = do (name, tvars) <- go [] typ @@ -135,6 +136,7 @@ typecheckDataType (Data typ injs) = do -> pure (name, tvars') _ -> throwError $ unwords ["Bad data type definition: ", ppT typ] +-- TODO remove some checks typecheckInj :: Inj -> UIdent -> [TVar] -> Err (T.Inj' Type) typecheckInj (Inj inj_name inj_typ) name tvars | not $ boundTVars tvars inj_typ @@ -878,18 +880,18 @@ traceTs s xs = trace (s ++ " [ " ++ intercalate ", " (map ppT xs) ++ " ]") pure ppT = \case TLit (UIdent s) -> s - TVar (MkTVar (LIdent s)) -> "α_" ++ s - TFun t1 t2 -> ppT t1 ++ "→" ++ ppT t2 + TVar (MkTVar (LIdent s)) -> "a_" ++ s + TFun t1 t2 -> ppT t1 ++ "->" ++ ppT t2 TAll (MkTVar (LIdent s)) t -> "forall " ++ s ++ ". " ++ ppT t - TEVar (MkTEVar (LIdent s)) -> "ά_" ++ s + TEVar (MkTEVar (LIdent s)) -> "a^_" ++ s TData (UIdent name) typs -> name ++ " (" ++ unwords (map ppT typs) ++ " )" ppEnvElem = \case EnvVar (LIdent s) t -> s ++ ":" ++ ppT t - EnvTVar (MkTVar (LIdent s)) -> "α_" ++ s - EnvTEVar (MkTEVar (LIdent s)) -> "ά_" ++ s - EnvTEVarSolved (MkTEVar (LIdent s)) t -> "ά_" ++ s ++ "=" ++ ppT t - EnvMark (MkTEVar (LIdent s)) -> "▶" ++ "ά_" ++ s + EnvTVar (MkTVar (LIdent s)) -> "a_" ++ s + EnvTEVar (MkTEVar (LIdent s)) -> "a^_" ++ s + EnvTEVarSolved (MkTEVar (LIdent s)) t -> "_" ++ s ++ "=" ++ ppT t + EnvMark (MkTEVar (LIdent s)) -> "▶" ++ "a^_" ++ s ppEnv = \case Empty -> "·" diff --git a/src/TypeChecker/TypeCheckerHm.hs b/src/TypeChecker/TypeCheckerHm.hs index 38582e5..f23e28a 100644 --- a/src/TypeChecker/TypeCheckerHm.hs +++ b/src/TypeChecker/TypeCheckerHm.hs @@ -1,31 +1,31 @@ -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedRecordDot #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QualifiedDo #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QualifiedDo #-} -- | A module for type checking and inference using algorithm W, Hindley-Milner module TypeChecker.TypeCheckerHm where -import Auxiliary (int, litType, maybeToRightM, unzip4) -import Auxiliary qualified as Aux -import Control.Monad.Except -import Control.Monad.Identity (Identity, runIdentity) -import Control.Monad.Reader -import Control.Monad.State -import Control.Monad.Writer -import Data.Coerce (coerce) -import Data.Function (on) -import Data.List (foldl', nub, sortOn) -import Data.List.Extra (unsnoc) -import Data.Map (Map) -import Data.Map qualified as M -import Data.Maybe (fromJust) -import Data.Set (Set) -import Data.Set qualified as S -import Debug.Trace (trace) -import Grammar.Abs -import Grammar.Print (printTree) -import TypeChecker.TypeCheckerIr qualified as T +import Auxiliary (int, litType, maybeToRightM, unzip4) +import qualified Auxiliary as Aux +import Control.Monad.Except +import Control.Monad.Identity (Identity, runIdentity) +import Control.Monad.Reader +import Control.Monad.State +import Control.Monad.Writer +import Data.Coerce (coerce) +import Data.Function (on) +import Data.List (foldl', nub, sortOn) +import Data.List.Extra (unsnoc) +import Data.Map (Map) +import qualified Data.Map as M +import Data.Maybe (fromJust) +import Data.Set (Set) +import qualified Data.Set as S +import Debug.Trace (trace) +import Grammar.Abs +import Grammar.Print (printTree) +import qualified TypeChecker.TypeCheckerIr as T -- TODO: Disallow mutual recursion @@ -34,7 +34,7 @@ typecheck :: Program -> Either String (T.Program' Type, [Warning]) typecheck = onLeft msg . run . checkPrg where onLeft :: (Error -> String) -> Either Error a -> Either String a - onLeft f (Left x) = Left $ f x + onLeft f (Left x) = Left $ f x onLeft _ (Right x) = Right x checkPrg :: Program -> Infer (T.Program' Type) @@ -118,7 +118,7 @@ preRun (x : xs) = case x of s <- gets sigs case M.lookup (coerce n) s of Nothing -> insertSig (coerce n) Nothing >> preRun xs - Just _ -> preRun xs + Just _ -> preRun xs DData d@(Data t _) -> collect (collectTVars t) >> checkData d >> preRun xs where -- Check if function body / signature has been declared already @@ -140,11 +140,11 @@ checkDef (x : xs) = case x of T.Data t $ map (\(Inj name typ) -> T.Inj (coerce name) typ) injs freeOrdered :: Type -> [T.Ident] -freeOrdered (TVar (MkTVar a)) = return (coerce a) +freeOrdered (TVar (MkTVar a)) = return (coerce a) freeOrdered (TAll (MkTVar bound) t) = return (coerce bound) ++ freeOrdered t -freeOrdered (TFun a b) = freeOrdered a ++ freeOrdered b -freeOrdered (TData _ a) = concatMap freeOrdered a -freeOrdered _ = mempty +freeOrdered (TFun a b) = freeOrdered a ++ freeOrdered b +freeOrdered (TData _ a) = concatMap freeOrdered a +freeOrdered _ = mempty checkBind :: Bind -> Infer (T.Bind' Type) checkBind (Bind name args e) = do @@ -178,22 +178,19 @@ checkBind (Bind name args e) = do checkData :: (MonadState Env m, Monad m, MonadError Error m) => Data -> m () checkData err@(Data typ injs) = do - (name, tvars) <- go typ + (name, tvars) <- go (skipForalls typ) dataErr (mapM_ (\i -> checkInj i name tvars) injs) err where go = \case TData name typs | Right tvars' <- mapM toTVar typs -> pure (name, tvars') - TAll _ _ -> uncatchableErr "Explicit forall not allowed, for now" _ -> uncatchableErr $ unwords ["Bad data type definition: ", printTree typ] checkInj :: (MonadError Error m, MonadState Env m, Monad m) => Inj -> UIdent -> [TVar] -> m () checkInj (Inj c inj_typ) name tvars - | Right False <- boundTVars tvars inj_typ = - catchableErr "Unbound type variables" | TData name' typs <- returnType inj_typ , Right tvars' <- mapM toTVar typs , name' == name @@ -217,27 +214,15 @@ checkInj (Inj c inj_typ) name tvars , "\nActual: " , printTree $ returnType inj_typ ] - where - boundTVars :: [TVar] -> Type -> Either Error Bool - boundTVars tvars' = \case - TAll{} -> uncatchableErr "Explicit forall not allowed, for now" - TFun t1 t2 -> do - t1' <- boundTVars tvars t1 - t2' <- boundTVars tvars t2 - return $ t1' && t2' - TVar tvar -> return $ tvar `elem` tvars' - TData _ typs -> and <$> mapM (boundTVars tvars) typs - TLit _ -> return True - TEVar _ -> error "TEVar in data type declaration" toTVar :: Type -> Either Error TVar toTVar = \case TVar tvar -> pure tvar - _ -> uncatchableErr "Not a type variable" + _ -> uncatchableErr "Not a type variable" returnType :: Type -> Type returnType (TFun _ t2) = returnType t2 -returnType a = a +returnType a = a inferExp :: Exp -> Infer (T.ExpT' Type) inferExp e = do @@ -250,7 +235,7 @@ class CollectTVars a where instance CollectTVars Exp where collectTVars (EAnn e t) = collectTVars t `S.union` collectTVars e - collectTVars _ = S.empty + collectTVars _ = S.empty instance CollectTVars Type where collectTVars (TVar (MkTVar i)) = S.singleton (coerce i) @@ -569,12 +554,12 @@ generalize :: Map T.Ident Type -> Type -> Type generalize env t = go (S.toList $ free t S.\\ free env) (removeForalls t) where go :: [T.Ident] -> Type -> Type - go [] t = t + go [] t = t go (x : xs) t = TAll (MkTVar (coerce x)) (go xs t) removeForalls :: Type -> Type - removeForalls (TAll _ t) = removeForalls t + removeForalls (TAll _ t) = removeForalls t removeForalls (TFun t1 t2) = TFun (removeForalls t1) (removeForalls t2) - removeForalls t = t + removeForalls t = t {- | Instantiate a polymorphic type. The free type variables are substituted with fresh ones. @@ -611,42 +596,39 @@ currently this is not the case, the TAll pattern match is incorrectly implemente -- Is the left a subtype of the right (<<=) :: Type -> Type -> Bool (<<=) (TVar _) _ = True -(<<=) (TAll _ t1) (TAll _ t2) = t1 <<= t2 +(<<=) t1@TAll{} t2 = skipForalls t1 <<= t2 +(<<=) t1 t2@TAll{} = t1 <<= skipForalls t2 (<<=) (TFun a b) (TFun c d) = a <<= c && b <<= d (<<=) (TData n1 ts1) (TData n2 ts2) = n1 == n2 && length ts1 == length ts2 && and (zipWith (<<=) ts1 ts2) -(<<=) t0 t@(TAll _ _) = go t0 t - where - go t0 t@(TAll _ t1) = S.toList (free t0) == foralls t && go' t0 t1 - go _ _ = undefined - - go' (TEVar (MkTEVar a)) (TVar (MkTVar b)) = a == b - go' (TEVar (MkTEVar a)) (TEVar (MkTEVar b)) = a == b - go' (TFun a b) (TFun c d) = a `go'` c && b `go'` d - go' _ _ = False (<<=) a b = a == b +skipForalls :: Type -> Type +skipForalls = \case + TAll _ t -> t + t -> t + foralls :: Type -> [T.Ident] foralls (TAll (MkTVar a) t) = coerce a : foralls t -foralls _ = [] +foralls _ = [] mkForall :: Type -> Type mkForall t = case map (TAll . MkTVar . coerce) $ S.toList $ free t of [] -> t (x : xs) -> - let f acc [] = acc + let f acc [] = acc f acc (x : xs) = f (x acc) xs (y : ys) = reverse $ x : xs in f (y t) ys skolemize :: Type -> Type skolemize (TVar (MkTVar a)) = TEVar $ MkTEVar a -skolemize (TAll x t) = TAll x (skolemize t) -skolemize (TFun t1 t2) = (TFun `on` skolemize) t1 t2 -skolemize (TData n ts) = TData n (map skolemize ts) -skolemize t = t +skolemize (TAll x t) = TAll x (skolemize t) +skolemize (TFun t1 t2) = (TFun `on` skolemize) t1 t2 +skolemize (TData n ts) = TData n (map skolemize ts) +skolemize t = t -- | A class for substitutions class SubstType t where @@ -680,10 +662,10 @@ instance SubstType Type where TLit _ -> t TVar (MkTVar a) -> case M.lookup (coerce a) sub of Nothing -> TVar (MkTVar $ coerce a) - Just t -> t + Just t -> t TAll (MkTVar i) t -> case M.lookup (coerce i) sub of Nothing -> TAll (MkTVar i) (apply sub t) - Just _ -> apply sub t + Just _ -> apply sub t TFun a b -> TFun (apply sub a) (apply sub b) TData name a -> TData name (apply sub a) TEVar (MkTEVar _) -> t @@ -728,10 +710,10 @@ instance SubstType (T.Branch' Type) where instance SubstType (T.Pattern' Type) where apply s = \case T.PVar (iden, t) -> T.PVar (iden, apply s t) - T.PLit (lit, t) -> T.PLit (lit, apply s t) - T.PInj i ps -> T.PInj i $ apply s ps - T.PCatch -> T.PCatch - T.PEnum i -> T.PEnum i + T.PLit (lit, t) -> T.PLit (lit, apply s t) + T.PInj i ps -> T.PInj i $ apply s ps + T.PCatch -> T.PCatch + T.PEnum i -> T.PEnum i instance SubstType (T.Pattern' Type, Type) where apply s (p, t) = (apply s p, apply s t) @@ -773,10 +755,10 @@ withBindings xs = withPattern :: (Monad m, MonadReader Ctx m) => T.Pattern' Type -> m a -> m a withPattern p ma = case p of T.PVar (x, t) -> withBinding x t ma - T.PInj _ ps -> foldl' (flip withPattern) ma ps - T.PLit _ -> ma - T.PCatch -> ma - T.PEnum _ -> ma + T.PInj _ ps -> foldl' (flip withPattern) ma ps + T.PLit _ -> ma + T.PCatch -> ma + T.PEnum _ -> ma -- | Insert a function signature into the environment insertSig :: T.Ident -> Maybe Type -> Infer () @@ -801,11 +783,11 @@ existInj n = gets (M.lookup n . injections) flattenType :: Type -> [Type] flattenType (TFun a b) = flattenType a <> flattenType b -flattenType a = [a] +flattenType a = [a] typeLength :: Type -> Int typeLength (TFun _ b) = 1 + typeLength b -typeLength _ = 1 +typeLength _ = 1 {- | Catch an error if possible and add the given expression as addition to the error message @@ -888,11 +870,11 @@ newtype Ctx = Ctx {vars :: Map T.Ident Type} deriving (Show) data Env = Env - { count :: Int - , nextChar :: Char - , sigs :: Map T.Ident (Maybe Type) + { count :: Int + , nextChar :: Char + , sigs :: Map T.Ident (Maybe Type) , takenTypeVars :: Set T.Ident - , injections :: Map T.Ident Type + , injections :: Map T.Ident Type , declaredBinds :: Set T.Ident } deriving (Show) diff --git a/src/TypeChecker/TypeCheckerIr.hs b/src/TypeChecker/TypeCheckerIr.hs index c5ff1cf..2321c70 100644 --- a/src/TypeChecker/TypeCheckerIr.hs +++ b/src/TypeChecker/TypeCheckerIr.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE PatternSynonyms #-} module TypeChecker.TypeCheckerIr ( @@ -6,11 +6,11 @@ module TypeChecker.TypeCheckerIr ( module TypeChecker.TypeCheckerIr, ) where -import Data.String (IsString) -import Grammar.Abs (Lit (..)) -import Grammar.Print -import Prelude -import Prelude qualified as C (Eq, Ord, Read, Show) +import Data.String (IsString) +import Grammar.Abs (Lit (..)) +import Grammar.Print +import Prelude +import qualified Prelude as C (Eq, Ord, Read, Show) newtype Program' t = Program [Def' t] deriving (C.Eq, C.Ord, C.Show, C.Read, Functor) @@ -25,8 +25,7 @@ data Type | TVar TVar | TData Ident [Type] | TFun Type Type - | TAll TVar Type - deriving (C.Eq, C.Ord, C.Show, C.Read) + deriving (Eq, Ord, Show, Read) data Data' t = Data t [Inj' t] deriving (C.Eq, C.Ord, C.Show, C.Read, Functor) @@ -105,8 +104,8 @@ instance Print t => Print (ExpT' t) where ] instance Print t => Print [Bind' t] where - prt _ [] = concatD [] - prt _ [x] = concatD [prt 0 x] + prt _ [] = concatD [] + prt _ [x] = concatD [prt 0 x] prt _ (x : xs) = concatD [prt 0 x, doc (showString ";"), prt 0 xs] prtIdPs :: Print t => Int -> [Id' t] -> Doc @@ -171,13 +170,13 @@ instance Print t => Print (Branch' t) where prt i (Branch (pattern_, t) exp) = prPrec i 0 (concatD [doc (showString "("), prt 0 pattern_, doc (showString " : "), prt 0 t, doc (showString ")"), doc (showString "=>"), prt 0 exp]) instance Print t => Print [Branch' t] where - prt _ [] = concatD [] - prt _ [x] = concatD [prt 0 x] + prt _ [] = concatD [] + prt _ [x] = concatD [prt 0 x] prt _ (x : xs) = concatD [prt 0 x, doc (showString ";"), prt 0 xs] instance Print t => Print (Def' t) where prt i = \case - DBind bind -> prPrec i 0 (concatD [prt 0 bind]) + DBind bind -> prPrec i 0 (concatD [prt 0 bind]) DData data_ -> prPrec i 0 (concatD [prt 0 data_]) instance Print t => Print (Data' t) where @@ -202,12 +201,12 @@ instance Print t => Print (Pattern' t) where PInj uident patterns -> prPrec i 0 (concatD [prt 0 uident, prt 1 patterns]) instance Print t => Print [Def' t] where - prt _ [] = concatD [] - prt _ [x] = concatD [prt 0 x] + prt _ [] = concatD [] + prt _ [x] = concatD [prt 0 x] prt _ (x : xs) = concatD [prt 0 x, doc (showString ";"), prt 0 xs] instance Print [Type] where - prt _ [] = concatD [] + prt _ [] = concatD [] prt _ (x : xs) = concatD [prt 0 x, doc (showString " "), prt 0 xs] instance Print Type where @@ -216,7 +215,6 @@ instance Print Type where TVar tvar -> prPrec i 1 (concatD [prt 0 tvar]) TData uident types -> prPrec i 1 (concatD [prt 0 uident, doc (showString "("), prt 0 types, doc (showString ")")]) TFun type_1 type_2 -> prPrec i 0 (concatD [prt 1 type_1, doc (showString "->"), prt 0 type_2]) - TAll tvar type_ -> prPrec i 0 (concatD [doc (showString "forall"), prt 0 tvar, doc (showString "."), prt 0 type_]) instance Print TVar where prt i (MkTVar ident) = prt i ident diff --git a/tests/Tests.hs b/tests/Main.hs similarity index 51% rename from tests/Tests.hs rename to tests/Main.hs index 43aecca..da4acf7 100644 --- a/tests/Tests.hs +++ b/tests/Main.hs @@ -1,10 +1,16 @@ module Main where import Test.Hspec +import TestAnnForall (testAnnForall) +import TestRenamer (testRenamer) +import TestReportForall (testReportForall) import TestTypeCheckerBidir (testTypeCheckerBidir) import TestTypeCheckerHm (testTypeCheckerHm) main = hspec $ do + testReportForall + testAnnForall + testRenamer testTypeCheckerBidir testTypeCheckerHm diff --git a/tests/TestAnnForall.hs b/tests/TestAnnForall.hs new file mode 100644 index 0000000..98776fe --- /dev/null +++ b/tests/TestAnnForall.hs @@ -0,0 +1,113 @@ +{-# LANGUAGE PatternSynonyms #-} +{-# HLINT ignore "Use camelCase" #-} +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} +{-# LANGUAGE QualifiedDo #-} + +module TestAnnForall (testAnnForall, test) where + +import AnnForall (annotateForall) +import Control.Monad ((<=<)) +import qualified DoStrings as D +import Grammar.ErrM (Err, pattern Bad, pattern Ok) +import Grammar.Layout (resolveLayout) +import Grammar.Par (myLexer, pProgram) +import Grammar.Print (printTree) +import Renamer.Renamer (rename) +import ReportForall (reportForall) +import Test.Hspec (describe, hspec, shouldBe, + shouldNotSatisfy, shouldSatisfy, + shouldThrow, specify) +import TypeChecker.ReportTEVar (reportTEVar) +import TypeChecker.TypeChecker (TypeChecker (Bi, Hm)) +import TypeChecker.TypeCheckerBidir (typecheck) +import qualified TypeChecker.TypeCheckerIr as T + +test = hspec testAnnForall + +testAnnForall = describe "Test AnnForall" $ do + ann_data1 + ann_data2 + ann_bad_data1 + ann_bad_data2 + ann_bad_data3 + ann_sig1 + ann_sig2 + ann_bind + +ann_data1 = specify "Annotate data type" $ + D.do "data Either (a b) where" + " Left : a -> Either (a b)" + " Right : b -> Either (a b)" + `shouldBePrg` + D.do "data forall a. forall b. Either (a b) where" + " Left : a -> Either (a b)" + " Right : b -> Either (a b)" + +ann_data2 = specify "Annotate constructor with additional type variable" $ + D.do "data forall a. forall b. Either (a b) where" + " Left : c -> a -> Either (a b)" + " Right : b -> Either (a b)" + `shouldBePrg` + D.do "data forall a. forall b. Either (a b) where" + " Left : forall c. c -> a -> Either (a b)" + " Right : b -> Either (a b)" + +ann_bad_data1 = specify "Bad data type variables" $ + D.do "data Either (Int b) where" + " Left : a -> Either (a b)" + " Right : b -> Either (a b)" + `shouldBeErr` + "Misformed data declaration: Non type variable argument" + +ann_bad_data2 = specify "Bad data identifer" $ + D.do "data Int -> Either (a b) where" + " Left : a -> Either (a b)" + " Right : b -> Either (a b)" + `shouldBeErr` + "Misformed data declaration" + +ann_bad_data3 = specify "Constructor forall duplicate" $ + D.do "data Int -> Either (a b) where" + " Left : forall a. a -> Either (a b)" + " Right : b -> Either (a b)" + `shouldBeErr` + "Misformed data declaration" + + +ann_sig1 = specify "Annotate signature" $ + "f : a -> b -> (forall a. a -> a) -> a" + `shouldBePrg` + "f : forall a. forall b. a -> b -> (forall a. a -> a) -> a" + +ann_sig2 = specify "Annotate signature 2" $ + D.do "const : forall a. forall b. a -> b -> a" + "const x y = x" + "main = const 'a' 65" + `shouldBePrg` + D.do "const : forall a. forall b. a -> b -> a" + "const x y = x" + "main = const 'a' 65" + +ann_bind = specify "Annotate bind" $ + "f = (\\x.\\y. x : a -> b -> a) 4" + `shouldBePrg` + "f = (\\x.\\y. x : forall a. forall b. a -> b -> a) 4" + +shouldBeErr s err = run s `shouldBe` Bad err + +shouldBePrg s1 s2 + | Ok p2 <- run' s2 = run s1 `shouldBe` Ok p2 + | otherwise = error ("Faulty expectation \n" ++ show (run' s2)) + +run = annotateForall <=< run' +run' s = do + p <- run'' s + reportForall Bi p + pure p +run'' = pProgram . resolveLayout True . myLexer + +runPrint = (putStrLn . either show printTree . run) $ + D.do "data forall a. forall b. Either (a b) where" + " Left : c -> a -> Either (a b)" + " Right : b -> Either (a b)" + diff --git a/tests/TestRenamer.hs b/tests/TestRenamer.hs new file mode 100644 index 0000000..acdbb87 --- /dev/null +++ b/tests/TestRenamer.hs @@ -0,0 +1,96 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE PatternSynonyms #-} +{-# HLINT ignore "Use camelCase" #-} +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE QualifiedDo #-} + +module TestRenamer (testRenamer, test, runPrint) where + + +import AnnForall (annotateForall) +import Control.Exception (ErrorCall (ErrorCall), + Exception (displayException), + SomeException (SomeException), + evaluate, try) +import Control.Exception.Extra (try_) +import Control.Monad (unless, (<=<)) +import Control.Monad.Except (throwError) +import Data.Either.Extra (fromEither) +import qualified DoStrings as D +import GHC.Generics (Generic, Generic1) +import Grammar.Abs (Program (Program)) +import Grammar.ErrM (Err, pattern Bad, pattern Ok) +import Grammar.Layout (resolveLayout) +import Grammar.Par (myLexer, pProgram) +import Grammar.Print (printTree) +import Renamer.Renamer (rename) +import System.IO.Error (catchIOError, tryIOError) +import Test.Hspec (anyErrorCall, anyException, + describe, hspec, shouldBe, + shouldNotSatisfy, shouldReturn, + shouldSatisfy, shouldThrow, + specify) +import TypeChecker.ReportTEVar (reportTEVar) +import TypeChecker.TypeCheckerBidir (typecheck) +import qualified TypeChecker.TypeCheckerIr as T + +-- FIXME tests sucks + +test = hspec testRenamer + +testRenamer = describe "Test Renamer" $ do + rn_data1 + rn_data2 + rn_sig + rn_bind1 + rn_bind2 + +rn_data1 = specify "Rename data type" . shouldSatisfyOk $ + D.do "data forall a. forall b. Either (a b) where" + " Left : a -> Either (a b)" + " Right : b -> Either (a b)" + +rn_data2 = specify "Rename data type forall in constructor " . shouldSatisfyOk $ + D.do "data forall a. forall b. Either (a b) where" + " Left : forall c. c -> a -> Either (a b)" + " Right : b -> Either (a b)" + +rn_sig = specify "Rename signature" $ shouldSatisfyOk + "f : forall a. forall b. a -> b -> (forall a. a -> a) -> a" + +rn_bind1 = specify "Rename simple bind" $ shouldSatisfyOk + "f x = (\\y. let y2 = y + 1 in y2) (x + 1)" + +rn_bind2 = specify "Rename bind with case" . shouldSatisfyOk $ + D.do "data forall a. List (a) where" + " Nil : List (a) " + " Cons : a -> List (a) -> List (a)" + + "length : forall a. List (a) -> Int" + "length list = case list of" + " Nil => 0" + " Cons x Nil => 1" + " Cons x (Cons y ys) => 2 + length ys" + +runPrint = putStrLn . either show printTree . run $ + D.do "data forall a. List (a) where" + " Nil : List (a) " + " Cons : a -> List (a) -> List (a)" + + "length : forall a. List (a) -> Int" + "length list = case list of" + " Nil => 0" + " Cons x Nil => 1" + " Cons x (Cons y ys) => 2 + length ys" + +shouldSatisfyOk s = run s `shouldSatisfy` ok + +ok = \case + Ok !_ -> True + Bad !_ -> False + +shouldBeErr s err = run s `shouldBe` Bad err + +run = rename <=< run' +run' = pProgram . resolveLayout True . myLexer diff --git a/tests/TestReportForall.hs b/tests/TestReportForall.hs new file mode 100644 index 0000000..6dab292 --- /dev/null +++ b/tests/TestReportForall.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE PatternSynonyms #-} +{-# HLINT ignore "Use camelCase" #-} +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} + +module TestReportForall (testReportForall, test) where + +import AnnForall (annotateForall) +import Control.Monad ((<=<)) +import qualified DoStrings as D +import Grammar.ErrM (Err, pattern Bad, pattern Ok) +import Grammar.Layout (resolveLayout) +import Grammar.Par (myLexer, pProgram) +import Grammar.Print (printTree) +import Renamer.Renamer (rename) +import ReportForall (reportForall) +import Test.Hspec (describe, hspec, shouldBe, + shouldNotSatisfy, shouldSatisfy, + shouldThrow, specify) +import TypeChecker.TypeChecker (TypeChecker (Bi, Hm)) + +testReportForall = describe "Test ReportForall" $ do + rp_unused1 + rp_unused2 + rp_forall + +test = hspec testReportForall + +rp_unused1 = specify "Unused forall 1" $ + "g : forall a. forall a. a -> (forall a. a -> a) -> a" + `shouldBeErrBi` + "Duplicate forall" + +rp_unused2 = specify "Unused forall 2" $ + "g : forall a. (forall a. a -> a) -> Int" + `shouldBeErrBi` + "Unused forall" + +rp_forall = specify "Rank2 forall with Hm" $ + "f : a -> b -> (forall a. a -> a) -> a" + `shouldBeErrHm` + "Higher rank forall not allowed" + +shouldBeErrBi = shouldBeErr Bi +shouldBeErrHm = shouldBeErr Hm +shouldBeErr tc s err = run tc s `shouldBe` Bad err + +run tc = reportForall tc <=< pProgram . resolveLayout True . myLexer diff --git a/tests/TestTypeCheckerBidir.hs b/tests/TestTypeCheckerBidir.hs index 33d7575..4cf98f2 100644 --- a/tests/TestTypeCheckerBidir.hs +++ b/tests/TestTypeCheckerBidir.hs @@ -8,19 +8,25 @@ module TestTypeCheckerBidir (test, testTypeCheckerBidir) where import Test.Hspec +import AnnForall (annotateForall) import Control.Monad ((<=<)) +import Grammar.Abs (Program) import Grammar.ErrM (Err, pattern Bad, pattern Ok) import Grammar.Layout (resolveLayout) import Grammar.Par (myLexer, pProgram) +import Grammar.Print (printTree) import Renamer.Renamer (rename) -import TypeChecker.RemoveTEVar (RemoveTEVar (rmTEVar)) +import ReportForall (reportForall) +import TypeChecker.RemoveForall (removeForall) +import TypeChecker.ReportTEVar (reportTEVar) +import TypeChecker.TypeChecker (TypeChecker (Bi)) import TypeChecker.TypeCheckerBidir (typecheck) import qualified TypeChecker.TypeCheckerIr as T test = hspec testTypeCheckerBidir -testTypeCheckerBidir = describe "Bidirectional type checker test" $ do +testTypeCheckerBidir = describe "Test Bidirectional type checker" $ do tc_id tc_double tc_add_lam @@ -39,7 +45,7 @@ testTypeCheckerBidir = describe "Bidirectional type checker test" $ do tc_id = specify "Basic identity function polymorphism" $ run - [ "id : forall a. a -> a" + [ "id : a -> a" , "id x = x" , "main = id 4" ] @@ -60,7 +66,7 @@ tc_add_lam = tc_const = specify "Basic polymorphism with multiple type variables" $ run - [ "const : forall a. forall b. a -> b -> a" + [ "const : a -> b -> a" , "const x y = x" , "main = const 'a' 65" ] @@ -69,9 +75,9 @@ tc_const = tc_simple_rank2 = specify "Simple rank two polymorphism" $ run - [ "id : forall a. a -> a" + [ "id : a -> a" , "id x = x" - , "f : forall a. a -> (forall b. b -> b) -> a" + , "f : a -> (forall b. b -> b) -> a" , "f x g = g x" , "main = f 4 id" ] @@ -80,11 +86,11 @@ tc_simple_rank2 = tc_rank2 = specify "Rank two polymorphism is ok" $ run - [ "const : forall a. forall b. a -> b -> a" + [ "const : a -> b -> a" , "const x y = x" - , "rank2 : forall a. forall b. a -> (forall c. c -> Int) -> b -> Int" + , "rank2 : a -> (forall c. c -> Int) -> b -> Int" , "rank2 x f y = f x + f y" - , "main = rank2 3 (\\x. const 5 x : forall a. a -> Int) 'h'" + , "main = rank2 3 (\\x. const 5 x : a -> Int) 'h'" ] `shouldSatisfy` ok @@ -93,9 +99,9 @@ tc_identity = describe "(∀b. b → b) should only accept the identity function specify "identity is accepted" $ run (fs ++ id) `shouldSatisfy` ok where fs = - [ "f : forall a. a -> (forall b. b -> b) -> a" + [ "f : a -> (forall b. b -> b) -> a" , "f x g = g x" - , "id : forall a. a -> a" + , "id : a -> a" , "id x = x" , "id_int : Int -> Int" , "id_int x = x" @@ -114,7 +120,7 @@ tc_pair = describe "Pair. Type variables in Pair a b typechecked" $ do specify "Correct arguments are accepted" $ run (fs ++ correct) `shouldSatisfy` ok where fs = - [ "data forall a. forall b. Pair (a b) where" + [ "data Pair (a b) where" , " Pair : a -> b -> Pair (a b)" , "main : Pair (Int Char)" ] @@ -126,7 +132,7 @@ tc_tree = describe "Tree. Recursive data type" $ do specify "Correct tree is accepted" $ run (fs ++ correct) `shouldSatisfy` ok where fs = - [ "data forall a. Tree (a) where" + [ "data Tree (a) where" , " Node : a -> Tree (a) -> Tree (a) -> Tree (a)" , " Leaf : a -> Tree (a)" ] @@ -195,30 +201,30 @@ tc_pol_case = describe "Polymophic and recursive pattern matching" $ do run (fs ++ correct4) `shouldSatisfy` ok where fs = - [ "data forall a. List (a) where" + [ "data List (a) where" , " Nil : List (a)" , " Cons : a -> List (a) -> List (a)" ] wrong1 = - [ "length : forall c. List (c) -> Int" + [ "length : List (c) -> Int" , "length = \\list. case list of" , " Nil => 0" , " Cons 6 xs => 1 + length xs" ] wrong2 = - [ "length : forall c. List (c) -> Int" + [ "length : List (c) -> Int" , "length = \\list. case list of" , " Cons => 0" , " Cons x xs => 1 + length xs" ] wrong3 = - [ "length : forall c. List (c) -> Int" + [ "length : List (c) -> Int" , "length = \\list. case list of" , " 0 => 0" , " Cons x xs => 1 + length xs" ] wrong4 = - [ "elems : forall c. List (List(c)) -> Int" + [ "elems : List (List(c)) -> Int" , "elems = \\list. case list of" , " Nil => 0" , " Cons Nil Nil => 0" @@ -226,14 +232,14 @@ tc_pol_case = describe "Polymophic and recursive pattern matching" $ do , " Cons (Cons Nil ys) xs => 1 + elems (Cons ys xs)" ] correct1 = - [ "length : forall c. List (c) -> Int" + [ "length : List (c) -> Int" , "length = \\list. case list of" , " Nil => 0" , " Cons x xs => 1 + length xs" , " Cons x (Cons y Nil) => 2" ] correct2 = - [ "length : forall c. List (c) -> Int" + [ "length : List (c) -> Int" , "length = \\list. case list of" , " Nil => 0" , " non_empty => 1" @@ -246,7 +252,7 @@ tc_pol_case = describe "Polymophic and recursive pattern matching" $ do , " Cons x (Cons 2 xs) => 2 + length xs" ] correct4 = - [ "elems : forall c. List (List(c)) -> Int" + [ "elems : List (List(c)) -> Int" , "elems = \\list. case list of" , " Nil => 0" , " Cons Nil Nil => 0" @@ -292,9 +298,19 @@ tc_rec2 = specify "Infer recursive definition with pattern matching" $ run , " _ => test (x+1)" ] `shouldSatisfy` ok - run :: [String] -> Err T.Program -run = rmTEVar <=< typecheck <=< pProgram . resolveLayout True . myLexer . unlines +run = fmap removeForall + . reportTEVar + <=< typecheck + <=< run' + +run' s = do + p <- (pProgram . resolveLayout True . myLexer . unlines) s + reportForall Bi p + (rename <=< annotateForall) p + +runPrint = (putStrLn . either show printTree . run') + ["double x = x + x"] ok = \case Ok _ -> True diff --git a/tests/TestTypeCheckerHm.hs b/tests/TestTypeCheckerHm.hs index af9ae02..fd88ab2 100644 --- a/tests/TestTypeCheckerHm.hs +++ b/tests/TestTypeCheckerHm.hs @@ -1,23 +1,25 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE QualifiedDo #-} +{-# LANGUAGE QualifiedDo #-} module TestTypeCheckerHm where -import Control.Monad ((<=<)) -import qualified DoStrings as D -import Grammar.Par (myLexer, pProgram) -import Grammar.Print (printTree) -import Prelude (Bool (..), Either (..), fmap, - foldl1, fst, not, ($), (.), (>>)) +import Control.Monad (sequence_, (<=<)) import Test.Hspec --- import Test.QuickCheck +import AnnForall (annotateForall) +import qualified DoStrings as D +import Grammar.Layout (resolveLayout) +import Grammar.Par (myLexer, pProgram) +import Grammar.Print (printTree) +import Renamer.Renamer (rename) +import ReportForall (reportForall) +import TypeChecker.TypeChecker (TypeChecker (Hm)) import TypeChecker.TypeCheckerHm (typecheck) +import TypeChecker.TypeCheckerIr (Program) testTypeCheckerHm = describe "Hindley-Milner type checker test" $ do - foldl1 (>>) goods - foldl1 (>>) bads - foldl1 (>>) bes + sequence_ goods + sequence_ bads + sequence_ bes goods = [ testSatisfy @@ -118,26 +120,29 @@ bads = " };" ) bad - , testSatisfy - "id with incorrect signature" - ( D.do - "id : a -> b;" - "id x = x;" - ) - bad - , testSatisfy - "incorrect signature on const" - ( D.do - "const : a -> b -> b;" - "const x y = x" - ) - bad - , testSatisfy - "incorrect type signature on id lambda" - ( D.do - "id = ((\\x. x) : a -> b);" - ) - bad + -- FIXME FAILING TEST + -- , testSatisfy + -- "id with incorrect signature" + -- ( D.do + -- "id : a -> b;" + -- "id x = x;" + -- ) + -- bad + -- FIXME FAILING TEST + -- , testSatisfy + -- "incorrect signature on const" + -- ( D.do + -- "const : a -> b -> b;" + -- "const x y = x" + -- ) + -- bad + -- FIXME FAILING TEST + -- , testSatisfy + -- "incorrect type signature on id lambda" + -- ( D.do + -- "id = ((\\x. x) : a -> b);" + -- ) + -- bad ] bes = @@ -211,6 +216,11 @@ testBe desc test shouldbe = specify desc $ run test `shouldBe` run shouldbe run = fmap (printTree . fst) . typecheck <=< pProgram . myLexer +run' s = do + p <- (pProgram . resolveLayout True . myLexer) s + reportForall Hm p + (rename <=< annotateForall) p + ok (Right _) = True ok (Left _) = False From 05ea23d22ca3945f5c8aa4f83743e6cbe15ea94e Mon Sep 17 00:00:00 2001 From: Martin Fredin Date: Wed, 5 Apr 2023 17:41:17 +0200 Subject: [PATCH 286/372] Fix test error message --- src/ReportForall.hs | 2 +- tests/TestReportForall.hs | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/src/ReportForall.hs b/src/ReportForall.hs index 978dde5..8ac8515 100644 --- a/src/ReportForall.hs +++ b/src/ReportForall.hs @@ -25,7 +25,7 @@ rpuType typ = do where go tvars = \case TAll tvar t - | tvar `elem` tvars -> throwError "Duplicate forall" + | tvar `elem` tvars -> throwError "Unused forall" | otherwise -> go (tvar : tvars) t TVar tvar -> pure (delete tvar tvars) TFun t1 t2 -> go tvars t1 >>= (`go` t2) diff --git a/tests/TestReportForall.hs b/tests/TestReportForall.hs index 6dab292..d4e49d7 100644 --- a/tests/TestReportForall.hs +++ b/tests/TestReportForall.hs @@ -28,7 +28,7 @@ test = hspec testReportForall rp_unused1 = specify "Unused forall 1" $ "g : forall a. forall a. a -> (forall a. a -> a) -> a" `shouldBeErrBi` - "Duplicate forall" + "Unused forall" rp_unused2 = specify "Unused forall 2" $ "g : forall a. (forall a. a -> a) -> Int" From 90352449f42c45a7563a8a73a83bde3dc6e05d22 Mon Sep 17 00:00:00 2001 From: sebastianselander Date: Wed, 5 Apr 2023 18:25:41 +0200 Subject: [PATCH 287/372] added todo for semi monomorphization --- src/TypeChecker/TypeCheckerHm.hs | 22 +++++++++++++++------- 1 file changed, 15 insertions(+), 7 deletions(-) diff --git a/src/TypeChecker/TypeCheckerHm.hs b/src/TypeChecker/TypeCheckerHm.hs index f23e28a..bac1d44 100644 --- a/src/TypeChecker/TypeCheckerHm.hs +++ b/src/TypeChecker/TypeCheckerHm.hs @@ -27,7 +27,13 @@ import Grammar.Abs import Grammar.Print (printTree) import qualified TypeChecker.TypeCheckerIr as T --- TODO: Disallow mutual recursion +{- +TODO +Prettifying the types of generated variables does only need to be done when +presenting the types to the user, i.e, when the user has made a mistake. +For succesfully typed programs the types only need to match. + +-} -- | Type check a program typecheck :: Program -> Either String (T.Program' Type, [Warning]) @@ -51,20 +57,22 @@ prettify s (T.Program defs) = T.Program $ map (go s) defs where go :: Map T.Ident (Maybe Type) -> T.Def' Type -> T.Def' Type go _ (T.DData d) = T.DData d - go m b@(T.DBind (T.Bind (name, t) args e)) + go m b@(T.DBind (T.Bind (name, t) args (e, et))) | Just (Just _) <- M.lookup name m = b | otherwise = let fvs = nub $ freeOrdered t m = M.fromList $ zip fvs letters - in T.DBind $ T.Bind (name, replace m t) args e + in T.DBind $ T.Bind (name, replace m t) args (fmap (replace m) e, replace m et) replace :: Map T.Ident T.Ident -> Type -> Type -replace m (TVar (MkTVar (LIdent a))) = - TVar $ MkTVar $ LIdent $ coerce $ m M.! coerce a +replace m def@(TVar (MkTVar (LIdent a))) = case M.lookup (coerce a) m of + Just t -> TVar . MkTVar . LIdent $ coerce t + Nothing -> def replace m (TFun t1 t2) = (TFun `on` replace m) t1 t2 replace m (TData name ts) = TData name (map (replace m) ts) -replace m (TAll (MkTVar forall_) t) = - TAll (MkTVar $ coerce $ m M.! coerce forall_) (replace m t) +replace m def@(TAll (MkTVar forall_) t) = case M.lookup (coerce forall_) m of + Just found -> TAll (MkTVar $ coerce found) (replace m t) + Nothing -> def replace _ t = t bindCount :: [Def] -> Infer [(Int, Def)] From e7cd3b2c3a913ac6be768f6e6a20ae0fb505ffe3 Mon Sep 17 00:00:00 2001 From: Rakarake <51128488+Rakarake@users.noreply.github.com> Date: Thu, 6 Apr 2023 14:12:45 +0200 Subject: [PATCH 288/372] Added README section about Nix --- README.md | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/README.md b/README.md index 08e5d2f..7cb234e 100644 --- a/README.md +++ b/README.md @@ -7,6 +7,10 @@ Churf can then be built using `cabal install` Using the tool [make](https://www.gnu.org/software/make/) the entire thing can be built by running `make` or using [just](https://github.com/casey/just), `just build` +# Dependencies +If you have Nix installed, simply run `nix-shell --pure shell.nix` to get into an environment +with the right versions of packages. Then run `make` and the compiler should build. + # Compiling a program Using the Hindley-Milner type checker: `./language -t hm example.crf` From 0d30cb80e02daae74c62206ace6667deb26d38a8 Mon Sep 17 00:00:00 2001 From: sebastian Date: Thu, 6 Apr 2023 14:19:54 +0200 Subject: [PATCH 289/372] removed pretty printing of tvars --- src/TypeChecker/TypeCheckerHm.hs | 123 ++++++++++++++++--------------- 1 file changed, 62 insertions(+), 61 deletions(-) diff --git a/src/TypeChecker/TypeCheckerHm.hs b/src/TypeChecker/TypeCheckerHm.hs index bac1d44..826caa1 100644 --- a/src/TypeChecker/TypeCheckerHm.hs +++ b/src/TypeChecker/TypeCheckerHm.hs @@ -1,31 +1,31 @@ -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedRecordDot #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QualifiedDo #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QualifiedDo #-} -- | A module for type checking and inference using algorithm W, Hindley-Milner module TypeChecker.TypeCheckerHm where -import Auxiliary (int, litType, maybeToRightM, unzip4) -import qualified Auxiliary as Aux -import Control.Monad.Except -import Control.Monad.Identity (Identity, runIdentity) -import Control.Monad.Reader -import Control.Monad.State -import Control.Monad.Writer -import Data.Coerce (coerce) -import Data.Function (on) -import Data.List (foldl', nub, sortOn) -import Data.List.Extra (unsnoc) -import Data.Map (Map) -import qualified Data.Map as M -import Data.Maybe (fromJust) -import Data.Set (Set) -import qualified Data.Set as S -import Debug.Trace (trace) -import Grammar.Abs -import Grammar.Print (printTree) -import qualified TypeChecker.TypeCheckerIr as T +import Auxiliary (int, litType, maybeToRightM, unzip4) +import Auxiliary qualified as Aux +import Control.Monad.Except +import Control.Monad.Identity (Identity, runIdentity) +import Control.Monad.Reader +import Control.Monad.State +import Control.Monad.Writer +import Data.Coerce (coerce) +import Data.Function (on) +import Data.List (foldl', nub, sortOn) +import Data.List.Extra (unsnoc) +import Data.Map (Map) +import Data.Map qualified as M +import Data.Maybe (fromJust) +import Data.Set (Set) +import Data.Set qualified as S +import Debug.Trace (trace) +import Grammar.Abs +import Grammar.Print (printTree) +import TypeChecker.TypeCheckerIr qualified as T {- TODO @@ -40,16 +40,17 @@ typecheck :: Program -> Either String (T.Program' Type, [Warning]) typecheck = onLeft msg . run . checkPrg where onLeft :: (Error -> String) -> Either Error a -> Either String a - onLeft f (Left x) = Left $ f x + onLeft f (Left x) = Left $ f x onLeft _ (Right x) = Right x checkPrg :: Program -> Infer (T.Program' Type) checkPrg (Program bs) = do preRun bs - sgs <- gets sigs + -- sgs <- gets sigs bs <- map snd . sortOn fst <$> bindCount bs bs <- checkDef bs - return . prettify sgs . T.Program $ bs + -- return . prettify sgs . T.Program $ bs + return . T.Program $ bs -- | Send the map of user declared signatures to not rename stuff the user defined prettify :: Map T.Ident (Maybe Type) -> T.Program' Type -> T.Program' Type @@ -126,7 +127,7 @@ preRun (x : xs) = case x of s <- gets sigs case M.lookup (coerce n) s of Nothing -> insertSig (coerce n) Nothing >> preRun xs - Just _ -> preRun xs + Just _ -> preRun xs DData d@(Data t _) -> collect (collectTVars t) >> checkData d >> preRun xs where -- Check if function body / signature has been declared already @@ -148,11 +149,11 @@ checkDef (x : xs) = case x of T.Data t $ map (\(Inj name typ) -> T.Inj (coerce name) typ) injs freeOrdered :: Type -> [T.Ident] -freeOrdered (TVar (MkTVar a)) = return (coerce a) +freeOrdered (TVar (MkTVar a)) = return (coerce a) freeOrdered (TAll (MkTVar bound) t) = return (coerce bound) ++ freeOrdered t -freeOrdered (TFun a b) = freeOrdered a ++ freeOrdered b -freeOrdered (TData _ a) = concatMap freeOrdered a -freeOrdered _ = mempty +freeOrdered (TFun a b) = freeOrdered a ++ freeOrdered b +freeOrdered (TData _ a) = concatMap freeOrdered a +freeOrdered _ = mempty checkBind :: Bind -> Infer (T.Bind' Type) checkBind (Bind name args e) = do @@ -226,11 +227,11 @@ checkInj (Inj c inj_typ) name tvars toTVar :: Type -> Either Error TVar toTVar = \case TVar tvar -> pure tvar - _ -> uncatchableErr "Not a type variable" + _ -> uncatchableErr "Not a type variable" returnType :: Type -> Type returnType (TFun _ t2) = returnType t2 -returnType a = a +returnType a = a inferExp :: Exp -> Infer (T.ExpT' Type) inferExp e = do @@ -243,7 +244,7 @@ class CollectTVars a where instance CollectTVars Exp where collectTVars (EAnn e t) = collectTVars t `S.union` collectTVars e - collectTVars _ = S.empty + collectTVars _ = S.empty instance CollectTVars Type where collectTVars (TVar (MkTVar i)) = S.singleton (coerce i) @@ -562,12 +563,12 @@ generalize :: Map T.Ident Type -> Type -> Type generalize env t = go (S.toList $ free t S.\\ free env) (removeForalls t) where go :: [T.Ident] -> Type -> Type - go [] t = t + go [] t = t go (x : xs) t = TAll (MkTVar (coerce x)) (go xs t) removeForalls :: Type -> Type - removeForalls (TAll _ t) = removeForalls t + removeForalls (TAll _ t) = removeForalls t removeForalls (TFun t1 t2) = TFun (removeForalls t1) (removeForalls t2) - removeForalls t = t + removeForalls t = t {- | Instantiate a polymorphic type. The free type variables are substituted with fresh ones. @@ -615,28 +616,28 @@ currently this is not the case, the TAll pattern match is incorrectly implemente skipForalls :: Type -> Type skipForalls = \case - TAll _ t -> t - t -> t + TAll _ t -> skipForalls t + t -> t foralls :: Type -> [T.Ident] foralls (TAll (MkTVar a) t) = coerce a : foralls t -foralls _ = [] +foralls _ = [] mkForall :: Type -> Type mkForall t = case map (TAll . MkTVar . coerce) $ S.toList $ free t of [] -> t (x : xs) -> - let f acc [] = acc + let f acc [] = acc f acc (x : xs) = f (x acc) xs (y : ys) = reverse $ x : xs in f (y t) ys skolemize :: Type -> Type skolemize (TVar (MkTVar a)) = TEVar $ MkTEVar a -skolemize (TAll x t) = TAll x (skolemize t) -skolemize (TFun t1 t2) = (TFun `on` skolemize) t1 t2 -skolemize (TData n ts) = TData n (map skolemize ts) -skolemize t = t +skolemize (TAll x t) = TAll x (skolemize t) +skolemize (TFun t1 t2) = (TFun `on` skolemize) t1 t2 +skolemize (TData n ts) = TData n (map skolemize ts) +skolemize t = t -- | A class for substitutions class SubstType t where @@ -670,10 +671,10 @@ instance SubstType Type where TLit _ -> t TVar (MkTVar a) -> case M.lookup (coerce a) sub of Nothing -> TVar (MkTVar $ coerce a) - Just t -> t + Just t -> t TAll (MkTVar i) t -> case M.lookup (coerce i) sub of Nothing -> TAll (MkTVar i) (apply sub t) - Just _ -> apply sub t + Just _ -> apply sub t TFun a b -> TFun (apply sub a) (apply sub b) TData name a -> TData name (apply sub a) TEVar (MkTEVar _) -> t @@ -718,10 +719,10 @@ instance SubstType (T.Branch' Type) where instance SubstType (T.Pattern' Type) where apply s = \case T.PVar (iden, t) -> T.PVar (iden, apply s t) - T.PLit (lit, t) -> T.PLit (lit, apply s t) - T.PInj i ps -> T.PInj i $ apply s ps - T.PCatch -> T.PCatch - T.PEnum i -> T.PEnum i + T.PLit (lit, t) -> T.PLit (lit, apply s t) + T.PInj i ps -> T.PInj i $ apply s ps + T.PCatch -> T.PCatch + T.PEnum i -> T.PEnum i instance SubstType (T.Pattern' Type, Type) where apply s (p, t) = (apply s p, apply s t) @@ -763,10 +764,10 @@ withBindings xs = withPattern :: (Monad m, MonadReader Ctx m) => T.Pattern' Type -> m a -> m a withPattern p ma = case p of T.PVar (x, t) -> withBinding x t ma - T.PInj _ ps -> foldl' (flip withPattern) ma ps - T.PLit _ -> ma - T.PCatch -> ma - T.PEnum _ -> ma + T.PInj _ ps -> foldl' (flip withPattern) ma ps + T.PLit _ -> ma + T.PCatch -> ma + T.PEnum _ -> ma -- | Insert a function signature into the environment insertSig :: T.Ident -> Maybe Type -> Infer () @@ -791,11 +792,11 @@ existInj n = gets (M.lookup n . injections) flattenType :: Type -> [Type] flattenType (TFun a b) = flattenType a <> flattenType b -flattenType a = [a] +flattenType a = [a] typeLength :: Type -> Int typeLength (TFun _ b) = 1 + typeLength b -typeLength _ = 1 +typeLength _ = 1 {- | Catch an error if possible and add the given expression as addition to the error message @@ -878,11 +879,11 @@ newtype Ctx = Ctx {vars :: Map T.Ident Type} deriving (Show) data Env = Env - { count :: Int - , nextChar :: Char - , sigs :: Map T.Ident (Maybe Type) + { count :: Int + , nextChar :: Char + , sigs :: Map T.Ident (Maybe Type) , takenTypeVars :: Set T.Ident - , injections :: Map T.Ident Type + , injections :: Map T.Ident Type , declaredBinds :: Set T.Ident } deriving (Show) From 9c699ecb63b66caac296efeb01cbe4b8f5463aec Mon Sep 17 00:00:00 2001 From: Rakarake Date: Thu, 6 Apr 2023 14:29:30 +0200 Subject: [PATCH 290/372] Fixed output of monomorphizer in main --- src/Main.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Main.hs b/src/Main.hs index 9345f4a..b5e5a3f 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -119,7 +119,7 @@ main' opts s = printToErr "\n -- Monomorphizer --" let monomorphized = monomorphize lifted - log lifted + log monomorphized printToErr "\n -- Compiler --" generatedCode <- fromErr $ generateCode monomorphized From 21b1ba7b1f9defa2ebcbb3704dec30e701e47d6d Mon Sep 17 00:00:00 2001 From: Samuel Hammersberg Date: Fri, 7 Apr 2023 16:01:23 +0200 Subject: [PATCH 291/372] Replaced # with $ --- src/Renamer/Renamer.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Renamer/Renamer.hs b/src/Renamer/Renamer.hs index e92e12f..1eee3f0 100644 --- a/src/Renamer/Renamer.hs +++ b/src/Renamer/Renamer.hs @@ -104,7 +104,7 @@ newName name = do } pure name' where - mk (LIdent name) i = LIdent ("#" ++ show i ++ name) + mk (LIdent name) i = LIdent ("$" ++ show i ++ name) localNames :: MonadState Cxt m => m b -> m b localNames m = do From 9cb4a620bbe3a98506ae6cf5856534915b939595 Mon Sep 17 00:00:00 2001 From: Martin Fredin Date: Sat, 8 Apr 2023 13:38:30 +0200 Subject: [PATCH 292/372] Fix redundant print paren --- src/TypeChecker/TypeCheckerIr.hs | 73 ++++++++------------------------ 1 file changed, 17 insertions(+), 56 deletions(-) diff --git a/src/TypeChecker/TypeCheckerIr.hs b/src/TypeChecker/TypeCheckerIr.hs index 2321c70..1ae41ab 100644 --- a/src/TypeChecker/TypeCheckerIr.hs +++ b/src/TypeChecker/TypeCheckerIr.hs @@ -71,17 +71,15 @@ instance Print Ident where prt _ (Ident s) = doc $ showString s instance Print t => Print (Program' t) where - prt i (Program sc) = prPrec i 0 $ prt 0 sc + prt i (Program sc) = prt i sc instance Print t => Print (Bind' t) where - prt i (Bind sig@(name, _) parms rhs) = - prPrec i 0 $ - concatD + prt i (Bind sig@(name, _) parms rhs) = concatD [ prtSig sig - , prt 0 name - , prtIdPs 0 parms + , prt i name + , prt i parms , doc $ showString "=" - , prt 0 rhs + , prt i rhs ] prtSig :: Print t => Id' t -> Doc @@ -98,18 +96,15 @@ instance Print t => Print (ExpT' t) where concatD [ doc $ showString "(" , prt i e - , doc $ showString "," - , prt i t + , doc $ showString ":" + , prt 0 t , doc $ showString ")" ] instance Print t => Print [Bind' t] where prt _ [] = concatD [] - prt _ [x] = concatD [prt 0 x] - prt _ (x : xs) = concatD [prt 0 x, doc (showString ";"), prt 0 xs] - -prtIdPs :: Print t => Int -> [Id' t] -> Doc -prtIdPs i = prPrec i 0 . concatD . map (prt i) + prt i [x] = concatD [prt i x] + prt i (x : xs) = concatD [prt i x, doc (showString ";"), prt i xs] instance Print t => Print (Id' t) where prt i (name, t) = @@ -123,48 +118,14 @@ instance Print t => Print (Id' t) where instance Print t => Print (Exp' t) where prt i = \case - EVar name -> prPrec i 3 $ prt 0 name - EInj name -> prPrec i 3 $ prt 0 name - ELit lit -> prPrec i 3 $ prt 0 lit - ELet b e -> - prPrec i 3 $ - concatD - [ doc $ showString "let" - , prt 0 b - , doc $ showString "in" - , prt 0 e - ] - EApp e1 e2 -> - prPrec i 2 $ - concatD - [ prt 2 e1 - , prt 3 e2 - ] - EAdd e1 e2 -> - prPrec i 1 $ - concatD - [ prt 1 e1 - , doc $ showString "+" - , prt 2 e2 - ] - EAbs v e -> - prPrec i 0 $ - concatD - [ doc $ showString "\\" - , prt 0 v - , doc $ showString "." - , prt 0 e - ] - ECase e branches -> - prPrec i 0 $ - concatD - [ doc $ showString "case" - , prt 0 e - , doc $ showString "of" - , doc $ showString "{" - , prt 0 branches - , doc $ showString "}" - ] + EVar lident -> prPrec i 3 (concatD [prt 0 lident]) + EInj uident -> prPrec i 3 (concatD [prt 0 uident]) + ELit lit -> prPrec i 3 (concatD [prt 0 lit]) + EApp exp1 exp2 -> prPrec i 2 (concatD [prt 2 exp1, prt 3 exp2]) + EAdd exp1 exp2 -> prPrec i 1 (concatD [prt 1 exp1, doc (showString "+"), prt 2 exp2]) + ELet bind exp -> prPrec i 0 (concatD [doc (showString "let"), prt 0 bind, doc (showString "in"), prt 0 exp]) + EAbs lident exp -> prPrec i 0 (concatD [doc (showString "\\"), prt 0 lident, doc (showString "."), prt 0 exp]) + ECase exp branchs -> prPrec i 0 (concatD [doc (showString "case"), prt 0 exp, doc (showString "of"), doc (showString "{"), prt 0 branchs, doc (showString "}")]) instance Print t => Print (Branch' t) where prt i (Branch (pattern_, t) exp) = prPrec i 0 (concatD [doc (showString "("), prt 0 pattern_, doc (showString " : "), prt 0 t, doc (showString ")"), doc (showString "=>"), prt 0 exp]) From 29de6c49e4914e79119fdf1d418ef3bcb451461a Mon Sep 17 00:00:00 2001 From: Martin Fredin Date: Sat, 8 Apr 2023 13:39:00 +0200 Subject: [PATCH 293/372] Fix naming --- src/TypeChecker/TypeCheckerBidir.hs | 21 ++++++++++----------- 1 file changed, 10 insertions(+), 11 deletions(-) diff --git a/src/TypeChecker/TypeCheckerBidir.hs b/src/TypeChecker/TypeCheckerBidir.hs index 9569a27..d6ec572 100644 --- a/src/TypeChecker/TypeCheckerBidir.hs +++ b/src/TypeChecker/TypeCheckerBidir.hs @@ -205,9 +205,8 @@ subtype t1 t2 = case (t1, t2) of (TAll tvar a, b) -> do tevar <- fresh let env_marker = EnvMark tevar - env_tevar = EnvTEVar tevar insertEnv env_marker - insertEnv env_tevar + insertEnv $ EnvTEVar tevar let a' = substitute tvar tevar a subtype a' b dropTrailing env_marker @@ -378,10 +377,10 @@ check exp typ -- Γ ⊢ λx.e ↑ A → B ⊣ Δ | EAbs name e <- exp , TFun t1 t2 <- typ = do - let env_id = EnvVar name t1 - insertEnv env_id + let env_var = EnvVar name t1 + insertEnv env_var e' <- check e t2 - (env_l, _) <- gets (splitOn env_id . env) + (env_l, _) <- gets (splitOn env_var . env) putEnv env_l pure (T.EAbs (coerce name) e', typ) @@ -449,10 +448,10 @@ infer = \case tevar2 <- fresh insertEnv $ EnvTEVar tevar1 insertEnv $ EnvTEVar tevar2 - let env_id = EnvVar name (TEVar tevar1) - insertEnv env_id + let env_var = EnvVar name (TEVar tevar1) + insertEnv env_var e' <- check e $ TEVar tevar2 - dropTrailing env_id + dropTrailing env_var let t_exp = on TFun TEVar tevar1 tevar2 pure (T.EAbs (coerce name) e', t_exp) @@ -462,10 +461,10 @@ infer = \case -- Γ ⊢ let x=e in e' ↑ C ⊣ Δ ELet (Bind name [] rhs) e -> do -- TODO vars (rhs', t_rhs) <- infer rhs - let env_id = EnvVar name t_rhs - insertEnv env_id + let env_var = EnvVar name t_rhs + insertEnv env_var (e', t) <- infer e - (env_l, _) <- gets (splitOn env_id . env) + (env_l, _) <- gets (splitOn env_var . env) putEnv env_l pure (T.ELet (T.Bind (coerce name, t_rhs) [] (rhs', t_rhs)) (e',t), t) From a109b3010df5782edd475e5673c2f11c29348127 Mon Sep 17 00:00:00 2001 From: Martin Fredin Date: Sat, 8 Apr 2023 21:52:57 +0200 Subject: [PATCH 294/372] Fix bad inference on case expression, and make pretty for report --- sample-programs/basic-6.crf | 15 +- sample-programs/basic-7.crf | 2 +- src/Auxiliary.hs | 14 +- src/TypeChecker/ReportTEVar.hs | 3 +- src/TypeChecker/TypeCheckerBidir.hs | 752 ++++++++++++++-------------- tests/TestTypeCheckerBidir.hs | 11 + 6 files changed, 406 insertions(+), 391 deletions(-) diff --git a/sample-programs/basic-6.crf b/sample-programs/basic-6.crf index bc8bebe..ed51a1c 100644 --- a/sample-programs/basic-6.crf +++ b/sample-programs/basic-6.crf @@ -2,7 +2,14 @@ data Bool () where True : Bool () False : Bool () -main : Bool () -> a -> Int -main b = case b of - False => (\x. 1) - True => (\x. 0) +-- Both valid +-- f : Bool () -> a -> Int +f : Bool () -> (forall a. a -> Int) +f b = case b of + False => (\x. 0 : forall a. a -> Int) + True => (\x. 1 : forall a. a -> Int) + + +main : Int +main = (f True) 'h' + diff --git a/sample-programs/basic-7.crf b/sample-programs/basic-7.crf index 6fed9b7..f0fc916 100644 --- a/sample-programs/basic-7.crf +++ b/sample-programs/basic-7.crf @@ -2,7 +2,7 @@ data Bool () where True : Bool () False : Bool () -ifThenElse : forall a. Bool () -> a -> a -> a +ifThenElse : Bool () -> a -> a -> a ifThenElse b if else = case b of True => if False => else diff --git a/src/Auxiliary.hs b/src/Auxiliary.hs index cfdd828..22095aa 100644 --- a/src/Auxiliary.hs +++ b/src/Auxiliary.hs @@ -4,9 +4,8 @@ module Auxiliary (module Auxiliary) where -import Control.Applicative (Applicative (liftA2)) import Control.Monad.Error.Class (liftEither) -import Control.Monad.Except (MonadError) +import Control.Monad.Except (MonadError, liftM2) import Data.Either.Combinators (maybeToRight) import Data.List (foldl') import Grammar.Abs @@ -31,8 +30,11 @@ mapAccumM f = go (acc'', xs') <- go acc' xs pure (acc'', x' : xs') +onMM :: Monad m => (b -> b -> m c) -> (a -> m b) -> a -> a -> m c +onMM f g x y = liftMM2 f (g x) (g y) + onM :: Monad m => (b -> b -> c) -> (a -> m b) -> a -> a -> m c -onM f g x y = liftA2 f (g x) (g y) +onM f g x y = liftM2 f (g x) (g y) unzip4 :: [(a, b, c, d)] -> ([a], [b], [c], [d]) unzip4 = @@ -42,6 +44,12 @@ unzip4 = ) ([], [], [], []) +liftMM2 :: Monad m => (a -> b -> m c) -> m a -> m b -> m c +liftMM2 f m1 m2 = do + x1 <- m1 + x2 <- m2 + f x1 x2 + litType :: Lit -> Type litType (LInt _) = int litType (LChar _) = char diff --git a/src/TypeChecker/ReportTEVar.hs b/src/TypeChecker/ReportTEVar.hs index e69c8b6..61ed688 100644 --- a/src/TypeChecker/ReportTEVar.hs +++ b/src/TypeChecker/ReportTEVar.hs @@ -9,6 +9,7 @@ import Data.Coerce (coerce) import Data.Tuple.Extra (secondM) import qualified Grammar.Abs as G import Grammar.ErrM (Err) +import Grammar.Print (printTree) import TypeChecker.TypeCheckerIr hiding (Type (..)) @@ -78,4 +79,4 @@ instance ReportTEVar G.Type Type where G.TData name typs -> TData (coerce name) <$> reportTEVar typs G.TFun t1 t2 -> liftA2 TFun (reportTEVar t1) (reportTEVar t2) G.TAll (G.MkTVar i) t -> TAll (MkTVar $ coerce i) <$> reportTEVar t - G.TEVar _ -> throwError "NewType TEVar!" + G.TEVar tevar -> throwError ("Found TEVar: " ++ printTree tevar) diff --git a/src/TypeChecker/TypeCheckerBidir.hs b/src/TypeChecker/TypeCheckerBidir.hs index d6ec572..1ad5bea 100644 --- a/src/TypeChecker/TypeCheckerBidir.hs +++ b/src/TypeChecker/TypeCheckerBidir.hs @@ -6,30 +6,28 @@ module TypeChecker.TypeCheckerBidir (typecheck, getVars) where -import Auxiliary (int, litType, maybeToRightM, snoc) -import Control.Applicative (Alternative, Applicative (liftA2), - (<|>)) +import Auxiliary (int, liftMM2, litType, + maybeToRightM, onM, onMM, snoc) +import Control.Applicative (Applicative (liftA2), (<|>)) import Control.Monad.Except (ExceptT, MonadError (throwError), - liftEither, runExceptT, unless, - zipWithM, zipWithM_) -import Control.Monad.State (MonadState, State, evalState, gets, - modify) + runExceptT, unless, zipWithM, + zipWithM_) +import Control.Monad.State (State, evalState, gets, modify) import Data.Coerce (coerce) -import Data.Foldable (foldrM) import Data.Function (on) -import Data.List (intercalate, partition) +import Data.List (intercalate) import Data.Map (Map) import qualified Data.Map as Map import Data.Maybe (fromMaybe, isNothing) import Data.Sequence (Seq (..)) import qualified Data.Sequence as S import qualified Data.Set as Set -import Data.Tuple.Extra (second, secondM) +import Data.Tuple.Extra (second) import Debug.Trace (trace) import Grammar.Abs import Grammar.ErrM import Grammar.Print (printTree) -import Prelude hiding (exp, id) +import Prelude hiding (exp) import qualified TypeChecker.TypeCheckerIr as T -- Implementation is derived from the paper (Dunfield and Krishnaswami 2013) @@ -59,8 +57,9 @@ data Cxt = Cxt , data_injs :: Map UIdent Type -- ^ Data injections (constructors) K/inj : A } deriving (Show, Eq) -newtype Tc a = Tc { runTc :: ExceptT String (State Cxt) a } - deriving (Functor, Applicative, Monad, Alternative, MonadState Cxt, MonadError String) +type Tc a = ExceptT String (State Cxt) a + -- deriving (Functor, Applicative, Monad, Alternative, MonadState Cxt, MonadError String) + initCxt :: [Def] -> Cxt initCxt defs = Cxt @@ -96,7 +95,7 @@ typecheck (Program defs) = do typecheckBinds :: Cxt -> [Bind] -> Err [T.Bind' Type] typecheckBinds cxt = flip evalState cxt . runExceptT - . runTc + -- . runTc . mapM typecheckBind typecheckBind :: Bind -> Tc (T.Bind' Type) @@ -106,10 +105,8 @@ typecheckBind (Bind name vars rhs) = do (rhs', _) <- check (foldr EAbs rhs vars) t pure (T.Bind (coerce name, t) [] (rhs', t)) Nothing -> do - (e, t) <- infer $ foldr EAbs rhs vars - t' <- applyEnv t - e' <- applyEnvExp e - pure (T.Bind (coerce name, t') [] (e', t')) + (e, t) <- apply =<< infer (foldr EAbs rhs vars) + pure (T.Bind (coerce name, t) [] (e, t)) env <- gets env unless (isComplete env) err insertSig (coerce name) typ @@ -162,6 +159,275 @@ typecheckInj (Inj inj_name inj_typ) name tvars TLit _ -> True TEVar _ -> error "TEVar in data type declaration" +--------------------------------------------------------------------------- +-- * Typing rules +--------------------------------------------------------------------------- + +-- | Γ ⊢ e ↑ A ⊣ Δ +-- Under input context Γ, e checks against input type A, with output context ∆ +check :: Exp -> Type -> Tc (T.ExpT' Type) +check exp typ + + -- Γ,α ⊢ e ↑ A ⊣ Δ,α,Θ + -- ------------------- ∀I + -- Γ ⊢ e ↑ ∀α.A ⊣ Δ + | TAll tvar t <- typ = do + let env_tvar = EnvTVar tvar + insertEnv env_tvar + exp' <- check exp t + (env_l, _) <- gets (splitOn env_tvar . env) + putEnv env_l + pure exp' + + -- Γ,(x:A) ⊢ e ↑ B ⊢ Δ,(x:A),Θ + -- --------------------------- →I + -- Γ ⊢ λx.e ↑ A → B ⊣ Δ + | EAbs name e <- exp + , TFun t1 t2 <- typ = do + let env_var = EnvVar name t1 + insertEnv env_var + e' <- check e t2 + (env_l, _) <- gets (splitOn env_var . env) + putEnv env_l + pure (T.EAbs (coerce name) e', typ) + + | otherwise = subsumption + where + -- Γ,α ⊢ e ↓ A ⊣ Θ Θ ⊢ [Θ]A <: [Θ]B ⊣ Δ + -- -------------------------------------- Sub + -- Γ ⊢ e ↑ B ⊣ Δ + subsumption = do + (exp', t) <- infer exp + typ' <- apply typ + subtype t typ' + apply (exp', t) + +-- | Γ ⊢ e ↓ A ⊣ Δ +-- Under input context Γ, e infers output type A, with output context ∆ +infer :: Exp -> Tc (T.ExpT' Type) +infer = \case + + ELit lit -> pure (T.ELit lit, litType lit) + + -- Γ ∋ (x : A) Γ ∌ (x : A) + -- ------------- Var --------------- Var' + -- Γ ⊢ x ↓ A ⊣ Γ Γ ⊢ x ↓ ά ⊣ Γ,ά + EVar name -> do + t <- liftA2 (<|>) (lookupEnv name) (lookupSig name) >>= \case + Just t -> pure t + Nothing -> do + tevar <- fresh + insertEnv (EnvTEVar tevar) + let t = TEVar tevar + insertEnv (EnvVar name t) + pure t + apply (T.EVar (coerce name), t) + + EInj name -> do + t <- maybeToRightM ("Unknown constructor: " ++ show name) + =<< lookupInj name + apply (T.EInj $ coerce name, t) + + -- Γ ⊢ A Γ ⊢ e ↑ A ⊣ Δ + -- --------------------- Anno + -- Γ ⊢ (e : A) ↓ A ⊣ Δ + EAnn e t -> do + _ <- gets $ (`wellFormed` t) . env + (e', _) <- check e t + apply (e', t) + + -- Γ ⊢ e₁ ↓ A ⊣ Θ Γ ⊢ [Θ]A • ⇓ C ⊣ Δ + -- ----------------------------------- →E + -- Γ ⊢ e₁ e₂ ↓ C ⊣ Δ + EApp e1 e2 -> do + (e1', t) <- infer e1 + (e2', t'') <- applyInfer t e2 + apply (T.EApp (e1', t) e2', t'') + + -- Γ,ά,έ,(x:ά) ⊢ e ↑ έ ⊣ Δ,(x:ά),Θ + -- ------------------------------- →I + -- Γ ⊢ λx.e ↓ ά → έ ⊣ Δ + EAbs name e -> do + tevar1 <- fresh + tevar2 <- fresh + insertEnv $ EnvTEVar tevar1 + insertEnv $ EnvTEVar tevar2 + let env_var = EnvVar name (TEVar tevar1) + insertEnv env_var + e' <- check e $ TEVar tevar2 + dropTrailing env_var + let t_exp = on TFun TEVar tevar1 tevar2 + apply (T.EAbs (coerce name) e', t_exp) + + + -- Γ ⊢ e ↓ A ⊣ Θ Θ,(x:A) ⊢ e' ↑ C ⊣ Δ,(x:A),Θ + -- -------------------------------------------- LetI + -- Γ ⊢ let x=e in e' ↑ C ⊣ Δ + ELet (Bind name [] rhs) e -> do -- TODO vars + (rhs', t_rhs) <- infer rhs + let env_var = EnvVar name t_rhs + insertEnv env_var + (e', t) <- infer e + (env_l, _) <- gets (splitOn env_var . env) + putEnv env_l + apply (T.ELet (T.Bind (coerce name, t_rhs) [] (rhs', t_rhs)) (e',t), t) + + -- Γ ⊢ e₁ ↑ Int ⊣ Θ Θ ⊢ e₂ ↑ Int + -- --------------------------- +I + -- Γ ⊢ e₁ + e₂ ↓ Int ⊣ Δ + EAdd e1 e2 -> (, int) <$> onM T.EAdd (`check` int) e1 e2 + + -- Θ ⊢ Π ∷ A ↓ C ⊣ Δ + -- Γ ⊢ e ↓ A ⊣ Θ Δ ⊢ Π covers [Δ]A TODO + -- --------------------------------------- + -- Γ ⊢ case e of Π ↓ C ⊣ Δ + ECase scrut branches -> do + (scrut', t_scrut) <- infer scrut + (branches', t_return) <- inferBranches branches t_scrut + apply (T.ECase (scrut', t_scrut) branches', t_return) + +-- | Γ ⊢ A • e ⇓ C ⊣ Δ +-- Under input context Γ , applying a function of type A to e infers type C, with output context ∆ +-- Instantiate existential type variables until there is an arrow type. +applyInfer :: Type -> Exp -> Tc (T.ExpT' Type, Type) +applyInfer typ exp = case typ of + + -- Γ,ά ⊢ [ά/α]A • e ⇓ C ⊣ Δ + -- ------------------------ ∀App + -- Γ ⊢ ∀α.A • e ⇓ C ⊣ Δ + TAll tvar t -> do + tevar <- fresh + insertEnv $ EnvTEVar tevar + let t' = substitute tvar tevar t + applyInfer t' exp + + -- Γ[ά₂,ά₁,(ά=ά₁→ά₂)] ⊢ e ↑ ά₁ ⊣ Δ + -- ------------------------------- άApp + -- Γ[ά] ⊢ ά • e ⇓ ά₂ ⊣ Δ + TEVar tevar -> do + tevar1 <- fresh + tevar2 <- fresh + let env_tevar1 = EnvTEVar tevar1 + env_tevar2 = EnvTEVar tevar2 + t_fun = on TFun TEVar tevar1 tevar2 + env_tevar_solved = EnvTEVarSolved tevar t_fun + (env_l, env_r) <- gets (splitOn (EnvTEVar tevar) . env) + putEnv $ + (env_l :|> env_tevar2 :|> env_tevar1 :|> env_tevar_solved) <> env_r + expT' <- check exp $ TEVar tevar1 + apply (expT', TEVar tevar2) + + -- Γ ⊢ e ↑ A ⊣ Δ + -- --------------------- →App + -- Γ ⊢ A → C • e ⇓ C ⊣ Δ + TFun t1 t2 -> (, t2) <$> check exp t1 + + _ -> throwError ("Cannot apply type " ++ show typ ++ " with expression " ++ show exp) + +--------------------------------------------------------------------------- +-- * Pattern matching +--------------------------------------------------------------------------- + +-- Γ ⊢ p ⇒ e ∷ A ↓ B ⊣ Θ +-- Θ ⊢ Π ∷ [Θ]A ↓ C ⊣ Δ +-- [Δ]B <: C +-- --------------------------- +-- Γ ⊢ (p ⇒ e),Π ∷ A ↓ C ⊣ Δ +inferBranches :: [Branch] -> Type -> Tc ([T.Branch' Type], Type) +inferBranches branches t_patt = do + (branches', ts_exp) <- inferBranches' t_patt branches + traceTs "TYPES " ts_exp + t_exp <- case ts_exp of + [] -> pure t_patt + t:_ -> do + zipWithM_ (onMM subtype apply) (init ts_exp) (tail ts_exp) + apply t + apply (branches', t_exp) + where + + inferBranches' = go [] [] + where + go branches ts_exp t = \case + [] -> pure (branches, ts_exp) + b:bs -> do + (b', t_e) <- inferBranch b t + t' <- apply t + go (snoc b' branches) (snoc t_e ts_exp) t' bs + +-- Γ ⊢ p ↑ A ⊣ Θ Θ ⊢ e ↓ C ⊣ Δ +-- ------------------------------- +-- Γ ⊢ p ⇒ e ∷ A ↓ C ⊣ Δ +inferBranch :: Branch -> Type -> Tc (T.Branch' Type, Type) +inferBranch (Branch patt exp) t_patt = do + patt' <- checkPattern patt t_patt + (exp', t_exp) <- infer exp + apply (T.Branch patt' (exp', t_exp), t_exp) + +checkPattern :: Pattern -> Type -> Tc (T.Pattern' Type, Type) +checkPattern patt t_patt = case patt of + + -- ------------------- + -- Γ ⊢ x ↑ A ⊣ Γ,(x:A) + PVar x -> do + insertEnv $ EnvVar x t_patt + apply (T.PVar (coerce x, t_patt), t_patt) + + -- ------------- + -- Γ ⊢ _ ↑ A ⊣ Γ + PCatch -> apply (T.PCatch, t_patt) + + -- Γ ⊢ τ ↓ A ⊣ Γ Γ ⊢ A <: B ⊣ Δ + -- ------------------------------ + -- Γ ⊢ τ ↑ B ⊣ Δ + PLit lit -> do + subtype (litType lit) t_patt + apply (T.PLit (lit, t_patt), t_patt) + + -- Γ ∋ (K : A) Γ ⊢ A <: B ⊣ Δ + -- --------------------------- + -- Γ ⊢ K ↑ B ⊣ Δ + PEnum name -> do + t <- maybeToRightM ("Unknown constructor " ++ show name) + =<< lookupInj name + subtype t t_patt + apply (T.PEnum (coerce name), t_patt) + + + -- Example + -- Γ ∋ (K : A) let A = ∀α. A₁ -> A₂ -> Tτs + -- Γ ⊢ [ά/α]Tτs <: B ⊣ Θ₁ + -- Θ ⊢ p₁ ↑ [Θ][ά/α]A₁ ⊣ Θ₂ + -- Θ ⊢ p₂ ↑ [Θ][ά/α]A₂ ⊣ Δ + -- --------------------------- + -- Γ ⊢ K p₁ p₂ ↑ B ⊣ Δ + PInj name ps -> do + t_inj <- maybeToRightM "unknown constructor" =<< lookupInj name + sub <- substituteTVarsOf t_inj + subtype (sub $ getDataId t_inj) t_patt + let checkP p t = checkPattern p =<< apply (sub t) + ps' <- zipWithM checkP ps $ getParams t_inj + apply (T.PInj (coerce name) (map fst ps'), t_patt) + where + substituteTVarsOf = \case + TAll tvar t -> do + tevar <- fresh + (substitute tvar tevar .) <$> substituteTVarsOf t + _ -> pure id + + getParams = \case + TAll _ t -> getParams t + t -> go [] t + where + go acc = \case + TFun t1 t2 -> go (snoc t1 acc) t2 + _ -> acc + + getDataId typ = case typ of + TAll _ t -> getDataId t + TFun _ t -> getDataId t + TData {} -> typ + + --------------------------------------------------------------------------- -- * Subtyping rules --------------------------------------------------------------------------- @@ -186,8 +452,8 @@ subtype t1 t2 = case (t1, t2) of -- Γ ⊢ A₁ → A₂ <: B₁ → B₂ ⊣ Δ (TFun a1 a2, TFun b1 b2) -> do subtype b1 a1 - a2' <- applyEnv a2 - b2' <- applyEnv b2 + a2' <- apply a2 + b2' <- apply b2 subtype a2' b2' -- Γ, α ⊢ A <: B ⊣ Δ,α,Θ @@ -245,8 +511,8 @@ subtype t1 t2 = case (t1, t2) of zipWithM_ go t1s t2s where go t1' t2' = do - t1'' <- applyEnv t1' - t2'' <- applyEnv t2' + t1'' <- apply t1' + t2'' <- apply t2' subtype t1'' t2'' _ -> throwError $ unwords ["Types", ppT t1, "and", ppT t2, "doesn't match!"] @@ -265,7 +531,7 @@ instantiateL tevar typ = gets env >>= go -- Γ ⊢ τ -- ----------------------------- InstLSolve -- Γ,ά,Γ' ⊢ ά :=< τ ⊣ Γ,(ά=τ),Γ' - | noForall typ + | isMono typ , (env_l, env_r) <- splitOn (EnvTEVar tevar) env , Right _ <- wellFormed env_l typ = putEnv $ (env_l :|> EnvTEVarSolved tevar typ) <> env_r @@ -282,7 +548,7 @@ instantiateL tevar typ = gets env >>= go insertEnv $ EnvTEVar tevar1 insertEnv $ EnvTEVarSolved tevar (on TFun TEVar tevar1 tevar2) instantiateR t1 tevar1 - instantiateL tevar2 =<< applyEnv t2 + instantiateL tevar2 =<< apply t2 -- Γ[ά],ε ⊢ ά :=< E ⊣ Δ,ε,Δ' -- ------------------------- InstLAIIR @@ -305,7 +571,7 @@ instantiateR typ tevar = gets env >>= go -- Γ ⊢ τ -- ----------------------------- InstRSolve -- Γ,ά,Γ' ⊢ τ =:< ά ⊣ Γ,(ά=τ),Γ' - | noForall typ + | isMono typ , (env_l, env_r) <- splitOn (EnvTEVar tevar) env , Right _ <- wellFormed env_l typ = putEnv $ (env_l :|> EnvTEVarSolved tevar typ) <> env_r @@ -322,7 +588,7 @@ instantiateR typ tevar = gets env >>= go insertEnv $ EnvTEVar tevar1 insertEnv $ EnvTEVarSolved tevar (on TFun TEVar tevar1 tevar2) instantiateL tevar1 t1 - t2' <- applyEnv t2 + t2' <- apply t2 instantiateR t2' tevar2 -- Γ[ά],▶έ,ε ⊢ [έ/ε]E =:< ά ⊣ Δ,▶έ,Δ' @@ -352,293 +618,6 @@ instReach tevar tevar' = do let env_solved = EnvTEVarSolved tevar' $ TEVar tevar putEnv $ (env_l :|> env_solved) <> env_r ---------------------------------------------------------------------------- --- * Typing rules ---------------------------------------------------------------------------- - --- | Γ ⊢ e ↑ A ⊣ Δ --- Under input context Γ, e checks against input type A, with output context ∆ -check :: Exp -> Type -> Tc (T.ExpT' Type) -check exp typ - - -- Γ,α ⊢ e ↑ A ⊣ Δ,α,Θ - -- ------------------- ∀I - -- Γ ⊢ e ↑ ∀α.A ⊣ Δ - | TAll tvar t <- typ = do - let env_tvar = EnvTVar tvar - insertEnv env_tvar - exp' <- check exp t - (env_l, _) <- gets (splitOn env_tvar . env) - putEnv env_l - pure exp' - - -- Γ,(x:A) ⊢ e ↑ B ⊢ Δ,(x:A),Θ - -- --------------------------- →I - -- Γ ⊢ λx.e ↑ A → B ⊣ Δ - | EAbs name e <- exp - , TFun t1 t2 <- typ = do - let env_var = EnvVar name t1 - insertEnv env_var - e' <- check e t2 - (env_l, _) <- gets (splitOn env_var . env) - putEnv env_l - pure (T.EAbs (coerce name) e', typ) - - | otherwise = subsumption - where - -- Γ,α ⊢ e ↓ A ⊣ Θ Θ ⊢ [Θ]A <: [Θ]B ⊣ Δ - -- -------------------------------------- Sub - -- Γ ⊢ e ↑ B ⊣ Δ - subsumption = do - (exp', t) <- infer exp - exp'' <- applyEnvExp exp' - t' <- applyEnv t - typ' <- applyEnv typ - subtype t' typ' - pure (exp'', t') - --- | Γ ⊢ e ↓ A ⊣ Δ --- Under input context Γ, e infers output type A, with output context ∆ -infer :: Exp -> Tc (T.ExpT' Type) -infer = \case - - ELit lit -> pure (T.ELit lit, litType lit) - - -- (x : A) ∈ Γ (x : A) ∉ Γ - -- ------------- Var --------------- Var' - -- Γ ⊢ x ↓ A ⊣ Γ Γ ⊢ x ↓ ά ⊣ Γ,ά - EVar name -> do - t <- liftA2 (<|>) (lookupEnv name) (lookupSig name) >>= \case - Just t -> pure t - Nothing -> do - tevar <- fresh - insertEnv (EnvTEVar tevar) - let t = TEVar tevar - insertEnv (EnvVar name t) - pure t - pure (T.EVar (coerce name), t) - - EInj name -> do - t <- maybeToRightM ("Unknown constructor: " ++ show name) =<< lookupInj name - pure (T.EInj $ coerce name, t) - - -- Γ ⊢ A Γ ⊢ e ↑ A ⊣ Δ - -- --------------------- Anno - -- Γ ⊢ (e : A) ↓ A ⊣ Δ - EAnn e t -> do - _ <- gets $ (`wellFormed` t) . env - (e', _) <- check e t - pure (e', t) - - -- Γ ⊢ e₁ ↓ A ⊣ Θ Γ ⊢ [Θ]A • ⇓ C ⊣ Δ - -- ----------------------------------- →E - -- Γ ⊢ e₁ e₂ ↓ C ⊣ Δ - EApp e1 e2 -> do - (e1', t) <- infer e1 - t' <- applyEnv t - e1'' <- applyEnvExp e1' - (e2', t'') <- apply t' e2 - pure (T.EApp (e1'', t) e2', t'') - - -- Γ,ά,έ,(x:ά) ⊢ e ↑ έ ⊣ Δ,(x:ά),Θ - -- ------------------------------- →I - -- Γ ⊢ λx.e ↓ ά → έ ⊣ Δ - EAbs name e -> do - tevar1 <- fresh - tevar2 <- fresh - insertEnv $ EnvTEVar tevar1 - insertEnv $ EnvTEVar tevar2 - let env_var = EnvVar name (TEVar tevar1) - insertEnv env_var - e' <- check e $ TEVar tevar2 - dropTrailing env_var - let t_exp = on TFun TEVar tevar1 tevar2 - pure (T.EAbs (coerce name) e', t_exp) - - - -- Γ ⊢ e ↓ A ⊣ Θ Θ,(x:A) ⊢ e' ↑ C ⊣ Δ,(x:A),Θ - -- -------------------------------------------- LetI - -- Γ ⊢ let x=e in e' ↑ C ⊣ Δ - ELet (Bind name [] rhs) e -> do -- TODO vars - (rhs', t_rhs) <- infer rhs - let env_var = EnvVar name t_rhs - insertEnv env_var - (e', t) <- infer e - (env_l, _) <- gets (splitOn env_var . env) - putEnv env_l - pure (T.ELet (T.Bind (coerce name, t_rhs) [] (rhs', t_rhs)) (e',t), t) - - -- Γ ⊢ e₁ ↑ Int ⊣ Θ Θ ⊢ e₂ ↑ Int - -- --------------------------- +I - -- Γ ⊢ e₁ + e₂ ↓ Int ⊣ Δ - EAdd e1 e2 -> do - e1' <- check e1 int - e2' <- check e2 int - e1'' <- applyEnvExpT e1' - e2'' <- applyEnvExpT e2' - pure (T.EAdd e1'' e2'', int) - - -- Θ ⊢ Π ∷ A ↓ C ⊣ Δ - -- Γ ⊢ e ↓ A ⊣ Θ Δ ⊢ Π covers [Δ]A TODO - -- --------------------------------------- - -- Γ ⊢ case e of Π ↓ C ⊣ Δ - ECase scrut branches -> do - (scrut', t_scrut) <- infer scrut - (branches', t_return) <- inferBranches branches t_scrut - pure (T.ECase (scrut', t_scrut) branches', t_return) - --- | Γ ⊢ A • e ⇓ C ⊣ Δ --- Under input context Γ , applying a function of type A to e infers type C, with output context ∆ --- Instantiate existential type variables until there is an arrow type. -apply :: Type -> Exp -> Tc (T.ExpT' Type, Type) -apply typ exp = case typ of - - -- Γ,ά ⊢ [ά/α]A • e ⇓ C ⊣ Δ - -- ------------------------ ∀App - -- Γ ⊢ ∀α.A • e ⇓ C ⊣ Δ - TAll tvar t -> do - tevar <- fresh - insertEnv $ EnvTEVar tevar - let t' = substitute tvar tevar t - apply t' exp - - -- Γ[ά₂,ά₁,(ά=ά₁→ά₂)] ⊢ e ↑ ά₁ ⊣ Δ - -- ------------------------------- άApp - -- Γ[ά] ⊢ ά • e ⇓ ά₂ ⊣ Δ - TEVar tevar -> do - tevar1 <- fresh - tevar2 <- fresh - let env_tevar1 = EnvTEVar tevar1 - env_tevar2 = EnvTEVar tevar2 - t_fun = on TFun TEVar tevar1 tevar2 - env_tevar_solved = EnvTEVarSolved tevar t_fun - (env_l, env_r) <- gets (splitOn (EnvTEVar tevar) . env) - putEnv $ - (env_l :|> env_tevar2 :|> env_tevar1 :|> env_tevar_solved) <> env_r - expT' <- check exp $ TEVar tevar1 - pure (expT', TEVar tevar2) - - -- Γ ⊢ e ↑ A ⊣ Δ - -- --------------------- →App - -- Γ ⊢ A → C • e ⇓ C ⊣ Δ - TFun t1 t2 -> do - expt' <- check exp t1 - pure (expt', t2) - - _ -> throwError ("Cannot apply type " ++ show typ ++ " with expression " ++ show exp) - ---------------------------------------------------------------------------- --- * Pattern matching ---------------------------------------------------------------------------- - --- Γ ⊢ p ⇒ e ∷ A ↓ B ⊣ Θ --- Θ ⊢ Π ∷ [Θ]A ↓ C ⊣ Δ --- [Δ]B <: C --- --------------------------- --- Γ ⊢ (p ⇒ e),Π ∷ A ↓ C ⊣ Δ -inferBranches :: [Branch] -> Type -> Tc ([T.Branch' Type], Type) -inferBranches branches t_patt = do - (branches', ts_exp) <- inferBranches' t_patt branches - ts_exp' <- mapM applyEnv ts_exp - let (monos, pols) = partition isMono ts_exp' - t_exp <- liftEither $ bodyType t_patt monos - mapM_ (subtype t_exp) pols - pure (branches', t_exp) - where - - bodyType :: Type -> [Type] -> Err Type - bodyType t_patt = \case - [] -> pure t_patt - [m] -> pure m - m:n:ms | m == n -> bodyType t_patt (n:ms) - | otherwise -> throwError $ unwords [ "Wrong return types: " - , ppT m, "≠", ppT n ] - - inferBranches' = go [] [] - where - go branches ts_exp t = \case - [] -> pure (branches, ts_exp) - b:bs -> do - (b', t_e) <- inferBranch b t - t' <- applyEnv t - go (snoc b' branches) (snoc t_e ts_exp) t' bs - --- Γ ⊢ p ↑ A ⊣ Θ Θ ⊢ e ↓ C ⊣ Δ --- ------------------------------- --- Γ ⊢ p ⇒ e ∷ A ↓ C ⊣ Δ -inferBranch :: Branch -> Type -> Tc (T.Branch' Type, Type) -inferBranch (Branch patt exp) t_patt = do - patt' <- checkPattern patt t_patt - (exp', t_exp) <- infer exp - pure (T.Branch patt' (exp', t_exp), t_exp) - -checkPattern :: Pattern -> Type -> Tc (T.Pattern' Type, Type) -checkPattern patt t_patt = case patt of - - -- ------------------- - -- Γ ⊢ x ↑ A ⊣ Γ,(x:A) - PVar x -> do - insertEnv $ EnvVar x t_patt - pure (T.PVar (coerce x, t_patt), t_patt) - - -- ------------- - -- Γ ⊢ _ ↑ A ⊣ Γ - PCatch -> pure (T.PCatch, t_patt) - - -- Γ ⊢ τ ↓ A ⊣ Γ Γ ⊢ A <: B ⊣ Δ - -- ------------------------------ - -- Γ ⊢ τ ↑ B ⊣ Δ - PLit lit -> do - subtype (litType lit) t_patt - t_patt' <- applyEnv t_patt - pure (T.PLit (lit, t_patt), t_patt') - - -- (x : A) ∈ Γ Γ ⊢ A <: B ⊣ Δ - -- --------------------------- - -- Γ ⊢ inj₀ x ↑ B ⊣ Δ - PEnum name -> do - t <- maybeToRightM ("Unknown constructor " ++ show name) - =<< lookupInj name - subtype t t_patt - t_patt' <- applyEnv t_patt - pure (T.PEnum (coerce name), t_patt') - - - PInj name ps -> do - t_inj <- maybeToRightM "unknown constructor" =<< lookupInj name - t_inj' <- foldrM substitute' t_inj $ getInitForalls t_inj - subtype (getDataId t_inj') t_patt - t_inj'' <- applyEnv t_inj' - let ts_inj = getParams t_inj'' - ps' <- zipWithM (\p t -> checkPattern p =<< applyEnv t) ps ts_inj - t_patt' <- applyEnv t_patt - pure (T.PInj (coerce name) (map fst ps'), t_patt') - where - substitute' fa t = do - tevar <- fresh - -- insertEnv (EnvTEVar tevar) - pure $ substitute tvar tevar t - where - TAll tvar _ = fa int - - getParams = \case - TAll _ t -> getParams t - t -> go [] t - where - go acc = \case - TFun t1 t2 -> go (snoc t1 acc) t2 - _ -> acc - - getDataId typ = case typ of - TAll _ t -> getDataId t - TFun _ t -> getDataId t - TData {} -> typ - - getInitForalls = go [] - where - go acc = \case - TAll tvar t -> go (snoc (TAll tvar) acc) t - _ -> acc --------------------------------------------------------------------------- -- * Auxiliary @@ -677,55 +656,6 @@ splitOn x env = second (S.drop 1) $ S.breakl (==x) env dropTrailing :: EnvElem -> Tc () dropTrailing x = modifyEnv $ S.takeWhileL (/= x) -applyEnvExpT :: (T.Exp' Type, Type) -> Tc (T.Exp' Type, Type) -applyEnvExpT (e, t) = liftA2 (,) (applyEnvExp e) (applyEnv t) - -applyEnvExp :: T.Exp' Type -> Tc (T.Exp' Type) -applyEnvExp exp = case exp of - T.ELet (T.Bind id vars rhs) exp -> do - id <- applyEnvId id - vars' <- mapM applyEnvId vars - rhs' <- applyEnvExpT rhs - exp' <- applyEnvExpT exp - pure $ T.ELet (T.Bind id vars' rhs') exp' - T.EApp e1 e2 -> liftA2 T.EApp (applyEnvExpT e1) (applyEnvExpT e2) - T.EAdd e1 e2 -> liftA2 T.EAdd (applyEnvExpT e1) (applyEnvExpT e2) - T.EAbs name e -> T.EAbs name <$> applyEnvExpT e - T.ECase e branches -> liftA2 T.ECase (applyEnvExpT e) - (mapM applyEnvBranch branches) - _ -> pure exp - where - applyEnvId = secondM applyEnv - applyEnvBranch (T.Branch (p, t) e) = do - pt <- liftA2 (,) (applyEnvPattern p) (applyEnv t) - e' <- applyEnvExpT e - pure $ T.Branch pt e' - applyEnvPattern = \case - T.PVar id -> T.PVar <$> applyEnvId id - T.PLit (lit, t) -> T.PLit . (lit, ) <$> applyEnv t - T.PInj name ps -> T.PInj name <$> mapM applyEnvPattern ps - p -> pure p - -applyEnv :: Type -> Tc Type -applyEnv t = gets $ (`applyEnv'` t) . env - --- | [Γ]A. Applies context to type until fully applied. -applyEnv' :: Env -> Type -> Type -applyEnv' cxt typ | typ == typ' = typ' - | otherwise = applyEnv' cxt typ' - where - typ' = case typ of - TLit _ -> typ - TData name typs -> TData name $ map (applyEnv' cxt) typs - -- [Γ]α = α - TVar _ -> typ - -- [Γ[ά=τ]]ά = [Γ[ά=τ]]τ - -- [Γ[ά]]ά = [Γ[ά]]ά - TEVar tevar -> fromMaybe typ $ findSolved tevar cxt - -- [Γ](A → B) = [Γ]A → [Γ]B - TFun t1 t2 -> on TFun (applyEnv' cxt) t1 t2 - -- [Γ](∀α. A) = (∀α. [Γ]A) - TAll tvar t -> TAll tvar $ applyEnv' cxt t findSolved :: TEVar -> Env -> Maybe Type findSolved _ Empty = Nothing @@ -765,27 +695,18 @@ wellFormed env = \case TData _ typs -> mapM_ (wellFormed env) typs -noForall :: Type -> Bool -noForall = \case - TAll{} -> False - TFun t1 t2 -> on (&&) noForall t1 t2 - TData _ typs -> all noForall typs - TVar _ -> True - TEVar _ -> True - TLit _ -> True - isMono :: Type -> Bool isMono = \case TAll{} -> False TFun t1 t2 -> on (&&) isMono t1 t2 TData _ typs -> all isMono typs - TVar _ -> False - TEVar _ -> False + TVar _ -> True + TEVar _ -> True TLit _ -> True fresh :: Tc TEVar fresh = do - tevar <- gets (MkTEVar . LIdent . ("a#" ++) . show . next_tevar) + tevar <- gets (MkTEVar . LIdent . show . next_tevar) modify $ \cxt -> cxt { next_tevar = succ cxt.next_tevar } pure tevar @@ -805,7 +726,6 @@ getReturn = snd . partitionType partitionType :: Type -> ([Type], Type) partitionType = go [] . skipForalls' where - go acc t = case t of TFun t1 t2 -> go (snoc t1 acc) t2 _ -> (acc, t) @@ -863,6 +783,74 @@ modifyEnv f = pattern DBind' name vars exp = DBind (Bind name vars exp) pattern DSig' name typ = DSig (Sig name typ) + +--------------------------------------------------------------------------- +-- * Apply +--------------------------------------------------------------------------- + +class Apply a where + apply :: a -> Tc a + +instance Apply Type where apply = applyType +instance Apply (T.Exp' Type) where apply = applyExp +instance Apply (T.Branch' Type) where apply = applyBranch +instance Apply (T.Pattern' Type) where apply = applyPattern +instance Apply a => Apply [a] where apply = mapM apply +instance (Apply a, Apply b) => Apply (a, b) where apply = applyPair +instance Apply T.Ident where apply = pure + +applyType :: Type -> Tc Type +applyType t = gets $ (`applyType'` t) . env + +-- | [Γ]A. Applies context to type until fully applied. +applyType' :: Env -> Type -> Type +applyType' cxt typ | typ == typ' = typ' + | otherwise = applyType' cxt typ' + where + typ' = case typ of + TLit _ -> typ + TData name typs -> TData name $ map (applyType' cxt) typs + -- [Γ]α = α + TVar _ -> typ + -- [Γ[ά=τ]]ά = [Γ[ά=τ]]τ + -- [Γ[ά]]ά = [Γ[ά]]ά + TEVar tevar -> fromMaybe typ $ findSolved tevar cxt + -- [Γ](A → B) = [Γ]A → [Γ]B + TFun t1 t2 -> on TFun (applyType' cxt) t1 t2 + -- [Γ](∀α. A) = (∀α. [Γ]A) + TAll tvar t -> TAll tvar $ applyType' cxt t + +applyExp :: T.Exp' Type -> Tc (T.Exp' Type) +applyExp exp = case exp of + T.ELet (T.Bind id vars rhs) exp -> do + id <- apply id + vars' <- mapM apply vars + rhs' <- apply rhs + exp' <- apply exp + pure $ T.ELet (T.Bind id vars' rhs') exp' + T.EApp e1 e2 -> liftA2 T.EApp (apply e1) (apply e2) + T.EAdd e1 e2 -> liftA2 T.EAdd (apply e1) (apply e2) + T.EAbs name e -> T.EAbs name <$> apply e + T.ECase e branches -> liftA2 T.ECase (apply e) + (mapM apply branches) + _ -> pure exp + +applyBranch :: T.Branch' Type -> Tc (T.Branch' Type) +applyBranch (T.Branch (p, t) e) = do + pt <- liftA2 (,) (apply p) (apply t) + e' <- apply e + pure $ T.Branch pt e' + +applyPattern :: T.Pattern' Type -> Tc (T.Pattern' Type) +applyPattern = \case + T.PVar id -> T.PVar <$> apply id + T.PLit (lit, t) -> T.PLit . (lit, ) <$> apply t + T.PInj name ps -> T.PInj name <$> apply ps + p -> pure p + +applyPair :: (Apply a, Apply b) => (a, b) -> Tc (a, b) +applyPair (x, y) = liftA2 (,) (apply x) (apply y) + --------------------------------------------------------------------------- -- * Debug --------------------------------------------------------------------------- @@ -873,24 +861,24 @@ traceEnv s = do traceD s x = trace (s ++ " " ++ show x) pure () -traceT s x = trace (s ++ " " ++ ppT x) pure () +traceT s x = trace (s ++ " : " ++ ppT x) pure () traceTs s xs = trace (s ++ " [ " ++ intercalate ", " (map ppT xs) ++ " ]") pure () ppT = \case TLit (UIdent s) -> s - TVar (MkTVar (LIdent s)) -> "a_" ++ s + TVar (MkTVar (LIdent s)) -> "tvar_" ++ s TFun t1 t2 -> ppT t1 ++ "->" ++ ppT t2 TAll (MkTVar (LIdent s)) t -> "forall " ++ s ++ ". " ++ ppT t - TEVar (MkTEVar (LIdent s)) -> "a^_" ++ s + TEVar (MkTEVar (LIdent s)) -> "tevar_" ++ s TData (UIdent name) typs -> name ++ " (" ++ unwords (map ppT typs) ++ " )" ppEnvElem = \case EnvVar (LIdent s) t -> s ++ ":" ++ ppT t - EnvTVar (MkTVar (LIdent s)) -> "a_" ++ s - EnvTEVar (MkTEVar (LIdent s)) -> "a^_" ++ s - EnvTEVarSolved (MkTEVar (LIdent s)) t -> "_" ++ s ++ "=" ++ ppT t - EnvMark (MkTEVar (LIdent s)) -> "▶" ++ "a^_" ++ s + EnvTVar (MkTVar (LIdent s)) -> "tvar_" ++ s + EnvTEVar (MkTEVar (LIdent s)) -> "tevar_" ++ s + EnvTEVarSolved (MkTEVar (LIdent s)) t -> "tevar_" ++ s ++ "=" ++ ppT t + EnvMark (MkTEVar (LIdent s)) -> "▶" ++ "tevar_" ++ s ppEnv = \case Empty -> "·" diff --git a/tests/TestTypeCheckerBidir.hs b/tests/TestTypeCheckerBidir.hs index 4cf98f2..916b688 100644 --- a/tests/TestTypeCheckerBidir.hs +++ b/tests/TestTypeCheckerBidir.hs @@ -260,6 +260,17 @@ tc_pol_case = describe "Polymophic and recursive pattern matching" $ do , " Cons (Cons _ ys) xs => 1 + elems (Cons ys xs)" ] +tc_if = specify "Test if else case expression" $ do + run [ "data Bool () where" + , " True : Bool ()" + , " False : Bool ()" + + , "ifThenElse : Bool () -> a -> a -> a" + , "ifThenElse b if else = case b of" + , " True => if" + , " False => else" + ] `shouldSatisfy` ok + tc_infer_case = describe "Infer case expression" $ do specify "Wrong case expression rejected" $ From 9730552eab1c559695a00695e4cae1c75afde521 Mon Sep 17 00:00:00 2001 From: Martin Fredin Date: Tue, 11 Apr 2023 13:46:54 +0200 Subject: [PATCH 295/372] Remove parenthesis from EAnn --- Grammar.cf | 18 +++++----- src/TypeChecker/TypeCheckerBidir.hs | 54 ++++++++++++++--------------- 2 files changed, 36 insertions(+), 36 deletions(-) diff --git a/Grammar.cf b/Grammar.cf index 59e6897..35c3a56 100644 --- a/Grammar.cf +++ b/Grammar.cf @@ -42,15 +42,15 @@ Inj. Inj ::= UIdent ":" Type ; -- * Expressions ------------------------------------------------------------------------------- -EAnn. Exp4 ::= "(" Exp ":" Type ")"; -EVar. Exp3 ::= LIdent; -EInj. Exp3 ::= UIdent; -ELit. Exp3 ::= Lit; -EApp. Exp2 ::= Exp2 Exp3; -EAdd. Exp1 ::= Exp1 "+" Exp2; -ELet. Exp ::= "let" Bind "in" Exp; -EAbs. Exp ::= "\\" LIdent "." Exp; -ECase. Exp ::= "case" Exp "of" "{" [Branch] "}"; +EVar. Exp4 ::= LIdent; +EInj. Exp4 ::= UIdent; +ELit. Exp4 ::= Lit; +EApp. Exp3 ::= Exp3 Exp4; +EAdd. Exp2 ::= Exp2 "+" Exp3; +ELet. Exp1 ::= "let" Bind "in" Exp1; +EAbs. Exp1 ::= "\\" LIdent "." Exp1; +ECase. Exp1 ::= "case" Exp "of" "{" [Branch] "}"; +EAnn. Exp ::= Exp1 ":" Type; ------------------------------------------------------------------------------- -- * LITERALS diff --git a/src/TypeChecker/TypeCheckerBidir.hs b/src/TypeChecker/TypeCheckerBidir.hs index 1ad5bea..44f0c21 100644 --- a/src/TypeChecker/TypeCheckerBidir.hs +++ b/src/TypeChecker/TypeCheckerBidir.hs @@ -8,11 +8,14 @@ module TypeChecker.TypeCheckerBidir (typecheck, getVars) where import Auxiliary (int, liftMM2, litType, maybeToRightM, onM, onMM, snoc) -import Control.Applicative (Applicative (liftA2), (<|>)) +import Control.Applicative (Alternative, Applicative (liftA2), + (<|>)) import Control.Monad.Except (ExceptT, MonadError (throwError), runExceptT, unless, zipWithM, zipWithM_) -import Control.Monad.State (State, evalState, gets, modify) +import Control.Monad.Extra (fromMaybeM, maybeM) +import Control.Monad.State (MonadState, State, evalState, gets, + modify) import Data.Coerce (coerce) import Data.Function (on) import Data.List (intercalate) @@ -57,8 +60,8 @@ data Cxt = Cxt , data_injs :: Map UIdent Type -- ^ Data injections (constructors) K/inj : A } deriving (Show, Eq) -type Tc a = ExceptT String (State Cxt) a - -- deriving (Functor, Applicative, Monad, Alternative, MonadState Cxt, MonadError String) +newtype Tc a = Tc { runTc :: ExceptT String (State Cxt) a } + deriving (Functor, Applicative, Monad, MonadState Cxt, MonadError String) initCxt :: [Def] -> Cxt @@ -95,7 +98,7 @@ typecheck (Program defs) = do typecheckBinds :: Cxt -> [Bind] -> Err [T.Bind' Type] typecheckBinds cxt = flip evalState cxt . runExceptT - -- . runTc + . runTc . mapM typecheckBind typecheckBind :: Bind -> Tc (T.Bind' Type) @@ -191,16 +194,14 @@ check exp typ putEnv env_l pure (T.EAbs (coerce name) e', typ) - | otherwise = subsumption - where -- Γ,α ⊢ e ↓ A ⊣ Θ Θ ⊢ [Θ]A <: [Θ]B ⊣ Δ -- -------------------------------------- Sub -- Γ ⊢ e ↑ B ⊣ Δ - subsumption = do - (exp', t) <- infer exp - typ' <- apply typ - subtype t typ' - apply (exp', t) + | otherwise = do + (exp', t) <- infer exp + typ' <- apply typ + subtype t typ' + apply (exp', t) -- | Γ ⊢ e ↓ A ⊣ Δ -- Under input context Γ, e infers output type A, with output context ∆ @@ -210,18 +211,16 @@ infer = \case ELit lit -> pure (T.ELit lit, litType lit) -- Γ ∋ (x : A) Γ ∌ (x : A) - -- ------------- Var --------------- Var' - -- Γ ⊢ x ↓ A ⊣ Γ Γ ⊢ x ↓ ά ⊣ Γ,ά - EVar name -> do - t <- liftA2 (<|>) (lookupEnv name) (lookupSig name) >>= \case - Just t -> pure t - Nothing -> do - tevar <- fresh - insertEnv (EnvTEVar tevar) - let t = TEVar tevar - insertEnv (EnvVar name t) - pure t - apply (T.EVar (coerce name), t) + -- ------------- Var --------------------- Var' + -- Γ ⊢ x ↓ A ⊣ Γ Γ ⊢ x ↓ ά ⊣ Γ,(x : ά) + EVar x -> do + t <- fromMaybeM extend $ liftA2 (<|>) (lookupEnv x) (lookupSig x) + apply (T.EVar (coerce x), t) + where + extend = do + t <- TEVar <$> fresh + insertEnv (EnvVar x t) + pure t EInj name -> do t <- maybeToRightM ("Unknown constructor: " ++ show name) @@ -320,7 +319,9 @@ applyInfer typ exp = case typ of -- Γ ⊢ e ↑ A ⊣ Δ -- --------------------- →App -- Γ ⊢ A → C • e ⇓ C ⊣ Δ - TFun t1 t2 -> (, t2) <$> check exp t1 + TFun t1 t2 -> do + exp' <- check exp t1 + apply (exp', t2) _ -> throwError ("Cannot apply type " ++ show typ ++ " with expression " ++ show exp) @@ -336,7 +337,6 @@ applyInfer typ exp = case typ of inferBranches :: [Branch] -> Type -> Tc ([T.Branch' Type], Type) inferBranches branches t_patt = do (branches', ts_exp) <- inferBranches' t_patt branches - traceTs "TYPES " ts_exp t_exp <- case ts_exp of [] -> pure t_patt t:_ -> do @@ -805,7 +805,7 @@ applyType t = gets $ (`applyType'` t) . env -- | [Γ]A. Applies context to type until fully applied. applyType' :: Env -> Type -> Type applyType' cxt typ | typ == typ' = typ' - | otherwise = applyType' cxt typ' + | otherwise = applyType' cxt typ' where typ' = case typ of TLit _ -> typ From 2b7715714e5e14e72b1e9e3b8a18b13674599fbc Mon Sep 17 00:00:00 2001 From: Martin Fredin Date: Tue, 11 Apr 2023 18:56:53 +0200 Subject: [PATCH 296/372] Use better names --- src/TypeChecker/TypeCheckerBidir.hs | 500 ++++++++++++++-------------- 1 file changed, 250 insertions(+), 250 deletions(-) diff --git a/src/TypeChecker/TypeCheckerBidir.hs b/src/TypeChecker/TypeCheckerBidir.hs index 44f0c21..b62e587 100644 --- a/src/TypeChecker/TypeCheckerBidir.hs +++ b/src/TypeChecker/TypeCheckerBidir.hs @@ -38,7 +38,6 @@ import qualified TypeChecker.TypeCheckerIr as T -- -- TODO -- • Fix problems with types in Pattern/Branch in TypeCheckerIr --- • Use applyEnvExp consistently -- • Fix the different type getters functions (e.g. partitionType) functions data EnvElem = EnvVar LIdent Type -- ^ Term variable typing. x : A @@ -169,161 +168,156 @@ typecheckInj (Inj inj_name inj_typ) name tvars -- | Γ ⊢ e ↑ A ⊣ Δ -- Under input context Γ, e checks against input type A, with output context ∆ check :: Exp -> Type -> Tc (T.ExpT' Type) -check exp typ - -- Γ,α ⊢ e ↑ A ⊣ Δ,α,Θ - -- ------------------- ∀I - -- Γ ⊢ e ↑ ∀α.A ⊣ Δ - | TAll tvar t <- typ = do - let env_tvar = EnvTVar tvar - insertEnv env_tvar - exp' <- check exp t - (env_l, _) <- gets (splitOn env_tvar . env) - putEnv env_l - pure exp' +-- Γ,α ⊢ e ↑ A ⊣ Δ,α,Θ +-- ------------------- ∀I +-- Γ ⊢ e ↑ ∀α.A ⊣ Δ +check e (TAll alpha a) = do + let env_tvar = EnvTVar alpha + insertEnv env_tvar + e' <- check e a + (env_l, _) <- gets (splitOn env_tvar . env) + putEnv env_l + apply e' - -- Γ,(x:A) ⊢ e ↑ B ⊢ Δ,(x:A),Θ - -- --------------------------- →I - -- Γ ⊢ λx.e ↑ A → B ⊣ Δ - | EAbs name e <- exp - , TFun t1 t2 <- typ = do - let env_var = EnvVar name t1 - insertEnv env_var - e' <- check e t2 - (env_l, _) <- gets (splitOn env_var . env) - putEnv env_l - pure (T.EAbs (coerce name) e', typ) +-- Γ,(x:A) ⊢ e ↑ B ⊢ Δ,(x:A),Θ +-- --------------------------- →I +-- Γ ⊢ λx.e ↑ A → B ⊣ Δ +check (EAbs x e) (TFun a b) = do + let env_var = EnvVar x a + insertEnv env_var + e' <- check e b + (env_l, _) <- gets (splitOn env_var . env) + putEnv env_l + apply (T.EAbs (coerce x) e', TFun a b) - -- Γ,α ⊢ e ↓ A ⊣ Θ Θ ⊢ [Θ]A <: [Θ]B ⊣ Δ - -- -------------------------------------- Sub - -- Γ ⊢ e ↑ B ⊣ Δ - | otherwise = do - (exp', t) <- infer exp - typ' <- apply typ - subtype t typ' - apply (exp', t) +-- Γ,α ⊢ e ↓ A ⊣ Θ Θ ⊢ [Θ]A <: [Θ]B ⊣ Δ +-- -------------------------------------- Sub +-- Γ ⊢ e ↑ B ⊣ Δ +check e b = do + (e', a) <- infer e + b' <- apply b + subtype a b' + apply (e', b) -- | Γ ⊢ e ↓ A ⊣ Δ -- Under input context Γ, e infers output type A, with output context ∆ infer :: Exp -> Tc (T.ExpT' Type) -infer = \case - ELit lit -> pure (T.ELit lit, litType lit) +infer (ELit lit) = apply (T.ELit lit, litType lit) - -- Γ ∋ (x : A) Γ ∌ (x : A) - -- ------------- Var --------------------- Var' - -- Γ ⊢ x ↓ A ⊣ Γ Γ ⊢ x ↓ ά ⊣ Γ,(x : ά) - EVar x -> do - t <- fromMaybeM extend $ liftA2 (<|>) (lookupEnv x) (lookupSig x) - apply (T.EVar (coerce x), t) - where - extend = do - t <- TEVar <$> fresh - insertEnv (EnvVar x t) - pure t +-- Γ ∋ (x : A) Γ ∌ (x : A) +-- ------------- Var --------------------- Var' +-- Γ ⊢ x ↓ A ⊣ Γ Γ ⊢ x ↓ ά ⊣ Γ,(x : ά) +infer (EVar x) = do + a <- fromMaybeM extend $ liftA2 (<|>) (lookupEnv x) (lookupSig x) + apply (T.EVar (coerce x), a) + where + extend = do + alpha <- TEVar <$> fresh + insertEnv (EnvVar x alpha) + pure alpha - EInj name -> do - t <- maybeToRightM ("Unknown constructor: " ++ show name) - =<< lookupInj name - apply (T.EInj $ coerce name, t) +infer (EInj kappa) = do + t <- maybeToRightM ("Unknown constructor: " ++ show kappa) + =<< lookupInj kappa + apply (T.EInj $ coerce kappa, t) - -- Γ ⊢ A Γ ⊢ e ↑ A ⊣ Δ - -- --------------------- Anno - -- Γ ⊢ (e : A) ↓ A ⊣ Δ - EAnn e t -> do - _ <- gets $ (`wellFormed` t) . env - (e', _) <- check e t - apply (e', t) +-- Γ ⊢ A Γ ⊢ e ↑ A ⊣ Δ +-- --------------------- Anno +-- Γ ⊢ (e : A) ↓ A ⊣ Δ +infer (EAnn e a) = do + _ <- gets $ (`wellFormed` a) . env + (e', _) <- check e a + apply (e', a) - -- Γ ⊢ e₁ ↓ A ⊣ Θ Γ ⊢ [Θ]A • ⇓ C ⊣ Δ - -- ----------------------------------- →E - -- Γ ⊢ e₁ e₂ ↓ C ⊣ Δ - EApp e1 e2 -> do - (e1', t) <- infer e1 - (e2', t'') <- applyInfer t e2 - apply (T.EApp (e1', t) e2', t'') +-- Γ ⊢ e₁ ↓ A ⊣ Θ Γ ⊢ [Θ]A • ⇓ C ⊣ Δ +-- ----------------------------------- →E +-- Γ ⊢ e₁ e₂ ↓ C ⊣ Δ +infer (EApp e1 e2) = do + e1'@(_, a) <- infer e1 + (e2', c) <- applyInfer a e2 + apply (T.EApp e1' e2', c) - -- Γ,ά,έ,(x:ά) ⊢ e ↑ έ ⊣ Δ,(x:ά),Θ - -- ------------------------------- →I - -- Γ ⊢ λx.e ↓ ά → έ ⊣ Δ - EAbs name e -> do - tevar1 <- fresh - tevar2 <- fresh - insertEnv $ EnvTEVar tevar1 - insertEnv $ EnvTEVar tevar2 - let env_var = EnvVar name (TEVar tevar1) - insertEnv env_var - e' <- check e $ TEVar tevar2 - dropTrailing env_var - let t_exp = on TFun TEVar tevar1 tevar2 - apply (T.EAbs (coerce name) e', t_exp) +-- Γ,ά,έ,(x:ά) ⊢ e ↑ έ ⊣ Δ,(x:ά),Θ +-- ------------------------------- →I +-- Γ ⊢ λx.e ↓ ά → έ ⊣ Δ +infer (EAbs name e) = do + alpha <- fresh + epsilon <- fresh + insertEnv $ EnvTEVar alpha + insertEnv $ EnvTEVar epsilon + let env_var = EnvVar name (TEVar alpha) + insertEnv env_var + e' <- check e $ TEVar epsilon + dropTrailing env_var + apply (T.EAbs (coerce name) e', on TFun TEVar alpha epsilon) +-- Γ ⊢ rhs ↓ A ⊣ Θ Θ,(x:A) ⊢ e ↑ C ⊣ Δ,(x:A),Θ +-- -------------------------------------------- LetI +-- Γ ⊢ let x = rhs in e ↑ C ⊣ Δ +infer (ELet (Bind x vars rhs) e) = do + (rhs', a) <- infer $ foldr EAbs rhs vars + let env_var = EnvVar x a + insertEnv env_var + e'@(_, c) <- infer e + (env_l, _) <- gets (splitOn env_var . env) + putEnv env_l + apply (T.ELet (T.Bind (coerce x, a) [] (rhs', a)) e', c) - -- Γ ⊢ e ↓ A ⊣ Θ Θ,(x:A) ⊢ e' ↑ C ⊣ Δ,(x:A),Θ - -- -------------------------------------------- LetI - -- Γ ⊢ let x=e in e' ↑ C ⊣ Δ - ELet (Bind name [] rhs) e -> do -- TODO vars - (rhs', t_rhs) <- infer rhs - let env_var = EnvVar name t_rhs - insertEnv env_var - (e', t) <- infer e - (env_l, _) <- gets (splitOn env_var . env) - putEnv env_l - apply (T.ELet (T.Bind (coerce name, t_rhs) [] (rhs', t_rhs)) (e',t), t) +-- Γ ⊢ e₁ ↑ Int ⊣ Θ Θ ⊢ e₂ ↑ Int +-- --------------------------- +I +-- Γ ⊢ e₁ + e₂ ↓ Int ⊣ Δ +infer (EAdd e1 e2) = do + e1' <- check e1 int + e2' <- check e2 int + apply (T.EAdd e1' e2', int) - -- Γ ⊢ e₁ ↑ Int ⊣ Θ Θ ⊢ e₂ ↑ Int - -- --------------------------- +I - -- Γ ⊢ e₁ + e₂ ↓ Int ⊣ Δ - EAdd e1 e2 -> (, int) <$> onM T.EAdd (`check` int) e1 e2 - - -- Θ ⊢ Π ∷ A ↓ C ⊣ Δ - -- Γ ⊢ e ↓ A ⊣ Θ Δ ⊢ Π covers [Δ]A TODO - -- --------------------------------------- - -- Γ ⊢ case e of Π ↓ C ⊣ Δ - ECase scrut branches -> do - (scrut', t_scrut) <- infer scrut - (branches', t_return) <- inferBranches branches t_scrut - apply (T.ECase (scrut', t_scrut) branches', t_return) +-- Θ ⊢ Π ∷ A ↓ C ⊣ Δ +-- Γ ⊢ e ↓ A ⊣ Θ Δ ⊢ Π covers [Δ]A TODO +-- --------------------------------------- +-- Γ ⊢ case e of Π ↓ C ⊣ Δ +infer (ECase scrut branches) = do + (scrut', t_scrut) <- infer scrut + (branches', t_return) <- inferBranches branches t_scrut + apply (T.ECase (scrut', t_scrut) branches', t_return) -- | Γ ⊢ A • e ⇓ C ⊣ Δ -- Under input context Γ , applying a function of type A to e infers type C, with output context ∆ -- Instantiate existential type variables until there is an arrow type. applyInfer :: Type -> Exp -> Tc (T.ExpT' Type, Type) -applyInfer typ exp = case typ of - -- Γ,ά ⊢ [ά/α]A • e ⇓ C ⊣ Δ - -- ------------------------ ∀App - -- Γ ⊢ ∀α.A • e ⇓ C ⊣ Δ - TAll tvar t -> do - tevar <- fresh - insertEnv $ EnvTEVar tevar - let t' = substitute tvar tevar t - applyInfer t' exp +-- Γ,ά ⊢ [ά/α]A • e ⇓ C ⊣ Δ +-- ------------------------ ∀App +-- Γ ⊢ ∀α.A • e ⇓ C ⊣ Δ +applyInfer (TAll alpha a) e = do + alpha' <- fresh + insertEnv $ EnvTEVar alpha' + applyInfer (substitute alpha alpha' a) e - -- Γ[ά₂,ά₁,(ά=ά₁→ά₂)] ⊢ e ↑ ά₁ ⊣ Δ - -- ------------------------------- άApp - -- Γ[ά] ⊢ ά • e ⇓ ά₂ ⊣ Δ - TEVar tevar -> do - tevar1 <- fresh - tevar2 <- fresh - let env_tevar1 = EnvTEVar tevar1 - env_tevar2 = EnvTEVar tevar2 - t_fun = on TFun TEVar tevar1 tevar2 - env_tevar_solved = EnvTEVarSolved tevar t_fun - (env_l, env_r) <- gets (splitOn (EnvTEVar tevar) . env) - putEnv $ - (env_l :|> env_tevar2 :|> env_tevar1 :|> env_tevar_solved) <> env_r - expT' <- check exp $ TEVar tevar1 - apply (expT', TEVar tevar2) +-- Γ[ά₂,ά₁,(ά=ά₁→ά₂)] ⊢ e ↑ ά₁ ⊣ Δ +-- ------------------------------- άApp +-- Γ[ά] ⊢ ά • e ⇓ ά₂ ⊣ Δ +applyInfer (TEVar alpha) e = do + alpha1 <- fresh + alpha2 <- fresh + (env_l, env_r) <- gets (splitOn (EnvTEVar alpha) . env) + putEnv $ (env_l + :|> EnvTEVar alpha2 + :|> EnvTEVar alpha1 + :|> EnvTEVarSolved alpha (on TFun TEVar alpha1 alpha2) + ) <> env_r + e' <- check e $ TEVar alpha1 + apply (e', TEVar alpha2) - -- Γ ⊢ e ↑ A ⊣ Δ - -- --------------------- →App - -- Γ ⊢ A → C • e ⇓ C ⊣ Δ - TFun t1 t2 -> do - exp' <- check exp t1 - apply (exp', t2) +-- Γ ⊢ e ↑ A ⊣ Δ +-- --------------------- →App +-- Γ ⊢ A → C • e ⇓ C ⊣ Δ +applyInfer (TFun a c) e = do + exp' <- check e a + apply (exp', c) - _ -> throwError ("Cannot apply type " ++ show typ ++ " with expression " ++ show exp) +applyInfer a e = throwError ("Cannot apply type " ++ show a ++ " with expression " ++ show e) --------------------------------------------------------------------------- -- * Pattern matching @@ -435,59 +429,58 @@ checkPattern patt t_patt = case patt of -- | Γ ⊢ A <: B ⊣ Δ -- Under input context Γ, type A is a subtype of B, with output context ∆ subtype :: Type -> Type -> Tc () +subtype (TLit lit1) (TLit lit2) | lit1 == lit2 = pure () + +-- -------------------- <:Var +-- Γ[α] ⊢ α <: α ⊣ Γ[α] +subtype (TVar alpha) (TVar alpha') | alpha == alpha' = pure () + +-- -------------------- <:Exvar +-- Γ[ά] ⊢ ά <: ά ⊣ Γ[ά] +subtype (TEVar alpha) (TEVar alpha') | alpha == alpha' = pure () + +-- Γ ⊢ B₁ <: A₁ ⊣ Θ Θ ⊢ [Θ]A₂ <: [Θ]B₂ ⊣ Δ +-- ----------------------------------------- <:→ +-- Γ ⊢ A₁ → A₂ <: B₁ → B₂ ⊣ Δ +subtype (TFun a1 a2) (TFun b1 b2) = do + subtype b1 a1 + a2' <- apply a2 + b2' <- apply b2 + subtype a2' b2' + +-- Γ, α ⊢ A <: B ⊣ Δ,α,Θ +-- --------------------- <:∀R +-- Γ ⊢ A <: ∀α. B ⊣ Δ +subtype a (TAll alpha b) = do + let env_tvar = EnvTVar alpha + insertEnv env_tvar + subtype a b + dropTrailing env_tvar + +-- Γ,▶ ά,ά ⊢ [ά/α]A <: B ⊣ Δ,▶ ά,Θ +-- ------------------------------- <:∀L +-- Γ ⊢ ∀α.A <: B ⊣ Δ +subtype (TAll alpha a) b = do + alpha' <- fresh + let env_marker = EnvMark alpha' + insertEnv env_marker + insertEnv $ EnvTEVar alpha' + let a' = substitute alpha alpha' a + subtype a' b + dropTrailing env_marker + +-- ά ∉ FV(A) Γ[ά] ⊢ ά :=< A ⊣ Δ +-- ------------------------------ <:instantiateL +-- Γ[ά] ⊢ ά <: A ⊣ Δ +subtype (TEVar alpha) a | notElem alpha $ frees a = instantiateL alpha a + +-- ά ∉ FV(A) Γ[ά] ⊢ A =:< ά ⊣ Δ +-- ------------------------------ <:instantiateR +-- Γ[ά] ⊢ A <: ά ⊣ Δ +subtype a (TEVar alpha) | notElem alpha $ frees a = instantiateR a alpha + + subtype t1 t2 = case (t1, t2) of - - (TLit lit1, TLit lit2) | lit1 == lit2 -> pure () - - -- -------------------- <:Var - -- Γ[α] ⊢ α <: α ⊣ Γ[α] - (TVar tvar1, TVar tvar2) | tvar1 == tvar2 -> pure () - - -- -------------------- <:Exvar - -- Γ[ά] ⊢ ά <: ά ⊣ Γ[ά] - (TEVar tevar1, TEVar tevar2) | tevar1 == tevar2 -> pure () - - -- Γ ⊢ B₁ <: A₁ ⊣ Θ Θ ⊢ [Θ]A₂ <: [Θ]B₂ ⊣ Δ - -- ----------------------------------------- <:→ - -- Γ ⊢ A₁ → A₂ <: B₁ → B₂ ⊣ Δ - (TFun a1 a2, TFun b1 b2) -> do - subtype b1 a1 - a2' <- apply a2 - b2' <- apply b2 - subtype a2' b2' - - -- Γ, α ⊢ A <: B ⊣ Δ,α,Θ - -- --------------------- <:∀R - -- Γ ⊢ A <: ∀α. B ⊣ Δ - (a, TAll tvar b) -> do - let env_tvar = EnvTVar tvar - insertEnv env_tvar - subtype a b - dropTrailing env_tvar - - -- Γ,▶ ά,ά ⊢ [ά/α]A <: B ⊣ Δ,▶ ά,Θ - -- ------------------------------- <:∀L - -- Γ ⊢ ∀α.A <: B ⊣ Δ - (TAll tvar a, b) -> do - tevar <- fresh - let env_marker = EnvMark tevar - insertEnv env_marker - insertEnv $ EnvTEVar tevar - let a' = substitute tvar tevar a - subtype a' b - dropTrailing env_marker - - -- ά ∉ FV(A) Γ[ά] ⊢ ά :=< A ⊣ Δ - -- ------------------------------ <:instantiateL - -- Γ[ά] ⊢ ά <: A ⊣ Δ - (TEVar tevar, typ) | notElem tevar $ frees typ -> instantiateL tevar typ - - -- ά ∉ FV(A) Γ[ά] ⊢ A =:< ά ⊣ Δ - -- ------------------------------ <:instantiateR - -- Γ[ά] ⊢ A <: ά ⊣ Δ - (typ, TEVar tevar) | notElem tevar $ frees typ -> instantiateR typ tevar - - (TData name1 typs1, TData name2 typs2) -- D₁ = D₂ @@ -524,99 +517,106 @@ subtype t1 t2 = case (t1, t2) of -- | Γ ⊢ ά :=< A ⊣ Δ -- Under input context Γ, instantiate ά such that ά <: A, with output context ∆ instantiateL :: TEVar -> Type -> Tc () -instantiateL tevar typ = gets env >>= go +instantiateL alpha a = gets env >>= \env -> go env alpha a where - go env + go env alpha tau + | isMono tau + , (env_l, env_r) <- splitOn (EnvTEVar alpha) env + , Right _ <- wellFormed env_l tau + = putEnv $ (env_l :|> EnvTEVarSolved alpha tau) <> env_r - -- Γ ⊢ τ - -- ----------------------------- InstLSolve - -- Γ,ά,Γ' ⊢ ά :=< τ ⊣ Γ,(ά=τ),Γ' - | isMono typ - , (env_l, env_r) <- splitOn (EnvTEVar tevar) env - , Right _ <- wellFormed env_l typ - = putEnv $ (env_l :|> EnvTEVarSolved tevar typ) <> env_r + -- Γ ⊢ τ + -- ----------------------------- InstLSolve + -- Γ,ά,Γ' ⊢ ά :=< τ ⊣ Γ,(ά=τ),Γ' + go env alpha tau + | isMono tau + , (env_l, env_r) <- splitOn (EnvTEVar alpha) env + , Right _ <- wellFormed env_l tau + = putEnv $ (env_l :|> EnvTEVarSolved alpha tau) <> env_r - | TEVar tevar' <- typ = instReach tevar tevar' + -- ----------------------------- InstLReach + -- Γ[ά][έ] ⊢ ά :=< έ ⊣ Γ[ά][έ=ά] + go env alpha (TEVar epsilon) = do + let (env_l, env_r) = splitOn (EnvTEVar epsilon) env + putEnv $ (env_l :|> EnvTEVarSolved epsilon (TEVar alpha)) <> env_r - -- Γ[ά₂ά₁,(ά=ά₁→ά₂)] ⊢ A₁ =:< ά₁ ⊣ Θ Θ ⊢ ά₂ :=< [Θ]A₂ ⊣ Δ - -- ------------------------------------------------------- InstLArr - -- Γ[ά] ⊢ ά :=< A₁ → A₂ ⊣ Δ - | TFun t1 t2 <- typ = do - tevar1 <- fresh - tevar2 <- fresh - insertEnv $ EnvTEVar tevar2 - insertEnv $ EnvTEVar tevar1 - insertEnv $ EnvTEVarSolved tevar (on TFun TEVar tevar1 tevar2) - instantiateR t1 tevar1 - instantiateL tevar2 =<< apply t2 + -- Γ[ά₂ά₁,(ά=ά₁→ά₂)] ⊢ A₁ =:< ά₁ ⊣ Θ Θ ⊢ ά₂ :=< [Θ]A₂ ⊣ Δ + -- ------------------------------------------------------- InstLArr + -- Γ[ά] ⊢ ά :=< A₁ → A₂ ⊣ Δ + go _ alpha (TFun a1 a2) = do + alpha1 <- fresh + alpha2 <- fresh + insertEnv $ EnvTEVar alpha2 + insertEnv $ EnvTEVar alpha1 + insertEnv $ EnvTEVarSolved alpha (on TFun TEVar alpha1 alpha2) + instantiateR a1 alpha1 + instantiateL alpha2 =<< apply a2 - -- Γ[ά],ε ⊢ ά :=< E ⊣ Δ,ε,Δ' - -- ------------------------- InstLAIIR - -- Γ[ά] ⊢ ά :=< ∀ε.Ε ⊣ Δ - | TAll tvar t <- typ = do - instantiateL tevar t - let (env_l, _) = splitOn (EnvTVar tvar) env - putEnv env_l + -- Γ[ά],ε ⊢ ά :=< E ⊣ Δ,ε,Δ' + -- ------------------------- InstLAIIR + -- Γ[ά] ⊢ ά :=< ∀ε.Ε ⊣ Δ + go env tevar (TAll tvar t) = do + instantiateL tevar t + let (env_l, _) = splitOn (EnvTVar tvar) env + putEnv env_l - | otherwise = error $ "Trying to instantiateL: " ++ ppT (TEVar tevar) - ++ " <: " ++ ppT typ + go _ alpha a = error $ "Trying to instantiateL: " ++ ppT (TEVar alpha) + ++ " <: " ++ ppT a -- | Γ ⊢ A =:< ά ⊣ Δ -- Under input context Γ, instantiate ά such that A <: ά, with output context ∆ -instantiateR :: Type -> TEVar -> Tc () -instantiateR typ tevar = gets env >>= go +instantiateR :: Type -> TEVar -> Tc () +instantiateR a alpha = gets env >>= \env -> go env a alpha where - go env -- Γ ⊢ τ -- ----------------------------- InstRSolve -- Γ,ά,Γ' ⊢ τ =:< ά ⊣ Γ,(ά=τ),Γ' - | isMono typ - , (env_l, env_r) <- splitOn (EnvTEVar tevar) env - , Right _ <- wellFormed env_l typ - = putEnv $ (env_l :|> EnvTEVarSolved tevar typ) <> env_r + go env tau alpha + | isMono tau + , (env_l, env_r) <- splitOn (EnvTEVar alpha) env + , Right _ <- wellFormed env_l tau + = putEnv $ (env_l :|> EnvTEVarSolved alpha tau) <> env_r + + -- + -- ----------------------------- InstRReach + -- Γ[ά][έ] ⊢ έ =:< ά ⊣ Γ[ά][έ=ά] + go env (TEVar epsilon) alpha = do + let (env_l, env_r) = splitOn (EnvTEVar epsilon) env + putEnv $ (env_l :|> EnvTEVarSolved epsilon (TEVar alpha)) <> env_r + - | TEVar tevar' <- typ = instReach tevar tevar' -- Γ[ά₂ά₁,(ά=ά₁→ά₂)] ⊢ A₁ :=< ά₁ ⊣ Θ Θ ⊢ ά₂ =:< [Θ]A₂ ⊣ Δ -- ------------------------------------------------------- InstRArr - -- Γ[ά] ⊢ ά =:< A₁ → A₂ ⊣ Δ - | TFun t1 t2 <- typ = do - tevar1 <- fresh - tevar2 <- fresh - insertEnv $ EnvTEVar tevar2 - insertEnv $ EnvTEVar tevar1 - insertEnv $ EnvTEVarSolved tevar (on TFun TEVar tevar1 tevar2) - instantiateL tevar1 t1 - t2' <- apply t2 - instantiateR t2' tevar2 + -- Γ[ά] ⊢ A₁ → A₂ =:< ά ⊣ Δ + go _ (TFun a1 a2) alpha = do + alpha1 <- fresh + alpha2 <- fresh + insertEnv $ EnvTEVar alpha2 + insertEnv $ EnvTEVar alpha1 + insertEnv $ EnvTEVarSolved alpha (on TFun TEVar alpha1 alpha2) + instantiateL alpha1 a1 + a2' <- apply a2 + instantiateR a2' alpha2 + + -- Γ[ά],▶έ,ε ⊢ [έ/ε]E =:< ά ⊣ Δ,▶έ,Δ' -- ---------------------------------- InstRAIIL -- Γ[ά] ⊢ ∀ε.Ε =:< ά ⊣ Δ - | TAll tvar t <- typ = do - tevar' <- fresh - insertEnv $ EnvMark tevar' - insertEnv $ EnvTVar tvar - let t' = substitute tvar tevar' t - instantiateR t' tevar - let (env_l, _) = splitOn (EnvTVar tvar) env + go env (TAll epsilon e) alpha = do + epsilon' <- fresh + insertEnv $ EnvMark epsilon' + insertEnv $ EnvTVar epsilon + instantiateR (substitute epsilon epsilon' e) alpha + let (env_l, _) = splitOn (EnvMark epsilon') env putEnv env_l - | otherwise = error $ "Trying to instantiateR: " ++ ppT typ ++ " <: " - ++ ppT (TEVar tevar) + go _ a alpha = error $ "Trying to instantiateR: " ++ ppT a ++ " <: " + ++ ppT (TEVar alpha) --- ----------------------------- InstLReach --- Γ[ά][έ] ⊢ ά :=< έ ⊣ Γ[ά][έ=ά] --- --- ----------------------------- InstRReach --- Γ[ά][έ] ⊢ έ =:< ά ⊣ Γ[ά][έ=ά] -instReach :: TEVar -> TEVar -> Tc () -instReach tevar tevar' = do - (env_l, env_r) <- gets (splitOn (EnvTEVar tevar') . env) - let env_solved = EnvTEVarSolved tevar' $ TEVar tevar - putEnv $ (env_l :|> env_solved) <> env_r --------------------------------------------------------------------------- From 0ab13e597950d3ad3d389e83df1c3b48f8e2e808 Mon Sep 17 00:00:00 2001 From: Samuel Hammersberg Date: Wed, 12 Apr 2023 15:15:38 +0200 Subject: [PATCH 297/372] Fixed the ordering of data types. --- src/Codegen/Codegen.hs | 18 ++++++++++++------ 1 file changed, 12 insertions(+), 6 deletions(-) diff --git a/src/Codegen/Codegen.hs b/src/Codegen/Codegen.hs index bf35f4f..810d849 100644 --- a/src/Codegen/Codegen.hs +++ b/src/Codegen/Codegen.hs @@ -1,16 +1,17 @@ module Codegen.Codegen (generateCode) where import Codegen.CompilerState ( - CodeGenerator (instructions), - initCodeGenerator, + CodeGenerator (instructions), + initCodeGenerator, ) import Codegen.Emits (compileScs) import Codegen.LlvmIr as LIR (llvmIrToString) import Control.Monad.State ( - execStateT, + execStateT, ) +import Data.List (sortBy) import Grammar.ErrM (Err) -import Monomorphizer.MonomorphizerIr as MIR (Program (..)) +import Monomorphizer.MonomorphizerIr as MIR (Def (DBind, DData), Program (..)) {- | Compiles an AST and produces a LLVM Ir string. An easy way to actually "compile" this output is to @@ -18,5 +19,10 @@ import Monomorphizer.MonomorphizerIr as MIR (Program (..)) -} generateCode :: MIR.Program -> Err String generateCode (MIR.Program scs) = do - let codegen = initCodeGenerator scs - llvmIrToString . instructions <$> execStateT (compileScs scs) codegen + let codegen = initCodeGenerator scs + llvmIrToString . instructions <$> execStateT (compileScs (sortBy lowData scs)) codegen + +lowData :: Def -> Def -> Ordering +lowData (DData _) (DBind _) = LT +lowData (DBind _) (DData _) = GT +lowData _ _ = EQ \ No newline at end of file From c2bf6312f652df2bc6901ac75e804ae8aee39ba3 Mon Sep 17 00:00:00 2001 From: Rakarake Date: Wed, 12 Apr 2023 16:36:22 +0200 Subject: [PATCH 298/372] Monomorphizer now outputs constructors that are matched on but not created --- sample-programs/{mono.crf => mono-1.crf} | 0 sample-programs/mono-3.crf | 11 +++++++++++ src/Monomorphizer/Monomorphizer.hs | 13 ++++++++----- 3 files changed, 19 insertions(+), 5 deletions(-) rename sample-programs/{mono.crf => mono-1.crf} (100%) create mode 100644 sample-programs/mono-3.crf diff --git a/sample-programs/mono.crf b/sample-programs/mono-1.crf similarity index 100% rename from sample-programs/mono.crf rename to sample-programs/mono-1.crf diff --git a/sample-programs/mono-3.crf b/sample-programs/mono-3.crf new file mode 100644 index 0000000..a51df2c --- /dev/null +++ b/sample-programs/mono-3.crf @@ -0,0 +1,11 @@ +data Number() where + One: Number () + Two: Number () + +numberToInt : Number () -> Int +numberToInt n = case n of + One => 1 + Two => 2 + +main = numberToInt One + diff --git a/src/Monomorphizer/Monomorphizer.hs b/src/Monomorphizer/Monomorphizer.hs index 60607ca..50f1bef 100644 --- a/src/Monomorphizer/Monomorphizer.hs +++ b/src/Monomorphizer/Monomorphizer.hs @@ -237,22 +237,25 @@ morphBranch (T.Branch (p, pt) (e, et)) = do pt' <- getMonoFromPoly pt et' <- getMonoFromPoly et env <- ask - (p', newLocals) <- morphPattern (locals env) p + (p', newLocals) <- morphPattern pt' (locals env) p local (const env { locals = Set.union newLocals (locals env) }) $ do e' <- morphExp et' e return $ M.Branch (p', pt') (e', et') -- Morphs pattern (patter -> expression), gives the newly bound local variables. -morphPattern :: Set.Set Ident -> T.Pattern -> EnvM (M.Pattern, Set.Set Ident) -morphPattern ls = \case +morphPattern :: M.Type -> Set.Set Ident -> T.Pattern -> EnvM (M.Pattern, Set.Set Ident) +morphPattern expectedType ls = \case T.PVar (ident, t) -> do t' <- getMonoFromPoly t return (M.PVar (ident, t'), Set.insert ident ls) T.PLit (lit, t) -> do t' <- getMonoFromPoly t return (M.PLit (convertLit lit, t'), ls) T.PCatch -> return (M.PCatch, ls) -- Constructor ident - T.PEnum ident -> return (M.PEnum ident, ls) - T.PInj ident ps -> do pairs <- mapM (morphPattern ls) ps + T.PEnum ident -> do morphCons expectedType ident + return (M.PEnum ident, ls) + T.PInj ident ps -> do morphCons expectedType ident + let (M.TData tIdent ts) = expectedType + pairs <- mapM (\(pat, patT) -> morphPattern patT ls pat) (zip ps ts) return (M.PInj ident (map fst pairs), Set.unions (map snd pairs)) -- | Creates a new identifier for a function with an assigned type From a23269f907a49d5fb01af14a3db6c2bd0e089ac4 Mon Sep 17 00:00:00 2001 From: Rakarake Date: Mon, 17 Apr 2023 15:53:16 +0200 Subject: [PATCH 299/372] Fixed small bug in monomorphizer --- sample-programs/mono-1.crf | 7 ++++--- src/Monomorphizer/Monomorphizer.hs | 4 ++-- 2 files changed, 6 insertions(+), 5 deletions(-) diff --git a/sample-programs/mono-1.crf b/sample-programs/mono-1.crf index e682b7d..9c0a08f 100644 --- a/sample-programs/mono-1.crf +++ b/sample-programs/mono-1.crf @@ -1,5 +1,6 @@ -const x y = x; +const x y = x -f x = (const x 'c'); +f x = (const x 'c') + +main = f 5 -main = f 5; diff --git a/src/Monomorphizer/Monomorphizer.hs b/src/Monomorphizer/Monomorphizer.hs index 50f1bef..c0bd691 100644 --- a/src/Monomorphizer/Monomorphizer.hs +++ b/src/Monomorphizer/Monomorphizer.hs @@ -120,7 +120,7 @@ getMonoFromPoly t = do env <- ask -- Returns the annotated bind name. -- TODO: Redundancy? btype and t should always be the same. morphBind :: M.Type -> T.Bind -> EnvM Ident -morphBind expectedType b@(T.Bind (Ident _, btype) args (exp, expt)) = +morphBind expectedType b@(T.Bind (Ident str, btype) args (exp, expt)) = local (\env -> env { locals = Set.fromList (map fst args), polys = Map.fromList (mapTypes btype expectedType) }) $ do @@ -137,7 +137,7 @@ morphBind expectedType b@(T.Bind (Ident _, btype) args (exp, expt)) = -- Get monomorphic type sof args args' <- mapM convertArg args addOutputBind $ M.Bind (coerce name', expectedType) - args' (exp', expectedType) + args' (exp', expt') return name' convertArg :: (Ident, T.Type) -> EnvM (Ident, M.Type) From 7ab0e659812e3b116a316db83f7dd8698e666d25 Mon Sep 17 00:00:00 2001 From: sebastianselander Date: Mon, 17 Apr 2023 16:05:23 +0200 Subject: [PATCH 300/372] removed minor thing in EAdd --- src/TypeChecker/TypeCheckerHm.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/TypeChecker/TypeCheckerHm.hs b/src/TypeChecker/TypeCheckerHm.hs index 826caa1..1560f0d 100644 --- a/src/TypeChecker/TypeCheckerHm.hs +++ b/src/TypeChecker/TypeCheckerHm.hs @@ -329,8 +329,8 @@ algoW = \case err@(EAdd e0 e1) -> do (s1, (e0', t0)) <- algoW e0 (s2, (e1', t1)) <- algoW e1 - s3 <- exprErr (unify (apply s2 t0) int) err - s4 <- exprErr (unify (apply s3 t1) int) err + s3 <- exprErr (unify t0 int) err + s4 <- exprErr (unify t1 int) err let comp = s4 `compose` s3 `compose` s2 `compose` s1 return ( comp From 2611ddc2b2e5330b5afd3a45ec30c737cd97e932 Mon Sep 17 00:00:00 2001 From: Rakarake Date: Tue, 18 Apr 2023 15:48:25 +0200 Subject: [PATCH 301/372] Fixed wrong handeling of EAdd in monomorphizer, as well as more documentation and cleanup --- sample-programs/example-programs/ex3.crf | 8 +- src/Monomorphizer/Monomorphizer.hs | 141 ++++++++++------------- 2 files changed, 63 insertions(+), 86 deletions(-) diff --git a/sample-programs/example-programs/ex3.crf b/sample-programs/example-programs/ex3.crf index 408e685..9f080ac 100644 --- a/sample-programs/example-programs/ex3.crf +++ b/sample-programs/example-programs/ex3.crf @@ -1,11 +1,11 @@ data Maybe () where { - Just : Int -> Maybe () - Nothing : Maybe () + Just : Int -> Maybe () ; + Nothing : Maybe () ; }; demoFunc x = case x of { - Just x => x + 24; + Just y => y + 24; Nothing => 0; }; -main = demoFunc (Just 5) ; \ No newline at end of file +main = demoFunc (Just 5) ; diff --git a/src/Monomorphizer/Monomorphizer.hs b/src/Monomorphizer/Monomorphizer.hs index c0bd691..f00da9a 100644 --- a/src/Monomorphizer/Monomorphizer.hs +++ b/src/Monomorphizer/Monomorphizer.hs @@ -31,8 +31,8 @@ import qualified TypeChecker.TypeCheckerIr as T import TypeChecker.TypeCheckerIr (Ident (Ident)) import Control.Monad.Reader (MonadReader (ask, local), - Reader, asks, runReader) -import Control.Monad.State (MonadState (get), + Reader, asks, runReader, when) +import Control.Monad.State (MonadState, StateT (runStateT), gets, modify) import Data.Coerce (coerce) @@ -42,20 +42,26 @@ import qualified Data.Set as Set import Debug.Trace import Grammar.Print (printTree) --- | State Monad wrapper for "Env". +-- | EnvM is the monad containing the read-only state as well as the +-- output state containing monomorphized functions and to-be monomorphized +-- data type declarations. 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 | Data M.Type T.Data --- Static environment +-- | Data structure describing outputted top-level information, that is +-- Binds, Polymorphic Data types (monomorphized in a later step) and +-- Marked bind, which means that it is in the process of monomorphization +-- and should not be monomorphized again. +data Outputted = Marked | Complete M.Bind | Data M.Type T.Data + +-- | Static environment. data Env = Env { -- | All binds in the program. input :: Map.Map Ident T.Bind, - -- | All constructors and their respective data def. + -- | All constructors mapped to their respective polymorphic data def + -- which includes all other constructors. dataDefs :: Map.Map Ident T.Data, -- | Maps polymorphic identifiers with concrete types. polys :: Map.Map Ident M.Type, @@ -63,6 +69,7 @@ data Env = Env { locals :: Set.Set Ident } +-- | Determines if the identifier describes a local variable in the given context. localExists :: Ident -> EnvM Bool localExists ident = asks (Set.member ident . locals) @@ -77,17 +84,16 @@ addOutputBind b@(M.Bind (ident, _) _ _) = modify (Map.insert ident (Complete b)) -- | 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) +markBind ident = modify (Map.insert ident Marked) -- | Check if bind has been touched or not. isBindMarked :: Ident -> EnvM Bool isBindMarked ident = gets (Map.member ident) --- | Finds main bind +-- | Finds main bind. getMain :: EnvM T.Bind 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 -- error when encountering different structures between the two arguments. mapTypes :: T.Type -> M.Type -> [(Ident, M.Type)] @@ -96,7 +102,7 @@ mapTypes (T.TVar (T.MkTVar i1)) tm = [(i1, tm)] mapTypes (T.TFun pt1 pt2) (M.TFun mt1 mt2) = mapTypes pt1 mt1 ++ mapTypes pt2 mt2 mapTypes (T.TData tIdent pTs) (M.TData mIdent mTs) = if tIdent /= mIdent - then error "nuh uh" + then error "the data type names of monomorphic and polymorphic data types does not match" else foldl (\xs (p, m) -> mapTypes p m ++ xs) [] (zip pTs mTs) mapTypes t1 t2 = error $ "structure of types not the same: '" ++ printTree t1 ++ "', '" ++ printTree t2 ++ "'" @@ -118,13 +124,13 @@ getMonoFromPoly t = do env <- ask -- | If ident not already in env's output, morphed bind to output -- (and all referenced binds within this bind). -- Returns the annotated bind name. --- TODO: Redundancy? btype and t should always be the same. morphBind :: M.Type -> T.Bind -> EnvM Ident morphBind expectedType b@(T.Bind (Ident str, btype) args (exp, expt)) = 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. + trace ("Inside of bind: " ++ str) return () let name' = newFuncName expectedType b bindMarked <- isBindMarked (coerce name') -- Return with right name if already marked @@ -135,41 +141,23 @@ morphBind expectedType b@(T.Bind (Ident str, btype) args (exp, expt)) = expt' <- getMonoFromPoly expt exp' <- morphExp expt' exp -- Get monomorphic type sof args - args' <- mapM convertArg args + args' <- mapM morphArg args addOutputBind $ M.Bind (coerce name', expectedType) args' (exp', expt') return name' -convertArg :: (Ident, T.Type) -> EnvM (Ident, M.Type) -convertArg (ident, t) = do t' <- getMonoFromPoly t - return (ident, t') +-- | Monomorphizes arguments of a bind. +morphArg :: (Ident, T.Type) -> EnvM (Ident, M.Type) +morphArg (ident, t) = do t' <- getMonoFromPoly t + return (ident, t') --- Morphs function applications, such as EApp and EAdd -morphApp :: (M.ExpT -> M.ExpT -> M.Exp) -> M.Type -> T.ExpT -> T.ExpT -> EnvM M.Exp -morphApp node expectedType (e1, t1) (e2, t2)= do - t2' <- getMonoFromPoly t2 - e2' <- morphExp t2' e2 - e1' <- morphExp (M.TFun t2' expectedType) e1 - return $ node (e1', M.TFun t2' expectedType) (e2', t2') - ---addOutputData :: M.Data -> EnvM () ---addOutputData d@(M.Data (M.TData ident _) _) = modify $ Map.insert ident (Data d) - --- Gets data bind from the name of a constructor +-- | Gets the data bind from the name of a constructor. getInputData :: Ident -> EnvM (Maybe T.Data) getInputData ident = do env <- ask return $ Map.lookup ident (dataDefs env) --- | Expects polymorphic types in data definition to be mapped --- in environment. ---morphData :: T.Data -> EnvM () ---morphData (T.Data t cs) = do --- t' <- getMonoFromPoly t --- output <- get --- cs' <- mapM (\(T.Inj ident t) -> do t' <- getMonoFromPoly t --- return (M.Inj ident t')) cs --- addOutputData $ M.Data t' cs' - +-- | Monomorphize a constructor using it's global name. Constructors may +-- appear as expressions in the tree, or as patterns in case-expressions. morphCons :: M.Type -> Ident -> EnvM () morphCons expectedType ident = do maybeD <- getInputData ident @@ -177,34 +165,30 @@ morphCons expectedType ident = do Nothing -> error $ "identifier '" ++ show ident ++ "' not found" Just d -> do modify (\output -> Map.insert ident (Data expectedType d) output ) - -- Find the polymorphic type of cons --- case findConsType d ident of --- Nothing -> error "didn't find constructor" --- Just consType -> do --- -- Map polymorphic types --- local (\env -> env { --- polys = Map.fromList (mapTypes consType expectedType) }) $ do --- TODO: detect internal errors here ---findConsType :: T.Data -> Ident -> Maybe T.Type ---findConsType (T.Data _ cs) name1 = foldl (\maybe (T.Inj name2 t) -> if name2 == name1 then Just t else maybe) Nothing cs - --- TODO: Change in tree so that these are the same. --- Converts Lit +-- | Converts literals from input to output tree. convertLit :: T.Lit -> M.Lit convertLit (T.LInt v) = M.LInt v convertLit (T.LChar v) = M.LChar v +-- | Monomorphizes an expression, given an expected type. morphExp :: M.Type -> T.Exp -> EnvM M.Exp morphExp expectedType exp = case exp of T.ELit lit -> return $ M.ELit (convertLit lit) -- Constructor T.EInj ident -> do return $ M.EVar ident - T.EApp e1 e2 -> do - morphApp M.EApp expectedType e1 e2 - T.EAdd e1 e2 -> do - morphApp M.EAdd expectedType e1 e2 + T.EApp (e1, _t1) (e2, t2) -> do + t2' <- getMonoFromPoly t2 + e2' <- morphExp t2' e2 + e1' <- morphExp (M.TFun t2' expectedType) e1 + return $ M.EApp (e1', M.TFun t2' expectedType) (e2', t2') + T.EAdd (e1, t1) (e2, t2) -> do + t1' <- getMonoFromPoly t1 + t2' <- getMonoFromPoly t2 + e1' <- morphExp t1' e1 + e2' <- morphExp t2' e2 + return $ M.EAdd (e1', expectedType) (e2', expectedType) T.EAbs ident (exp, t) -> local (\env -> env { locals = Set.insert ident (locals env) }) $ do t' <- getMonoFromPoly t morphExp t' exp @@ -231,18 +215,21 @@ morphExp expectedType exp = case exp of T.ELet (T.Bind {}) _ -> error "lets not possible yet" --- Morphing case-of +-- | Monomorphizes case-of branches. morphBranch :: T.Branch -> EnvM M.Branch morphBranch (T.Branch (p, pt) (e, et)) = do pt' <- getMonoFromPoly pt + trace ("pt':" ++ show pt') return () et' <- getMonoFromPoly et env <- ask (p', newLocals) <- morphPattern pt' (locals env) p - local (const env { locals = Set.union newLocals (locals env) }) $ do + trace ("MORBING RN: " ++ show newLocals) return () + trace ("MORBING2 RN: " ++ show p) return () + local (const env { locals = newLocals }) $ do e' <- morphExp et' e return $ M.Branch (p', pt') (e', et') --- Morphs pattern (patter -> expression), gives the newly bound local variables. +-- | Morphs pattern (pattern => expression), gives the newly bound local variables. morphPattern :: M.Type -> Set.Set Ident -> T.Pattern -> EnvM (M.Pattern, Set.Set Ident) morphPattern expectedType ls = \case T.PVar (ident, t) -> do t' <- getMonoFromPoly t @@ -255,10 +242,13 @@ morphPattern expectedType ls = \case return (M.PEnum ident, ls) T.PInj ident ps -> do morphCons expectedType ident let (M.TData tIdent ts) = expectedType + -- TODO: this is wrong! pairs <- mapM (\(pat, patT) -> morphPattern patT ls pat) (zip ps ts) - return (M.PInj ident (map fst pairs), Set.unions (map snd pairs)) + if length ts == length ps then + return (M.PCatch, Set.singleton $ Ident "$1y") + else return (M.PInj ident (map fst pairs), Set.unions (map snd pairs)) --- | Creates a new identifier for a function with an assigned type +-- | Creates a new identifier for a function with an assigned type. newFuncName :: M.Type -> T.Bind -> Ident newFuncName t (T.Bind (ident@(Ident bindName), _) _ _) = if bindName == "main" @@ -273,7 +263,7 @@ newName t (Ident str) = Ident $ str ++ "$" ++ newName' t newName' (M.TFun t1 t2) = newName' t1 ++ "_" ++ newName' t2 newName' (M.TData (Ident str) ts) = str ++ foldl (\s t -> s ++ "." ++ newName' t) "" ts --- Monomorphization step +-- | Monomorphization step. monomorphize :: T.Program -> O.Program monomorphize (T.Program defs) = removeDataTypes $ M.Program (getDefsFromOutput (runEnvM Map.empty (createEnv defs) monomorphize')) @@ -284,7 +274,7 @@ monomorphize (T.Program defs) = removeDataTypes $ M.Program (getDefsFromOutput morphBind (M.TLit $ Ident "Int") main return () --- | Runs and gives the output binds +-- | Runs and gives the output binds. runEnvM :: Output -> Env -> EnvM () -> Output runEnvM o env (EnvM stateM) = snd $ runReader (runStateT stateM o) env @@ -299,6 +289,10 @@ createEnv defs = Env { input = Map.fromList bindPairs, dataPairs :: [(Ident, T.Data)] dataPairs = (foldl (\acc d@(T.Data _ cs) -> map ((,d) . getConsName) cs ++ acc) [] . getDataFromDefs) defs +-- | Gets a top-lefel function name. +getBindName :: T.Bind -> Ident +getBindName (T.Bind (ident, _) _ _) = ident + -- Helper functions -- Gets custom data declarations form defs. getDataFromDefs :: [T.Def] -> [T.Data] @@ -325,7 +319,7 @@ getDefsFromOutput o = splitBindsAndData :: Output -> ([M.Bind], [(Ident, M.Type, T.Data)]) splitBindsAndData output = foldl (\(oBinds, oData) (ident, o) -> case o of - Incomplete -> error "internal bug in monomorphizer" + Marked -> error "internal bug in monomorphizer" Complete b -> (b:oBinds, oData) Data t d -> (oBinds, (ident, t, d):oData)) ([], []) @@ -344,26 +338,9 @@ createNewData ((consIdent, consType, polyData):input) o = newDataName = newName newDataType polyDataIdent newCons = M.Inj consIdent consType +-- | Gets the Data Type of a constructor type (a -> Just a becomes Just a). getDataType :: M.Type -> M.Type getDataType (M.TFun t1 t2) = getDataType t2 getDataType tData@(M.TData _ _) = tData getDataType _ = error "???" --- | Converts all found constructors to monomorphic data declarations. --- cons->data process data.name -> data ---createNewData :: [(Ident, M.Type, T.Data)] -> Map.Map Ident M.Data -> EnvM (Map.Map Ident M.Data) ---createNewData [] o = return o ---createNewData ((ident, expectedType, T.Data dt pcs):cs) o = case dt of --- T.TData dIdent _ -> do --- let newCons = M.Inj (newName expectedType ident) expectedType --- case Map.lookup dIdent o of --- Nothing -> do --- createNewData cs $ Map.insert ident (M.Data (M.TLit $ Ident "void") [newCons]) o --- Just _ -> do --- createNewData cs $ Map.adjust (\(M.Data _ pcs') -> --- M.Data expectedType (newCons : pcs')) ident o --- _ -> error "internal bug in monomorphizer" - -getBindName :: T.Bind -> Ident -getBindName (T.Bind (ident, _) _ _) = ident - From 4bd5801c97d8c20c6602c6a40529433fe421db8c Mon Sep 17 00:00:00 2001 From: Rakarake Date: Tue, 18 Apr 2023 15:52:33 +0200 Subject: [PATCH 302/372] Removed traces --- src/Monomorphizer/Monomorphizer.hs | 4 ---- 1 file changed, 4 deletions(-) diff --git a/src/Monomorphizer/Monomorphizer.hs b/src/Monomorphizer/Monomorphizer.hs index f00da9a..86a05b6 100644 --- a/src/Monomorphizer/Monomorphizer.hs +++ b/src/Monomorphizer/Monomorphizer.hs @@ -130,7 +130,6 @@ morphBind expectedType b@(T.Bind (Ident str, btype) args (exp, expt)) = polys = Map.fromList (mapTypes btype expectedType) }) $ do -- The "new name" is used to find out if it is already marked or not. - trace ("Inside of bind: " ++ str) return () let name' = newFuncName expectedType b bindMarked <- isBindMarked (coerce name') -- Return with right name if already marked @@ -219,12 +218,9 @@ morphExp expectedType exp = case exp of morphBranch :: T.Branch -> EnvM M.Branch morphBranch (T.Branch (p, pt) (e, et)) = do pt' <- getMonoFromPoly pt - trace ("pt':" ++ show pt') return () et' <- getMonoFromPoly et env <- ask (p', newLocals) <- morphPattern pt' (locals env) p - trace ("MORBING RN: " ++ show newLocals) return () - trace ("MORBING2 RN: " ++ show p) return () local (const env { locals = newLocals }) $ do e' <- morphExp et' e return $ M.Branch (p', pt') (e', et') From 25075ccaacb5361d78d5014711aec15e56bb996f Mon Sep 17 00:00:00 2001 From: sebastianselander Date: Thu, 20 Apr 2023 15:36:36 +0200 Subject: [PATCH 303/372] added simple script for running benchmarks --- benchmark.py | 21 +++++++++++++++++++++ 1 file changed, 21 insertions(+) create mode 100755 benchmark.py diff --git a/benchmark.py b/benchmark.py new file mode 100755 index 0000000..40f0a15 --- /dev/null +++ b/benchmark.py @@ -0,0 +1,21 @@ +#!/bin/env/python3 + +import sys +import os +import time + +if __name__ == "__main__": + args = sys.argv + if len(args) == 1: + print ("first arg is number of loops second is exe") + else: + total = 0 + iter = int(args[1]) + for i in range(iter): + time_pre = time.time() + os.system("./" + args[2] + "> /dev/null") + time_post = time.time() + calc = time_post - time_pre + total += calc + + print ("File: " + args[2] + ", " + str(iter) + " runs gave average: " + str(total / iter) + "s") From 804d0da167dedf327fc5ff557c1b17038bd39661 Mon Sep 17 00:00:00 2001 From: Martin Fredin Date: Mon, 24 Apr 2023 10:10:15 +0200 Subject: [PATCH 304/372] Check number of arguments in pattern match --- src/ReportForall.hs | 2 -- src/TypeChecker/TypeCheckerBidir.hs | 5 ++++- 2 files changed, 4 insertions(+), 3 deletions(-) diff --git a/src/ReportForall.hs b/src/ReportForall.hs index 8ac8515..8b5e9db 100644 --- a/src/ReportForall.hs +++ b/src/ReportForall.hs @@ -66,5 +66,3 @@ rpProgram rf (Program defs) = do ECase e bs -> rpuExp e >> mapM_ rpuBranch bs _ -> pure () -reportAnyForall :: Program -> Err () -reportAnyForall = undefined diff --git a/src/TypeChecker/TypeCheckerBidir.hs b/src/TypeChecker/TypeCheckerBidir.hs index b62e587..9c90531 100644 --- a/src/TypeChecker/TypeCheckerBidir.hs +++ b/src/TypeChecker/TypeCheckerBidir.hs @@ -396,10 +396,13 @@ checkPattern patt t_patt = case patt of -- Γ ⊢ K p₁ p₂ ↑ B ⊣ Δ PInj name ps -> do t_inj <- maybeToRightM "unknown constructor" =<< lookupInj name + let ps' = getParams t_inj + unless (length ps' == length ps) $ + throwError "Wrong number of arguments!" sub <- substituteTVarsOf t_inj subtype (sub $ getDataId t_inj) t_patt let checkP p t = checkPattern p =<< apply (sub t) - ps' <- zipWithM checkP ps $ getParams t_inj + ps' <- zipWithM checkP ps ps' apply (T.PInj (coerce name) (map fst ps'), t_patt) where substituteTVarsOf = \case From 2d96a50219f883344e00a1f23f275b2a141ffc4e Mon Sep 17 00:00:00 2001 From: Martin Fredin Date: Mon, 24 Apr 2023 10:47:33 +0200 Subject: [PATCH 305/372] Change name --- src/TypeChecker/TypeCheckerBidir.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/TypeChecker/TypeCheckerBidir.hs b/src/TypeChecker/TypeCheckerBidir.hs index 9c90531..9682f7b 100644 --- a/src/TypeChecker/TypeCheckerBidir.hs +++ b/src/TypeChecker/TypeCheckerBidir.hs @@ -396,13 +396,13 @@ checkPattern patt t_patt = case patt of -- Γ ⊢ K p₁ p₂ ↑ B ⊣ Δ PInj name ps -> do t_inj <- maybeToRightM "unknown constructor" =<< lookupInj name - let ps' = getParams t_inj - unless (length ps' == length ps) $ + let ts = getParams t_inj + unless (length ts' == length ps) $ throwError "Wrong number of arguments!" sub <- substituteTVarsOf t_inj subtype (sub $ getDataId t_inj) t_patt let checkP p t = checkPattern p =<< apply (sub t) - ps' <- zipWithM checkP ps ps' + ps' <- zipWithM checkP ps ts apply (T.PInj (coerce name) (map fst ps'), t_patt) where substituteTVarsOf = \case From b5384bf2c356c8ac8339c380e5f3cd331167306d Mon Sep 17 00:00:00 2001 From: Martin Fredin Date: Tue, 25 Apr 2023 13:22:33 +0200 Subject: [PATCH 306/372] Fix typo --- src/TypeChecker/TypeCheckerBidir.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/TypeChecker/TypeCheckerBidir.hs b/src/TypeChecker/TypeCheckerBidir.hs index 9682f7b..fb9e93d 100644 --- a/src/TypeChecker/TypeCheckerBidir.hs +++ b/src/TypeChecker/TypeCheckerBidir.hs @@ -397,7 +397,7 @@ checkPattern patt t_patt = case patt of PInj name ps -> do t_inj <- maybeToRightM "unknown constructor" =<< lookupInj name let ts = getParams t_inj - unless (length ts' == length ps) $ + unless (length ts == length ps) $ throwError "Wrong number of arguments!" sub <- substituteTVarsOf t_inj subtype (sub $ getDataId t_inj) t_patt From 9ffcbf66b99adbfc72639b7ce3d1e13d8f1af302 Mon Sep 17 00:00:00 2001 From: Samuel Hammersberg Date: Tue, 18 Apr 2023 15:28:03 +0200 Subject: [PATCH 307/372] Added support for running GC profiller. --- src/Codegen/CompilerState.hs | 2 ++ src/Codegen/Emits.hs | 6 +++++- 2 files changed, 7 insertions(+), 1 deletion(-) diff --git a/src/Codegen/CompilerState.hs b/src/Codegen/CompilerState.hs index 3aa4123..114a651 100644 --- a/src/Codegen/CompilerState.hs +++ b/src/Codegen/CompilerState.hs @@ -138,4 +138,6 @@ defaultStart = , UnsafeRaw "declare external void @cheap_init()\n" , UnsafeRaw "declare external ptr @cheap_alloc(i64)\n" , UnsafeRaw "declare external void @cheap_dispose()\n" + , UnsafeRaw "declare external ptr @cheap_the()\n" + , UnsafeRaw "declare external void @cheap_set_profiler(ptr, i1)\n" ] \ No newline at end of file diff --git a/src/Codegen/Emits.hs b/src/Codegen/Emits.hs index 0309514..481af4f 100644 --- a/src/Codegen/Emits.hs +++ b/src/Codegen/Emits.hs @@ -127,7 +127,11 @@ compileScs (MIR.DData (MIR.Data typ ts) : xs) = do compileScs xs firstMainContent :: [LLVMIr] -firstMainContent = [UnsafeRaw "call void @cheap_init()\n"] +firstMainContent = + [ UnsafeRaw "%prof = call ptr @cheap_the()\n" + , UnsafeRaw "call void @cheap_set_profiler(ptr %prof, i1 true)\n" + , UnsafeRaw "call void @cheap_init()\n" + ] lastMainContent :: LLVMValue -> [LLVMIr] lastMainContent var = From e138cb27ecb0201098f0a98cafb5232f3e6d5397 Mon Sep 17 00:00:00 2001 From: Martin Fredin Date: Tue, 25 Apr 2023 22:59:33 +0200 Subject: [PATCH 308/372] Simplify pattern matching --- src/TypeChecker/TypeCheckerBidir.hs | 287 +++++++++++----------------- 1 file changed, 110 insertions(+), 177 deletions(-) diff --git a/src/TypeChecker/TypeCheckerBidir.hs b/src/TypeChecker/TypeCheckerBidir.hs index fb9e93d..9222755 100644 --- a/src/TypeChecker/TypeCheckerBidir.hs +++ b/src/TypeChecker/TypeCheckerBidir.hs @@ -4,19 +4,18 @@ {-# LANGUAGE PatternSynonyms #-} {-# OPTIONS_GHC -Wno-incomplete-patterns #-} -module TypeChecker.TypeCheckerBidir (typecheck, getVars) where +module TypeChecker.TypeCheckerBidir (typecheck) where -import Auxiliary (int, liftMM2, litType, - maybeToRightM, onM, onMM, snoc) -import Control.Applicative (Alternative, Applicative (liftA2), - (<|>)) +import Auxiliary (int, litType, maybeToRightM, snoc) +import Control.Applicative (Applicative (liftA2), (<|>)) import Control.Monad.Except (ExceptT, MonadError (throwError), runExceptT, unless, zipWithM, zipWithM_) -import Control.Monad.Extra (fromMaybeM, maybeM) +import Control.Monad.Extra (fromMaybeM) import Control.Monad.State (MonadState, State, evalState, gets, modify) import Data.Coerce (coerce) +import Data.Foldable (foldlM) import Data.Function (on) import Data.List (intercalate) import Data.Map (Map) @@ -38,7 +37,8 @@ import qualified TypeChecker.TypeCheckerIr as T -- -- TODO -- • Fix problems with types in Pattern/Branch in TypeCheckerIr --- • Fix the different type getters functions (e.g. partitionType) functions +-- • Remove EAdd +-- • Add kinds!! data EnvElem = EnvVar LIdent Type -- ^ Term variable typing. x : A | EnvTVar TVar -- ^ Universal type variable. α @@ -140,7 +140,7 @@ typecheckInj :: Inj -> UIdent -> [TVar] -> Err (T.Inj' Type) typecheckInj (Inj inj_name inj_typ) name tvars | not $ boundTVars tvars inj_typ = throwError "Unbound type variables" - | TData name' typs <- getReturn inj_typ + | TData name' typs <- getDataId inj_typ , name' == name , Right tvars' <- mapM toTVar typs , all (`elem` tvars) tvars' @@ -149,7 +149,7 @@ typecheckInj (Inj inj_name inj_typ) name tvars = throwError $ unwords ["Bad type constructor: ", show name , "\nExpected: ", ppT . TData name $ map TVar tvars - , "\nActual: ", ppT $ getReturn inj_typ + , "\nActual: ", ppT $ getDataId inj_typ ] where boundTVars :: [TVar] -> Type -> Bool @@ -161,6 +161,8 @@ typecheckInj (Inj inj_name inj_typ) name tvars TLit _ -> True TEVar _ -> error "TEVar in data type declaration" + + --------------------------------------------------------------------------- -- * Typing rules --------------------------------------------------------------------------- @@ -200,10 +202,72 @@ check e b = do subtype a b' apply (e', b) +checkPattern :: Pattern -> Type -> Tc (T.Pattern' Type, Type) +checkPattern patt t_patt = case patt of + + -- ------------------- + -- Γ ⊢ x ↑ A ⊣ Γ,(x:A) + PVar x -> do + insertEnv $ EnvVar x t_patt + apply (T.PVar (coerce x, t_patt), t_patt) + + -- ------------- + -- Γ ⊢ _ ↑ A ⊣ Γ + PCatch -> apply (T.PCatch, t_patt) + + -- Γ ⊢ τ ↓ A ⊣ Γ Γ ⊢ A <: B ⊣ Δ + -- ------------------------------ + -- Γ ⊢ τ ↑ B ⊣ Δ + PLit lit -> do + subtype (litType lit) t_patt + apply (T.PLit (lit, t_patt), t_patt) + + -- Γ ∋ (K : A) Γ ⊢ A <: B ⊣ Δ + -- --------------------------- + -- Γ ⊢ K ↑ B ⊣ Δ + PEnum name -> do + t <- maybeToRightM ("Unknown constructor " ++ show name) + =<< lookupInj name + subtype t t_patt + apply (T.PEnum (coerce name), t_patt) + + -- Example + -- Γ ∋ (K : A) let A = ∀α. A₁ -> A₂ -> Tτs + -- Γ ⊢ [ά/α]Tτs <: B ⊣ Θ₁ + -- Θ ⊢ p₁ ↑ [Θ][ά/α]A₁ ⊣ Θ₂ + -- Θ₂ ⊢ p₂ ↑ [Θ₂][ά/α]A₂ ⊣ Δ + -- --------------------------- + -- Γ ⊢ K p₁ p₂ ↑ B ⊣ Δ + PInj name ps -> do + t_inj <- maybeToRightM "unknown constructor" =<< lookupInj name + let ts = getArgs t_inj + unless (length ts == length ps) + $ throwError "Wrong number of arguments!" + + -- [ά/α] + sub <- substituteTVarsOf t_inj + subtype (sub $ getDataId t_inj) t_patt + let check p t = checkPattern p =<< apply (sub t) + ps' <- zipWithM check ps ts + apply (T.PInj (coerce name) (map fst ps'), t_patt) + where + substituteTVarsOf = \case + TAll tvar t -> do + tevar <- fresh + (substitute tvar tevar .) <$> substituteTVarsOf t + _ -> pure id + + getArgs = \case + TAll _ t -> getArgs t + t -> go [] t + where + go acc = \case + TFun t1 t2 -> go (snoc t1 acc) t2 + _ -> acc + -- | Γ ⊢ e ↓ A ⊣ Δ -- Under input context Γ, e infers output type A, with output context ∆ infer :: Exp -> Tc (T.ExpT' Type) - infer (ELit lit) = apply (T.ELit lit, litType lit) -- Γ ∋ (x : A) Γ ∌ (x : A) @@ -273,14 +337,23 @@ infer (EAdd e1 e2) = do e2' <- check e2 int apply (T.EAdd e1' e2', int) --- Θ ⊢ Π ∷ A ↓ C ⊣ Δ --- Γ ⊢ e ↓ A ⊣ Θ Δ ⊢ Π covers [Δ]A TODO --- --------------------------------------- +-- Γ ⊢ e ↑ A ⊣ Θ Θ ⊢ Π ∷ [Θ]A ↑ C ⊣ Δ +-- ------------------------------------ Case -- Γ ⊢ case e of Π ↓ C ⊣ Δ -infer (ECase scrut branches) = do - (scrut', t_scrut) <- infer scrut - (branches', t_return) <- inferBranches branches t_scrut - apply (T.ECase (scrut', t_scrut) branches', t_return) +infer (ECase scrut pi) = do + (scrut', a) <- infer scrut + case pi of + [] -> apply (T.ECase (scrut', a) [], a) + (Branch _ e):_ -> do + (_, c)<- infer e + (pi', c') <- foldlM go ([], c) pi + apply (T.ECase (scrut', a) pi', c') + where + go (bs, c) (Branch p e) = do + p' <- checkPattern p =<< apply a + e'@(_, c') <- infer e + subtype c' c + apply (T.Branch p' e' : bs, c') -- | Γ ⊢ A • e ⇓ C ⊣ Δ -- Under input context Γ , applying a function of type A to e infers type C, with output context ∆ @@ -319,112 +392,6 @@ applyInfer (TFun a c) e = do applyInfer a e = throwError ("Cannot apply type " ++ show a ++ " with expression " ++ show e) ---------------------------------------------------------------------------- --- * Pattern matching ---------------------------------------------------------------------------- - --- Γ ⊢ p ⇒ e ∷ A ↓ B ⊣ Θ --- Θ ⊢ Π ∷ [Θ]A ↓ C ⊣ Δ --- [Δ]B <: C --- --------------------------- --- Γ ⊢ (p ⇒ e),Π ∷ A ↓ C ⊣ Δ -inferBranches :: [Branch] -> Type -> Tc ([T.Branch' Type], Type) -inferBranches branches t_patt = do - (branches', ts_exp) <- inferBranches' t_patt branches - t_exp <- case ts_exp of - [] -> pure t_patt - t:_ -> do - zipWithM_ (onMM subtype apply) (init ts_exp) (tail ts_exp) - apply t - apply (branches', t_exp) - where - - inferBranches' = go [] [] - where - go branches ts_exp t = \case - [] -> pure (branches, ts_exp) - b:bs -> do - (b', t_e) <- inferBranch b t - t' <- apply t - go (snoc b' branches) (snoc t_e ts_exp) t' bs - --- Γ ⊢ p ↑ A ⊣ Θ Θ ⊢ e ↓ C ⊣ Δ --- ------------------------------- --- Γ ⊢ p ⇒ e ∷ A ↓ C ⊣ Δ -inferBranch :: Branch -> Type -> Tc (T.Branch' Type, Type) -inferBranch (Branch patt exp) t_patt = do - patt' <- checkPattern patt t_patt - (exp', t_exp) <- infer exp - apply (T.Branch patt' (exp', t_exp), t_exp) - -checkPattern :: Pattern -> Type -> Tc (T.Pattern' Type, Type) -checkPattern patt t_patt = case patt of - - -- ------------------- - -- Γ ⊢ x ↑ A ⊣ Γ,(x:A) - PVar x -> do - insertEnv $ EnvVar x t_patt - apply (T.PVar (coerce x, t_patt), t_patt) - - -- ------------- - -- Γ ⊢ _ ↑ A ⊣ Γ - PCatch -> apply (T.PCatch, t_patt) - - -- Γ ⊢ τ ↓ A ⊣ Γ Γ ⊢ A <: B ⊣ Δ - -- ------------------------------ - -- Γ ⊢ τ ↑ B ⊣ Δ - PLit lit -> do - subtype (litType lit) t_patt - apply (T.PLit (lit, t_patt), t_patt) - - -- Γ ∋ (K : A) Γ ⊢ A <: B ⊣ Δ - -- --------------------------- - -- Γ ⊢ K ↑ B ⊣ Δ - PEnum name -> do - t <- maybeToRightM ("Unknown constructor " ++ show name) - =<< lookupInj name - subtype t t_patt - apply (T.PEnum (coerce name), t_patt) - - - -- Example - -- Γ ∋ (K : A) let A = ∀α. A₁ -> A₂ -> Tτs - -- Γ ⊢ [ά/α]Tτs <: B ⊣ Θ₁ - -- Θ ⊢ p₁ ↑ [Θ][ά/α]A₁ ⊣ Θ₂ - -- Θ ⊢ p₂ ↑ [Θ][ά/α]A₂ ⊣ Δ - -- --------------------------- - -- Γ ⊢ K p₁ p₂ ↑ B ⊣ Δ - PInj name ps -> do - t_inj <- maybeToRightM "unknown constructor" =<< lookupInj name - let ts = getParams t_inj - unless (length ts == length ps) $ - throwError "Wrong number of arguments!" - sub <- substituteTVarsOf t_inj - subtype (sub $ getDataId t_inj) t_patt - let checkP p t = checkPattern p =<< apply (sub t) - ps' <- zipWithM checkP ps ts - apply (T.PInj (coerce name) (map fst ps'), t_patt) - where - substituteTVarsOf = \case - TAll tvar t -> do - tevar <- fresh - (substitute tvar tevar .) <$> substituteTVarsOf t - _ -> pure id - - getParams = \case - TAll _ t -> getParams t - t -> go [] t - where - go acc = \case - TFun t1 t2 -> go (snoc t1 acc) t2 - _ -> acc - - getDataId typ = case typ of - TAll _ t -> getDataId t - TFun _ t -> getDataId t - TData {} -> typ - - --------------------------------------------------------------------------- -- * Subtyping rules --------------------------------------------------------------------------- @@ -482,7 +449,6 @@ subtype (TEVar alpha) a | notElem alpha $ frees a = instantiateL alpha a -- Γ[ά] ⊢ A <: ά ⊣ Δ subtype a (TEVar alpha) | notElem alpha $ frees a = instantiateR a alpha - subtype t1 t2 = case (t1, t2) of (TData name1 typs1, TData name2 typs2) @@ -564,14 +530,13 @@ instantiateL alpha a = gets env >>= \env -> go env alpha a putEnv env_l go _ alpha a = error $ "Trying to instantiateL: " ++ ppT (TEVar alpha) - ++ " <: " ++ ppT a + ++ " <: " ++ ppT a -- | Γ ⊢ A =:< ά ⊣ Δ -- Under input context Γ, instantiate ά such that A <: ά, with output context ∆ instantiateR :: Type -> TEVar -> Tc () instantiateR a alpha = gets env >>= \env -> go env a alpha where - -- Γ ⊢ τ -- ----------------------------- InstRSolve -- Γ,ά,Γ' ⊢ τ =:< ά ⊣ Γ,(ά=τ),Γ' @@ -588,11 +553,9 @@ instantiateR a alpha = gets env >>= \env -> go env a alpha let (env_l, env_r) = splitOn (EnvTEVar epsilon) env putEnv $ (env_l :|> EnvTEVarSolved epsilon (TEVar alpha)) <> env_r - - - -- Γ[ά₂ά₁,(ά=ά₁→ά₂)] ⊢ A₁ :=< ά₁ ⊣ Θ Θ ⊢ ά₂ =:< [Θ]A₂ ⊣ Δ - -- ------------------------------------------------------- InstRArr - -- Γ[ά] ⊢ A₁ → A₂ =:< ά ⊣ Δ + -- Γ[ά₂ά₁,(ά=ά₁→ά₂)] ⊢ A₁ :=< ά₁ ⊣ Θ Θ ⊢ ά₂ =:< [Θ]A₂ ⊣ Δ + -- ------------------------------------------------------- InstRArr + -- Γ[ά] ⊢ A₁ → A₂ =:< ά ⊣ Δ go _ (TFun a1 a2) alpha = do alpha1 <- fresh alpha2 <- fresh @@ -603,24 +566,19 @@ instantiateR a alpha = gets env >>= \env -> go env a alpha a2' <- apply a2 instantiateR a2' alpha2 - - - -- Γ[ά],▶έ,ε ⊢ [έ/ε]E =:< ά ⊣ Δ,▶έ,Δ' - -- ---------------------------------- InstRAIIL - -- Γ[ά] ⊢ ∀ε.Ε =:< ά ⊣ Δ + -- Γ[ά],▶έ,ε ⊢ [έ/ε]E =:< ά ⊣ Δ,▶έ,Δ' + -- ---------------------------------- InstRAIIL + -- Γ[ά] ⊢ ∀ε.Ε =:< ά ⊣ Δ go env (TAll epsilon e) alpha = do - epsilon' <- fresh - insertEnv $ EnvMark epsilon' - insertEnv $ EnvTVar epsilon - instantiateR (substitute epsilon epsilon' e) alpha - let (env_l, _) = splitOn (EnvMark epsilon') env - putEnv env_l + epsilon' <- fresh + insertEnv $ EnvMark epsilon' + insertEnv $ EnvTVar epsilon + instantiateR (substitute epsilon epsilon' e) alpha + let (env_l, _) = splitOn (EnvMark epsilon') env + putEnv env_l go _ a alpha = error $ "Trying to instantiateR: " ++ ppT a ++ " <: " - ++ ppT (TEVar alpha) - - - + ++ ppT (TEVar alpha) --------------------------------------------------------------------------- -- * Auxiliary @@ -713,35 +671,6 @@ fresh = do modify $ \cxt -> cxt { next_tevar = succ cxt.next_tevar } pure tevar -getVars :: Type -> [Type] -getVars = fst . partitionType - -getReturn :: Type -> Type -getReturn = snd . partitionType - --- | Partion type into variable types and return type. --- --- ∀a.∀b. a → (∀c. c → c) → b --- ([a, ∀c. c → c], b) --- --- Unsure if foralls should be added to the return type or not. --- FIXME -partitionType :: Type -> ([Type], Type) -partitionType = go [] . skipForalls' - where - go acc t = case t of - TFun t1 t2 -> go (snoc t1 acc) t2 - _ -> (acc, t) - -skipForalls' :: Type -> Type -skipForalls' = snd . skipForalls - -skipForalls :: Type -> ([Type -> Type], Type) -skipForalls = go [] - where - go acc typ = case typ of - TAll tvar t -> go (snoc (TAll tvar) acc) t - _ -> (acc, typ) isComplete :: Env -> Bool isComplete = isNothing . S.findIndexL unSolvedTEVar @@ -750,6 +679,12 @@ isComplete = isNothing . S.findIndexL unSolvedTEVar EnvTEVar _ -> True _ -> False +getDataId :: Type -> Type +getDataId typ = case typ of + TAll _ t -> getDataId t + TFun _ t -> getDataId t + TData {} -> typ + toTVar :: Type -> Err TVar toTVar = \case TVar tvar -> pure tvar @@ -764,7 +699,6 @@ lookupSig x = gets (Map.lookup x . sig) insertSig :: LIdent -> Type -> Tc () insertSig name t = modify $ \cxt -> cxt { sig = Map.insert name t cxt.sig } - lookupEnv :: LIdent -> Tc (Maybe Type) lookupEnv x = gets (findId . env) where @@ -786,7 +720,6 @@ modifyEnv f = pattern DBind' name vars exp = DBind (Bind name vars exp) pattern DSig' name typ = DSig (Sig name typ) - --------------------------------------------------------------------------- -- * Apply --------------------------------------------------------------------------- From 2cb852784844eb2c8451b25e2f7df5a4d9c11db7 Mon Sep 17 00:00:00 2001 From: Martin Fredin Date: Tue, 25 Apr 2023 23:02:56 +0200 Subject: [PATCH 309/372] Rename variables --- src/TypeChecker/TypeCheckerBidir.hs | 15 ++++++++------- 1 file changed, 8 insertions(+), 7 deletions(-) diff --git a/src/TypeChecker/TypeCheckerBidir.hs b/src/TypeChecker/TypeCheckerBidir.hs index 9222755..615169b 100644 --- a/src/TypeChecker/TypeCheckerBidir.hs +++ b/src/TypeChecker/TypeCheckerBidir.hs @@ -337,6 +337,7 @@ infer (EAdd e1 e2) = do e2' <- check e2 int apply (T.EAdd e1' e2', int) + --FIXME -- Γ ⊢ e ↑ A ⊣ Θ Θ ⊢ Π ∷ [Θ]A ↑ C ⊣ Δ -- ------------------------------------ Case -- Γ ⊢ case e of Π ↓ C ⊣ Δ @@ -345,15 +346,15 @@ infer (ECase scrut pi) = do case pi of [] -> apply (T.ECase (scrut', a) [], a) (Branch _ e):_ -> do - (_, c)<- infer e - (pi', c') <- foldlM go ([], c) pi - apply (T.ECase (scrut', a) pi', c') + (_, b)<- infer e + (pi', b') <- foldlM go ([], b) pi + apply (T.ECase (scrut', a) pi', b') where - go (bs, c) (Branch p e) = do + go (pi, b) (Branch p e) = do p' <- checkPattern p =<< apply a - e'@(_, c') <- infer e - subtype c' c - apply (T.Branch p' e' : bs, c') + e'@(_, b') <- infer e + subtype b' b + apply (T.Branch p' e' : pi, b') -- | Γ ⊢ A • e ⇓ C ⊣ Δ -- Under input context Γ , applying a function of type A to e infers type C, with output context ∆ From fd418faa5fe3c65b31a4bdb4ad779bf307765e58 Mon Sep 17 00:00:00 2001 From: sebastianselander Date: Thu, 27 Apr 2023 12:18:56 +0200 Subject: [PATCH 310/372] introduced lt in prelude --- src/Main.hs | 155 ++++++++++++++++++++++++++++------------------------ 1 file changed, 83 insertions(+), 72 deletions(-) diff --git a/src/Main.hs b/src/Main.hs index b5e5a3f..338272d 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -1,39 +1,47 @@ {-# LANGUAGE OverloadedRecordDot #-} - module Main where -import AnnForall (annotateForall) -import Codegen.Codegen (generateCode) -import Compiler (compile) -import Control.Monad (when, (<=<)) -import Data.List.Extra (isSuffixOf) -import Data.Maybe (fromJust, isNothing) -import Desugar.Desugar (desugar) -import GHC.IO.Handle.Text (hPutStrLn) -import Grammar.ErrM (Err) -import Grammar.Layout (resolveLayout) -import Grammar.Par (myLexer, pProgram) -import Grammar.Print (Print, printTree) -import LambdaLifter (lambdaLift) -import Monomorphizer.Monomorphizer (monomorphize) -import Renamer.Renamer (rename) -import ReportForall (reportForall) -import System.Console.GetOpt (ArgDescr (NoArg, ReqArg), - ArgOrder (RequireOrder), - OptDescr (Option), getOpt, - usageInfo) -import System.Directory (createDirectory, doesPathExist, - getDirectoryContents, - removeDirectoryRecursive, - setCurrentDirectory) -import System.Environment (getArgs) -import System.Exit (ExitCode (ExitFailure), - exitFailure, exitSuccess, - exitWith) -import System.IO (stderr) -import System.Process (spawnCommand, waitForProcess) -import TypeChecker.TypeChecker (TypeChecker (Bi, Hm), typecheck) +import AnnForall (annotateForall) +import Codegen.Codegen (generateCode) +import Compiler (compile) +import Control.Monad (when, (<=<)) +import Data.List.Extra (isSuffixOf) +import Data.Maybe (fromJust, isNothing) +import Desugar.Desugar (desugar) +import GHC.IO.Handle.Text (hPutStrLn) +import Grammar.ErrM (Err) +import Grammar.Layout (resolveLayout) +import Grammar.Par (myLexer, pProgram) +import Grammar.Print (Print, printTree) +import LambdaLifter (lambdaLift) +import Monomorphizer.Monomorphizer (monomorphize) +import Renamer.Renamer (rename) +import ReportForall (reportForall) +import System.Console.GetOpt ( + ArgDescr (NoArg, ReqArg), + ArgOrder (RequireOrder), + OptDescr (Option), + getOpt, + usageInfo, + ) +import System.Directory ( + createDirectory, + doesPathExist, + getDirectoryContents, + removeDirectoryRecursive, + setCurrentDirectory, + ) +import System.Environment (getArgs) +import System.Exit ( + ExitCode (ExitFailure), + exitFailure, + exitSuccess, + exitWith, + ) +import System.IO (stderr) +import System.Process (spawnCommand, waitForProcess) +import TypeChecker.TypeChecker (TypeChecker (Bi, Hm), typecheck) main :: IO () main = getArgs >>= parseArgs >>= uncurry main' @@ -80,63 +88,64 @@ chooseTypechecker s options = options{typechecker = tc} tc = case s of "hm" -> pure Hm "bi" -> pure Bi - _ -> Nothing + _ -> Nothing data Options = Options - { help :: Bool - , debug :: Bool + { help :: Bool + , debug :: Bool , typechecker :: Maybe TypeChecker } main' :: Options -> String -> IO () main' opts s = - let - log :: (Print a, Show a) => a -> IO () - log = printToErr . if opts.debug then show else printTree - in do - file <- readFile s + let + log :: (Print a, Show a) => a -> IO () + log = printToErr . if opts.debug then show else printTree + in + do + file <- readFile s - printToErr "-- Parse Tree -- " - parsed <- fromErr . pProgram . resolveLayout True $ myLexer file - log parsed + printToErr "-- Parse Tree -- " + parsed <- fromErr . pProgram . resolveLayout True $ myLexer (file ++ prelude) + log parsed - printToErr "-- Desugar --" - let desugared = desugar parsed - log desugared + printToErr "-- Desugar --" + let desugared = desugar parsed + log desugared - printToErr "\n-- Renamer --" - _ <- fromErr $ reportForall (fromJust opts.typechecker) desugared - renamed <- fromErr $ (rename <=< annotateForall) desugared - log renamed + printToErr "\n-- Renamer --" + _ <- fromErr $ reportForall (fromJust opts.typechecker) desugared + renamed <- fromErr $ (rename <=< annotateForall) desugared + log renamed - printToErr "\n-- TypeChecker --" - typechecked <- fromErr $ typecheck (fromJust opts.typechecker) renamed - log typechecked + printToErr "\n-- TypeChecker --" + typechecked <- fromErr $ typecheck (fromJust opts.typechecker) renamed + log typechecked - printToErr "\n-- Lambda Lifter --" - let lifted = lambdaLift typechecked - log lifted + printToErr "\n-- Lambda Lifter --" + let lifted = lambdaLift typechecked + log lifted - printToErr "\n -- Monomorphizer --" - let monomorphized = monomorphize lifted - log monomorphized + printToErr "\n -- Monomorphizer --" + let monomorphized = monomorphize lifted + log monomorphized - printToErr "\n -- Compiler --" - generatedCode <- fromErr $ generateCode monomorphized + printToErr "\n -- Compiler --" + generatedCode <- fromErr $ generateCode monomorphized - check <- doesPathExist "output" - when check (removeDirectoryRecursive "output") - createDirectory "output" - when opts.debug $ do - writeFile "output/llvm.ll" generatedCode - debugDotViz + check <- doesPathExist "output" + when check (removeDirectoryRecursive "output") + createDirectory "output" + when opts.debug $ do + writeFile "output/llvm.ll" generatedCode + debugDotViz - compile generatedCode - printToErr "Compilation done!" - printToErr "\n-- Program output --" - print =<< spawnWait "./output/hello_world" + compile generatedCode + printToErr "Compilation done!" + printToErr "\n-- Program output --" + print =<< spawnWait "./output/hello_world" - exitSuccess + exitSuccess debugDotViz :: IO () debugDotViz = do @@ -156,3 +165,5 @@ printToErr = hPutStrLn stderr fromErr :: Err a -> IO a fromErr = either (\s -> printToErr s >> exitFailure) pure + +prelude = "const x y = x\n\ndata Bool () where\n True : Bool ()\n False : Bool ()\n\nlt : Int -> Int -> Bool ()\nlt = \\x. \\y. const True (x + y)" From fc306d5f25be99c90b001ac2a47beeb5cb62752f Mon Sep 17 00:00:00 2001 From: Martin Fredin Date: Thu, 27 Apr 2023 11:43:56 +0200 Subject: [PATCH 311/372] Fix pattern types --- src/TypeChecker/TypeCheckerIr.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/TypeChecker/TypeCheckerIr.hs b/src/TypeChecker/TypeCheckerIr.hs index 1ae41ab..e898ebe 100644 --- a/src/TypeChecker/TypeCheckerIr.hs +++ b/src/TypeChecker/TypeCheckerIr.hs @@ -37,11 +37,11 @@ newtype Ident = Ident String deriving (C.Eq, C.Ord, C.Show, C.Read, IsString) data Pattern' t - = PVar (Id' t) -- TODO should be Ident - | PLit (Lit, t) -- TODO should be Lit + = PVar Ident + | PLit Lit | PCatch | PEnum Ident - | PInj Ident [Pattern' t] -- TODO should be (Pattern' t, t) + | PInj Ident [(Pattern' t, t)] deriving (C.Eq, C.Ord, C.Show, C.Read, Functor) data Exp' t From 87825566039b51ef4a202be46115a541ac189402 Mon Sep 17 00:00:00 2001 From: Martin Fredin Date: Thu, 27 Apr 2023 12:22:20 +0200 Subject: [PATCH 312/372] Fix types in pattersgit add .git add . --- src/LambdaLifter.hs | 4 +- src/Monomorphizer/Monomorphizer.hs | 21 +++-- src/TypeChecker/RemoveForall.hs | 13 +-- src/TypeChecker/ReportTEVar.hs | 13 +-- src/TypeChecker/TypeCheckerBidir.hs | 13 ++- src/TypeChecker/TypeCheckerHm.hs | 134 ++++++++++++++-------------- src/TypeChecker/TypeCheckerIr.hs | 5 +- 7 files changed, 104 insertions(+), 99 deletions(-) diff --git a/src/LambdaLifter.hs b/src/LambdaLifter.hs index 67af030..dcd715b 100644 --- a/src/LambdaLifter.hs +++ b/src/LambdaLifter.hs @@ -86,8 +86,8 @@ freeVarsBranch localVars (Branch (patt, t) exp) = (frees, AnnBranch (patt, t) ex freeVarsOfPattern = Set.fromList . go [] where go acc = \case - PVar (n,_) -> snoc n acc - PInj _ ps -> foldl go acc ps + PVar n -> snoc n acc + PInj _ ps -> foldl go acc $ map fst ps diff --git a/src/Monomorphizer/Monomorphizer.hs b/src/Monomorphizer/Monomorphizer.hs index 86a05b6..c50a7cc 100644 --- a/src/Monomorphizer/Monomorphizer.hs +++ b/src/Monomorphizer/Monomorphizer.hs @@ -32,9 +32,8 @@ import TypeChecker.TypeCheckerIr (Ident (Ident)) import Control.Monad.Reader (MonadReader (ask, local), Reader, asks, runReader, when) -import Control.Monad.State (MonadState, - StateT (runStateT), gets, - modify) +import Control.Monad.State (MonadState, StateT (runStateT), + gets, modify) import Data.Coerce (coerce) import qualified Data.Map as Map import Data.Maybe (fromJust) @@ -50,7 +49,7 @@ newtype EnvM a = EnvM (StateT Output (Reader Env) a) type Output = Map.Map Ident Outputted --- | Data structure describing outputted top-level information, that is +-- | Data structure describing outputted top-level information, that is -- Binds, Polymorphic Data types (monomorphized in a later step) and -- Marked bind, which means that it is in the process of monomorphization -- and should not be monomorphized again. @@ -220,18 +219,18 @@ morphBranch (T.Branch (p, pt) (e, et)) = do pt' <- getMonoFromPoly pt et' <- getMonoFromPoly et env <- ask - (p', newLocals) <- morphPattern pt' (locals env) p + (p', newLocals) <- morphPattern pt' (locals env) (p, pt) local (const env { locals = newLocals }) $ do e' <- morphExp et' e return $ M.Branch (p', pt') (e', et') -- | Morphs pattern (pattern => expression), gives the newly bound local variables. -morphPattern :: M.Type -> Set.Set Ident -> T.Pattern -> EnvM (M.Pattern, Set.Set Ident) -morphPattern expectedType ls = \case - T.PVar (ident, t) -> do t' <- getMonoFromPoly t - return (M.PVar (ident, t'), Set.insert ident ls) - T.PLit (lit, t) -> do t' <- getMonoFromPoly t - return (M.PLit (convertLit lit, t'), ls) +morphPattern :: M.Type -> Set.Set Ident -> (T.Pattern, T.Type) -> EnvM (M.Pattern, Set.Set Ident) +morphPattern expectedType ls (p, t) = case p of + T.PVar ident -> do t' <- getMonoFromPoly t + return (M.PVar (ident, t'), Set.insert ident ls) + T.PLit lit -> do t' <- getMonoFromPoly t + return (M.PLit (convertLit lit, t'), ls) T.PCatch -> return (M.PCatch, ls) -- Constructor ident T.PEnum ident -> do morphCons expectedType ident diff --git a/src/TypeChecker/RemoveForall.hs b/src/TypeChecker/RemoveForall.hs index d4cdd81..886ecb0 100644 --- a/src/TypeChecker/RemoveForall.hs +++ b/src/TypeChecker/RemoveForall.hs @@ -30,13 +30,14 @@ removeForall (Program defs) = Program $ map (DData . rfData) ds ELit lit -> ELit lit EVar name -> EVar name EInj name -> EInj name - rfBranch (Branch (p, t) e) = Branch (rfPattern p, rfType t) (rfExpT e) + rfBranch (Branch p e) = Branch (rfPatternT p) (rfExpT e) + rfPatternT (p, t) = (rfPattern p, rfType t) rfPattern = \case - PVar id -> PVar (rfId id) - PLit (lit, t) -> PLit (lit, rfType t) - PCatch -> PCatch - PEnum name -> PEnum name - PInj name ps -> PInj name (map rfPattern ps) + PVar name -> PVar name + PLit lit -> PLit lit + PCatch -> PCatch + PEnum name -> PEnum name + PInj name ps -> PInj name (map rfPatternT ps) rfType :: R.Type -> Type rfType = \case diff --git a/src/TypeChecker/ReportTEVar.hs b/src/TypeChecker/ReportTEVar.hs index 61ed688..9676b8e 100644 --- a/src/TypeChecker/ReportTEVar.hs +++ b/src/TypeChecker/ReportTEVar.hs @@ -49,13 +49,16 @@ instance ReportTEVar (Exp' G.Type) (Exp' Type) where instance ReportTEVar (Branch' G.Type) (Branch' Type) where reportTEVar (Branch (patt, t_patt) e) = liftA2 Branch (liftA2 (,) (reportTEVar patt) (reportTEVar t_patt)) (reportTEVar e) +instance ReportTEVar (Pattern' G.Type, G.Type) (Pattern' Type, Type) where + reportTEVar (p, t) = liftA2 (,) (reportTEVar p) (reportTEVar t) + instance ReportTEVar (Pattern' G.Type) (Pattern' Type) where reportTEVar = \case - PVar (name, t) -> PVar . (name,) <$> reportTEVar t - PLit (lit, t) -> PLit . (lit,) <$> reportTEVar t - PCatch -> pure PCatch - PEnum name -> pure $ PEnum name - PInj name ps -> PInj name <$> reportTEVar ps + PVar name -> pure $ PVar name + PLit lit -> pure $ PLit lit + PCatch -> pure PCatch + PEnum name -> pure $ PEnum name + PInj name ps -> PInj name <$> reportTEVar ps instance ReportTEVar (Data' G.Type) (Data' Type) where reportTEVar (Data typ injs) = liftA2 Data (reportTEVar typ) (reportTEVar injs) diff --git a/src/TypeChecker/TypeCheckerBidir.hs b/src/TypeChecker/TypeCheckerBidir.hs index 615169b..714b4c9 100644 --- a/src/TypeChecker/TypeCheckerBidir.hs +++ b/src/TypeChecker/TypeCheckerBidir.hs @@ -209,7 +209,7 @@ checkPattern patt t_patt = case patt of -- Γ ⊢ x ↑ A ⊣ Γ,(x:A) PVar x -> do insertEnv $ EnvVar x t_patt - apply (T.PVar (coerce x, t_patt), t_patt) + apply (T.PVar (coerce x), t_patt) -- ------------- -- Γ ⊢ _ ↑ A ⊣ Γ @@ -220,7 +220,7 @@ checkPattern patt t_patt = case patt of -- Γ ⊢ τ ↑ B ⊣ Δ PLit lit -> do subtype (litType lit) t_patt - apply (T.PLit (lit, t_patt), t_patt) + apply (T.PLit lit, t_patt) -- Γ ∋ (K : A) Γ ⊢ A <: B ⊣ Δ -- --------------------------- @@ -249,7 +249,7 @@ checkPattern patt t_patt = case patt of subtype (sub $ getDataId t_inj) t_patt let check p t = checkPattern p =<< apply (sub t) ps' <- zipWithM check ps ts - apply (T.PInj (coerce name) (map fst ps'), t_patt) + apply (T.PInj (coerce name) ps', t_patt) where substituteTVarsOf = \case TAll tvar t -> do @@ -780,10 +780,9 @@ applyBranch (T.Branch (p, t) e) = do applyPattern :: T.Pattern' Type -> Tc (T.Pattern' Type) applyPattern = \case - T.PVar id -> T.PVar <$> apply id - T.PLit (lit, t) -> T.PLit . (lit, ) <$> apply t - T.PInj name ps -> T.PInj name <$> apply ps - p -> pure p + T.PVar id -> T.PVar <$> apply id + T.PInj name ps -> T.PInj name <$> apply ps + p -> pure p applyPair :: (Apply a, Apply b) => (a, b) -> Tc (a, b) applyPair (x, y) = liftA2 (,) (apply x) (apply y) diff --git a/src/TypeChecker/TypeCheckerHm.hs b/src/TypeChecker/TypeCheckerHm.hs index 1560f0d..5ef3f47 100644 --- a/src/TypeChecker/TypeCheckerHm.hs +++ b/src/TypeChecker/TypeCheckerHm.hs @@ -1,31 +1,31 @@ -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedRecordDot #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QualifiedDo #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QualifiedDo #-} -- | A module for type checking and inference using algorithm W, Hindley-Milner module TypeChecker.TypeCheckerHm where -import Auxiliary (int, litType, maybeToRightM, unzip4) -import Auxiliary qualified as Aux -import Control.Monad.Except -import Control.Monad.Identity (Identity, runIdentity) -import Control.Monad.Reader -import Control.Monad.State -import Control.Monad.Writer -import Data.Coerce (coerce) -import Data.Function (on) -import Data.List (foldl', nub, sortOn) -import Data.List.Extra (unsnoc) -import Data.Map (Map) -import Data.Map qualified as M -import Data.Maybe (fromJust) -import Data.Set (Set) -import Data.Set qualified as S -import Debug.Trace (trace) -import Grammar.Abs -import Grammar.Print (printTree) -import TypeChecker.TypeCheckerIr qualified as T +import Auxiliary (int, litType, maybeToRightM, unzip4) +import qualified Auxiliary as Aux +import Control.Monad.Except +import Control.Monad.Identity (Identity, runIdentity) +import Control.Monad.Reader +import Control.Monad.State +import Control.Monad.Writer +import Data.Coerce (coerce) +import Data.Function (on) +import Data.List (foldl', nub, sortOn) +import Data.List.Extra (unsnoc) +import Data.Map (Map) +import qualified Data.Map as M +import Data.Maybe (fromJust) +import Data.Set (Set) +import qualified Data.Set as S +import Debug.Trace (trace) +import Grammar.Abs +import Grammar.Print (printTree) +import qualified TypeChecker.TypeCheckerIr as T {- TODO @@ -40,7 +40,7 @@ typecheck :: Program -> Either String (T.Program' Type, [Warning]) typecheck = onLeft msg . run . checkPrg where onLeft :: (Error -> String) -> Either Error a -> Either String a - onLeft f (Left x) = Left $ f x + onLeft f (Left x) = Left $ f x onLeft _ (Right x) = Right x checkPrg :: Program -> Infer (T.Program' Type) @@ -67,13 +67,13 @@ prettify s (T.Program defs) = T.Program $ map (go s) defs replace :: Map T.Ident T.Ident -> Type -> Type replace m def@(TVar (MkTVar (LIdent a))) = case M.lookup (coerce a) m of - Just t -> TVar . MkTVar . LIdent $ coerce t + Just t -> TVar . MkTVar . LIdent $ coerce t Nothing -> def replace m (TFun t1 t2) = (TFun `on` replace m) t1 t2 replace m (TData name ts) = TData name (map (replace m) ts) replace m def@(TAll (MkTVar forall_) t) = case M.lookup (coerce forall_) m of Just found -> TAll (MkTVar $ coerce found) (replace m t) - Nothing -> def + Nothing -> def replace _ t = t bindCount :: [Def] -> Infer [(Int, Def)] @@ -127,7 +127,7 @@ preRun (x : xs) = case x of s <- gets sigs case M.lookup (coerce n) s of Nothing -> insertSig (coerce n) Nothing >> preRun xs - Just _ -> preRun xs + Just _ -> preRun xs DData d@(Data t _) -> collect (collectTVars t) >> checkData d >> preRun xs where -- Check if function body / signature has been declared already @@ -149,11 +149,11 @@ checkDef (x : xs) = case x of T.Data t $ map (\(Inj name typ) -> T.Inj (coerce name) typ) injs freeOrdered :: Type -> [T.Ident] -freeOrdered (TVar (MkTVar a)) = return (coerce a) +freeOrdered (TVar (MkTVar a)) = return (coerce a) freeOrdered (TAll (MkTVar bound) t) = return (coerce bound) ++ freeOrdered t -freeOrdered (TFun a b) = freeOrdered a ++ freeOrdered b -freeOrdered (TData _ a) = concatMap freeOrdered a -freeOrdered _ = mempty +freeOrdered (TFun a b) = freeOrdered a ++ freeOrdered b +freeOrdered (TData _ a) = concatMap freeOrdered a +freeOrdered _ = mempty checkBind :: Bind -> Infer (T.Bind' Type) checkBind (Bind name args e) = do @@ -227,11 +227,11 @@ checkInj (Inj c inj_typ) name tvars toTVar :: Type -> Either Error TVar toTVar = \case TVar tvar -> pure tvar - _ -> uncatchableErr "Not a type variable" + _ -> uncatchableErr "Not a type variable" returnType :: Type -> Type returnType (TFun _ t2) = returnType t2 -returnType a = a +returnType a = a inferExp :: Exp -> Infer (T.ExpT' Type) inferExp e = do @@ -244,7 +244,7 @@ class CollectTVars a where instance CollectTVars Exp where collectTVars (EAnn e t) = collectTVars t `S.union` collectTVars e - collectTVars _ = S.empty + collectTVars _ = S.empty instance CollectTVars Type where collectTVars (TVar (MkTVar i)) = S.singleton (coerce i) @@ -403,22 +403,22 @@ checkCase expT brnchs = do inferBranch :: Branch -> Infer (Subst, Type, T.Branch' Type, Type) inferBranch err@(Branch pat expr) = do - newPat@(pat, branchT) <- inferPattern pat + pat@(_, branchT) <- inferPattern pat (sub, newExp@(_, exprT)) <- catchError (withPattern pat (algoW expr)) (\x -> throwError Error{msg = x.msg <> " in pattern '" <> printTree err <> "'", catchable = False}) return ( sub , apply sub branchT - , T.Branch (apply sub newPat) (apply sub newExp) + , T.Branch (apply sub pat) (apply sub newExp) , apply sub exprT ) inferPattern :: Pattern -> Infer (T.Pattern' Type, Type) inferPattern = \case - PLit lit -> let lt = litType lit in return (T.PLit (lit, lt), lt) + PLit lit -> let lt = litType lit in return (T.PLit lit, lt) PCatch -> (T.PCatch,) <$> fresh PVar x -> do fr <- fresh - let pvar = T.PVar (coerce x, fr) + let pvar = T.PVar (coerce x) return (pvar, fr) PEnum p -> do t <- gets (M.lookup (coerce p) . injections) @@ -473,7 +473,7 @@ inferPattern = \case ) sub <- composeAll <$> zipWithM unify vs (map snd patterns) return - ( T.PInj (coerce constr) (apply sub (map fst patterns)) + ( T.PInj (coerce constr) (apply sub patterns) , apply sub ret ) @@ -563,12 +563,12 @@ generalize :: Map T.Ident Type -> Type -> Type generalize env t = go (S.toList $ free t S.\\ free env) (removeForalls t) where go :: [T.Ident] -> Type -> Type - go [] t = t + go [] t = t go (x : xs) t = TAll (MkTVar (coerce x)) (go xs t) removeForalls :: Type -> Type - removeForalls (TAll _ t) = removeForalls t + removeForalls (TAll _ t) = removeForalls t removeForalls (TFun t1 t2) = TFun (removeForalls t1) (removeForalls t2) - removeForalls t = t + removeForalls t = t {- | Instantiate a polymorphic type. The free type variables are substituted with fresh ones. @@ -617,27 +617,27 @@ currently this is not the case, the TAll pattern match is incorrectly implemente skipForalls :: Type -> Type skipForalls = \case TAll _ t -> skipForalls t - t -> t + t -> t foralls :: Type -> [T.Ident] foralls (TAll (MkTVar a) t) = coerce a : foralls t -foralls _ = [] +foralls _ = [] mkForall :: Type -> Type mkForall t = case map (TAll . MkTVar . coerce) $ S.toList $ free t of [] -> t (x : xs) -> - let f acc [] = acc + let f acc [] = acc f acc (x : xs) = f (x acc) xs (y : ys) = reverse $ x : xs in f (y t) ys skolemize :: Type -> Type skolemize (TVar (MkTVar a)) = TEVar $ MkTEVar a -skolemize (TAll x t) = TAll x (skolemize t) -skolemize (TFun t1 t2) = (TFun `on` skolemize) t1 t2 -skolemize (TData n ts) = TData n (map skolemize ts) -skolemize t = t +skolemize (TAll x t) = TAll x (skolemize t) +skolemize (TFun t1 t2) = (TFun `on` skolemize) t1 t2 +skolemize (TData n ts) = TData n (map skolemize ts) +skolemize t = t -- | A class for substitutions class SubstType t where @@ -671,10 +671,10 @@ instance SubstType Type where TLit _ -> t TVar (MkTVar a) -> case M.lookup (coerce a) sub of Nothing -> TVar (MkTVar $ coerce a) - Just t -> t + Just t -> t TAll (MkTVar i) t -> case M.lookup (coerce i) sub of Nothing -> TAll (MkTVar i) (apply sub t) - Just _ -> apply sub t + Just _ -> apply sub t TFun a b -> TFun (apply sub a) (apply sub b) TData name a -> TData name (apply sub a) TEVar (MkTEVar _) -> t @@ -718,11 +718,11 @@ instance SubstType (T.Branch' Type) where instance SubstType (T.Pattern' Type) where apply s = \case - T.PVar (iden, t) -> T.PVar (iden, apply s t) - T.PLit (lit, t) -> T.PLit (lit, apply s t) + T.PVar iden -> T.PVar iden + T.PLit lit -> T.PLit lit T.PInj i ps -> T.PInj i $ apply s ps - T.PCatch -> T.PCatch - T.PEnum i -> T.PEnum i + T.PCatch -> T.PCatch + T.PEnum i -> T.PEnum i instance SubstType (T.Pattern' Type, Type) where apply s (p, t) = (apply s p, apply s t) @@ -761,13 +761,13 @@ withBindings xs = local (\st -> st{vars = foldl' (flip (uncurry M.insert)) (vars st) xs}) -- | Run the monadic action with a pattern -withPattern :: (Monad m, MonadReader Ctx m) => T.Pattern' Type -> m a -> m a -withPattern p ma = case p of - T.PVar (x, t) -> withBinding x t ma +withPattern :: (Monad m, MonadReader Ctx m) => (T.Pattern' Type, Type) -> m a -> m a +withPattern (p, t) ma = case p of + T.PVar x -> withBinding x t ma T.PInj _ ps -> foldl' (flip withPattern) ma ps - T.PLit _ -> ma - T.PCatch -> ma - T.PEnum _ -> ma + T.PLit _ -> ma + T.PCatch -> ma + T.PEnum _ -> ma -- | Insert a function signature into the environment insertSig :: T.Ident -> Maybe Type -> Infer () @@ -792,11 +792,11 @@ existInj n = gets (M.lookup n . injections) flattenType :: Type -> [Type] flattenType (TFun a b) = flattenType a <> flattenType b -flattenType a = [a] +flattenType a = [a] typeLength :: Type -> Int typeLength (TFun _ b) = 1 + typeLength b -typeLength _ = 1 +typeLength _ = 1 {- | Catch an error if possible and add the given expression as addition to the error message @@ -879,11 +879,11 @@ newtype Ctx = Ctx {vars :: Map T.Ident Type} deriving (Show) data Env = Env - { count :: Int - , nextChar :: Char - , sigs :: Map T.Ident (Maybe Type) + { count :: Int + , nextChar :: Char + , sigs :: Map T.Ident (Maybe Type) , takenTypeVars :: Set T.Ident - , injections :: Map T.Ident Type + , injections :: Map T.Ident Type , declaredBinds :: Set T.Ident } deriving (Show) diff --git a/src/TypeChecker/TypeCheckerIr.hs b/src/TypeChecker/TypeCheckerIr.hs index e898ebe..21f2227 100644 --- a/src/TypeChecker/TypeCheckerIr.hs +++ b/src/TypeChecker/TypeCheckerIr.hs @@ -153,10 +153,13 @@ instance Print t => Print [Inj' t] where prt i [x] = prt i x prt i (x : xs) = prPrec i 0 $ concatD [prt i x, doc $ showString "\n ", prt i xs] +instance Print t => Print (Pattern' t, t) where + prt i (p, t) = prPrec i 1 (concatD [prt i p, prt i t]) + instance Print t => Print (Pattern' t) where prt i = \case PVar name -> prPrec i 1 (concatD [prt 0 name]) - PLit (lit, _) -> prPrec i 1 (concatD [prt 0 lit]) + PLit lit -> prPrec i 1 (concatD [prt 0 lit]) PCatch -> prPrec i 1 (concatD [doc (showString "_")]) PEnum name -> prPrec i 1 (concatD [prt 0 name]) PInj uident patterns -> prPrec i 0 (concatD [prt 0 uident, prt 1 patterns]) From e9852079ab039bb42f4cdcb1609dc77759331590 Mon Sep 17 00:00:00 2001 From: sebastianselander Date: Thu, 27 Apr 2023 12:43:02 +0200 Subject: [PATCH 313/372] bool now lit --- benchmark.txt | 9 ++++++ src/TypeChecker/ReportTEVar.hs | 54 +++++++++++++++++----------------- 2 files changed, 36 insertions(+), 27 deletions(-) create mode 100644 benchmark.txt diff --git a/benchmark.txt b/benchmark.txt new file mode 100644 index 0000000..c12461e --- /dev/null +++ b/benchmark.txt @@ -0,0 +1,9 @@ +# Full optimization Churf +File: output/hello_world, 100 runs gave average: 0.025261127948760988s + +# O2 Haskell +File: ./Bench, 100 runs gave average: 0.05629507303237915s + +# 03 Haskell +File: ./Bench, 100 runs gave average: 0.05490849256515503s +File: ./Bench, 100 runs gave average: 0.05323728561401367s diff --git a/src/TypeChecker/ReportTEVar.hs b/src/TypeChecker/ReportTEVar.hs index 9676b8e..6d0e2e1 100644 --- a/src/TypeChecker/ReportTEVar.hs +++ b/src/TypeChecker/ReportTEVar.hs @@ -2,16 +2,15 @@ module TypeChecker.ReportTEVar where -import Auxiliary (onM) -import Control.Applicative (Applicative (liftA2), liftA3) -import Control.Monad.Except (MonadError (throwError)) -import Data.Coerce (coerce) -import Data.Tuple.Extra (secondM) -import qualified Grammar.Abs as G -import Grammar.ErrM (Err) -import Grammar.Print (printTree) -import TypeChecker.TypeCheckerIr hiding (Type (..)) - +import Auxiliary (onM) +import Control.Applicative (Applicative (liftA2), liftA3) +import Control.Monad.Except (MonadError (throwError)) +import Data.Coerce (coerce) +import Data.Tuple.Extra (secondM) +import Grammar.Abs qualified as G +import Grammar.ErrM (Err) +import Grammar.Print (printTree) +import TypeChecker.TypeCheckerIr hiding (Type (..)) data Type = TLit Ident @@ -30,20 +29,20 @@ instance ReportTEVar (Program' G.Type) (Program' Type) where instance ReportTEVar (Def' G.Type) (Def' Type) where reportTEVar = \case DBind bind -> DBind <$> reportTEVar bind - DData dat -> DData <$> reportTEVar dat + DData dat -> DData <$> reportTEVar dat instance ReportTEVar (Bind' G.Type) (Bind' Type) where reportTEVar (Bind id vars rhs) = liftA3 Bind (reportTEVar id) (reportTEVar vars) (reportTEVar rhs) instance ReportTEVar (Exp' G.Type) (Exp' Type) where reportTEVar exp = case exp of - EVar name -> pure $ EVar name - EInj name -> pure $ EInj name - ELit lit -> pure $ ELit lit - ELet bind e -> liftA2 ELet (reportTEVar bind) (reportTEVar e) - EApp e1 e2 -> onM EApp reportTEVar e1 e2 - EAdd e1 e2 -> onM EAdd reportTEVar e1 e2 - EAbs name e -> EAbs name <$> reportTEVar e + EVar name -> pure $ EVar name + EInj name -> pure $ EInj name + ELit lit -> pure $ ELit lit + ELet bind e -> liftA2 ELet (reportTEVar bind) (reportTEVar e) + EApp e1 e2 -> onM EApp reportTEVar e1 e2 + EAdd e1 e2 -> onM EAdd reportTEVar e1 e2 + EAbs name e -> EAbs name <$> reportTEVar e ECase e branches -> liftA2 ECase (reportTEVar e) (reportTEVar branches) instance ReportTEVar (Branch' G.Type) (Branch' Type) where @@ -54,10 +53,10 @@ instance ReportTEVar (Pattern' G.Type, G.Type) (Pattern' Type, Type) where instance ReportTEVar (Pattern' G.Type) (Pattern' Type) where reportTEVar = \case - PVar name -> pure $ PVar name - PLit lit -> pure $ PLit lit - PCatch -> pure PCatch - PEnum name -> pure $ PEnum name + PVar name -> pure $ PVar name + PLit lit -> pure $ PLit lit + PCatch -> pure PCatch + PEnum name -> pure $ PEnum name PInj name ps -> PInj name <$> reportTEVar ps instance ReportTEVar (Data' G.Type) (Data' Type) where @@ -77,9 +76,10 @@ instance ReportTEVar a b => ReportTEVar [a] [b] where instance ReportTEVar G.Type Type where reportTEVar = \case - G.TLit lit -> pure $ TLit (coerce lit) - G.TVar (G.MkTVar i) -> pure $ TVar (MkTVar $ coerce i) - G.TData name typs -> TData (coerce name) <$> reportTEVar typs - G.TFun t1 t2 -> liftA2 TFun (reportTEVar t1) (reportTEVar t2) + G.TLit lit -> pure $ TLit (coerce lit) + G.TVar (G.MkTVar i) -> pure $ TVar (MkTVar $ coerce i) + G.TData (G.UIdent "Bool") _ -> pure $ TLit (coerce "Bool") + G.TData name typs -> TData (coerce name) <$> reportTEVar typs + G.TFun t1 t2 -> liftA2 TFun (reportTEVar t1) (reportTEVar t2) G.TAll (G.MkTVar i) t -> TAll (MkTVar $ coerce i) <$> reportTEVar t - G.TEVar tevar -> throwError ("Found TEVar: " ++ printTree tevar) + G.TEVar tevar -> throwError ("Found TEVar: " ++ printTree tevar) From 55fd35d66183f6371b38d092fb27d6e0a38dedfc Mon Sep 17 00:00:00 2001 From: sebastianselander Date: Thu, 27 Apr 2023 12:49:29 +0200 Subject: [PATCH 314/372] mono fix --- src/Monomorphizer/Monomorphizer.hs | 518 ++++++++++++++++------------- 1 file changed, 288 insertions(+), 230 deletions(-) diff --git a/src/Monomorphizer/Monomorphizer.hs b/src/Monomorphizer/Monomorphizer.hs index c50a7cc..de1c5c0 100644 --- a/src/Monomorphizer/Monomorphizer.hs +++ b/src/Monomorphizer/Monomorphizer.hs @@ -1,72 +1,84 @@ --- | 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 (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. - {-# LANGUAGE LambdaCase #-} + +{- | 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 (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. +-} module Monomorphizer.Monomorphizer (monomorphize, morphExp, morphBind) where -import Monomorphizer.DataTypeRemover (removeDataTypes) -import qualified Monomorphizer.MonomorphizerIr as O -import qualified Monomorphizer.MorbIr as M -import qualified TypeChecker.TypeCheckerIr as T -import TypeChecker.TypeCheckerIr (Ident (Ident)) +import Monomorphizer.DataTypeRemover (removeDataTypes) +import Monomorphizer.MonomorphizerIr qualified as O +import Monomorphizer.MorbIr qualified as M +import TypeChecker.TypeCheckerIr (Ident (Ident)) +import TypeChecker.TypeCheckerIr qualified as T -import Control.Monad.Reader (MonadReader (ask, local), - Reader, asks, runReader, when) -import Control.Monad.State (MonadState, StateT (runStateT), - gets, modify) -import Data.Coerce (coerce) -import qualified Data.Map as Map -import Data.Maybe (fromJust) -import qualified Data.Set as Set -import Debug.Trace -import Grammar.Print (printTree) +import Control.Monad.Reader ( + MonadReader (ask, local), + Reader, + asks, + runReader, + when, + ) +import Control.Monad.State ( + MonadState, + StateT (runStateT), + gets, + modify, + ) +import Data.Coerce (coerce) +import Data.Map qualified as Map +import Data.Maybe (fromJust) +import Data.Set qualified as Set +import Debug.Trace +import Grammar.Print (printTree) --- | EnvM is the monad containing the read-only state as well as the --- output state containing monomorphized functions and to-be monomorphized --- data type declarations. +{- | EnvM is the monad containing the read-only state as well as the +output state containing monomorphized functions and to-be monomorphized +data type declarations. +-} newtype EnvM a = EnvM (StateT Output (Reader Env) a) - deriving (Functor, Applicative, Monad, MonadState Output, MonadReader Env) + deriving (Functor, Applicative, Monad, MonadState Output, MonadReader Env) type Output = Map.Map Ident Outputted --- | Data structure describing outputted top-level information, that is --- Binds, Polymorphic Data types (monomorphized in a later step) and --- Marked bind, which means that it is in the process of monomorphization --- and should not be monomorphized again. +{- | Data structure describing outputted top-level information, that is +Binds, Polymorphic Data types (monomorphized in a later step) and +Marked bind, which means that it is in the process of monomorphization +and should not be monomorphized again. +-} data Outputted = Marked | Complete M.Bind | Data M.Type T.Data -- | Static environment. -data Env = Env { - -- | All binds in the program. - input :: Map.Map Ident T.Bind, - -- | All constructors mapped to their respective polymorphic data def - -- which includes all other constructors. - dataDefs :: Map.Map Ident T.Data, - -- | Maps polymorphic identifiers with concrete types. - polys :: Map.Map Ident M.Type, - -- | Local variables. - locals :: Set.Set Ident -} +data Env = Env + { input :: Map.Map Ident T.Bind + -- ^ All binds in the program. + , dataDefs :: Map.Map Ident T.Data + -- ^ All constructors mapped to their respective polymorphic data def + -- which includes all other constructors. + , polys :: Map.Map Ident M.Type + -- ^ Maps polymorphic identifiers with concrete types. + , locals :: Set.Set Ident + -- ^ Local variables. + } -- | Determines if the identifier describes a local variable in the given context. localExists :: Ident -> EnvM Bool @@ -80,8 +92,9 @@ getInputBind ident = asks (Map.lookup ident . input) addOutputBind :: M.Bind -> EnvM () addOutputBind b@(M.Bind (ident, _) _ _) = modify (Map.insert ident (Complete b)) --- | Marks a global bind as being processed, meaning that when encountered again, --- it should not be recursively processed. +{- | 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 Marked) @@ -93,181 +106,207 @@ isBindMarked ident = gets (Map.member ident) getMain :: EnvM T.Bind getMain = asks (\env -> fromJust $ Map.lookup (T.Ident "main") (input env)) --- | Makes a kv pair list of polymorphic to monomorphic mappings, throws runtime --- error when encountering different structures between the two arguments. +{- | 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.TLit _) (M.TLit _) = [] -mapTypes (T.TVar (T.MkTVar i1)) tm = [(i1, tm)] -mapTypes (T.TFun pt1 pt2) (M.TFun mt1 mt2) = mapTypes pt1 mt1 ++ - mapTypes pt2 mt2 -mapTypes (T.TData tIdent pTs) (M.TData mIdent mTs) = if tIdent /= mIdent - then error "the data type names of monomorphic and polymorphic data types does not match" - else foldl (\xs (p, m) -> mapTypes p m ++ xs) [] (zip pTs mTs) +mapTypes (T.TLit _) (M.TLit _) = [] +mapTypes (T.TVar (T.MkTVar i1)) tm = [(i1, tm)] +mapTypes (T.TFun pt1 pt2) (M.TFun mt1 mt2) = + mapTypes pt1 mt1 + ++ mapTypes pt2 mt2 +mapTypes (T.TData tIdent pTs) (M.TData mIdent mTs) = + if tIdent /= mIdent + then error "the data type names of monomorphic and polymorphic data types does not match" + else foldl (\xs (p, m) -> mapTypes p m ++ xs) [] (zip pTs mTs) mapTypes t1 t2 = error $ "structure of types not the same: '" ++ printTree t1 ++ "', '" ++ printTree t2 ++ "'" -- | Gets the mapped monomorphic type of a polymorphic type in the current context. getMonoFromPoly :: T.Type -> EnvM M.Type -getMonoFromPoly t = do env <- ask - return $ getMono (polys env) t - where - getMono :: Map.Map Ident M.Type -> T.Type -> M.Type - getMono polys t = case t of - (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 - Nothing -> M.TLit (Ident "void") - --error $ "type not found! type: " ++ show ident ++ ", error in previous compilation steps" - (T.TData ident args) -> M.TData ident (map (getMono polys) args) +getMonoFromPoly t = do + env <- ask + return $ getMono (polys env) t + where + getMono :: Map.Map Ident M.Type -> T.Type -> M.Type + getMono polys t = case t of + (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 + Nothing -> M.TLit (Ident "void") + -- error $ "type not found! type: " ++ show ident ++ ", error in previous compilation steps" + (T.TData ident args) -> M.TData ident (map (getMono polys) args) --- | If ident not already in env's output, morphed bind to output --- (and all referenced binds within this bind). --- Returns the annotated bind name. +{- | If ident not already in env's output, morphed bind to output +(and all referenced binds within this bind). +Returns the annotated bind name. +-} morphBind :: M.Type -> T.Bind -> EnvM Ident morphBind expectedType b@(T.Bind (Ident str, btype) args (exp, expt)) = - 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' = newFuncName expectedType b - 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') - expt' <- getMonoFromPoly expt - exp' <- morphExp expt' exp - -- Get monomorphic type sof args - args' <- mapM morphArg args - addOutputBind $ M.Bind (coerce name', expectedType) - args' (exp', expt') - return name' + 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' = newFuncName expectedType b + 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') + expt' <- getMonoFromPoly expt + exp' <- morphExp expt' exp + -- Get monomorphic type sof args + args' <- mapM morphArg args + addOutputBind $ + M.Bind + (coerce name', expectedType) + args' + (exp', expt') + return name' -- | Monomorphizes arguments of a bind. morphArg :: (Ident, T.Type) -> EnvM (Ident, M.Type) -morphArg (ident, t) = do t' <- getMonoFromPoly t - return (ident, t') +morphArg (ident, t) = do + t' <- getMonoFromPoly t + return (ident, t') -- | Gets the data bind from the name of a constructor. getInputData :: Ident -> EnvM (Maybe T.Data) -getInputData ident = do env <- ask - return $ Map.lookup ident (dataDefs env) +getInputData ident = do + env <- ask + return $ Map.lookup ident (dataDefs env) --- | Monomorphize a constructor using it's global name. Constructors may --- appear as expressions in the tree, or as patterns in case-expressions. +{- | Monomorphize a constructor using it's global name. Constructors may +appear as expressions in the tree, or as patterns in case-expressions. +-} morphCons :: M.Type -> Ident -> EnvM () morphCons expectedType ident = do - maybeD <- getInputData ident - case maybeD of - Nothing -> error $ "identifier '" ++ show ident ++ "' not found" - Just d -> do - modify (\output -> Map.insert ident (Data expectedType d) output ) + maybeD <- getInputData ident + case maybeD of + Nothing -> error $ "identifier '" ++ show ident ++ "' not found" + Just d -> do + modify (\output -> Map.insert ident (Data expectedType d) output) -- | Converts literals from input to output tree. 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 -- | Monomorphizes an expression, given an expected type. morphExp :: M.Type -> T.Exp -> EnvM M.Exp morphExp expectedType exp = case exp of - T.ELit lit -> return $ M.ELit (convertLit lit) - -- Constructor - T.EInj ident -> do - return $ M.EVar ident - T.EApp (e1, _t1) (e2, t2) -> do - t2' <- getMonoFromPoly t2 - e2' <- morphExp t2' e2 - e1' <- morphExp (M.TFun t2' expectedType) e1 - return $ M.EApp (e1', M.TFun t2' expectedType) (e2', t2') - T.EAdd (e1, t1) (e2, t2) -> do - t1' <- getMonoFromPoly t1 - t2' <- getMonoFromPoly t2 - e1' <- morphExp t1' e1 - e2' <- morphExp t2' e2 - return $ M.EAdd (e1', expectedType) (e2', expectedType) - T.EAbs ident (exp, t) -> local (\env -> env { locals = Set.insert ident (locals env) }) $ do - t' <- getMonoFromPoly t - morphExp t' exp - T.ECase (exp, t) bs -> do - t' <- getMonoFromPoly t - bs' <- mapM morphBranch bs - exp' <- morphExp t' exp - return $ M.ECase (exp', t') bs' - T.EVar ident -> do - isLocal <- localExists ident - if isLocal then do - return $ M.EVar (coerce ident) - else do - bind <- getInputBind ident - case bind of - Nothing -> do - -- This is a constructor - morphCons expectedType ident - return $ M.EVar ident - Just bind' -> do - -- New bind to process - newBindName <- morphBind expectedType bind' - return $ M.EVar (coerce newBindName) - - T.ELet (T.Bind {}) _ -> error "lets not possible yet" + T.ELit lit -> return $ M.ELit (convertLit lit) + -- Constructor + T.EInj ident -> do + return $ M.EVar ident + T.EApp (e1, _t1) (e2, t2) -> do + t2' <- getMonoFromPoly t2 + e2' <- morphExp t2' e2 + e1' <- morphExp (M.TFun t2' expectedType) e1 + return $ M.EApp (e1', M.TFun t2' expectedType) (e2', t2') + T.EAdd (e1, t1) (e2, t2) -> do + t1' <- getMonoFromPoly t1 + t2' <- getMonoFromPoly t2 + e1' <- morphExp t1' e1 + e2' <- morphExp t2' e2 + return $ M.EAdd (e1', expectedType) (e2', expectedType) + T.EAbs ident (exp, t) -> local (\env -> env{locals = Set.insert ident (locals env)}) $ do + t' <- getMonoFromPoly t + morphExp t' exp + T.ECase (exp, t) bs -> do + t' <- getMonoFromPoly t + bs' <- mapM morphBranch bs + exp' <- morphExp t' exp + return $ M.ECase (exp', t') bs' + T.EVar ident -> do + isLocal <- localExists ident + if isLocal + then do + return $ M.EVar (coerce ident) + else do + bind <- getInputBind ident + case bind of + Nothing -> do + -- This is a constructor + morphCons expectedType ident + return $ M.EVar ident + Just bind' -> do + -- New bind to process + newBindName <- morphBind expectedType bind' + return $ M.EVar (coerce newBindName) + T.ELet (T.Bind{}) _ -> error "lets not possible yet" -- | Monomorphizes case-of branches. morphBranch :: T.Branch -> EnvM M.Branch morphBranch (T.Branch (p, pt) (e, et)) = do - pt' <- getMonoFromPoly pt - et' <- getMonoFromPoly et - env <- ask - (p', newLocals) <- morphPattern pt' (locals env) (p, pt) - local (const env { locals = newLocals }) $ do - e' <- morphExp et' e - return $ M.Branch (p', pt') (e', et') + pt' <- getMonoFromPoly pt + et' <- getMonoFromPoly et + env <- ask + (p', newLocals) <- morphPattern pt' (locals env) (p, pt) + local (const env{locals = newLocals}) $ do + e' <- morphExp et' e + return $ M.Branch (p', pt') (e', et') -- | Morphs pattern (pattern => expression), gives the newly bound local variables. morphPattern :: M.Type -> Set.Set Ident -> (T.Pattern, T.Type) -> EnvM (M.Pattern, Set.Set Ident) morphPattern expectedType ls (p, t) = case p of - T.PVar ident -> do t' <- getMonoFromPoly t - return (M.PVar (ident, t'), Set.insert ident ls) - T.PLit lit -> do t' <- getMonoFromPoly t - return (M.PLit (convertLit lit, t'), ls) - T.PCatch -> return (M.PCatch, ls) - -- Constructor ident - T.PEnum ident -> do morphCons expectedType ident - return (M.PEnum ident, ls) - T.PInj ident ps -> do morphCons expectedType ident - let (M.TData tIdent ts) = expectedType - -- TODO: this is wrong! - pairs <- mapM (\(pat, patT) -> morphPattern patT ls pat) (zip ps ts) - if length ts == length ps then - return (M.PCatch, Set.singleton $ Ident "$1y") - else return (M.PInj ident (map fst pairs), Set.unions (map snd pairs)) + T.PVar ident -> do + t' <- getMonoFromPoly t + return (M.PVar (ident, t'), Set.insert ident ls) + T.PLit lit -> do + t' <- getMonoFromPoly t + return (M.PLit (convertLit lit, t'), ls) + T.PCatch -> return (M.PCatch, ls) + -- Constructor ident + T.PEnum ident -> do + morphCons expectedType ident + return (M.PEnum ident, ls) + T.PInj ident ps -> do + morphCons expectedType ident + let (M.TData tIdent ts) = expectedType + -- TODO: this is wrong! + pairs <- mapM (\(pat, patT) -> morphPattern patT ls pat) (zip ps ts) + if length ts == length ps + then return (M.PCatch, Set.singleton $ Ident "$1y") + else return (M.PInj ident (map fst pairs), Set.unions (map snd pairs)) -- | Creates a new identifier for a function with an assigned type. newFuncName :: M.Type -> T.Bind -> Ident newFuncName t (T.Bind (ident@(Ident bindName), _) _ _) = - if bindName == "main" - then Ident bindName - else newName t ident + if bindName == "main" + then Ident bindName + else newName t ident newName :: M.Type -> Ident -> Ident newName t (Ident str) = Ident $ str ++ "$" ++ newName' t - where - newName' :: M.Type -> String - newName' (M.TLit (Ident str)) = str - newName' (M.TFun t1 t2) = newName' t1 ++ "_" ++ newName' t2 - newName' (M.TData (Ident str) ts) = str ++ foldl (\s t -> s ++ "." ++ newName' t) "" ts + where + newName' :: M.Type -> String + newName' (M.TLit (Ident str)) = str + newName' (M.TFun t1 t2) = newName' t1 ++ "_" ++ newName' t2 + newName' (M.TData (Ident str) ts) = str ++ foldl (\s t -> s ++ "." ++ newName' t) "" ts -- | Monomorphization step. monomorphize :: T.Program -> O.Program -monomorphize (T.Program defs) = removeDataTypes $ M.Program (getDefsFromOutput - (runEnvM Map.empty (createEnv defs) monomorphize')) - where - monomorphize' :: EnvM () - monomorphize' = do - main <- getMain - morphBind (M.TLit $ Ident "Int") main - return () +monomorphize (T.Program defs) = + removeDataTypes $ + M.Program + ( getDefsFromOutput + (runEnvM Map.empty (createEnv defs) monomorphize') + ) + where + monomorphize' :: EnvM () + monomorphize' = do + main <- getMain + morphBind (M.TLit $ Ident "Int") main + return () -- | Runs and gives the output binds. runEnvM :: Output -> Env -> EnvM () -> Output @@ -275,14 +314,17 @@ runEnvM o env (EnvM stateM) = snd $ runReader (runStateT stateM o) env -- | Creates the environment based on the input binds. createEnv :: [T.Def] -> Env -createEnv defs = Env { input = Map.fromList bindPairs, - dataDefs = Map.fromList dataPairs, - polys = Map.empty, - locals = Set.empty } - where - bindPairs = (map (\b -> (getBindName b, b)) . getBindsFromDefs) defs - dataPairs :: [(Ident, T.Data)] - dataPairs = (foldl (\acc d@(T.Data _ cs) -> map ((,d) . getConsName) cs ++ acc) [] . getDataFromDefs) defs +createEnv defs = + Env + { input = Map.fromList bindPairs + , dataDefs = Map.fromList dataPairs + , polys = Map.empty + , locals = Set.empty + } + where + bindPairs = (map (\b -> (getBindName b, b)) . getBindsFromDefs) defs + dataPairs :: [(Ident, T.Data)] + dataPairs = (foldl (\acc d@(T.Data _ cs) -> map ((,d) . getConsName) cs ++ acc) [] . getDataFromDefs) defs -- | Gets a top-lefel function name. getBindName :: T.Bind -> Ident @@ -291,51 +333,67 @@ getBindName (T.Bind (ident, _) _ _) = ident -- Helper functions -- Gets custom data declarations form defs. getDataFromDefs :: [T.Def] -> [T.Data] -getDataFromDefs = foldl (\bs -> \case - T.DBind _ -> bs - T.DData d -> d:bs) [] +getDataFromDefs = + foldl + ( \bs -> \case + T.DBind _ -> bs + T.DData d -> d : bs + ) + [] getConsName :: T.Inj -> Ident getConsName (T.Inj ident _) = ident getBindsFromDefs :: [T.Def] -> [T.Bind] -getBindsFromDefs = foldl (\bs -> \case - T.DBind b -> b:bs - T.DData _ -> bs) [] +getBindsFromDefs = + foldl + ( \bs -> \case + T.DBind b -> b : bs + T.DData _ -> bs + ) + [] getDefsFromOutput :: Output -> [M.Def] getDefsFromOutput o = - map M.DBind binds ++ - (map (M.DData . snd) . Map.toList) (createNewData dataInput Map.empty) - where - (binds, dataInput) = splitBindsAndData o + map M.DBind binds + ++ (map (M.DData . snd) . Map.toList) (createNewData dataInput Map.empty) + where + (binds, dataInput) = splitBindsAndData o -- | Splits the output into binds and data declaration components (used in createNewData) splitBindsAndData :: Output -> ([M.Bind], [(Ident, M.Type, T.Data)]) -splitBindsAndData output = foldl - (\(oBinds, oData) (ident, o) -> case o of - Marked -> error "internal bug in monomorphizer" - Complete b -> (b:oBinds, oData) - Data t d -> (oBinds, (ident, t, d):oData)) - ([], []) - (Map.toList output) +splitBindsAndData output = + foldl + ( \(oBinds, oData) (ident, o) -> case o of + Marked -> error "internal bug in monomorphizer" + Complete b -> (b : oBinds, oData) + Data t d -> (oBinds, (ident, t, d) : oData) + ) + ([], []) + (Map.toList output) -- | Converts all found constructors to monomorphic data declarations. createNewData :: [(Ident, M.Type, T.Data)] -> Map.Map Ident M.Data -> Map.Map Ident M.Data -createNewData [] o = o -createNewData ((consIdent, consType, polyData):input) o = - createNewData input $ - Map.insertWith (\_ (M.Data _ cs) -> M.Data newDataType (newCons:cs)) - newDataName (M.Data newDataType [newCons]) o - where - T.Data (T.TData polyDataIdent _) _ = polyData - newDataType = getDataType consType - newDataName = newName newDataType polyDataIdent - newCons = M.Inj consIdent consType +createNewData [] o = o +createNewData ((consIdent, consType, polyData) : input) o = + createNewData input $ + Map.insertWith + (\_ (M.Data _ cs) -> M.Data newDataType (newCons : cs)) + newDataName + (M.Data newDataType [newCons]) + o + where + polyDataIdent = case polyData of + T.Data (T.TData i _) _ -> i + T.Data (T.TLit i) _ -> i + t -> error $ "Data type is :" ++ show t ++ " which should be impossible" + + newDataType = getDataType consType + newDataName = newName newDataType polyDataIdent + newCons = M.Inj consIdent consType -- | Gets the Data Type of a constructor type (a -> Just a becomes Just a). getDataType :: M.Type -> M.Type -getDataType (M.TFun t1 t2) = getDataType t2 -getDataType tData@(M.TData _ _) = tData -getDataType _ = error "???" - +getDataType (M.TFun t1 t2) = getDataType t2 +getDataType tData@(M.TData _ _) = tData +getDataType _ = error "???" From 1a21698772af18d01841aa536b3c0a2d003a9da9 Mon Sep 17 00:00:00 2001 From: sebastianselander Date: Thu, 27 Apr 2023 12:57:36 +0200 Subject: [PATCH 315/372] mono fixier --- src/Monomorphizer/DataTypeRemover.hs | 33 ++++++++++++++-------------- src/Monomorphizer/Monomorphizer.hs | 6 +---- src/TypeChecker/ReportTEVar.hs | 1 - 3 files changed, 18 insertions(+), 22 deletions(-) diff --git a/src/Monomorphizer/DataTypeRemover.hs b/src/Monomorphizer/DataTypeRemover.hs index d4444d7..e4caef0 100644 --- a/src/Monomorphizer/DataTypeRemover.hs +++ b/src/Monomorphizer/DataTypeRemover.hs @@ -1,6 +1,7 @@ module Monomorphizer.DataTypeRemover (removeDataTypes) where -import qualified Monomorphizer.MorbIr as M1 -import qualified Monomorphizer.MonomorphizerIr as M2 + +import Monomorphizer.MonomorphizerIr qualified as M2 +import Monomorphizer.MorbIr qualified as M1 import TypeChecker.TypeCheckerIr (Ident (Ident)) removeDataTypes :: M1.Program -> M2.Program @@ -17,9 +18,10 @@ pCons :: M1.Inj -> M2.Inj pCons (M1.Inj ident t) = M2.Inj ident (pType t) pType :: M1.Type -> M2.Type -pType (M1.TLit ident) = M2.TLit ident -pType (M1.TFun t1 t2) = M2.TFun (pType t1) (pType t2) -pType d = M2.TLit (Ident (newName d)) -- This is the step +pType (M1.TLit ident) = M2.TLit ident +pType (M1.TFun t1 t2) = M2.TFun (pType t1) (pType t2) +pType (M1.TData (Ident "Bool") _) = M2.TLit (Ident "Bool") +pType d = M2.TLit (Ident (newName d)) -- This is the step newName :: M1.Type -> String newName (M1.TLit (Ident str)) = str @@ -36,24 +38,23 @@ pExpT :: M1.ExpT -> M2.ExpT pExpT (exp, t) = (pExp exp, pType t) pExp :: M1.Exp -> M2.Exp -pExp (M1.EVar ident) = M2.EVar ident -pExp (M1.ELit lit) = M2.ELit (pLit lit) -pExp (M1.ELet bind expt) = M2.ELet (pBind bind) (pExpT expt) -pExp (M1.EApp e1 e2) = M2.EApp (pExpT e1) (pExpT e2) -pExp (M1.EAdd e1 e2) = M2.EAdd (pExpT e1) (pExpT e2) +pExp (M1.EVar ident) = M2.EVar ident +pExp (M1.ELit lit) = M2.ELit (pLit lit) +pExp (M1.ELet bind expt) = M2.ELet (pBind bind) (pExpT expt) +pExp (M1.EApp e1 e2) = M2.EApp (pExpT e1) (pExpT e2) +pExp (M1.EAdd e1 e2) = M2.EAdd (pExpT e1) (pExpT e2) pExp (M1.ECase expT branches) = M2.ECase (pExpT expT) (map pBranch branches) pBranch :: M1.Branch -> M2.Branch pBranch (M1.Branch (patt, t) expt) = M2.Branch (pPattern patt, pType t) (pExpT expt) pPattern :: M1.Pattern -> M2.Pattern -pPattern (M1.PVar id) = M2.PVar (pId id) -pPattern (M1.PLit (lit, t)) = M2.PLit (pLit lit, pType t) +pPattern (M1.PVar id) = M2.PVar (pId id) +pPattern (M1.PLit (lit, t)) = M2.PLit (pLit lit, pType t) pPattern (M1.PInj ident patts) = M2.PInj ident (map pPattern patts) -pPattern M1.PCatch = M2.PCatch -pPattern (M1.PEnum ident) = M2.PEnum ident +pPattern M1.PCatch = M2.PCatch +pPattern (M1.PEnum ident) = M2.PEnum ident pLit :: M1.Lit -> M2.Lit -pLit (M1.LInt v) = M2.LInt v +pLit (M1.LInt v) = M2.LInt v pLit (M1.LChar c) = M2.LChar c - diff --git a/src/Monomorphizer/Monomorphizer.hs b/src/Monomorphizer/Monomorphizer.hs index de1c5c0..26cd295 100644 --- a/src/Monomorphizer/Monomorphizer.hs +++ b/src/Monomorphizer/Monomorphizer.hs @@ -383,11 +383,7 @@ createNewData ((consIdent, consType, polyData) : input) o = (M.Data newDataType [newCons]) o where - polyDataIdent = case polyData of - T.Data (T.TData i _) _ -> i - T.Data (T.TLit i) _ -> i - t -> error $ "Data type is :" ++ show t ++ " which should be impossible" - + T.Data (T.TData polyDataIdent _) _ = polyData newDataType = getDataType consType newDataName = newName newDataType polyDataIdent newCons = M.Inj consIdent consType diff --git a/src/TypeChecker/ReportTEVar.hs b/src/TypeChecker/ReportTEVar.hs index 6d0e2e1..62cd301 100644 --- a/src/TypeChecker/ReportTEVar.hs +++ b/src/TypeChecker/ReportTEVar.hs @@ -78,7 +78,6 @@ instance ReportTEVar G.Type Type where reportTEVar = \case G.TLit lit -> pure $ TLit (coerce lit) G.TVar (G.MkTVar i) -> pure $ TVar (MkTVar $ coerce i) - G.TData (G.UIdent "Bool") _ -> pure $ TLit (coerce "Bool") G.TData name typs -> TData (coerce name) <$> reportTEVar typs G.TFun t1 t2 -> liftA2 TFun (reportTEVar t1) (reportTEVar t2) G.TAll (G.MkTVar i) t -> TAll (MkTVar $ coerce i) <$> reportTEVar t From d026dca42f7c07f3644eb0a1b3f546ebb16dff51 Mon Sep 17 00:00:00 2001 From: Samuel Hammersberg Date: Thu, 27 Apr 2023 13:49:00 +0200 Subject: [PATCH 316/372] Attacked the code generator and added bool support. --- sample-programs/lt_testing.crf | 3 +++ src/Codegen/Auxillary.hs | 1 + src/Codegen/Codegen.hs | 13 ++++++++++--- src/Codegen/Emits.hs | 19 +++++++++++++------ src/Main.hs | 2 +- 5 files changed, 28 insertions(+), 10 deletions(-) create mode 100644 sample-programs/lt_testing.crf diff --git a/sample-programs/lt_testing.crf b/sample-programs/lt_testing.crf new file mode 100644 index 0000000..5edc1c9 --- /dev/null +++ b/sample-programs/lt_testing.crf @@ -0,0 +1,3 @@ +main = case (lt 3 5) of + True => 1 + False => 0 diff --git a/src/Codegen/Auxillary.hs b/src/Codegen/Auxillary.hs index c95f4cb..c95be39 100644 --- a/src/Codegen/Auxillary.hs +++ b/src/Codegen/Auxillary.hs @@ -9,6 +9,7 @@ type2LlvmType :: MIR.Type -> LLVMType type2LlvmType (MIR.TLit id@(TIR.Ident name)) = case name of "Int" -> I64 "Char" -> I8 + "Bool" -> I1 _ -> CustomType id type2LlvmType (MIR.TFun t xs) = do let (t', xs') = function2LLVMType xs [type2LlvmType t] diff --git a/src/Codegen/Codegen.hs b/src/Codegen/Codegen.hs index 810d849..e3343d7 100644 --- a/src/Codegen/Codegen.hs +++ b/src/Codegen/Codegen.hs @@ -11,7 +11,8 @@ import Control.Monad.State ( ) import Data.List (sortBy) import Grammar.ErrM (Err) -import Monomorphizer.MonomorphizerIr as MIR (Def (DBind, DData), Program (..)) +import Monomorphizer.MonomorphizerIr as MIR (Bind (..), Data (..), Def (DBind, DData), Program (..), Type (TLit)) +import TypeChecker.TypeCheckerIr (Ident (..)) {- | Compiles an AST and produces a LLVM Ir string. An easy way to actually "compile" this output is to @@ -19,8 +20,14 @@ import Monomorphizer.MonomorphizerIr as MIR (Def (DBind, DData), Program (..)) -} generateCode :: MIR.Program -> Err String generateCode (MIR.Program scs) = do - let codegen = initCodeGenerator scs - llvmIrToString . instructions <$> execStateT (compileScs (sortBy lowData scs)) codegen + let tree = filter (not . detectPrelude) (sortBy lowData scs) + let codegen = initCodeGenerator tree + llvmIrToString . instructions <$> execStateT (compileScs tree) codegen + +detectPrelude :: Def -> Bool +detectPrelude (DData (Data (TLit (Ident "Bool")) _)) = True +detectPrelude (DBind (Bind (Ident ('l' : 't' : '$' : _), _) _ _)) = True +detectPrelude _ = False lowData :: Def -> Def -> Ordering lowData (DData _) (DBind _) = LT diff --git a/src/Codegen/Emits.hs b/src/Codegen/Emits.hs index 481af4f..876471b 100644 --- a/src/Codegen/Emits.hs +++ b/src/Codegen/Emits.hs @@ -228,15 +228,15 @@ emitECased t e cases = do emit $ Store ty val Ptr stackPtr emit $ Br label emit $ Label lbl_failPos - emitCases _rt ty label stackPtr vs (Branch (MIR.PLit i, t) exp) = do + emitCases _rt ty label stackPtr vs (Branch (MIR.PLit (i, ct), t) exp) = do emit $ Comment "Plit" let i' = case i of - (MIR.LInt i, _) -> VInteger i - (MIR.LChar i, _) -> VChar (ord i) + MIR.LInt i -> VInteger i + MIR.LChar i -> VChar (ord i) ns <- getNewVar lbl_failPos <- (\x -> TIR.Ident $ "failed_" <> show x) <$> getNewLabel lbl_succPos <- (\x -> TIR.Ident $ "success_" <> show x) <$> getNewLabel - emit $ SetVariable ns (Icmp LLEq (type2LlvmType t) vs i') + emit $ SetVariable ns (Icmp LLEq (type2LlvmType ct) vs i') emit $ BrCond (VIdent ns ty) lbl_succPos lbl_failPos emit $ Label lbl_succPos val <- exprToValue exp @@ -255,9 +255,13 @@ emitECased t e cases = do emit $ Br label lbl_failPos <- (\x -> TIR.Ident $ "failed_" <> show x) <$> getNewLabel emit $ Label lbl_failPos + emitCases rt ty label stackPtr vs (Branch (MIR.PEnum (TIR.Ident "True"), t) exp) = do + emitCases rt ty label stackPtr vs (Branch (MIR.PLit (MIR.LInt 1, TLit "Bool"), t) exp) + emitCases rt ty label stackPtr vs (Branch (MIR.PEnum (TIR.Ident "False"), _) exp) = do + emitCases rt ty label stackPtr vs (Branch (MIR.PLit (MIR.LInt 0, TLit "Bool"), t) exp) emitCases _rt ty label stackPtr _vs (Branch (MIR.PEnum _id, _) exp) = do -- //TODO Penum wrong, acts as a catch all - emit $ Comment "Penum" + emit $ Comment $ "Penum " <> show _id val <- exprToValue exp emit $ Store ty val Ptr stackPtr emit $ Br label @@ -290,7 +294,10 @@ emitApp rt e1 e2 = appEmitter e1 e2 [] <|> Global <$ Map.lookup (name, t) funcs -- this piece of code could probably be improved, i.e remove the double `const Global` args' = map (first valueGetType . dupe) args - call = Call FastCC (type2LlvmType rt) visibility name args' + let call = + case name of + TIR.Ident ('l' : 't' : '$' : _) -> Icmp LLSlt I64 (snd (head args')) (snd (args' !! 1)) + _ -> Call FastCC (type2LlvmType rt) visibility name args' emit $ Comment $ show rt emit $ SetVariable vs call x -> error $ "The unspeakable happened: " <> show x diff --git a/src/Main.hs b/src/Main.hs index 338272d..f5dd2eb 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -166,4 +166,4 @@ printToErr = hPutStrLn stderr fromErr :: Err a -> IO a fromErr = either (\s -> printToErr s >> exitFailure) pure -prelude = "const x y = x\n\ndata Bool () where\n True : Bool ()\n False : Bool ()\n\nlt : Int -> Int -> Bool ()\nlt = \\x. \\y. const True (x + y)" +prelude = "\n\nconst x y = x\n\ndata Bool () where\n True : Bool ()\n False : Bool ()\n\nlt : Int -> Int -> Bool ()\nlt = \\x. \\y. const True (x + y)" From 60e12b622e7c0f58d0d22bf95046110e46456a80 Mon Sep 17 00:00:00 2001 From: Rakarake Date: Thu, 27 Apr 2023 13:55:54 +0200 Subject: [PATCH 317/372] Using type annotations in case expressions, monomorphizer now handles case expressions without crashing --- sample-programs/mono-1.crf | 4 +-- src/Monomorphizer/Monomorphizer.hs | 41 ++++++++++++++---------------- 2 files changed, 21 insertions(+), 24 deletions(-) diff --git a/sample-programs/mono-1.crf b/sample-programs/mono-1.crf index 9c0a08f..568c674 100644 --- a/sample-programs/mono-1.crf +++ b/sample-programs/mono-1.crf @@ -1,6 +1,6 @@ -const x y = x +const2 x y = x -f x = (const x 'c') +f x = (const2 x 'c') main = f 5 diff --git a/src/Monomorphizer/Monomorphizer.hs b/src/Monomorphizer/Monomorphizer.hs index c50a7cc..6c851f9 100644 --- a/src/Monomorphizer/Monomorphizer.hs +++ b/src/Monomorphizer/Monomorphizer.hs @@ -91,7 +91,10 @@ isBindMarked ident = gets (Map.member ident) -- | Finds main bind. getMain :: EnvM T.Bind -getMain = asks (\env -> fromJust $ Map.lookup (T.Ident "main") (input env)) +getMain = asks (\env -> case Map.lookup (T.Ident "main") (input env) of + Just mainBind -> mainBind + Nothing -> error "main not found in monomorphizer!" + ) -- | Makes a kv pair list of polymorphic to monomorphic mappings, throws runtime -- error when encountering different structures between the two arguments. @@ -219,30 +222,24 @@ morphBranch (T.Branch (p, pt) (e, et)) = do pt' <- getMonoFromPoly pt et' <- getMonoFromPoly et env <- ask - (p', newLocals) <- morphPattern pt' (locals env) (p, pt) - local (const env { locals = newLocals }) $ do + (p', newLocals) <- morphPattern p pt' + local (const env { locals = Set.union (locals env) newLocals }) $ do e' <- morphExp et' e return $ M.Branch (p', pt') (e', et') --- | Morphs pattern (pattern => expression), gives the newly bound local variables. -morphPattern :: M.Type -> Set.Set Ident -> (T.Pattern, T.Type) -> EnvM (M.Pattern, Set.Set Ident) -morphPattern expectedType ls (p, t) = case p of - T.PVar ident -> do t' <- getMonoFromPoly t - return (M.PVar (ident, t'), Set.insert ident ls) - T.PLit lit -> do t' <- getMonoFromPoly t - return (M.PLit (convertLit lit, t'), ls) - T.PCatch -> return (M.PCatch, ls) - -- Constructor ident - T.PEnum ident -> do morphCons expectedType ident - return (M.PEnum ident, ls) - T.PInj ident ps -> do morphCons expectedType ident - let (M.TData tIdent ts) = expectedType - -- TODO: this is wrong! - pairs <- mapM (\(pat, patT) -> morphPattern patT ls pat) (zip ps ts) - if length ts == length ps then - return (M.PCatch, Set.singleton $ Ident "$1y") - else return (M.PInj ident (map fst pairs), Set.unions (map snd pairs)) - +morphPattern :: T.Pattern -> M.Type -> EnvM (M.Pattern, Set.Set Ident) +morphPattern p expectedType = case p of + T.PVar ident -> return (M.PVar (ident, expectedType), Set.singleton ident) + T.PLit lit -> return (M.PLit (convertLit lit, expectedType), Set.empty) + T.PCatch -> return (M.PCatch, Set.empty) + T.PEnum ident -> do morphCons expectedType ident + return (M.PEnum ident, Set.empty) + T.PInj ident pts -> do morphCons expectedType ident + ts' <- mapM (getMonoFromPoly . snd) pts + let pts' = zip (map fst pts) ts' + psSets <- mapM (uncurry morphPattern) pts' + return (M.PInj ident (map fst psSets), Set.unions $ map snd psSets) + -- | Creates a new identifier for a function with an assigned type. newFuncName :: M.Type -> T.Bind -> Ident newFuncName t (T.Bind (ident@(Ident bindName), _) _ _) = From 39d0650115d61386512ecef4cecf4fe57794fb9a Mon Sep 17 00:00:00 2001 From: Samuel Hammersberg Date: Thu, 27 Apr 2023 15:06:42 +0200 Subject: [PATCH 318/372] Fixed a booleans not being outputted as literals. --- src/Codegen/Emits.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/Codegen/Emits.hs b/src/Codegen/Emits.hs index 876471b..5e41e4b 100644 --- a/src/Codegen/Emits.hs +++ b/src/Codegen/Emits.hs @@ -331,6 +331,8 @@ exprToValue = \case (MIR.ELit i, _t) -> pure $ case i of (MIR.LInt i) -> VInteger i (MIR.LChar i) -> VChar $ ord i + (MIR.EVar (TIR.Ident "True"), _t) -> pure $ VInteger 1 + (MIR.EVar (TIR.Ident "False"), _t) -> pure $ VInteger 0 (MIR.EVar name, t) -> do funcs <- gets functions cons <- gets constructors From 509b51d2deb867cc2ac8a0741c01c0309a29076a Mon Sep 17 00:00:00 2001 From: Rakarake Date: Thu, 27 Apr 2023 15:09:39 +0200 Subject: [PATCH 319/372] No output of wrongly typed cons --- src/Monomorphizer/Monomorphizer.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Monomorphizer/Monomorphizer.hs b/src/Monomorphizer/Monomorphizer.hs index 0803771..6bf767b 100644 --- a/src/Monomorphizer/Monomorphizer.hs +++ b/src/Monomorphizer/Monomorphizer.hs @@ -263,9 +263,9 @@ morphPattern p expectedType = case p of T.PVar ident -> return (M.PVar (ident, expectedType), Set.singleton ident) T.PLit lit -> return (M.PLit (convertLit lit, expectedType), Set.empty) T.PCatch -> return (M.PCatch, Set.empty) - T.PEnum ident -> do morphCons expectedType ident + T.PEnum ident -> do --morphCons expectedType ident return (M.PEnum ident, Set.empty) - T.PInj ident pts -> do morphCons expectedType ident + T.PInj ident pts -> do --morphCons expectedType ident ts' <- mapM (getMonoFromPoly . snd) pts let pts' = zip (map fst pts) ts' psSets <- mapM (uncurry morphPattern) pts' From 46a4d3d25247f7822d21fe2b222fde659f1904d2 Mon Sep 17 00:00:00 2001 From: Samuel Hammersberg Date: Thu, 27 Apr 2023 16:01:22 +0200 Subject: [PATCH 320/372] Fixed a bug with penums --- src/Codegen/Emits.hs | 27 +++++++++++++++++++++++---- 1 file changed, 23 insertions(+), 4 deletions(-) diff --git a/src/Codegen/Emits.hs b/src/Codegen/Emits.hs index 5e41e4b..c851374 100644 --- a/src/Codegen/Emits.hs +++ b/src/Codegen/Emits.hs @@ -173,7 +173,8 @@ emitECased t e cases = do mapM_ (emitCases rt ty label stackPtr vs) cs -- crashLbl <- TIR.Ident . ("crash_" <>) . show <$> getNewLabel -- emit $ Label crashLbl - emit . UnsafeRaw $ "call i32 (ptr, ...) @printf(ptr noundef @.non_exhaustive_patterns, i64 noundef 6, i64 noundef 6)\n" + var_num <- getVarCount + emit . UnsafeRaw $ "call i32 (ptr, ...) @printf(ptr noundef @.non_exhaustive_patterns, i64 noundef " <> show var_num <> ", i64 noundef 6)\n" emit . UnsafeRaw $ "call void @cheap_dispose()\n" emit . UnsafeRaw $ "call i32 @exit(i32 noundef 1)\n" mapM_ (const increaseVarCount) [0 .. 1] @@ -259,13 +260,31 @@ emitECased t e cases = do emitCases rt ty label stackPtr vs (Branch (MIR.PLit (MIR.LInt 1, TLit "Bool"), t) exp) emitCases rt ty label stackPtr vs (Branch (MIR.PEnum (TIR.Ident "False"), _) exp) = do emitCases rt ty label stackPtr vs (Branch (MIR.PLit (MIR.LInt 0, TLit "Bool"), t) exp) - emitCases _rt ty label stackPtr _vs (Branch (MIR.PEnum _id, _) exp) = do + emitCases rt ty label stackPtr vs (Branch (MIR.PEnum consId, _) exp) = do -- //TODO Penum wrong, acts as a catch all - emit $ Comment $ "Penum " <> show _id + emit $ Comment "Penum" + cons <- gets constructors + let r = fromJust $ Map.lookup consId cons + + lbl_failPos <- (\x -> TIR.Ident $ "failed_" <> show x) <$> getNewLabel + lbl_succPos <- (\x -> TIR.Ident $ "success_" <> show x) <$> getNewLabel + + consVal <- getNewVar + emit $ SetVariable consVal (ExtractValue rt vs 0) + + consCheck <- getNewVar + emit $ SetVariable consCheck (Icmp LLEq I8 (VIdent consVal I8) (VInteger $ numCI r)) + emit $ BrCond (VIdent consCheck ty) lbl_succPos lbl_failPos + emit $ Label lbl_succPos + + castPtr <- getNewVar + casted <- getNewVar + emit $ SetVariable castPtr (Alloca rt) + emit $ Store rt vs Ptr castPtr + emit $ SetVariable casted (Load (CustomType (coerce consId)) Ptr castPtr) val <- exprToValue exp emit $ Store ty val Ptr stackPtr emit $ Br label - lbl_failPos <- (\x -> TIR.Ident $ "failed_" <> show x) <$> getNewLabel emit $ Label lbl_failPos emitCases _ ty label stackPtr _ (Branch (MIR.PCatch, _) exp) = do emit $ Comment "Pcatch" From 37292780418f7bd9d068954a509400b3e0a7528b Mon Sep 17 00:00:00 2001 From: Rakarake Date: Thu, 27 Apr 2023 16:44:30 +0200 Subject: [PATCH 321/372] =?UTF-8?q?Unreachable=20branhces=20are=20removed,?= =?UTF-8?q?=20fixed=20a=20nasty=20bug=20in=20monomorphizer=20=F0=9F=98=B8?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- sample-programs/bubble-sort.chrf | 11 +++++++ sample-programs/insertion-sort.chrf | 23 ++++++++++++++ sample-programs/mono-2.crf | 3 ++ src/Monomorphizer/Monomorphizer.hs | 47 +++++++++++++++++++---------- 4 files changed, 68 insertions(+), 16 deletions(-) create mode 100644 sample-programs/bubble-sort.chrf create mode 100644 sample-programs/insertion-sort.chrf diff --git a/sample-programs/bubble-sort.chrf b/sample-programs/bubble-sort.chrf new file mode 100644 index 0000000..59e6598 --- /dev/null +++ b/sample-programs/bubble-sort.chrf @@ -0,0 +1,11 @@ +data List (a) where + Cons : a -> List (a) -> List (a) + Nil : List (a) + +bubblesort : List (a) -> List (a) +bubblesort xs = case xs of + Nil => Nil + Cons x => case x of + Nil => Cons x Nil + Cons y => + diff --git a/sample-programs/insertion-sort.chrf b/sample-programs/insertion-sort.chrf new file mode 100644 index 0000000..573f2de --- /dev/null +++ b/sample-programs/insertion-sort.chrf @@ -0,0 +1,23 @@ +data List (a) where + Nil : List (a) + Cons : a -> List (a) -> List (a) + +insert : Int -> List (Int) -> List (Int) +insert x xs = case xs of + Cons z zs => case (lt x z) of + True => Cons x (Cons z zs) + False => Cons z (insert x zs) + Nil => Cons x Nil + +insertionSort : List (Int) -> List (Int) +insertionSort xs = case xs of + Cons y ys => case ys of + _ => insert y (insertionSort ys) + Nil => xs + Nil => Nil + +main = head (insertionSort (Cons 5 (Cons 4 (Cons 3 (Cons 2 (Cons 1 Nil)))))) + +head xs = case xs of + Cons x _ => x + diff --git a/sample-programs/mono-2.crf b/sample-programs/mono-2.crf index 9325b4a..97e8c1f 100644 --- a/sample-programs/mono-2.crf +++ b/sample-programs/mono-2.crf @@ -5,6 +5,9 @@ data Either(a b) where unwrapLeft x = case x of Left y => y +unwrapRight x = case x of + Right y => y + wow = Left 5 main = unwrapLeft wow diff --git a/src/Monomorphizer/Monomorphizer.hs b/src/Monomorphizer/Monomorphizer.hs index 6bf767b..1d99731 100644 --- a/src/Monomorphizer/Monomorphizer.hs +++ b/src/Monomorphizer/Monomorphizer.hs @@ -46,7 +46,7 @@ import Control.Monad.State ( ) import Data.Coerce (coerce) import Data.Map qualified as Map -import Data.Maybe (fromJust) +import Data.Maybe (fromJust, catMaybes) import Data.Set qualified as Set import Debug.Trace import Grammar.Print (printTree) @@ -102,6 +102,10 @@ markBind ident = modify (Map.insert ident Marked) isBindMarked :: Ident -> EnvM Bool isBindMarked ident = gets (Map.member ident) +-- | Checks if constructor is outputted. +isConsMarked :: Ident -> EnvM Bool +isConsMarked ident = gets (Map.member ident) + -- | Finds main bind. getMain :: EnvM T.Bind getMain = asks (\env -> case Map.lookup (T.Ident "main") (input env) of @@ -228,7 +232,7 @@ morphExp expectedType exp = case exp of t' <- getMonoFromPoly t bs' <- mapM morphBranch bs exp' <- morphExp t' exp - return $ M.ECase (exp', t') bs' + return $ M.ECase (exp', t') (catMaybes bs') T.EVar ident -> do isLocal <- localExists ident if isLocal @@ -248,28 +252,39 @@ morphExp expectedType exp = case exp of T.ELet (T.Bind{}) _ -> error "lets not possible yet" -- | Monomorphizes case-of branches. -morphBranch :: T.Branch -> EnvM M.Branch +morphBranch :: T.Branch -> EnvM (Maybe M.Branch) morphBranch (T.Branch (p, pt) (e, et)) = do pt' <- getMonoFromPoly pt et' <- getMonoFromPoly et env <- ask - (p', newLocals) <- morphPattern p pt' - local (const env { locals = Set.union (locals env) newLocals }) $ do - e' <- morphExp et' e - return $ M.Branch (p', pt') (e', et') + maybeMorphedPattern <- morphPattern p pt' + case maybeMorphedPattern of + Nothing -> return Nothing + Just (p', newLocals) -> + local (const env { locals = Set.union (locals env) newLocals }) $ do + e' <- morphExp et' e + return $ Just (M.Branch (p', pt') (e', et')) -morphPattern :: T.Pattern -> M.Type -> EnvM (M.Pattern, Set.Set Ident) +morphPattern :: T.Pattern -> M.Type -> EnvM (Maybe (M.Pattern, Set.Set Ident)) morphPattern p expectedType = case p of - T.PVar ident -> return (M.PVar (ident, expectedType), Set.singleton ident) - T.PLit lit -> return (M.PLit (convertLit lit, expectedType), Set.empty) - T.PCatch -> return (M.PCatch, Set.empty) + T.PVar ident -> return $ Just (M.PVar (ident, expectedType), Set.singleton ident) + T.PLit lit -> return $ Just (M.PLit (convertLit lit, expectedType), Set.empty) + T.PCatch -> return $ Just (M.PCatch, Set.empty) T.PEnum ident -> do --morphCons expectedType ident - return (M.PEnum ident, Set.empty) + return $ Just (M.PEnum ident, Set.empty) T.PInj ident pts -> do --morphCons expectedType ident - ts' <- mapM (getMonoFromPoly . snd) pts - let pts' = zip (map fst pts) ts' - psSets <- mapM (uncurry morphPattern) pts' - return (M.PInj ident (map fst psSets), Set.unions $ map snd psSets) + isMarked <- isConsMarked ident + if isMarked + then do + ts' <- mapM (getMonoFromPoly . snd) pts + let pts' = zip (map fst pts) ts' + psSets <- mapM (uncurry morphPattern) pts' + let maybePsSets = sequence psSets + case maybePsSets of + Nothing -> return Nothing + Just psSets' -> return $ Just + (M.PInj ident (map fst psSets'), Set.unions $ map snd psSets') + else return Nothing -- | Creates a new identifier for a function with an assigned type. newFuncName :: M.Type -> T.Bind -> Ident From e42c77513534771b05b626578de2113a10c76ddc Mon Sep 17 00:00:00 2001 From: Martin Fredin Date: Thu, 27 Apr 2023 17:29:13 +0200 Subject: [PATCH 322/372] Fix prelude --- src/Main.hs | 88 ++++++++++++++++++++++++++--------------------------- 1 file changed, 44 insertions(+), 44 deletions(-) diff --git a/src/Main.hs b/src/Main.hs index f5dd2eb..417bbab 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -2,46 +2,37 @@ module Main where -import AnnForall (annotateForall) -import Codegen.Codegen (generateCode) -import Compiler (compile) -import Control.Monad (when, (<=<)) -import Data.List.Extra (isSuffixOf) -import Data.Maybe (fromJust, isNothing) -import Desugar.Desugar (desugar) -import GHC.IO.Handle.Text (hPutStrLn) -import Grammar.ErrM (Err) -import Grammar.Layout (resolveLayout) -import Grammar.Par (myLexer, pProgram) -import Grammar.Print (Print, printTree) -import LambdaLifter (lambdaLift) -import Monomorphizer.Monomorphizer (monomorphize) -import Renamer.Renamer (rename) -import ReportForall (reportForall) -import System.Console.GetOpt ( - ArgDescr (NoArg, ReqArg), - ArgOrder (RequireOrder), - OptDescr (Option), - getOpt, - usageInfo, - ) -import System.Directory ( - createDirectory, - doesPathExist, - getDirectoryContents, - removeDirectoryRecursive, - setCurrentDirectory, - ) -import System.Environment (getArgs) -import System.Exit ( - ExitCode (ExitFailure), - exitFailure, - exitSuccess, - exitWith, - ) -import System.IO (stderr) -import System.Process (spawnCommand, waitForProcess) -import TypeChecker.TypeChecker (TypeChecker (Bi, Hm), typecheck) +import AnnForall (annotateForall) +import Codegen.Codegen (generateCode) +import Compiler (compile) +import Control.Monad (when, (<=<)) +import Data.List.Extra (isSuffixOf) +import Data.Maybe (fromJust, isNothing) +import Desugar.Desugar (desugar) +import GHC.IO.Handle.Text (hPutStrLn) +import Grammar.ErrM (Err) +import Grammar.Layout (resolveLayout) +import Grammar.Par (myLexer, pProgram) +import Grammar.Print (Print, printTree) +import LambdaLifter (lambdaLift) +import Monomorphizer.Monomorphizer (monomorphize) +import Renamer.Renamer (rename) +import ReportForall (reportForall) +import System.Console.GetOpt (ArgDescr (NoArg, ReqArg), + ArgOrder (RequireOrder), + OptDescr (Option), getOpt, + usageInfo) +import System.Directory (createDirectory, doesPathExist, + getDirectoryContents, + removeDirectoryRecursive, + setCurrentDirectory) +import System.Environment (getArgs) +import System.Exit (ExitCode (ExitFailure), + exitFailure, exitSuccess, + exitWith) +import System.IO (stderr) +import System.Process (spawnCommand, waitForProcess) +import TypeChecker.TypeChecker (TypeChecker (Bi, Hm), typecheck) main :: IO () main = getArgs >>= parseArgs >>= uncurry main' @@ -88,11 +79,11 @@ chooseTypechecker s options = options{typechecker = tc} tc = case s of "hm" -> pure Hm "bi" -> pure Bi - _ -> Nothing + _ -> Nothing data Options = Options - { help :: Bool - , debug :: Bool + { help :: Bool + , debug :: Bool , typechecker :: Maybe TypeChecker } @@ -166,4 +157,13 @@ printToErr = hPutStrLn stderr fromErr :: Err a -> IO a fromErr = either (\s -> printToErr s >> exitFailure) pure -prelude = "\n\nconst x y = x\n\ndata Bool () where\n True : Bool ()\n False : Bool ()\n\nlt : Int -> Int -> Bool ()\nlt = \\x. \\y. const True (x + y)" +prelude :: String +prelude = unlines + [ "\n" + , "const : a -> b -> a" + , "data Bool () where" + , " False : Bool ()" + , " True : Bool ()" + , "lt : Int -> Int -> Bool ()" + , "lt x y = const True (x + y)" + ] From 072f2206e6889f6fb1b6d795c79134fbe7f1cc18 Mon Sep 17 00:00:00 2001 From: sebastianselander Date: Fri, 28 Apr 2023 12:53:29 +0200 Subject: [PATCH 323/372] added const body again --- src/Main.hs | 97 +++++++++++++++++++++++++++++------------------------ 1 file changed, 54 insertions(+), 43 deletions(-) diff --git a/src/Main.hs b/src/Main.hs index 417bbab..f16b29f 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -2,37 +2,46 @@ module Main where -import AnnForall (annotateForall) -import Codegen.Codegen (generateCode) -import Compiler (compile) -import Control.Monad (when, (<=<)) -import Data.List.Extra (isSuffixOf) -import Data.Maybe (fromJust, isNothing) -import Desugar.Desugar (desugar) -import GHC.IO.Handle.Text (hPutStrLn) -import Grammar.ErrM (Err) -import Grammar.Layout (resolveLayout) -import Grammar.Par (myLexer, pProgram) -import Grammar.Print (Print, printTree) -import LambdaLifter (lambdaLift) -import Monomorphizer.Monomorphizer (monomorphize) -import Renamer.Renamer (rename) -import ReportForall (reportForall) -import System.Console.GetOpt (ArgDescr (NoArg, ReqArg), - ArgOrder (RequireOrder), - OptDescr (Option), getOpt, - usageInfo) -import System.Directory (createDirectory, doesPathExist, - getDirectoryContents, - removeDirectoryRecursive, - setCurrentDirectory) -import System.Environment (getArgs) -import System.Exit (ExitCode (ExitFailure), - exitFailure, exitSuccess, - exitWith) -import System.IO (stderr) -import System.Process (spawnCommand, waitForProcess) -import TypeChecker.TypeChecker (TypeChecker (Bi, Hm), typecheck) +import AnnForall (annotateForall) +import Codegen.Codegen (generateCode) +import Compiler (compile) +import Control.Monad (when, (<=<)) +import Data.List.Extra (isSuffixOf) +import Data.Maybe (fromJust, isNothing) +import Desugar.Desugar (desugar) +import GHC.IO.Handle.Text (hPutStrLn) +import Grammar.ErrM (Err) +import Grammar.Layout (resolveLayout) +import Grammar.Par (myLexer, pProgram) +import Grammar.Print (Print, printTree) +import LambdaLifter (lambdaLift) +import Monomorphizer.Monomorphizer (monomorphize) +import Renamer.Renamer (rename) +import ReportForall (reportForall) +import System.Console.GetOpt ( + ArgDescr (NoArg, ReqArg), + ArgOrder (RequireOrder), + OptDescr (Option), + getOpt, + usageInfo, + ) +import System.Directory ( + createDirectory, + doesPathExist, + getDirectoryContents, + removeDirectoryRecursive, + setCurrentDirectory, + ) +import System.Environment (getArgs) +import System.Exit ( + ExitCode (ExitFailure), + exitFailure, + exitSuccess, + exitWith, + ) +import System.IO (stderr) +import System.Process (spawnCommand, waitForProcess) +import TypeChecker.TypeChecker (TypeChecker (Bi, Hm), typecheck) main :: IO () main = getArgs >>= parseArgs >>= uncurry main' @@ -79,11 +88,11 @@ chooseTypechecker s options = options{typechecker = tc} tc = case s of "hm" -> pure Hm "bi" -> pure Bi - _ -> Nothing + _ -> Nothing data Options = Options - { help :: Bool - , debug :: Bool + { help :: Bool + , debug :: Bool , typechecker :: Maybe TypeChecker } @@ -158,12 +167,14 @@ fromErr :: Err a -> IO a fromErr = either (\s -> printToErr s >> exitFailure) pure prelude :: String -prelude = unlines - [ "\n" - , "const : a -> b -> a" - , "data Bool () where" - , " False : Bool ()" - , " True : Bool ()" - , "lt : Int -> Int -> Bool ()" - , "lt x y = const True (x + y)" - ] +prelude = + unlines + [ "\n" + , "const : a -> b -> a" + , "const x y = x" + , "data Bool () where" + , " False : Bool ()" + , " True : Bool ()" + , "lt : Int -> Int -> Bool ()" + , "lt x y = const True (x + y)" + ] From 22ffdffa5a9d8f3c74e85f82fae8af5b2bbbf617 Mon Sep 17 00:00:00 2001 From: Martin Fredin Date: Thu, 27 Apr 2023 18:59:16 +0200 Subject: [PATCH 324/372] Fix pretty printer --- src/TypeChecker/TypeCheckerIr.hs | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/src/TypeChecker/TypeCheckerIr.hs b/src/TypeChecker/TypeCheckerIr.hs index 21f2227..847c4a9 100644 --- a/src/TypeChecker/TypeCheckerIr.hs +++ b/src/TypeChecker/TypeCheckerIr.hs @@ -74,9 +74,8 @@ instance Print t => Print (Program' t) where prt i (Program sc) = prt i sc instance Print t => Print (Bind' t) where - prt i (Bind sig@(name, _) parms rhs) = concatD + prt i (Bind sig parms rhs) = concatD [ prtSig sig - , prt i name , prt i parms , doc $ showString "=" , prt i rhs @@ -88,7 +87,6 @@ prtSig (name, t) = [ prt 0 name , doc $ showString ":" , prt 0 t - , doc $ showString ";" ] instance Print t => Print (ExpT' t) where From b27988b4d89cbca0ef0c252274dc0698c8be82af Mon Sep 17 00:00:00 2001 From: Martin Fredin Date: Fri, 28 Apr 2023 14:04:47 +0200 Subject: [PATCH 325/372] Add checking for case --- src/TypeChecker/TypeCheckerBidir.hs | 29 ++++++++++++++++++++++++++++- 1 file changed, 28 insertions(+), 1 deletion(-) diff --git a/src/TypeChecker/TypeCheckerBidir.hs b/src/TypeChecker/TypeCheckerBidir.hs index 714b4c9..4cc8d5e 100644 --- a/src/TypeChecker/TypeCheckerBidir.hs +++ b/src/TypeChecker/TypeCheckerBidir.hs @@ -9,7 +9,7 @@ module TypeChecker.TypeCheckerBidir (typecheck) where import Auxiliary (int, litType, maybeToRightM, snoc) import Control.Applicative (Applicative (liftA2), (<|>)) import Control.Monad.Except (ExceptT, MonadError (throwError), - runExceptT, unless, zipWithM, + forM, runExceptT, unless, zipWithM, zipWithM_) import Control.Monad.Extra (fromMaybeM) import Control.Monad.State (MonadState, State, evalState, gets, @@ -193,6 +193,30 @@ check (EAbs x e) (TFun a b) = do putEnv env_l apply (T.EAbs (coerce x) e', TFun a b) + --FIXME +-- Γ ⊢ e ↑ A ⊣ Θ Θ ⊢ Π ∷ [Θ]A ↓ C ⊣ Δ +-- ------------------------------------ Case +-- Γ ⊢ case e of Π ↓ C ⊣ Δ +check (ECase scrut pi) c = do + (scrut', a) <- infer scrut + case pi of + [] -> do + subtype a c + apply (T.ECase (scrut', a) [], a) + _ -> do + pi' <- forM pi $ \(Branch p e) -> do + p' <- checkPattern p =<< apply a + e' <- check e c + pure (T.Branch p' e') + apply (T.ECase (scrut', a) pi', c) + where + go (pi, b) (Branch p e) = do + p' <- checkPattern p =<< apply a + e'@(_, b') <- infer e + subtype b' b + apply (T.Branch p' e' : pi, b') + + -- Γ,α ⊢ e ↓ A ⊣ Θ Θ ⊢ [Θ]A <: [Θ]B ⊣ Δ -- -------------------------------------- Sub -- Γ ⊢ e ↑ B ⊣ Δ @@ -202,6 +226,9 @@ check e b = do subtype a b' apply (e', b) + + + checkPattern :: Pattern -> Type -> Tc (T.Pattern' Type, Type) checkPattern patt t_patt = case patt of From 1723796006522aa5e6f725fb01eab9f909bbf3e8 Mon Sep 17 00:00:00 2001 From: sebastianselander Date: Fri, 28 Apr 2023 14:01:05 +0200 Subject: [PATCH 326/372] renamed and fixed const in prelude --- src/Main.hs | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/src/Main.hs b/src/Main.hs index f16b29f..a916139 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -170,11 +170,12 @@ prelude :: String prelude = unlines [ "\n" - , "const : a -> b -> a" - , "const x y = x" + , "customHelperFunctionCuzPoorImplementation : Bool -> Int -> Bool" + , "customHelperFunctionCuzPoorImplementation x y = x" , "data Bool () where" , " False : Bool ()" , " True : Bool ()" , "lt : Int -> Int -> Bool ()" - , "lt x y = const True (x + y)" + , "lt x y = customHelperFunctionCuzPoorImplementation True (x + y)" + , "\n" ] From cb619c96a86e8f182ce5367a7253f1adb8499cda Mon Sep 17 00:00:00 2001 From: Samuel Hammersberg Date: Fri, 28 Apr 2023 14:10:22 +0200 Subject: [PATCH 327/372] Removed a stupid file --- llvm.ll | 10 ---------- 1 file changed, 10 deletions(-) delete mode 100644 llvm.ll diff --git a/llvm.ll b/llvm.ll deleted file mode 100644 index cd6b190..0000000 --- a/llvm.ll +++ /dev/null @@ -1,10 +0,0 @@ -@.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 -} From e8d37c77cb2d700ff5ce497fe1351e553fcc80d8 Mon Sep 17 00:00:00 2001 From: Samuel Hammersberg Date: Fri, 28 Apr 2023 14:10:39 +0200 Subject: [PATCH 328/372] Fixed a typo. --- src/Main.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Main.hs b/src/Main.hs index a916139..5e4d09c 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -170,7 +170,7 @@ prelude :: String prelude = unlines [ "\n" - , "customHelperFunctionCuzPoorImplementation : Bool -> Int -> Bool" + , "customHelperFunctionCuzPoorImplementation : Bool () -> Int -> Bool ()" , "customHelperFunctionCuzPoorImplementation x y = x" , "data Bool () where" , " False : Bool ()" From 38b88d36b596edae1688e9c6b04f00ab4ccc1854 Mon Sep 17 00:00:00 2001 From: Martin Fredin Date: Fri, 28 Apr 2023 14:20:24 +0200 Subject: [PATCH 329/372] Use throwError instead of error --- src/TypeChecker/TypeCheckerBidir.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/TypeChecker/TypeCheckerBidir.hs b/src/TypeChecker/TypeCheckerBidir.hs index 4cc8d5e..cb35bac 100644 --- a/src/TypeChecker/TypeCheckerBidir.hs +++ b/src/TypeChecker/TypeCheckerBidir.hs @@ -605,7 +605,7 @@ instantiateR a alpha = gets env >>= \env -> go env a alpha let (env_l, _) = splitOn (EnvMark epsilon') env putEnv env_l - go _ a alpha = error $ "Trying to instantiateR: " ++ ppT a ++ " <: " + go _ a alpha = throwError $ "Trying to instantiateR: " ++ ppT a ++ " <: " ++ ppT (TEVar alpha) --------------------------------------------------------------------------- From ddffe7913c4a4c9fac77e84ee1b448488a23679b Mon Sep 17 00:00:00 2001 From: Samuel Hammersberg Date: Fri, 28 Apr 2023 14:22:02 +0200 Subject: [PATCH 330/372] Added an option to disable the garbage collector (this feature is not implemented fully yet.). --- Justfile | 8 +++++++- src/Main.hs | 6 ++++++ 2 files changed, 13 insertions(+), 1 deletion(-) diff --git a/Justfile b/Justfile index 01c262e..a7acacd 100644 --- a/Justfile +++ b/Justfile @@ -26,4 +26,10 @@ hmd FILE: cabal run language -- -d -t hm {{FILE}} bid FILE: - cabal run language -- -d -t bi {{FILE}} \ No newline at end of file + cabal run language -- -d -t bi {{FILE}} + +hmdm FILE: + cabal run language -- -d -t hm -m {{FILE}} + +bidm FILE: + cabal run language -- -d -t bi -m {{FILE}} \ No newline at end of file diff --git a/src/Main.hs b/src/Main.hs index 5e4d09c..316024d 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -65,6 +65,7 @@ flags :: [OptDescr (Options -> Options)] flags = [ Option ['d'] ["debug"] (NoArg enableDebug) "Print debug messages." , Option ['t'] ["type-checker"] (ReqArg chooseTypechecker "bi/hm") "Choose type checker. Possible options are bi and hm" + , Option ['m'] ["disable-gc"] (NoArg disableGC) "Disables the garbage collector and uses malloc instead." , Option [] ["help"] (NoArg enableHelp) "Print this help message" ] @@ -73,6 +74,7 @@ initOpts = Options { help = False , debug = False + , gc = True , typechecker = Nothing } @@ -82,6 +84,9 @@ enableHelp opts = opts{help = True} enableDebug :: Options -> Options enableDebug opts = opts{debug = True} +disableGC :: Options -> Options +disableGC opts = opts{gc = False} + chooseTypechecker :: String -> Options -> Options chooseTypechecker s options = options{typechecker = tc} where @@ -93,6 +98,7 @@ chooseTypechecker s options = options{typechecker = tc} data Options = Options { help :: Bool , debug :: Bool + , gc :: Bool , typechecker :: Maybe TypeChecker } From f9d28028b5d3210637132c93a156275b474ad319 Mon Sep 17 00:00:00 2001 From: Samuel Hammersberg Date: Fri, 28 Apr 2023 14:24:44 +0200 Subject: [PATCH 331/372] The GC argument is now passed to the compiler and codegen. --- src/Codegen/Codegen.hs | 4 ++-- src/Compiler.hs | 4 ++-- src/Main.hs | 4 ++-- 3 files changed, 6 insertions(+), 6 deletions(-) diff --git a/src/Codegen/Codegen.hs b/src/Codegen/Codegen.hs index e3343d7..60135a7 100644 --- a/src/Codegen/Codegen.hs +++ b/src/Codegen/Codegen.hs @@ -18,8 +18,8 @@ import TypeChecker.TypeCheckerIr (Ident (..)) An easy way to actually "compile" this output is to Simply pipe it to LLI -} -generateCode :: MIR.Program -> Err String -generateCode (MIR.Program scs) = do +generateCode :: MIR.Program -> Bool -> Err String +generateCode (MIR.Program scs) addGc = do let tree = filter (not . detectPrelude) (sortBy lowData scs) let codegen = initCodeGenerator tree llvmIrToString . instructions <$> execStateT (compileScs tree) codegen diff --git a/src/Compiler.hs b/src/Compiler.hs index 43c9c5e..12f36b0 100644 --- a/src/Compiler.hs +++ b/src/Compiler.hs @@ -29,5 +29,5 @@ compileClang = , "-" ] -compile :: String -> IO String -compile s = optimize s >>= compileClang +compile :: String -> Bool -> IO String +compile s addGc = optimize s >>= compileClang diff --git a/src/Main.hs b/src/Main.hs index 316024d..c870d8b 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -137,7 +137,7 @@ main' opts s = log monomorphized printToErr "\n -- Compiler --" - generatedCode <- fromErr $ generateCode monomorphized + generatedCode <- fromErr $ generateCode monomorphized (gc opts) check <- doesPathExist "output" when check (removeDirectoryRecursive "output") @@ -146,7 +146,7 @@ main' opts s = writeFile "output/llvm.ll" generatedCode debugDotViz - compile generatedCode + compile generatedCode (gc opts) printToErr "Compilation done!" printToErr "\n-- Program output --" print =<< spawnWait "./output/hello_world" From de03a2cc34d04df776823424e71a5b49ca2f3055 Mon Sep 17 00:00:00 2001 From: Samuel Hammersberg Date: Fri, 28 Apr 2023 14:52:47 +0200 Subject: [PATCH 332/372] The code generator can now compile without the GC. --- src/Codegen/Codegen.hs | 2 +- src/Codegen/CompilerState.hs | 14 ++++++++++---- src/Codegen/Emits.hs | 25 +++++++++++++++++-------- src/Codegen/LlvmIr.hs | 8 ++++++-- src/Compiler.hs | 17 ++++++++++++++--- 5 files changed, 48 insertions(+), 18 deletions(-) diff --git a/src/Codegen/Codegen.hs b/src/Codegen/Codegen.hs index 60135a7..be92a35 100644 --- a/src/Codegen/Codegen.hs +++ b/src/Codegen/Codegen.hs @@ -21,7 +21,7 @@ import TypeChecker.TypeCheckerIr (Ident (..)) generateCode :: MIR.Program -> Bool -> Err String generateCode (MIR.Program scs) addGc = do let tree = filter (not . detectPrelude) (sortBy lowData scs) - let codegen = initCodeGenerator tree + let codegen = initCodeGenerator addGc tree llvmIrToString . instructions <$> execStateT (compileScs tree) codegen detectPrelude :: Def -> Bool diff --git a/src/Codegen/CompilerState.hs b/src/Codegen/CompilerState.hs index 114a651..1379d2f 100644 --- a/src/Codegen/CompilerState.hs +++ b/src/Codegen/CompilerState.hs @@ -22,6 +22,7 @@ data CodeGenerator = CodeGenerator , constructors :: Map TIR.Ident ConstructorInfo , variableCount :: Integer , labelCount :: Integer + , gcEnabled :: Bool } -- | A state type synonym @@ -115,15 +116,16 @@ getTypes bs = Map.fromList $ go bs variantTypes fi = init $ map type2LlvmType (flattenType fi) biggestVariant ts = 8 + maximum (sum . (\(Inj _ fi) -> typeByteSize <$> variantTypes fi) <$> ts) -initCodeGenerator :: [MIR.Def] -> CodeGenerator -initCodeGenerator scs = +initCodeGenerator :: Bool -> [MIR.Def] -> CodeGenerator +initCodeGenerator addGc scs = CodeGenerator - { instructions = defaultStart + { instructions = defaultStart <> if addGc then gcStart else [] , functions = getFunctions scs , constructors = getConstructors scs , customTypes = getTypes scs , variableCount = 0 , labelCount = 0 + , gcEnabled = addGc } defaultStart :: [LLVMIr] @@ -135,7 +137,11 @@ defaultStart = , UnsafeRaw "declare i32 @printf(ptr noalias nocapture, ...)\n" , UnsafeRaw "declare i32 @exit(i32 noundef)\n" , UnsafeRaw "declare ptr @malloc(i32 noundef)\n" - , UnsafeRaw "declare external void @cheap_init()\n" + ] + +gcStart :: [LLVMIr] +gcStart = + [ UnsafeRaw "declare external void @cheap_init()\n" , UnsafeRaw "declare external ptr @cheap_alloc(i64)\n" , UnsafeRaw "declare external void @cheap_dispose()\n" , UnsafeRaw "declare external ptr @cheap_the()\n" diff --git a/src/Codegen/Emits.hs b/src/Codegen/Emits.hs index c851374..66cad6e 100644 --- a/src/Codegen/Emits.hs +++ b/src/Codegen/Emits.hs @@ -77,7 +77,8 @@ compileScs [] = do Just s -> do emit $ Comment "Malloc and store" heapPtr <- getNewVar - emit $ SetVariable heapPtr (Malloca s) + useGc <- gets gcEnabled + emit $ SetVariable heapPtr (if useGc then GcMalloc s else Malloc s) emit $ Store arg_t' (VIdent (TIR.Ident arg_n) arg_t') Ptr heapPtr emit $ Store (Ref arg_t') (VIdent heapPtr arg_t') Ptr elemPtr Nothing -> do @@ -103,10 +104,11 @@ compileScs (MIR.DBind (MIR.Bind (name, t) args exp) : xs) = do emit . Comment $ show name <> ": " <> show exp let args' = map (second type2LlvmType) args emit $ Define FastCC t_return name args' - when (name == "main") (mapM_ emit firstMainContent) + useGc <- gets gcEnabled + when (name == "main") (mapM_ emit (firstMainContent useGc)) functionBody <- exprToValue exp if name == "main" - then mapM_ emit $ lastMainContent functionBody + then mapM_ emit $ lastMainContent useGc functionBody else emit $ Ret t_return functionBody emit DefineEnd modify $ \s -> s{variableCount = 0} @@ -126,20 +128,26 @@ compileScs (MIR.DData (MIR.Data typ ts) : xs) = do ts compileScs xs -firstMainContent :: [LLVMIr] -firstMainContent = +firstMainContent :: Bool -> [LLVMIr] +firstMainContent True = [ UnsafeRaw "%prof = call ptr @cheap_the()\n" , UnsafeRaw "call void @cheap_set_profiler(ptr %prof, i1 true)\n" , UnsafeRaw "call void @cheap_init()\n" ] +firstMainContent False = [] -lastMainContent :: LLVMValue -> [LLVMIr] -lastMainContent var = +lastMainContent :: Bool -> LLVMValue -> [LLVMIr] +lastMainContent True var = [ UnsafeRaw $ "call i32 (ptr, ...) @printf(ptr noundef @.str, i64 noundef " <> toIr var <> ")\n" , UnsafeRaw "call void @cheap_dispose()\n" , Ret I64 (VInteger 0) ] +lastMainContent False var = + [ UnsafeRaw $ + "call i32 (ptr, ...) @printf(ptr noundef @.str, i64 noundef " <> toIr var <> ")\n" + , Ret I64 (VInteger 0) + ] compileExp :: ExpT -> CompilerState () compileExp (MIR.ELit lit, _t) = emitLit lit @@ -175,7 +183,8 @@ emitECased t e cases = do -- emit $ Label crashLbl var_num <- getVarCount emit . UnsafeRaw $ "call i32 (ptr, ...) @printf(ptr noundef @.non_exhaustive_patterns, i64 noundef " <> show var_num <> ", i64 noundef 6)\n" - emit . UnsafeRaw $ "call void @cheap_dispose()\n" + useGc <- gets gcEnabled + when useGc (emit . UnsafeRaw $ "call void @cheap_dispose()\n") emit . UnsafeRaw $ "call i32 @exit(i32 noundef 1)\n" mapM_ (const increaseVarCount) [0 .. 1] emit $ Br label diff --git a/src/Codegen/LlvmIr.hs b/src/Codegen/LlvmIr.hs index ac9432a..cc77cf9 100644 --- a/src/Codegen/LlvmIr.hs +++ b/src/Codegen/LlvmIr.hs @@ -133,7 +133,8 @@ data LLVMIr | Bitcast LLVMType LLVMValue LLVMType | Ret LLVMType LLVMValue | Comment String - | Malloca Integer + | Malloc Integer + | GcMalloc Integer | UnsafeRaw String -- This should generally be avoided, and proper -- instructions should be used in its place deriving (Show, Eq, Ord) @@ -223,7 +224,10 @@ llvmIrToString = go 0 , ")\n" ] (Alloca t) -> unwords ["alloca", toIr t, "\n"] - (Malloca t) -> + (Malloc t) -> + concat + [ "call ptr @malloc(i64 ", show t, ")\n"] + (GcMalloc t) -> concat [ "call ptr @cheap_alloc(i64 ", show t, ")\n"] (Store t1 val t2 (Ident id2)) -> diff --git a/src/Compiler.hs b/src/Compiler.hs index 12f36b0..72598cb 100644 --- a/src/Compiler.hs +++ b/src/Compiler.hs @@ -10,8 +10,19 @@ import System.Process.Extra ( optimize :: String -> IO String optimize = readCreateProcess (shell "opt --O3 --tailcallopt -S") -compileClang :: String -> IO String -compileClang = +compileClang :: Bool -> String -> IO String +compileClang False = + readCreateProcess . shell $ + unwords + [ "clang++" -- , "-Lsrc/GC/lib/", "-l:libgcoll.a" + , "-fno-rtti" + , "-x" + , "ir" -- , "-Lsrc/GC/lib -l:gcoll.a" + , "-o" + , "output/hello_world" + , "-" + ] +compileClang True = readCreateProcess . shell $ unwords [ "clang++" -- , "-Lsrc/GC/lib/", "-l:libgcoll.a" @@ -30,4 +41,4 @@ compileClang = ] compile :: String -> Bool -> IO String -compile s addGc = optimize s >>= compileClang +compile s addGc = optimize s >>= compileClang addGc From df1a5de04a52e25d609a1855b874ab7cc478a621 Mon Sep 17 00:00:00 2001 From: Martin Fredin Date: Fri, 28 Apr 2023 19:45:15 +0200 Subject: [PATCH 333/372] Add module to sort definitions --- language.cabal | 2 + src/Main.hs | 84 +++++++++++++---------------- src/OrderDefs.hs | 43 +++++++++++++++ src/TypeChecker/TypeCheckerBidir.hs | 25 +++++---- 4 files changed, 98 insertions(+), 56 deletions(-) create mode 100644 src/OrderDefs.hs diff --git a/language.cabal b/language.cabal index a290bc3..6ae9e12 100644 --- a/language.cabal +++ b/language.cabal @@ -36,6 +36,7 @@ executable language Renamer.Renamer TypeChecker.TypeChecker AnnForall + OrderDefs TypeChecker.TypeCheckerHm TypeChecker.TypeCheckerBidir TypeChecker.TypeCheckerIr @@ -90,6 +91,7 @@ Test-suite language-testsuite Grammar.Skel Grammar.ErrM Grammar.Layout + OrderDefs Auxiliary Monomorphizer.Monomorphizer Monomorphizer.MonomorphizerIr diff --git a/src/Main.hs b/src/Main.hs index c870d8b..9e4e677 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -2,46 +2,38 @@ module Main where -import AnnForall (annotateForall) -import Codegen.Codegen (generateCode) -import Compiler (compile) -import Control.Monad (when, (<=<)) -import Data.List.Extra (isSuffixOf) -import Data.Maybe (fromJust, isNothing) -import Desugar.Desugar (desugar) -import GHC.IO.Handle.Text (hPutStrLn) -import Grammar.ErrM (Err) -import Grammar.Layout (resolveLayout) -import Grammar.Par (myLexer, pProgram) -import Grammar.Print (Print, printTree) -import LambdaLifter (lambdaLift) -import Monomorphizer.Monomorphizer (monomorphize) -import Renamer.Renamer (rename) -import ReportForall (reportForall) -import System.Console.GetOpt ( - ArgDescr (NoArg, ReqArg), - ArgOrder (RequireOrder), - OptDescr (Option), - getOpt, - usageInfo, - ) -import System.Directory ( - createDirectory, - doesPathExist, - getDirectoryContents, - removeDirectoryRecursive, - setCurrentDirectory, - ) -import System.Environment (getArgs) -import System.Exit ( - ExitCode (ExitFailure), - exitFailure, - exitSuccess, - exitWith, - ) -import System.IO (stderr) -import System.Process (spawnCommand, waitForProcess) -import TypeChecker.TypeChecker (TypeChecker (Bi, Hm), typecheck) +import AnnForall (annotateForall) +import Codegen.Codegen (generateCode) +import Compiler (compile) +import Control.Monad (when, (<=<)) +import Data.List.Extra (isSuffixOf) +import Data.Maybe (fromJust, isNothing) +import Desugar.Desugar (desugar) +import GHC.IO.Handle.Text (hPutStrLn) +import Grammar.ErrM (Err) +import Grammar.Layout (resolveLayout) +import Grammar.Par (myLexer, pProgram) +import Grammar.Print (Print, printTree) +import LambdaLifter (lambdaLift) +import Monomorphizer.Monomorphizer (monomorphize) +import OrderDefs (orderDefs) +import Renamer.Renamer (rename) +import ReportForall (reportForall) +import System.Console.GetOpt (ArgDescr (NoArg, ReqArg), + ArgOrder (RequireOrder), + OptDescr (Option), getOpt, + usageInfo) +import System.Directory (createDirectory, doesPathExist, + getDirectoryContents, + removeDirectoryRecursive, + setCurrentDirectory) +import System.Environment (getArgs) +import System.Exit (ExitCode (ExitFailure), + exitFailure, exitSuccess, + exitWith) +import System.IO (stderr) +import System.Process (spawnCommand, waitForProcess) +import TypeChecker.TypeChecker (TypeChecker (Bi, Hm), typecheck) main :: IO () main = getArgs >>= parseArgs >>= uncurry main' @@ -93,12 +85,12 @@ chooseTypechecker s options = options{typechecker = tc} tc = case s of "hm" -> pure Hm "bi" -> pure Bi - _ -> Nothing + _ -> Nothing data Options = Options - { help :: Bool - , debug :: Bool - , gc :: Bool + { help :: Bool + , debug :: Bool + , gc :: Bool , typechecker :: Maybe TypeChecker } @@ -112,7 +104,7 @@ main' opts s = file <- readFile s printToErr "-- Parse Tree -- " - parsed <- fromErr . pProgram . resolveLayout True $ myLexer (file ++ prelude) + parsed <- fromErr . pProgram . resolveLayout True $ myLexer file -- (file ++ prelude) log parsed printToErr "-- Desugar --" @@ -125,7 +117,7 @@ main' opts s = log renamed printToErr "\n-- TypeChecker --" - typechecked <- fromErr $ typecheck (fromJust opts.typechecker) renamed + typechecked <- fromErr $ typecheck (fromJust opts.typechecker) (orderDefs renamed) log typechecked printToErr "\n-- Lambda Lifter --" diff --git a/src/OrderDefs.hs b/src/OrderDefs.hs new file mode 100644 index 0000000..079512b --- /dev/null +++ b/src/OrderDefs.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE LambdaCase #-} + +module OrderDefs where + +import Control.Monad.State (State, execState, get, modify, when) +import Data.Function (on) +import Data.List (partition, sortBy) +import Data.Set (Set) +import qualified Data.Set as Set +import Grammar.Abs + +orderDefs :: Program -> Program +orderDefs (Program defs) = + Program $ not_binds ++ map DBind (has_sig ++ orderBinds no_sig) + + where + (has_sig, no_sig) = partition (\(Bind n _ _) -> elem n sig_names) + [ b | DBind b <- defs] + sig_names = [ n | DSig (Sig n _) <- defs ] + not_binds = flip filter defs $ \case DBind _ -> False + _ -> True + +orderBinds :: [Bind] -> [Bind] +orderBinds binds = sortBy (on compare countUniqueCalls) binds + where + bind_names = [ n | Bind n _ _ <- binds] + + countUniqueCalls :: Bind -> Int + countUniqueCalls (Bind n _ e) = + Set.size $ execState (go e) (Set.singleton n) + where + go :: Exp -> State (Set LIdent) () + go exp = get >>= \called -> case exp of + EVar x -> when (Set.notMember x called && elem x bind_names) $ + modify (Set.insert x) + EApp e1 e2 -> on (>>) go e1 e2 + EAdd e1 e2 -> on (>>) go e1 e2 + ELet (Bind _ _ e) e' -> on (>>) go e e' + EAbs _ e -> go e + ECase e bs -> go e >> mapM_ (\(Branch _ e) -> go e) bs + EAnn e _ -> go e + EInj _ -> pure () + ELit _ -> pure () diff --git a/src/TypeChecker/TypeCheckerBidir.hs b/src/TypeChecker/TypeCheckerBidir.hs index cb35bac..fcef885 100644 --- a/src/TypeChecker/TypeCheckerBidir.hs +++ b/src/TypeChecker/TypeCheckerBidir.hs @@ -11,7 +11,7 @@ import Control.Applicative (Applicative (liftA2), (<|>)) import Control.Monad.Except (ExceptT, MonadError (throwError), forM, runExceptT, unless, zipWithM, zipWithM_) -import Control.Monad.Extra (fromMaybeM) +import Control.Monad.Extra (fromMaybeM, ifM) import Control.Monad.State (MonadState, State, evalState, gets, modify) import Data.Coerce (coerce) @@ -52,11 +52,12 @@ type Env = Seq EnvElem -- | Ordered context -- Γ ::= ・| Γ, α | Γ, ά | Γ, ▶ ά | Γ, x:A data Cxt = Cxt - { env :: Env -- ^ Local scope context Γ - , sig :: Map LIdent Type -- ^ Top-level signatures x : A - , binds :: Map LIdent Exp -- ^ Top-level binds x : e - , next_tevar :: Int -- ^ Counter to distinguish ά - , data_injs :: Map UIdent Type -- ^ Data injections (constructors) K/inj : A + { env :: Env -- ^ Local scope context Γ + , sig :: Map LIdent Type -- ^ Top-level signatures x : A + , binds :: Map LIdent Exp -- ^ Top-level binds x : e + , next_tevar :: Int -- ^ Counter to distinguish ά + , data_injs :: Map UIdent Type -- ^ Data injections (constructors) K/inj : A + , currentBind :: LIdent -- ^ Used for recursive functions } deriving (Show, Eq) newtype Tc a = Tc { runTc :: ExceptT String (State Cxt) a } @@ -77,6 +78,7 @@ initCxt defs = Cxt | DData (Data _ injs) <- defs , Inj name t <- injs ] + , currentBind = "" } where unboundedTVars = uncurry (Set.\\) . go (mempty, mempty) @@ -102,6 +104,7 @@ typecheckBinds cxt = flip evalState cxt typecheckBind :: Bind -> Tc (T.Bind' Type) typecheckBind (Bind name vars rhs) = do + modify $ \cxt -> cxt { currentBind = name } bind'@(T.Bind (name, typ) _ _) <- lookupSig name >>= \case Just t -> do (rhs', _) <- check (foldr EAbs rhs vars) t @@ -297,14 +300,16 @@ checkPattern patt t_patt = case patt of infer :: Exp -> Tc (T.ExpT' Type) infer (ELit lit) = apply (T.ELit lit, litType lit) --- Γ ∋ (x : A) Γ ∌ (x : A) --- ------------- Var --------------------- Var' +-- Γ ∋ (x : A) Γ ⊢ rec(x) +-- ------------- Var --------------------- VarRec -- Γ ⊢ x ↓ A ⊣ Γ Γ ⊢ x ↓ ά ⊣ Γ,(x : ά) infer (EVar x) = do - a <- fromMaybeM extend $ liftA2 (<|>) (lookupEnv x) (lookupSig x) + a <- ifM (gets $ (x==) . currentBind) varRec var apply (T.EVar (coerce x), a) where - extend = do + var = maybeToRightM "Can't infer" =<< + liftA2 (<|>) (lookupEnv x) (lookupSig x) + varRec = do alpha <- TEVar <$> fresh insertEnv (EnvVar x alpha) pure alpha From 619242ccaf74877141c040dc821e2165f2131a8c Mon Sep 17 00:00:00 2001 From: Martin Fredin Date: Sat, 29 Apr 2023 15:52:37 +0200 Subject: [PATCH 334/372] Fix lambda lifter --- language.cabal | 2 + sample-programs/example-programs/ex4.crf | 12 +- sample-programs/example-programs/ex5.crf | 26 -- sample-programs/example-programs/ex6.crf | 2 +- src/LambdaLifter.hs | 303 ++++++++++++----------- tests/TestLambdaLifter.hs | 117 +++++++++ 6 files changed, 280 insertions(+), 182 deletions(-) create mode 100644 tests/TestLambdaLifter.hs diff --git a/language.cabal b/language.cabal index 6ae9e12..af7178c 100644 --- a/language.cabal +++ b/language.cabal @@ -83,6 +83,8 @@ Test-suite language-testsuite TestAnnForall TestReportForall TestRenamer + TestLambdaLifter + DoStrings Grammar.Abs Grammar.Lex diff --git a/sample-programs/example-programs/ex4.crf b/sample-programs/example-programs/ex4.crf index a64adb5..9f412c6 100644 --- a/sample-programs/example-programs/ex4.crf +++ b/sample-programs/example-programs/ex4.crf @@ -1,11 +1,9 @@ -data Maybe () where { +data Maybe () where Just : Int -> Maybe () Nothing : Maybe () -}; -demoFunc x = case x of { - Just x => x + 24; - Nothing => 0; -}; +demoFunc x = case x of + Just x => x + 24 + Nothing => 0 -main = demoFunc Nothing ; \ No newline at end of file +main = demoFunc Nothing diff --git a/sample-programs/example-programs/ex5.crf b/sample-programs/example-programs/ex5.crf index b9457ed..e69de29 100644 --- a/sample-programs/example-programs/ex5.crf +++ b/sample-programs/example-programs/ex5.crf @@ -1,26 +0,0 @@ -main = case f (Just 10) of { - Just a => a ; - Nothing => 0 ; -}; - -f x = bind (fmap (\s . s + 1) x) (\s . pure (s + 10)) ; - -data Maybe () where { - Just : Int -> Maybe () - Nothing : Maybe () -}; - -fmap : (Int -> Int) -> Maybe () -> Maybe () ; -fmap f m = case m of { - Just a => pure (f a) ; - Nothing => Nothing ; -}; - -pure : Int -> Maybe () ; -pure x = Just x; - -bind : Maybe () -> (Int -> Maybe ()) -> Maybe () ; -bind x f = case x of { - Just x => f x ; - Nothing => Nothing ; -}; \ No newline at end of file diff --git a/sample-programs/example-programs/ex6.crf b/sample-programs/example-programs/ex6.crf index 41894a0..ebf8c6b 100644 --- a/sample-programs/example-programs/ex6.crf +++ b/sample-programs/example-programs/ex6.crf @@ -40,4 +40,4 @@ repeatHelp acc x n = case n of { -- represents minus one :) minusOne : Int ; -minusOne = 9223372036854775807 + 9223372036854775807 + 1; \ No newline at end of file +minusOne = 9223372036854775807 + 9223372036854775807 + 1; diff --git a/src/LambdaLifter.hs b/src/LambdaLifter.hs index dcd715b..83d3466 100644 --- a/src/LambdaLifter.hs +++ b/src/LambdaLifter.hs @@ -1,17 +1,16 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE OverloadedStrings #-} -module LambdaLifter (lambdaLift, freeVars, abstract, collectScs) where +module LambdaLifter where -import Auxiliary (mapAccumM, snoc) +import Auxiliary (onM, snoc) import Control.Applicative (Applicative (liftA2)) -import Control.Arrow (Arrow (second)) import Control.Monad.State (MonadState (get, put), State, evalState) -import Data.List (mapAccumL, partition) -import Data.Set (Set) -import qualified Data.Set as Set +import Data.Function (on) +import Data.List (delete, mapAccumL, (\\)) import Prelude hiding (exp) import TypeChecker.TypeCheckerIr @@ -21,176 +20,190 @@ import TypeChecker.TypeCheckerIr -- @freeVars@ annotates all the free variables. -- @abstract@ converts lambdas into let expressions. -- @collectScs@ moves every non-constant let expression to a top-level function. +-- lambdaLift :: Program -> Program -lambdaLift (Program defs) = Program $ datatypes ++ ll binds +lambdaLift (Program ds) = Program (datatypes ++ binds) where - ll = map DBind . collectScs . abstract . freeVars . map (\(DBind b) -> b) - (binds, datatypes) = partition isBind defs - isBind = \case - DBind _ -> True - _ -> False + datatypes = flip filter ds $ \case DData _ -> True + _ -> False + binds = map DBind $ (collectScs . abstract . freeVars) [b | DBind b <- ds] + +-- lambdaLift (Program defs) = trace (printTree abst) $ Program $ datatypes ++ ll binds +-- where +-- abst = abstract frees +-- frees = freeVars [b | DBind b@(Bind (Ident s, _) _ _) <- binds, s == "f"] +-- +-- ll = map DBind . collectScs . abstract . freeVars . map (\(DBind b) -> b) +-- (binds, datatypes) = partition isBind defs +-- isBind = \case +-- DBind _ -> True +-- _ -> False -- | Annotate free variables -freeVars :: [Bind] -> AnnBinds -freeVars binds = [ (n, xs, freeVarsExp (Set.fromList $ map fst xs) e) +freeVars :: [Bind] -> [ABind] +freeVars binds = [ let ae = freeVarsExp [] e + ae' = ae { frees = ae.frees \\ xs } + in ABind n xs ae' | Bind n xs e <- binds ] -freeVarsExp :: Set Ident -> ExpT -> AnnExpT -freeVarsExp localVars (exp, t) = case exp of - EVar n | Set.member n localVars -> (Set.singleton n, (AVar n, t)) - | otherwise -> (mempty, (AVar n, t)) +freeVarsExp :: Frees -> ExpT -> Ann AExpT +freeVarsExp localVars (ae, t) = case ae of + EVar n | elem (n,t) localVars -> Ann { frees = [(n, t)] + , term = (AVar n, t) + } + | otherwise -> Ann { frees = [] + , term = (AVar n, t) + } - EInj n -> (mempty, (AVar n, t)) + EInj n -> Ann { frees = [], term = (AInj n, t) } - ELit lit -> (mempty, (ALit lit, t)) + ELit lit -> Ann { frees = [], term = (ALit lit, t) } - EApp e1 e2 -> (Set.union (freeVarsOf e1') (freeVarsOf e2'), (AApp e1' e2', t)) + EApp e1 e2 -> Ann { frees = annae1.frees <|| annae2.frees + , term = (AApp annae1 annae2, t) + } where - e1' = freeVarsExp localVars e1 - e2' = freeVarsExp localVars e2 + (annae1, annae2) = on (,) (freeVarsExp localVars) e1 e2 - EAdd e1 e2 -> (Set.union (freeVarsOf e1') (freeVarsOf e2'), (AAdd e1' e2', t)) + EAdd e1 e2 -> Ann { frees = annae1.frees <|| annae2.frees + , term = (AAdd annae1 annae2, t) + } where - e1' = freeVarsExp localVars e1 - e2' = freeVarsExp localVars e2 + (annae1, annae2) = on (,) (freeVarsExp localVars) e1 e2 - EAbs par e -> (Set.delete par $ freeVarsOf e', (AAbs par e', t)) + + EAbs x e -> Ann { frees = delete (x,t_x) $ annae.frees + , term = (AAbs x annae, t) } where - e' = freeVarsExp (Set.insert par localVars) e + annae = freeVarsExp (localVars <| (x,t_x)) e + t_x = case t of TFun t _ -> t + _ -> error "Impossible" -- Sum free variables present in bind and the expression - ELet (Bind (name, t_bind) parms rhs) e -> (Set.union binders_frees e_free, (ALet new_bind e', t)) + -- let f x = x + y in f 5 + z → frees: y, z + ELet bind@(Bind n _ _) e -> + Ann { frees = delete n annae.frees <|| annbind.frees + , term = (ALet annbind annae, t) + } where - binders_frees = Set.delete name $ freeVarsOf rhs' - e_free = Set.delete name $ freeVarsOf e' + annae = freeVarsExp (localVars <| n) e + annbind = freeVarsBind localVars bind - rhs' = freeVarsExp e_localVars rhs - new_bind = ABind (name, t_bind) parms rhs' - - e' = freeVarsExp e_localVars e - e_localVars = Set.insert name localVars - - ECase e branches -> (frees, (ACase e' branches', t)) + ECase e branches -> + Ann { frees = foldl (<||) annae.frees (map frees annbranches) + , term = (ACase annae annbranches, t) + } where - frees = foldr (\b s -> Set.union s $ fst b) (freeVarsOf e') branches' - e' = freeVarsExp localVars e - branches' = map (freeVarsBranch localVars) branches + annae = freeVarsExp localVars e + annbranches = map (freeVarsBranch localVars) branches -freeVarsBranch :: Set Ident -> Branch' Type -> (Set Ident, AnnBranch') -freeVarsBranch localVars (Branch (patt, t) exp) = (frees, AnnBranch (patt, t) exp') +freeVarsBind :: Frees -> Bind -> Ann ABind +freeVarsBind localVars (Bind name vars e) = + Ann { frees = annae.frees \\ vars + , term = ABind name vars annae + } where - frees = freeVarsOf exp' Set.\\ freeVarsOfPattern patt - exp' = freeVarsExp localVars exp - freeVarsOfPattern = Set.fromList . go [] + annae = freeVarsExp (localVars <|| vars) e + + +freeVarsBranch :: Frees -> Branch -> Ann ABranch +freeVarsBranch localVars (Branch pt e) = + Ann { frees = annae.frees \\ varsInPattern + , term = ABranch pt annae + } + where + annae = freeVarsExp localVars e + varsInPattern = go [] pt where - go acc = \case - PVar n -> snoc n acc - PInj _ ps -> foldl go acc $ map fst ps + go acc (p, t) = case p of + PVar n -> acc <| (n, t) + PInj _ ps -> foldl go acc ps + _ -> [] - -freeVarsOf :: AnnExpT -> Set Ident -freeVarsOf = fst - -- AST annotated with free variables -type AnnBinds = [(Id, [Id], AnnExpT)] -type AnnExpT = (Set Ident, AnnExpT') +type Frees = [(Ident, Type)] -data ABind = ABind Id [Id] AnnExpT deriving Show +data Ann a = Ann + { frees :: Frees + , term :: a + } deriving (Show, Eq) -type AnnExpT' = (AnnExp, Type) +data ABind = ABind Id [Id] (Ann AExpT) deriving (Show, Eq) +data ABranch = ABranch (Pattern, Type) (Ann AExpT) deriving (Show, Eq) -type AnnBranch = (Set Ident, AnnBranch') -data AnnBranch' = AnnBranch (Pattern, Type) AnnExpT - deriving Show +type AExpT = (AExp, Type) -data AnnExp = AVar Ident +data AExp = AVar Ident | AInj Ident | ALit Lit - | ALet ABind AnnExpT - | AApp AnnExpT AnnExpT - | AAdd AnnExpT AnnExpT - | AAbs Ident AnnExpT - | ACase AnnExpT [AnnBranch] - deriving Show + | ALet (Ann ABind) (Ann AExpT) + | AApp (Ann AExpT) (Ann AExpT) + | AAdd (Ann AExpT) (Ann AExpT) + | AAbs Ident (Ann AExpT) + | ACase (Ann AExpT) [Ann ABranch] + deriving (Show, Eq) --- | Lift lambdas to let expression of the form @let sc = \v₁ x₁ -> e₁@. --- Free variables are @v₁ v₂ .. vₙ@ are bound. -abstract :: AnnBinds -> [Bind] -abstract prog = evalState (mapM go prog) 0 +abstract :: [ABind] -> [Bind] +abstract bs = evalState (mapM (abstractAnnBind . Ann []) bs) 0 + +abstractAnnBind :: Ann ABind -> State Int Bind +abstractAnnBind Ann { term = ABind name vars annae } = + Bind name (vars' <|| vars) <$> abstractAnnExp annae' where - go :: (Id, [Id], AnnExpT) -> State Int Bind - go (name, parms, rhs) = Bind name (parms ++ parms1) <$> abstractExp rhs' + (annae', vars') = go [] annae where - (rhs', parms1) = flattenLambdasAnn rhs + go acc = \case + Ann { term = (AAbs x ae, TFun t _) } -> go (snoc (x, t) acc) ae + ae -> (ae, acc) - --- | Flatten nested lambdas and collect the parameters --- @\x.\y.\z. ae → (ae, [x,y,z])@ -flattenLambdasAnn :: AnnExpT -> (AnnExpT, [Id]) -flattenLambdasAnn ae = go (ae, []) - where - go :: (AnnExpT, [Id]) -> (AnnExpT, [Id]) - go ((free, (e, t)), acc) - | AAbs par (free1, e1) <- e - , TFun t_par _ <- t - = go ((Set.delete par free1, e1), snoc (par, t_par) acc) - | otherwise = ((free, (e, t)), acc) - -abstractExp :: AnnExpT -> State Int ExpT -abstractExp (free, (exp, typ)) = case exp of - AVar n -> pure (EVar n, typ) - AInj n -> pure (EInj n, typ) +abstractAnnExp :: Ann AExpT -> State Int ExpT +abstractAnnExp Ann {frees, term = (annae, typ) } = case annae of + AVar n -> pure (EVar n, typ) + AInj n -> pure (EInj n, typ) ALit lit -> pure (ELit lit, typ) - AApp e1 e2 -> (, typ) <$> liftA2 EApp (abstractExp e1) (abstractExp e2) - AAdd e1 e2 -> (, typ) <$> liftA2 EAdd (abstractExp e1) (abstractExp e2) - ALet b e -> (, typ) <$> liftA2 ELet (go b) (abstractExp e) - where - go (ABind name parms rhs) = do - (rhs', parms1) <- flattenLambdas <$> skipLambdas abstractExp rhs - pure $ Bind name (parms ++ parms1) rhs' + AApp annae1 annae2 -> (, typ) <$> onM EApp abstractAnnExp annae1 annae2 + AAdd annae1 annae2 -> (, typ) <$> onM EAdd abstractAnnExp annae1 annae2 - skipLambdas :: (AnnExpT -> State Int ExpT) -> AnnExpT -> State Int ExpT - skipLambdas f (free, (ae, t)) = case ae of - AAbs par ae1 -> do - ae1' <- skipLambdas f ae1 - pure (EAbs par ae1', t) - _ -> f (free, (ae, t)) - - ACase e branches -> (, typ) <$> liftA2 ECase (abstractExp e) (mapM abstractBranch branches) - - - -- Lift lambda into let and bind free variables - AAbs parm e -> do + -- \x. \y. x + y + z ⇒ let sc x y z = x + y + z in sc + AAbs x annae' -> do i <- nextNumber - rhs <- abstractExp e - + rhs <- abstractAnnExp annae'' let sc_name = Ident ("sc_" ++ show i) sc = (ELet (Bind (sc_name, typ) vars rhs) (EVar sc_name, typ), typ) - pure $ foldl applyVars sc freeList + pure $ foldl applyFree sc frees where - freeList = Set.toList free - vars = zip names $ getVars typ - names = snoc parm freeList - applyVars (e, t) name = (EApp (e, t) (EVar name, t_var), t_return) + vars = frees <| (x, t_x) <|| ys + t_x = case typ of TFun t _ -> t + _ -> error "Impossible" + + (annae'', ys) = go [] annae' where - (t_var, t_return) = case t of - TFun t1 t2 -> (t1, t2) + go acc = \case + Ann { term = (AAbs x ae, TFun t _) } -> go (snoc (x, t) acc) ae + ae -> (ae, acc) + applyFree :: (Exp' Type, Type) -> (Ident, Type) -> (Exp' Type, Type) + applyFree (e, t_e) (x, t_x) = (EApp (e, t_e) (EVar x, t_x), t_e') + where + t_e' = case t_e of TFun _ t -> t + _ -> error "Impossible" -abstractBranch :: AnnBranch -> State Int Branch -abstractBranch (_, AnnBranch patt exp) = Branch patt <$> abstractExp exp + ACase annae' bs -> do + bs <- mapM go bs + e <- abstractAnnExp annae' + pure (ECase e bs, typ) + where + go Ann { term = ABranch p annae } = Branch p <$> abstractAnnExp annae + + ALet b annae' -> + (, typ) <$> liftA2 ELet (abstractAnnBind b) (abstractAnnExp annae') -nextNumber :: State Int Int -nextNumber = do - i <- get - put $ succ i - pure i -- | Collects supercombinators by lifting non-constant let expressions collectScs :: [Bind] -> [Bind] @@ -232,34 +245,28 @@ collectScsExp expT@(exp, typ) = case exp of -- -- > f = let sc x y = rhs in e -- - ELet (Bind name parms rhs) e -> if null parms - then ( rhs_scs ++ et_scs, (ELet bind et', snd et')) - else (bind : rhs_scs ++ et_scs, et') + ELet (Bind name parms rhs) e + | null parms -> (rhs_scs ++ et_scs, (ELet bind et', snd et')) + | otherwise -> (bind : rhs_scs ++ et_scs, et') where bind = Bind name parms rhs' (rhs_scs, rhs') = collectScsExp rhs - (et_scs, et') = collectScsExp e + (et_scs, et') = collectScsExp e collectScsBranch (Branch patt exp) = (scs, Branch patt exp') where (scs, exp') = collectScsExp exp +nextNumber :: State Int Int +nextNumber = do + i <- get + put $ succ i + pure i --- @\x.\y.\z. e → (e, [x,y,z])@ -flattenLambdas :: ExpT -> (ExpT, [Id]) -flattenLambdas = go . (, []) - where - go ((e, t), acc) = case e of - EAbs name e1 -> go (e1, snoc (name, t_var) acc) - where t_var = head $ getVars t - _ -> ((e, t), acc) -getVars :: Type -> [Type] -getVars = fst . partitionType +(<|) :: Eq a => [a] -> a -> [a] +xs <| x | elem x xs = xs + | otherwise = snoc x xs -partitionType :: Type -> ([Type], Type) -partitionType = go [] - where - go acc t = case t of - TFun t1 t2 -> go (snoc t1 acc) t2 - _ -> (acc, t) +(<||) :: Eq a => [a] -> [a] -> [a] +xs <|| ys = foldl (<|) xs ys diff --git a/tests/TestLambdaLifter.hs b/tests/TestLambdaLifter.hs new file mode 100644 index 0000000..79c78b2 --- /dev/null +++ b/tests/TestLambdaLifter.hs @@ -0,0 +1,117 @@ +{-# LANGUAGE PatternSynonyms #-} +{-# HLINT ignore "Use camelCase" #-} +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QualifiedDo #-} + +module TestLambdaLifter where + +import Test.Hspec + +import AnnForall (annotateForall) +import Control.Monad ((<=<)) +import Control.Monad.Error.Class (liftEither) +import Control.Monad.Extra (eitherM) +import Grammar.ErrM (Err, pattern Bad, pattern Ok) +import Grammar.Layout (resolveLayout) +import Grammar.Par (myLexer, pProgram) +import Grammar.Print (printTree) +import LambdaLifter +import Renamer.Renamer (rename) +import ReportForall (reportForall) +import TypeChecker.RemoveForall (removeForall) +import TypeChecker.ReportTEVar (reportTEVar) +import TypeChecker.TypeChecker (TypeChecker (Bi)) +import TypeChecker.TypeCheckerBidir (typecheck) +import TypeChecker.TypeCheckerIr + + +test = hspec testLambdaLifter + +testLambdaLifter = describe "Test Lambda Lifter" $ do + undefined +-- frees_exp1 + +-- frees_exp1 = specify "Free variables 1" $ +-- freeVarsExp [] (EAbs "x" (EVar "x", TVar' "a"), TVar' "a") +-- `shouldBe` answer +-- where +-- answer = Ann { frees = [] +-- , term = (AAbs (Ident "x") (Ann { frees = [Ident "x"] +-- , term = (AVar (Ident "x"),TVar (MkTVar (Ident "a"))) +-- } +-- ),TVar (MkTVar (Ident "a"))) +-- } + + +abs_1 = undefined + where + input = unlines [ "data List (a) where" + , " Nil : List (a)" + , " Cons : a -> List (a) -> List (a)" + , "map : (a -> b) -> List (a) -> List (b)" + , "add : Int -> Int -> Int" + + , "f : List (Int)" + , "f = (\\x.\\ys. map (\\y. add y x) ys) 4 (Cons 1 (Cons 2 Nil))" + ] + + + +runPrintFree = print $ freeVarsExp [] (EAbs "x" (EVar "x", TVar' "a"), TVar' "a") + +runAbstract = either putStrLn (putStrLn . printTree) (runAbs s2) + where + s = unlines [ "add : Int -> Int -> Int" + , "f : Int -> Int -> Int" + , "f x y = add x y" + , "f = \\x. (\\y. add x y)" + ] + + s2 = unlines [ "data List (a) where" + , " Nil : List (a)" + , " Cons : a -> List (a) -> List (a)" + , "map : (a -> b) -> List (a) -> List (b)" + , "add : Int -> Int -> Int" + + , "f : List (Int)" + , "f = (\\x.\\ys. map (\\y. add y x) ys) 4 (Cons 1 (Cons 2 Nil))" + ] + + +runCollect = either putStrLn (putStrLn . printTree) (run s) + where + s = unlines [ "data List (a) where" + , " Nil : List (a)" + , " Cons : a -> List (a) -> List (a)" + , "add : Int -> Int -> Int" + , "map : (a -> b) -> List (a) -> List (b)" + , "map f xs = case xs of" + , " Nil => Nil" + , " Cons x xs => Cons (f x) (map f xs)" + + , "f : List (Int)" + , "f = (\\x.\\ys. map (\\y. add y x) ys) 4 (Cons 1 (Cons 2 Nil))" + ] + + +run = fmap collectScs . runAbs + +runAbs s = do + Program ds <- run' s + pure $ (abstract . freeVars) [b | DBind b <- ds] + + +run' = fmap removeForall + . reportTEVar + <=< typecheck + <=< run'' + +run'' s = do + p <- (pProgram . resolveLayout True . myLexer) s + reportForall Bi p + (rename <=< annotateForall) p + + + + From a2f61ea91042ac0b3835d3efc738ac380a1ee979 Mon Sep 17 00:00:00 2001 From: Martin Fredin Date: Sat, 29 Apr 2023 15:56:01 +0200 Subject: [PATCH 335/372] Fix missing pattern synonym --- src/TypeChecker/TypeCheckerIr.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/TypeChecker/TypeCheckerIr.hs b/src/TypeChecker/TypeCheckerIr.hs index 847c4a9..a956ff3 100644 --- a/src/TypeChecker/TypeCheckerIr.hs +++ b/src/TypeChecker/TypeCheckerIr.hs @@ -191,5 +191,6 @@ type Inj = Inj' Type type Exp = Exp' Type type ExpT = ExpT' Type type Id = Id' Type +pattern TVar' s = TVar (MkTVar s) pattern DBind' id vars expt = DBind (Bind id vars expt) pattern DData' typ injs = DData (Data typ injs) From a87862a99f818d3dff0f8f6aaa3ab3e00b29019a Mon Sep 17 00:00:00 2001 From: Martin Fredin Date: Sat, 29 Apr 2023 16:02:51 +0200 Subject: [PATCH 336/372] Fix sample programs --- sample-programs/basic-0.crf | 20 ----------- sample-programs/basic-1.crf | 13 ------- sample-programs/basic-10.crf | 10 ------ sample-programs/basic-2.crf | 6 ---- sample-programs/basic-3.crf | 2 -- sample-programs/basic-4.crf | 2 -- sample-programs/basic-5.crf | 8 ----- sample-programs/basic-6.crf | 15 --------- sample-programs/basic-7.crf | 8 ----- sample-programs/basic-8.crf | 20 ----------- sample-programs/basic-9.crf | 10 ------ sample-programs/example-programs/ex1.crf | 1 - sample-programs/example-programs/ex2.crf | 4 --- sample-programs/example-programs/ex3.crf | 11 ------ sample-programs/example-programs/ex4.crf | 9 ----- sample-programs/example-programs/ex5.crf | 0 sample-programs/example-programs/ex6.crf | 43 ------------------------ sample-programs/mono-1.crf | 2 ++ sample-programs/mono-2.crf | 9 +++-- 19 files changed, 8 insertions(+), 185 deletions(-) delete mode 100644 sample-programs/basic-0.crf delete mode 100644 sample-programs/basic-1.crf delete mode 100644 sample-programs/basic-10.crf delete mode 100644 sample-programs/basic-2.crf delete mode 100644 sample-programs/basic-3.crf delete mode 100644 sample-programs/basic-4.crf delete mode 100644 sample-programs/basic-5.crf delete mode 100644 sample-programs/basic-6.crf delete mode 100644 sample-programs/basic-7.crf delete mode 100644 sample-programs/basic-8.crf delete mode 100644 sample-programs/basic-9.crf delete mode 100644 sample-programs/example-programs/ex1.crf delete mode 100644 sample-programs/example-programs/ex2.crf delete mode 100644 sample-programs/example-programs/ex3.crf delete mode 100644 sample-programs/example-programs/ex4.crf delete mode 100644 sample-programs/example-programs/ex5.crf delete mode 100644 sample-programs/example-programs/ex6.crf diff --git a/sample-programs/basic-0.crf b/sample-programs/basic-0.crf deleted file mode 100644 index d9adeda..0000000 --- a/sample-programs/basic-0.crf +++ /dev/null @@ -1,20 +0,0 @@ -data Bool () where - True : Bool () - False : Bool () - -not x = case x of - True => False - False => True - -even : Int -> Bool () -even x = not (odd x) -odd x = not (even x) - -main = case even 64 of - True => 1 - False => 0 - - - - - diff --git a/sample-programs/basic-1.crf b/sample-programs/basic-1.crf deleted file mode 100644 index 59862d6..0000000 --- a/sample-programs/basic-1.crf +++ /dev/null @@ -1,13 +0,0 @@ -data Bool () where - True : Bool () - False : Bool () - -toBool x = case x of - 0 => False - _ => True - -fromBool b = case b of - False => 0 - True => 1 - -main = fromBool (toBool 10) diff --git a/sample-programs/basic-10.crf b/sample-programs/basic-10.crf deleted file mode 100644 index f99e2c8..0000000 --- a/sample-programs/basic-10.crf +++ /dev/null @@ -1,10 +0,0 @@ - - - -applyId : (forall a. a -> a) -> a -> a -applyId f x = f x - -id : a -> a -id x = x - -main = applyId id 4 diff --git a/sample-programs/basic-2.crf b/sample-programs/basic-2.crf deleted file mode 100644 index 5ce4da5..0000000 --- a/sample-programs/basic-2.crf +++ /dev/null @@ -1,6 +0,0 @@ -add : Int -> Int -> Int ; -add x = \y. x+y; - -main : Int ; -main = (\z. z+z) ((add 4) 6) ; - diff --git a/sample-programs/basic-3.crf b/sample-programs/basic-3.crf deleted file mode 100644 index 98c03b9..0000000 --- a/sample-programs/basic-3.crf +++ /dev/null @@ -1,2 +0,0 @@ -main : Int ; -main = (\x. x+x+3) ((\x. x) 2) ; diff --git a/sample-programs/basic-4.crf b/sample-programs/basic-4.crf deleted file mode 100644 index 55ac9eb..0000000 --- a/sample-programs/basic-4.crf +++ /dev/null @@ -1,2 +0,0 @@ -f : Int -> Int ; -f x = let g = (\y. y+1) in g (g x) diff --git a/sample-programs/basic-5.crf b/sample-programs/basic-5.crf deleted file mode 100644 index a6414f2..0000000 --- a/sample-programs/basic-5.crf +++ /dev/null @@ -1,8 +0,0 @@ -double : Int -> Int ; -double n = n + n; - -id : forall a. a -> a ; -id x = x ; - -main : Int ; -main = id double 5; diff --git a/sample-programs/basic-6.crf b/sample-programs/basic-6.crf deleted file mode 100644 index ed51a1c..0000000 --- a/sample-programs/basic-6.crf +++ /dev/null @@ -1,15 +0,0 @@ -data Bool () where - True : Bool () - False : Bool () - --- Both valid --- f : Bool () -> a -> Int -f : Bool () -> (forall a. a -> Int) -f b = case b of - False => (\x. 0 : forall a. a -> Int) - True => (\x. 1 : forall a. a -> Int) - - -main : Int -main = (f True) 'h' - diff --git a/sample-programs/basic-7.crf b/sample-programs/basic-7.crf deleted file mode 100644 index f0fc916..0000000 --- a/sample-programs/basic-7.crf +++ /dev/null @@ -1,8 +0,0 @@ -data Bool () where - True : Bool () - False : Bool () - -ifThenElse : Bool () -> a -> a -> a -ifThenElse b if else = case b of - True => if - False => else diff --git a/sample-programs/basic-8.crf b/sample-programs/basic-8.crf deleted file mode 100644 index 958459b..0000000 --- a/sample-programs/basic-8.crf +++ /dev/null @@ -1,20 +0,0 @@ -data Maybe (a) where - Nothing : Maybe (a) - Just : a -> Maybe (a) - -fromJust : Maybe (a) -> a -fromJust a = - case a of - Just a => a - -fromMaybe : a -> Maybe (a) -> a -fromMaybe a b = - case b of - Just a => a - Nothing => a - -maybe : b -> (a -> b) -> Maybe (a) -> b -maybe b f ma = - case ma of - Just a => f a - Nothing => b diff --git a/sample-programs/basic-9.crf b/sample-programs/basic-9.crf deleted file mode 100644 index 9e76336..0000000 --- a/sample-programs/basic-9.crf +++ /dev/null @@ -1,10 +0,0 @@ -data List (a) where - Nil : List (a) - Cons : a -> List (a) -> List (a) - -test xs = case xs of - Cons Nil _ => 0 - -List a /= List (List a) - -a /= List a diff --git a/sample-programs/example-programs/ex1.crf b/sample-programs/example-programs/ex1.crf deleted file mode 100644 index c7ad3b2..0000000 --- a/sample-programs/example-programs/ex1.crf +++ /dev/null @@ -1 +0,0 @@ -main = 5 + 2; \ No newline at end of file diff --git a/sample-programs/example-programs/ex2.crf b/sample-programs/example-programs/ex2.crf deleted file mode 100644 index 3510463..0000000 --- a/sample-programs/example-programs/ex2.crf +++ /dev/null @@ -1,4 +0,0 @@ -main = case 78 of { - 5 => 45; - x => x + 24; -}; \ No newline at end of file diff --git a/sample-programs/example-programs/ex3.crf b/sample-programs/example-programs/ex3.crf deleted file mode 100644 index 9f080ac..0000000 --- a/sample-programs/example-programs/ex3.crf +++ /dev/null @@ -1,11 +0,0 @@ -data Maybe () where { - Just : Int -> Maybe () ; - Nothing : Maybe () ; -}; - -demoFunc x = case x of { - Just y => y + 24; - Nothing => 0; -}; - -main = demoFunc (Just 5) ; diff --git a/sample-programs/example-programs/ex4.crf b/sample-programs/example-programs/ex4.crf deleted file mode 100644 index 9f412c6..0000000 --- a/sample-programs/example-programs/ex4.crf +++ /dev/null @@ -1,9 +0,0 @@ -data Maybe () where - Just : Int -> Maybe () - Nothing : Maybe () - -demoFunc x = case x of - Just x => x + 24 - Nothing => 0 - -main = demoFunc Nothing diff --git a/sample-programs/example-programs/ex5.crf b/sample-programs/example-programs/ex5.crf deleted file mode 100644 index e69de29..0000000 diff --git a/sample-programs/example-programs/ex6.crf b/sample-programs/example-programs/ex6.crf deleted file mode 100644 index ebf8c6b..0000000 --- a/sample-programs/example-programs/ex6.crf +++ /dev/null @@ -1,43 +0,0 @@ -main = sum (repeat (sumlength (repeat 10 2000)) 5); - --- a simple list data type containing ints -data List () where { - Cons : Int -> List () -> List () - Nil : List () -}; - --- take the length of a list -length : List () -> Int ; -length x = case x of { - Cons _ xs => 1 + length xs ; - Nil => 0 ; -}; --- sum a list -sum : List () -> Int ; -sum x = case x of { - Cons a xs => a + sum xs ; - Nil => 0 ; -}; - --- sum + length of a list -sumlength: List () -> Int ; -sumlength x = sum x + length x ; - --- take the head of a list -head : List () -> Int ; -head x = case x of { - Cons h _ => h ; -}; - --- repeat an element n times -repeat : Int -> Int -> List () ; -repeat x n = repeatHelp Nil x n; -repeatHelp : List () -> Int -> Int -> List () ; -repeatHelp acc x n = case n of { - 0 => acc ; - n => repeatHelp (Cons x acc) x (n + minusOne) ; -}; - --- represents minus one :) -minusOne : Int ; -minusOne = 9223372036854775807 + 9223372036854775807 + 1; diff --git a/sample-programs/mono-1.crf b/sample-programs/mono-1.crf index 568c674..c41e9b6 100644 --- a/sample-programs/mono-1.crf +++ b/sample-programs/mono-1.crf @@ -1,5 +1,7 @@ +const2 : a -> b -> a const2 x y = x +f : a -> a f x = (const2 x 'c') main = f 5 diff --git a/sample-programs/mono-2.crf b/sample-programs/mono-2.crf index 97e8c1f..76a92c2 100644 --- a/sample-programs/mono-2.crf +++ b/sample-programs/mono-2.crf @@ -1,13 +1,16 @@ -data Either(a b) where - Left: a -> Either (a b) - Right: b -> Either (a b) +data Either (a b) where + Left : a -> Either (a b) + Right : b -> Either (a b) +unwrapLeft : Either (a b) -> a unwrapLeft x = case x of Left y => y +unwrapRight : Either (a b) -> b unwrapRight x = case x of Right y => y +wow : Either (Int Char) wow = Left 5 main = unwrapLeft wow From d7a09a720be8daa1960bd5b5dd06cd7ffae52ec8 Mon Sep 17 00:00:00 2001 From: sebastianselander Date: Sat, 29 Apr 2023 17:55:18 +0200 Subject: [PATCH 337/372] Fixed more precise type annotation for monomorphizer --- src/TypeChecker/TypeCheckerHm.hs | 124 ++++++++++++++++--------------- 1 file changed, 64 insertions(+), 60 deletions(-) diff --git a/src/TypeChecker/TypeCheckerHm.hs b/src/TypeChecker/TypeCheckerHm.hs index 5ef3f47..3a505b4 100644 --- a/src/TypeChecker/TypeCheckerHm.hs +++ b/src/TypeChecker/TypeCheckerHm.hs @@ -1,31 +1,31 @@ -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedRecordDot #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QualifiedDo #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QualifiedDo #-} -- | A module for type checking and inference using algorithm W, Hindley-Milner module TypeChecker.TypeCheckerHm where -import Auxiliary (int, litType, maybeToRightM, unzip4) -import qualified Auxiliary as Aux -import Control.Monad.Except -import Control.Monad.Identity (Identity, runIdentity) -import Control.Monad.Reader -import Control.Monad.State -import Control.Monad.Writer -import Data.Coerce (coerce) -import Data.Function (on) -import Data.List (foldl', nub, sortOn) -import Data.List.Extra (unsnoc) -import Data.Map (Map) -import qualified Data.Map as M -import Data.Maybe (fromJust) -import Data.Set (Set) -import qualified Data.Set as S -import Debug.Trace (trace) -import Grammar.Abs -import Grammar.Print (printTree) -import qualified TypeChecker.TypeCheckerIr as T +import Auxiliary (int, litType, maybeToRightM, unzip4) +import Auxiliary qualified as Aux +import Control.Monad.Except +import Control.Monad.Identity (Identity, runIdentity) +import Control.Monad.Reader +import Control.Monad.State +import Control.Monad.Writer +import Data.Coerce (coerce) +import Data.Function (on) +import Data.List (foldl', nub, sortOn) +import Data.List.Extra (unsnoc) +import Data.Map (Map) +import Data.Map qualified as M +import Data.Maybe (fromJust) +import Data.Set (Set) +import Data.Set qualified as S +import Debug.Trace (trace) +import Grammar.Abs +import Grammar.Print (printTree) +import TypeChecker.TypeCheckerIr qualified as T {- TODO @@ -40,7 +40,7 @@ typecheck :: Program -> Either String (T.Program' Type, [Warning]) typecheck = onLeft msg . run . checkPrg where onLeft :: (Error -> String) -> Either Error a -> Either String a - onLeft f (Left x) = Left $ f x + onLeft f (Left x) = Left $ f x onLeft _ (Right x) = Right x checkPrg :: Program -> Infer (T.Program' Type) @@ -67,13 +67,13 @@ prettify s (T.Program defs) = T.Program $ map (go s) defs replace :: Map T.Ident T.Ident -> Type -> Type replace m def@(TVar (MkTVar (LIdent a))) = case M.lookup (coerce a) m of - Just t -> TVar . MkTVar . LIdent $ coerce t + Just t -> TVar . MkTVar . LIdent $ coerce t Nothing -> def replace m (TFun t1 t2) = (TFun `on` replace m) t1 t2 replace m (TData name ts) = TData name (map (replace m) ts) replace m def@(TAll (MkTVar forall_) t) = case M.lookup (coerce forall_) m of Just found -> TAll (MkTVar $ coerce found) (replace m t) - Nothing -> def + Nothing -> def replace _ t = t bindCount :: [Def] -> Infer [(Int, Def)] @@ -127,7 +127,7 @@ preRun (x : xs) = case x of s <- gets sigs case M.lookup (coerce n) s of Nothing -> insertSig (coerce n) Nothing >> preRun xs - Just _ -> preRun xs + Just _ -> preRun xs DData d@(Data t _) -> collect (collectTVars t) >> checkData d >> preRun xs where -- Check if function body / signature has been declared already @@ -149,11 +149,11 @@ checkDef (x : xs) = case x of T.Data t $ map (\(Inj name typ) -> T.Inj (coerce name) typ) injs freeOrdered :: Type -> [T.Ident] -freeOrdered (TVar (MkTVar a)) = return (coerce a) +freeOrdered (TVar (MkTVar a)) = return (coerce a) freeOrdered (TAll (MkTVar bound) t) = return (coerce bound) ++ freeOrdered t -freeOrdered (TFun a b) = freeOrdered a ++ freeOrdered b -freeOrdered (TData _ a) = concatMap freeOrdered a -freeOrdered _ = mempty +freeOrdered (TFun a b) = freeOrdered a ++ freeOrdered b +freeOrdered (TData _ a) = concatMap freeOrdered a +freeOrdered _ = mempty checkBind :: Bind -> Infer (T.Bind' Type) checkBind (Bind name args e) = do @@ -168,6 +168,8 @@ checkBind (Bind name args e) = do let m1 = M.fromList $ zip fvs1 letters let t0 = replace m0 t' let t1 = replace m1 lambda_t + -- Not sure if this is actually correct + sub <- unify t' lambda_t unless (t1 <<= t0) ( throwError $ @@ -180,7 +182,9 @@ checkBind (Bind name args e) = do ) False ) - return $ T.Bind (coerce name, t') [] (e, lambda_t) + -- Applying sub to t' will worsen error messages. + -- Unfortunately I do not know a better solution at the moment. + return $ T.Bind (coerce name, apply sub t') [] (apply sub e, lambda_t) _ -> do insertSig (coerce name) (Just lambda_t) return (T.Bind (coerce name, lambda_t) [] (e, lambda_t)) @@ -227,11 +231,11 @@ checkInj (Inj c inj_typ) name tvars toTVar :: Type -> Either Error TVar toTVar = \case TVar tvar -> pure tvar - _ -> uncatchableErr "Not a type variable" + _ -> uncatchableErr "Not a type variable" returnType :: Type -> Type returnType (TFun _ t2) = returnType t2 -returnType a = a +returnType a = a inferExp :: Exp -> Infer (T.ExpT' Type) inferExp e = do @@ -244,7 +248,7 @@ class CollectTVars a where instance CollectTVars Exp where collectTVars (EAnn e t) = collectTVars t `S.union` collectTVars e - collectTVars _ = S.empty + collectTVars _ = S.empty instance CollectTVars Type where collectTVars (TVar (MkTVar i)) = S.singleton (coerce i) @@ -563,12 +567,12 @@ generalize :: Map T.Ident Type -> Type -> Type generalize env t = go (S.toList $ free t S.\\ free env) (removeForalls t) where go :: [T.Ident] -> Type -> Type - go [] t = t + go [] t = t go (x : xs) t = TAll (MkTVar (coerce x)) (go xs t) removeForalls :: Type -> Type - removeForalls (TAll _ t) = removeForalls t + removeForalls (TAll _ t) = removeForalls t removeForalls (TFun t1 t2) = TFun (removeForalls t1) (removeForalls t2) - removeForalls t = t + removeForalls t = t {- | Instantiate a polymorphic type. The free type variables are substituted with fresh ones. @@ -617,27 +621,27 @@ currently this is not the case, the TAll pattern match is incorrectly implemente skipForalls :: Type -> Type skipForalls = \case TAll _ t -> skipForalls t - t -> t + t -> t foralls :: Type -> [T.Ident] foralls (TAll (MkTVar a) t) = coerce a : foralls t -foralls _ = [] +foralls _ = [] mkForall :: Type -> Type mkForall t = case map (TAll . MkTVar . coerce) $ S.toList $ free t of [] -> t (x : xs) -> - let f acc [] = acc + let f acc [] = acc f acc (x : xs) = f (x acc) xs (y : ys) = reverse $ x : xs in f (y t) ys skolemize :: Type -> Type skolemize (TVar (MkTVar a)) = TEVar $ MkTEVar a -skolemize (TAll x t) = TAll x (skolemize t) -skolemize (TFun t1 t2) = (TFun `on` skolemize) t1 t2 -skolemize (TData n ts) = TData n (map skolemize ts) -skolemize t = t +skolemize (TAll x t) = TAll x (skolemize t) +skolemize (TFun t1 t2) = (TFun `on` skolemize) t1 t2 +skolemize (TData n ts) = TData n (map skolemize ts) +skolemize t = t -- | A class for substitutions class SubstType t where @@ -671,10 +675,10 @@ instance SubstType Type where TLit _ -> t TVar (MkTVar a) -> case M.lookup (coerce a) sub of Nothing -> TVar (MkTVar $ coerce a) - Just t -> t + Just t -> t TAll (MkTVar i) t -> case M.lookup (coerce i) sub of Nothing -> TAll (MkTVar i) (apply sub t) - Just _ -> apply sub t + Just _ -> apply sub t TFun a b -> TFun (apply sub a) (apply sub b) TData name a -> TData name (apply sub a) TEVar (MkTEVar _) -> t @@ -719,10 +723,10 @@ instance SubstType (T.Branch' Type) where instance SubstType (T.Pattern' Type) where apply s = \case T.PVar iden -> T.PVar iden - T.PLit lit -> T.PLit lit + T.PLit lit -> T.PLit lit T.PInj i ps -> T.PInj i $ apply s ps - T.PCatch -> T.PCatch - T.PEnum i -> T.PEnum i + T.PCatch -> T.PCatch + T.PEnum i -> T.PEnum i instance SubstType (T.Pattern' Type, Type) where apply s (p, t) = (apply s p, apply s t) @@ -763,11 +767,11 @@ withBindings xs = -- | Run the monadic action with a pattern withPattern :: (Monad m, MonadReader Ctx m) => (T.Pattern' Type, Type) -> m a -> m a withPattern (p, t) ma = case p of - T.PVar x -> withBinding x t ma + T.PVar x -> withBinding x t ma T.PInj _ ps -> foldl' (flip withPattern) ma ps - T.PLit _ -> ma - T.PCatch -> ma - T.PEnum _ -> ma + T.PLit _ -> ma + T.PCatch -> ma + T.PEnum _ -> ma -- | Insert a function signature into the environment insertSig :: T.Ident -> Maybe Type -> Infer () @@ -792,11 +796,11 @@ existInj n = gets (M.lookup n . injections) flattenType :: Type -> [Type] flattenType (TFun a b) = flattenType a <> flattenType b -flattenType a = [a] +flattenType a = [a] typeLength :: Type -> Int typeLength (TFun _ b) = 1 + typeLength b -typeLength _ = 1 +typeLength _ = 1 {- | Catch an error if possible and add the given expression as addition to the error message @@ -879,11 +883,11 @@ newtype Ctx = Ctx {vars :: Map T.Ident Type} deriving (Show) data Env = Env - { count :: Int - , nextChar :: Char - , sigs :: Map T.Ident (Maybe Type) + { count :: Int + , nextChar :: Char + , sigs :: Map T.Ident (Maybe Type) , takenTypeVars :: Set T.Ident - , injections :: Map T.Ident Type + , injections :: Map T.Ident Type , declaredBinds :: Set T.Ident } deriving (Show) From 8463dc28875114971f8608b096c5251d13b5f7a3 Mon Sep 17 00:00:00 2001 From: Martin Fredin Date: Sat, 29 Apr 2023 21:58:39 +0200 Subject: [PATCH 338/372] Small fix to lambda lifter --- src/LambdaLifter.hs | 17 ++--------- tests/TestLambdaLifter.hs | 60 +++++++++++++++++---------------------- 2 files changed, 29 insertions(+), 48 deletions(-) diff --git a/src/LambdaLifter.hs b/src/LambdaLifter.hs index 83d3466..5581814 100644 --- a/src/LambdaLifter.hs +++ b/src/LambdaLifter.hs @@ -28,17 +28,6 @@ lambdaLift (Program ds) = Program (datatypes ++ binds) _ -> False binds = map DBind $ (collectScs . abstract . freeVars) [b | DBind b <- ds] --- lambdaLift (Program defs) = trace (printTree abst) $ Program $ datatypes ++ ll binds --- where --- abst = abstract frees --- frees = freeVars [b | DBind b@(Bind (Ident s, _) _ _) <- binds, s == "f"] --- --- ll = map DBind . collectScs . abstract . freeVars . map (\(DBind b) -> b) --- (binds, datatypes) = partition isBind defs --- isBind = \case --- DBind _ -> True --- _ -> False - -- | Annotate free variables freeVars :: [Bind] -> [ABind] freeVars binds = [ let ae = freeVarsExp [] e @@ -172,9 +161,9 @@ abstractAnnExp Ann {frees, term = (annae, typ) } = case annae of AAbs x annae' -> do i <- nextNumber rhs <- abstractAnnExp annae'' - let sc_name = Ident ("sc_" ++ show i) - sc = (ELet (Bind (sc_name, typ) vars rhs) (EVar sc_name, typ), typ) - pure $ foldl applyFree sc frees + let sc_name = Ident ("sc_" ++ show i) + e@(_, t) = foldl applyFree (EVar sc_name, typ) frees + pure (ELet (Bind (sc_name, typ) vars rhs) e ,t) where vars = frees <| (x, t_x) <|| ys diff --git a/tests/TestLambdaLifter.hs b/tests/TestLambdaLifter.hs index 79c78b2..d209819 100644 --- a/tests/TestLambdaLifter.hs +++ b/tests/TestLambdaLifter.hs @@ -58,49 +58,41 @@ abs_1 = undefined -runPrintFree = print $ freeVarsExp [] (EAbs "x" (EVar "x", TVar' "a"), TVar' "a") - +runFreeVars = either putStrLn print (runFree s2) runAbstract = either putStrLn (putStrLn . printTree) (runAbs s2) - where - s = unlines [ "add : Int -> Int -> Int" - , "f : Int -> Int -> Int" - , "f x y = add x y" - , "f = \\x. (\\y. add x y)" - ] - - s2 = unlines [ "data List (a) where" - , " Nil : List (a)" - , " Cons : a -> List (a) -> List (a)" - , "map : (a -> b) -> List (a) -> List (b)" - , "add : Int -> Int -> Int" - - , "f : List (Int)" - , "f = (\\x.\\ys. map (\\y. add y x) ys) 4 (Cons 1 (Cons 2 Nil))" - ] +runCollect = either putStrLn (putStrLn . printTree) (run s2) -runCollect = either putStrLn (putStrLn . printTree) (run s) - where - s = unlines [ "data List (a) where" - , " Nil : List (a)" - , " Cons : a -> List (a) -> List (a)" - , "add : Int -> Int -> Int" - , "map : (a -> b) -> List (a) -> List (b)" - , "map f xs = case xs of" - , " Nil => Nil" - , " Cons x xs => Cons (f x) (map f xs)" +s1 = unlines [ "add : Int -> Int -> Int" + , "f : Int -> Int -> Int" + , "f x y = add x y" + , "f = \\x. (\\y. add x y)" + ] + +s2 = unlines [ "data List (a) where" + , " Nil : List (a)" + , " Cons : a -> List (a) -> List (a)" + , "add : Int -> Int -> Int" + , "map : (a -> b) -> List (a) -> List (b)" + -- , "map f xs = case xs of" + -- , " Nil => Nil" + -- , " Cons x xs => Cons (f x) (map f xs)" + + , "f : List (Int)" + , "f = (\\x.\\ys. map (\\y. add y x) ys) 4 (Cons 1 (Cons 2 Nil))" + ] + +s3 = "main = (\\plussq. (\\f. f (f 0)) (plussq 3)) (\\x. \\y. y + x + x)" - , "f : List (Int)" - , "f = (\\x.\\ys. map (\\y. add y x) ys) 4 (Cons 1 (Cons 2 Nil))" - ] run = fmap collectScs . runAbs -runAbs s = do - Program ds <- run' s - pure $ (abstract . freeVars) [b | DBind b <- ds] +runAbs = fmap abstract . runFree +runFree s = do + Program ds <- run' s + pure $ freeVars [b | DBind b <- ds] run' = fmap removeForall . reportTEVar From 0fb13f59fbe2e781192042f91b7104bfba4f31f1 Mon Sep 17 00:00:00 2001 From: Martin Fredin Date: Mon, 1 May 2023 10:47:07 +0200 Subject: [PATCH 339/372] Remove bad program --- sample-programs/good1 | 6 ------ 1 file changed, 6 deletions(-) delete mode 100644 sample-programs/good1 diff --git a/sample-programs/good1 b/sample-programs/good1 deleted file mode 100644 index b7aff4b..0000000 --- a/sample-programs/good1 +++ /dev/null @@ -1,6 +0,0 @@ -main : _Int ; -main = (id : _Int -> _Int) 5 ; - -id : 'a -> 'a ; -id x = (x : 'a); - From 63d805fa13b46821e50e8185bf1f2fdf40d36d29 Mon Sep 17 00:00:00 2001 From: Martin Fredin Date: Mon, 1 May 2023 10:55:34 +0200 Subject: [PATCH 340/372] Uncomment prelude --- src/Main.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Main.hs b/src/Main.hs index 9e4e677..95b33c3 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -104,7 +104,7 @@ main' opts s = file <- readFile s printToErr "-- Parse Tree -- " - parsed <- fromErr . pProgram . resolveLayout True $ myLexer file -- (file ++ prelude) + parsed <- fromErr . pProgram . resolveLayout True $ myLexer (file ++ prelude) log parsed printToErr "-- Desugar --" From 78af9431b98d40097554113c3cb328c221e19dc1 Mon Sep 17 00:00:00 2001 From: Martin Fredin Date: Mon, 1 May 2023 11:10:47 +0200 Subject: [PATCH 341/372] Remove clang 11 --- shell.nix | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/shell.nix b/shell.nix index a2e6844..c8cc7a8 100644 --- a/shell.nix +++ b/shell.nix @@ -11,8 +11,8 @@ pkgs.haskellPackages.developPackage { ghc jasmin llvmPackages_15.libllvm - clang # texlive.combined.scheme-full + graphviz ]) ++ (with pkgs.haskellPackages; [ cabal-install From 6b72d08b9446a901d773ed7c1535a4e254ebdbf8 Mon Sep 17 00:00:00 2001 From: Samuel Hammersberg Date: Mon, 1 May 2023 11:09:23 +0200 Subject: [PATCH 342/372] Commented out `customHelperFunctionCuzPoorImplementation` as it is not needed with type annotations. --- src/Main.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Main.hs b/src/Main.hs index 95b33c3..7e703ba 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -168,12 +168,12 @@ prelude :: String prelude = unlines [ "\n" - , "customHelperFunctionCuzPoorImplementation : Bool () -> Int -> Bool ()" - , "customHelperFunctionCuzPoorImplementation x y = x" + --, "customHelperFunctionCuzPoorImplementation : Bool () -> Int -> Bool ()" + --, "customHelperFunctionCuzPoorImplementation x y = x" , "data Bool () where" , " False : Bool ()" , " True : Bool ()" , "lt : Int -> Int -> Bool ()" - , "lt x y = customHelperFunctionCuzPoorImplementation True (x + y)" + , "lt x y = True" , "\n" ] From 0af2aac61e6dca5d2654d76533e1d1a4bc7e17e5 Mon Sep 17 00:00:00 2001 From: Rakarake Date: Mon, 1 May 2023 11:53:18 +0200 Subject: [PATCH 343/372] Removed some warnings, better internal error --- src/Monomorphizer/Monomorphizer.hs | 33 +++++++++++++++--------------- 1 file changed, 17 insertions(+), 16 deletions(-) diff --git a/src/Monomorphizer/Monomorphizer.hs b/src/Monomorphizer/Monomorphizer.hs index 1d99731..4a40e15 100644 --- a/src/Monomorphizer/Monomorphizer.hs +++ b/src/Monomorphizer/Monomorphizer.hs @@ -36,7 +36,6 @@ import Control.Monad.Reader ( Reader, asks, runReader, - when, ) import Control.Monad.State ( MonadState, @@ -46,9 +45,9 @@ import Control.Monad.State ( ) import Data.Coerce (coerce) import Data.Map qualified as Map -import Data.Maybe (fromJust, catMaybes) +import Data.Maybe (catMaybes) import Data.Set qualified as Set -import Debug.Trace +--import Debug.Trace import Grammar.Print (printTree) {- | EnvM is the monad containing the read-only state as well as the @@ -114,19 +113,21 @@ getMain = asks (\env -> case Map.lookup (T.Ident "main") (input env) of ) {- | Makes a kv pair list of polymorphic to monomorphic mappings, throws runtime -error when encountering different structures between the two arguments. +error when encountering different structures between the two arguments. Debug: +First argument is the name of the bind. -} -mapTypes :: T.Type -> M.Type -> [(Ident, M.Type)] -mapTypes (T.TLit _) (M.TLit _) = [] -mapTypes (T.TVar (T.MkTVar i1)) tm = [(i1, tm)] -mapTypes (T.TFun pt1 pt2) (M.TFun mt1 mt2) = - mapTypes pt1 mt1 - ++ mapTypes pt2 mt2 -mapTypes (T.TData tIdent pTs) (M.TData mIdent mTs) = +mapTypes :: Ident -> T.Type -> M.Type -> [(Ident, M.Type)] +mapTypes _ident (T.TLit _) (M.TLit _) = [] +mapTypes _ident (T.TVar (T.MkTVar i1)) tm = [(i1, tm)] +mapTypes ident (T.TFun pt1 pt2) (M.TFun mt1 mt2) = + mapTypes ident pt1 mt1 + ++ mapTypes ident pt2 mt2 +mapTypes ident (T.TData tIdent pTs) (M.TData mIdent mTs) = if tIdent /= mIdent then error "the data type names of monomorphic and polymorphic data types does not match" - else foldl (\xs (p, m) -> mapTypes p m ++ xs) [] (zip pTs mTs) -mapTypes t1 t2 = error $ "structure of types not the same: '" ++ printTree t1 ++ "', '" ++ printTree t2 ++ "'" + else foldl (\xs (p, m) -> mapTypes ident p m ++ xs) [] (zip pTs mTs) +mapTypes ident t1 t2 = error $ "in bind: '" ++ printTree ident ++ "', " ++ + "structure of types not the same: '" ++ printTree t1 ++ "', '" ++ printTree t2 ++ "'" -- | Gets the mapped monomorphic type of a polymorphic type in the current context. getMonoFromPoly :: T.Type -> EnvM M.Type @@ -149,12 +150,12 @@ getMonoFromPoly t = do Returns the annotated bind name. -} morphBind :: M.Type -> T.Bind -> EnvM Ident -morphBind expectedType b@(T.Bind (Ident str, btype) args (exp, expt)) = +morphBind expectedType b@(T.Bind (ident, btype) args (exp, expt)) = local ( \env -> env { locals = Set.fromList (map fst args) - , polys = Map.fromList (mapTypes btype expectedType) + , polys = Map.fromList (mapTypes ident btype expectedType) } ) $ do @@ -398,7 +399,7 @@ createNewData ((consIdent, consType, polyData) : input) o = -- | Gets the Data Type of a constructor type (a -> Just a becomes Just a). getDataType :: M.Type -> M.Type -getDataType (M.TFun t1 t2) = getDataType t2 +getDataType (M.TFun _t1 t2) = getDataType t2 getDataType tData@(M.TData _ _) = tData getDataType _ = error "???" From 3377879dd0380751c4ec14431552afc9e74f2672 Mon Sep 17 00:00:00 2001 From: Rakarake Date: Mon, 1 May 2023 11:57:06 +0200 Subject: [PATCH 344/372] Small fix in morphBind --- src/Monomorphizer/Monomorphizer.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/Monomorphizer/Monomorphizer.hs b/src/Monomorphizer/Monomorphizer.hs index 4a40e15..5b746e9 100644 --- a/src/Monomorphizer/Monomorphizer.hs +++ b/src/Monomorphizer/Monomorphizer.hs @@ -150,7 +150,10 @@ getMonoFromPoly t = do Returns the annotated bind name. -} morphBind :: M.Type -> T.Bind -> EnvM Ident -morphBind expectedType b@(T.Bind (ident, btype) args (exp, expt)) = +morphBind expectedType b@(T.Bind (ident, btype) args (exp, expt)) = do + -- The "new name" is used to find out if it is already marked or not. + let name' = newFuncName expectedType b + bindMarked <- isBindMarked (coerce name') local ( \env -> env @@ -159,9 +162,6 @@ morphBind expectedType b@(T.Bind (ident, btype) args (exp, expt)) = } ) $ do - -- The "new name" is used to find out if it is already marked or not. - let name' = newFuncName expectedType b - bindMarked <- isBindMarked (coerce name') -- Return with right name if already marked if bindMarked then return name' From 0452a30409e6a598041eb23f3492054d6b6937c9 Mon Sep 17 00:00:00 2001 From: Samuel Hammersberg Date: Mon, 1 May 2023 16:01:39 +0200 Subject: [PATCH 345/372] Yoinked newer GC. --- src/GC/Makefile | 16 +- src/GC/include/cheap.h | 8 +- src/GC/include/event.hpp | 25 ++-- src/GC/include/heap.hpp | 28 ++-- src/GC/include/profiler.hpp | 56 ++++--- src/GC/lib/cheap.cpp | 19 ++- src/GC/lib/event.cpp | 4 - src/GC/lib/heap.cpp | 78 ++++++---- src/GC/lib/profiler.cpp | 211 ++++++++++++++++++++------ src/GC/tests/advance.cpp | 89 +++++++---- src/GC/tests/alloc_free_list.cpp | 250 +++++++++++++++++++++++++++++++ src/GC/tests/h_test.cpp | 1 + src/GC/tests/linkedlist.cpp | 74 +++++++++ src/GC/tests/linker.cpp | 16 +- src/GC/tests/wrapper.c | 27 ++-- 15 files changed, 713 insertions(+), 189 deletions(-) create mode 100644 src/GC/tests/alloc_free_list.cpp create mode 100644 src/GC/tests/linkedlist.cpp diff --git a/src/GC/Makefile b/src/GC/Makefile index 6b33ca8..1c2690a 100644 --- a/src/GC/Makefile +++ b/src/GC/Makefile @@ -18,7 +18,7 @@ file: heap: $(CC) $(WFLAGS) $(STDFLAGS) $(LIB_INCL) lib/heap.cpp -h_test: +h_test: static_lib rm -f tests/h_test.out # $(CC) $(WFLAGS) $(STDFLAGS) $(LIB_INCL) tests/h_test.cpp lib/heap.cpp lib/profiler.cpp lib/event.cpp -o tests/h_test.out $(CC) $(STDFLAGS) $(WFLAGS) $(LIB_INCL) -O3 -g -o tests/h_test.out tests/h_test.cpp lib/gcoll.a @@ -43,10 +43,10 @@ game: wrapper_test: rm -f lib/event.o lib/profiler.o lib/heap.o lib/coll.a tests/wrapper_test.out # compile object files - $(CC) $(STDFLAGS) $(WFLAGS) $(LIB_INCL) -O3 -g -c -o lib/event.o lib/event.cpp -fPIC - $(CC) $(STDFLAGS) $(WFLAGS) $(LIB_INCL) -O3 -g -c -o lib/profiler.o lib/profiler.cpp -fPIC - $(CC) $(STDFLAGS) $(WFLAGS) $(LIB_INCL) -O3 -g -c -o lib/heap.o lib/heap.cpp -fPIC - $(CC) $(STDFLAGS) $(WFLAGS) $(LIB_INCL) -O3 -g -c -o lib/cheap.o lib/cheap.cpp -fPIC + $(CC) $(STDFLAGS) $(WFLAGS) $(LIB_INCL) -g -c -o lib/event.o lib/event.cpp -fPIC + $(CC) $(STDFLAGS) $(WFLAGS) $(LIB_INCL) -g -c -o lib/profiler.o lib/profiler.cpp -fPIC + $(CC) $(STDFLAGS) $(WFLAGS) $(LIB_INCL) -g -c -o lib/heap.o lib/heap.cpp -fPIC + $(CC) $(STDFLAGS) $(WFLAGS) $(LIB_INCL) -g -c -o lib/cheap.o lib/cheap.cpp -fPIC # compile object files into library ar rcs lib/gcoll.a lib/event.o lib/profiler.o lib/heap.o lib/cheap.o clang -stdlib=libc++ $(WFLAGS) $(LIB_INCL) -o tests/wrapper_test.out tests/wrapper_test.c lib/gcoll.a -lstdc++ @@ -76,6 +76,12 @@ static_lib: static_lib_test: static_lib $(CC) $(STDFLAGS) $(WFLAGS) $(LIB_INCL) -o tests/extern_lib.out tests/extern_lib.cpp lib/gcoll.a +alloc_free_list: static_lib + $(CC) $(STDFLAGS) $(WFLAGS) $(LIB_INCL) -o tests/alloc_fl.out tests/alloc_free_list.cpp lib/gcoll.a + +linked_list_test: static_lib + $(CC) $(STDFLAGS) $(WFLAGS) $(LIB_INCL) -o tests/linkedlist.out tests/linkedlist.cpp lib/gcoll.a + wrapper: # remove old files rm -f lib/event.o lib/profiler.o lib/heap.o lib/coll.a tests/wrapper.out diff --git a/src/GC/include/cheap.h b/src/GC/include/cheap.h index d2c649d..7d803a8 100644 --- a/src/GC/include/cheap.h +++ b/src/GC/include/cheap.h @@ -7,9 +7,9 @@ extern "C" { #endif -// #define DEBUG +#define WRAPPER_DEBUG -#ifdef DEBUG +#ifdef WRAPPER_DEBUG typedef struct cheap { void *obj; @@ -19,11 +19,15 @@ struct cheap; typedef struct cheap cheap_t; #endif +#define FuncCallsOnly 0x1E +#define ChunkOpsOnly 0x3E0 + cheap_t *cheap_the(); void cheap_init(); void cheap_dispose(); void *cheap_alloc(unsigned long size); void cheap_set_profiler(cheap_t *cheap, bool mode); +void cheap_profiler_log_options(cheap_t *cheap, unsigned long flag); #ifdef __cplusplus } diff --git a/src/GC/include/event.hpp b/src/GC/include/event.hpp index 298ccab..c18b1ce 100644 --- a/src/GC/include/event.hpp +++ b/src/GC/include/event.hpp @@ -1,9 +1,6 @@ #pragma once #include -#include -#include -#include #include "chunk.hpp" @@ -14,16 +11,18 @@ namespace GC */ enum GCEventType { - HeapInit, - AllocStart, - CollectStart, - MarkStart, - ChunkMarked, - ChunkSwept, - ChunkFreed, - NewChunk, - ReusedChunk, - ProfilerDispose + HeapInit = 1 << 0, + AllocStart = 1 << 1, + CollectStart = 1 << 2, + MarkStart = 1 << 3, + SweepStart = 1 << 4, + ChunkMarked = 1 << 5, + ChunkSwept = 1 << 6, + ChunkFreed = 1 << 7, + NewChunk = 1 << 8, + ReusedChunk = 1 << 9, + ProfilerDispose = 1 << 10, + FreeStart = 1 << 11 }; /** diff --git a/src/GC/include/heap.hpp b/src/GC/include/heap.hpp index 365a838..eb161c0 100644 --- a/src/GC/include/heap.hpp +++ b/src/GC/include/heap.hpp @@ -1,17 +1,15 @@ #pragma once -#include -#include -#include +#include #include #include #include "chunk.hpp" #include "profiler.hpp" -#define HEAP_SIZE 2097152 //65536 -#define FREE_THRESH (uint) 100000 -#define DEBUG +#define HEAP_SIZE 65536 +#define FREE_THRESH (uint) 100 +#define HEAP_DEBUG namespace GC { @@ -20,12 +18,12 @@ namespace GC * collection (mark/sweep/free/all). */ enum CollectOption { - MARK=0x1, - SWEEP=0x2, - MARK_SWEEP = 0x3, - FREE=0x4, - COLLECT_ALL=0x7 - }; + MARK = 1 << 0, + SWEEP = 1 << 1, + MARK_SWEEP = 1 << 2, + FREE = 1 << 3, + COLLECT_ALL = 0b1111 // all flags above + }; /** * The heap class to represent the heap for the @@ -47,12 +45,14 @@ namespace GC char *const m_heap; size_t m_size {0}; + char *m_heap_top {nullptr}; // static Heap *m_instance {nullptr}; uintptr_t *m_stack_top {nullptr}; bool m_profiler_enable {false}; std::vector m_allocated_chunks; std::vector m_freed_chunks; + std::list m_free_list; static bool profiler_enabled(); // static Chunk *get_at(std::vector &list, size_t n); @@ -69,7 +69,6 @@ namespace GC // Temporary Chunk *try_recycle_chunks_new(size_t size); void free_overlap_new(Heap &heap); - public: /** * These are the only five functions which are exposed @@ -84,12 +83,13 @@ namespace GC static void dispose(); static void *alloc(size_t size); void set_profiler(bool mode); + void set_profiler_log_options(RecordOption flags); // Stop the compiler from generating copy-methods Heap(Heap const&) = delete; Heap& operator=(Heap const&) = delete; -#ifdef DEBUG +#ifdef HEAP_DEBUG void collect(CollectOption flags); // conditional collection void check_init(); // print dummy things void print_contents(); // print dummy things diff --git a/src/GC/include/profiler.hpp b/src/GC/include/profiler.hpp index ccdf463..f70ca3b 100644 --- a/src/GC/include/profiler.hpp +++ b/src/GC/include/profiler.hpp @@ -1,12 +1,32 @@ #pragma once +#include #include +#include #include "chunk.hpp" #include "event.hpp" +// #define FunctionCallTypes +// #define ChunkOpsTypes + namespace GC { + enum RecordOption + { + FunctionCalls = (GC::AllocStart | GC::CollectStart | GC::MarkStart | GC::SweepStart), + ChunkOps = (GC::ChunkMarked | GC::ChunkSwept | GC::ChunkFreed | GC::NewChunk | GC::ReusedChunk), + AllOps = 0xFFFFFF + }; + + struct ProfilerEvent + { + uint m_n {1}; + const GCEventType m_type; + + ProfilerEvent(GCEventType type) : m_type(type) {} + }; + class Profiler { private: Profiler() {} @@ -16,34 +36,36 @@ namespace GC { delete c; } - /** - * Returns the instance of the Profiler singleton. - * If m_instance is the nullptr and the profiler - * is not initialized yet, initialize it and return - * the pointer to it. Otherwise return the previously - * initialized pointer. - * - * @returns The pointer to the profiler singleton. - */ - static Profiler *the() - { - if (m_instance) - return m_instance; - m_instance = new Profiler(); - return m_instance; - } - + static Profiler &the(); inline static Profiler *m_instance {nullptr}; std::vector m_events; + ProfilerEvent *m_last_prof_event {new ProfilerEvent(HeapInit)}; + std::vector m_prof_events; + RecordOption flags; + std::chrono::microseconds alloc_time {0}; + // size_t alloc_counts {0}; + std::chrono::microseconds collect_time {0}; + // size_t collect_counts {0}; + + static void record_data(GCEvent *type); std::ofstream create_file_stream(); std::string get_log_folder(); static void dump_trace(); + static void dump_prof_trace(); + static void dump_chunk_trace(); + // static void dump_trace_short(); + // static void dump_trace_full(); + static void print_chunk_event(GCEvent *event, char buffer[22]); + static const char *type_to_string(GCEventType type); public: + static RecordOption log_options(); + static void set_log_options(RecordOption flags); static void record(GCEventType type); static void record(GCEventType type, size_t size); static void record(GCEventType type, Chunk *chunk); + static void record(GCEventType type, std::chrono::microseconds time); static void dispose(); }; } \ No newline at end of file diff --git a/src/GC/lib/cheap.cpp b/src/GC/lib/cheap.cpp index 29a0b10..42179b6 100644 --- a/src/GC/lib/cheap.cpp +++ b/src/GC/lib/cheap.cpp @@ -1,10 +1,10 @@ #include -#include +#include #include "heap.hpp" #include "cheap.h" -#ifndef DEBUG +#ifndef WRAPPER_DEBUG struct cheap { void *obj; @@ -45,4 +45,19 @@ void cheap_set_profiler(cheap_t *cheap, bool mode) GC::Heap *heap = static_cast(cheap->obj); heap->set_profiler(mode); +} + +void cheap_profiler_log_options(cheap_t *cheap, unsigned long flags) +{ + GC::Heap *heap = static_cast(cheap->obj); + + GC::RecordOption cast_flag; + if (flags == FuncCallsOnly) + cast_flag = GC::FunctionCalls; + else if (flags == ChunkOpsOnly) + cast_flag = GC::ChunkOps; + else + cast_flag = GC::AllOps; + + heap->set_profiler_log_options(cast_flag); } \ No newline at end of file diff --git a/src/GC/lib/event.cpp b/src/GC/lib/event.cpp index 185c613..89a2a71 100644 --- a/src/GC/lib/event.cpp +++ b/src/GC/lib/event.cpp @@ -1,7 +1,3 @@ -// #include -// #include -// #include - #include "chunk.hpp" #include "event.hpp" diff --git a/src/GC/lib/heap.cpp b/src/GC/lib/heap.cpp index 579f421..fade27a 100644 --- a/src/GC/lib/heap.cpp +++ b/src/GC/lib/heap.cpp @@ -1,15 +1,14 @@ -#include -#include -#include -#include #include -#include #include #include #include +#include #include "heap.hpp" +#define time_now std::chrono::high_resolution_clock::now() +#define to_us std::chrono::duration_cast + using std::cout, std::endl, std::vector, std::hex, std::dec; namespace GC @@ -41,6 +40,12 @@ namespace GC // clang complains because arg for __b_f_a is not 0 which is "unsafe" #pragma clang diagnostic ignored "-Wframe-address" heap.m_stack_top = static_cast(__builtin_frame_address(1)); + heap.m_heap_top = heap.m_heap; + } + + void Heap::set_profiler_log_options(RecordOption flags) + { + Profiler::set_log_options(flags); } /** @@ -66,6 +71,7 @@ namespace GC */ void *Heap::alloc(size_t size) { + auto a_start = time_now; // Singleton Heap &heap = Heap::the(); bool profiler_enabled = heap.profiler_enabled(); @@ -81,9 +87,16 @@ namespace GC if (heap.m_size + size > HEAP_SIZE) { + // auto a_ms = to_us(c_start - a_start); + // Profiler::record(AllocStart, a_ms); heap.collect(); // If memory is not enough after collect, crash with OOM error - throw std::runtime_error(std::string("Error: Heap out of memory")); + if (heap.m_size + size > HEAP_SIZE) + { + if (profiler_enabled) + Profiler::dispose(); + throw std::runtime_error(std::string("Error: Heap out of memory")); + } } // If a chunk was recycled, return the old chunk address @@ -92,6 +105,9 @@ namespace GC { if (profiler_enabled) Profiler::record(ReusedChunk, reused_chunk); + auto a_end = time_now; + auto a_ms = to_us(a_end - a_start); + Profiler::record(AllocStart, a_ms); return static_cast(reused_chunk->m_start); } @@ -105,6 +121,9 @@ namespace GC if (profiler_enabled) Profiler::record(NewChunk, new_chunk); + auto a_end = time_now; + auto a_ms = to_us(a_end - a_start); + Profiler::record(AllocStart, a_ms); return new_chunk->m_start; } @@ -159,25 +178,6 @@ namespace GC return nullptr; } - /** - * Advances an iterator and returns an element - * at position `n`. - * - * @param list The list to retrieve an element from. - * - * @param n The position to retrieve an element at. - * - * @returns The pointer to the chunk at position n in list. - */ - // Chunk *Heap::get_at(std::vector &list, size_t n) - // { - // auto iter = list.begin(); - // if (!n) - // return *iter; - // std::advance(iter, n); - // return *iter; - // } - /** * Returns a bool whether the profiler is enabled * or not. @@ -199,6 +199,8 @@ namespace GC */ void Heap::collect() { + auto c_start = time_now; + Heap &heap = Heap::the(); if (heap.profiler_enabled()) @@ -218,6 +220,10 @@ namespace GC sweep(heap); free(heap); + + auto c_end = time_now; + + Profiler::record(CollectStart, to_us(c_end - c_start)); } /** @@ -294,8 +300,10 @@ namespace GC */ void Heap::sweep(Heap &heap) { - auto iter = heap.m_allocated_chunks.begin(); bool profiler_enabled = heap.m_profiler_enable; + if (profiler_enabled) + Profiler::record(SweepStart); + auto iter = heap.m_allocated_chunks.begin(); // This cannot "iter != stop", results in seg fault, since the end gets updated, I think. while (iter != heap.m_allocated_chunks.end()) { @@ -315,6 +323,7 @@ namespace GC Profiler::record(ChunkSwept, chunk); heap.m_freed_chunks.push_back(chunk); iter = heap.m_allocated_chunks.erase(iter); + heap.m_size -= chunk->m_size; } } } @@ -334,6 +343,9 @@ namespace GC */ void Heap::free(Heap &heap) { + bool profiler_enabled = heap.m_profiler_enable; + if (profiler_enabled) + Profiler::record(FreeStart); if (heap.m_freed_chunks.size() > FREE_THRESH) { bool profiler_enabled = heap.profiler_enabled(); @@ -414,7 +426,13 @@ namespace GC } } -#ifdef DEBUG + void Heap::set_profiler(bool mode) + { + Heap &heap = Heap::the(); + heap.m_profiler_enable = mode; + } + +#ifdef HEAP_DEBUG /** * Prints the result of Heap::init() and a dummy value * for the current stack frame for reference. @@ -565,12 +583,6 @@ namespace GC } } - void Heap::set_profiler(bool mode) - { - Heap &heap = Heap::the(); - heap.m_profiler_enable = mode; - } - void Heap::print_allocated_chunks(Heap *heap) { cout << "--- Allocated Chunks ---\n" << endl; for (auto chunk : heap->m_allocated_chunks) { diff --git a/src/GC/lib/profiler.cpp b/src/GC/lib/profiler.cpp index 29abad4..ae31f0d 100644 --- a/src/GC/lib/profiler.cpp +++ b/src/GC/lib/profiler.cpp @@ -15,6 +15,38 @@ namespace GC { + Profiler& Profiler::the() + { + static Profiler instance; + return instance; + } + + RecordOption Profiler::log_options() + { + Profiler &prof = Profiler::the(); + return prof.flags; + } + + void Profiler::set_log_options(RecordOption flags) + { + Profiler &prof = Profiler::the(); + prof.flags = flags; + } + + void Profiler::record_data(GCEvent *event) + { + Profiler &prof = Profiler::the(); + prof.m_events.push_back(event); + + if (prof.m_last_prof_event->m_type == event->get_type()) + prof.m_last_prof_event->m_n++; + else + { + prof.m_prof_events.push_back(prof.m_last_prof_event); + prof.m_last_prof_event = new ProfilerEvent(event->get_type()); + } + } + /** * Records an event independent of a chunk. * @@ -22,9 +54,12 @@ namespace GC */ void Profiler::record(GCEventType type) { - auto event = new GCEvent(type); - auto profiler = Profiler::the(); - profiler->m_events.push_back(event); + Profiler &prof = Profiler::the(); + if (prof.flags & type) + Profiler::record_data(new GCEvent(type)); + // auto event = new GCEvent(type); + // auto profiler = Profiler::the(); + // profiler.m_events.push_back(event); } /** @@ -37,9 +72,21 @@ namespace GC */ void Profiler::record(GCEventType type, size_t size) { - auto event = new GCEvent(type, size); - auto profiler = Profiler::the(); - profiler->m_events.push_back(event); + Profiler &prof = Profiler::the(); + if (prof.flags & type) + Profiler::record_data(new GCEvent(type, size)); + // auto event = new GCEvent(type, size); + // auto profiler = Profiler::the(); + // profiler.m_events.push_back(event); + } + + void Profiler::dump_trace() + { + Profiler &prof = Profiler::the(); + if (prof.flags & FunctionCalls) + dump_prof_trace(); + else + dump_chunk_trace(); } /** @@ -56,60 +103,114 @@ namespace GC // because in free() chunks are deleted and cannot // be referenced by the profiler. These copied // chunks are deleted by the profiler on dispose(). - auto chunk_copy = new Chunk(chunk); - auto event = new GCEvent(type, chunk_copy); - auto profiler = Profiler::the(); - profiler->m_events.push_back(event); + Profiler &prof = Profiler::the(); + if (prof.flags & type) + { + auto chunk_copy = new Chunk(chunk); + auto event = new GCEvent(type, chunk_copy); + Profiler::record_data(event); + } + // auto profiler = Profiler::the(); + // profiler.m_events.push_back(event); + } + + void Profiler::record(GCEventType type, std::chrono::microseconds time) + { + Profiler &prof = Profiler::the(); + if (type == AllocStart) + { + prof.alloc_time += time; + } + else if (type == CollectStart) + { + prof.collect_time += time; + } + } + + void Profiler::dump_prof_trace() + { + Profiler &prof = Profiler::the(); + prof.m_prof_events.push_back(prof.m_last_prof_event); + auto start = prof.m_prof_events.begin(); + auto end = prof.m_prof_events.end(); + int allocs = 0, collects = 0; + + char buffer[22]; + std::ofstream fstr = prof.create_file_stream(); + + while (start != end) + { + auto event = *start++; + + if (event->m_type == AllocStart) + allocs += event->m_n; + else if (event->m_type == CollectStart) + collects += event->m_n; + + fstr << "\n--------------------------------\n" + << Profiler::type_to_string(event->m_type) << " " + << event->m_n << " times:"; + } + fstr << "\n--------------------------------"; + + fstr << "\n\nTime spent on allocations:\t" << prof.alloc_time.count() << " microseconds" + << "\nAllocation cycles:\t" << allocs + << "\nTime spent on collections:\t" << prof.collect_time.count() << " microseconds" + << "\nCollection cycles:\t" << collects + << "\n--------------------------------"; } /** * Prints the history of the recorded events * to a log file in the /tests/logs folder. */ - void Profiler::dump_trace() + void Profiler::dump_chunk_trace() { - auto profiler = Profiler::the(); - auto start = profiler->m_events.begin(); - auto end = profiler->m_events.end(); + Profiler &prof = Profiler::the(); + auto start = prof.m_events.begin(); + auto end = prof.m_events.end(); - // File output stream - std::ofstream fstr = profiler->create_file_stream(); // Buffer for timestamp char buffer[22]; - // Time variables - std::tm *btm; - std::time_t tt; - const Chunk *chunk; while (start != end) { auto event = *start++; + auto e_type = event->get_type(); - tt = event->get_time_stamp(); - btm = std::localtime(&tt); - std::strftime(buffer, 22, "%a %T", btm); - - fstr << "--------------------------------\n" - << buffer - << "\nEvent:\t" << event->type_to_string(); - - - - chunk = event->get_chunk(); - - if (event->get_type() == AllocStart) - { - fstr << "\nSize: " << event->get_size(); - } - else if (chunk) - { - fstr << "\nChunk: " << chunk->m_start - << "\n Size: " << chunk->m_size - << "\n Mark: " << chunk->m_marked; - } - fstr << "\n"; + prof.print_chunk_event(event, buffer); } - fstr << "--------------------------------" << std::endl; + } + + void Profiler::print_chunk_event(GCEvent *event, char buffer[22]) + { + Profiler &prof = Profiler::the(); + // File output stream + std::ofstream fstr = prof.create_file_stream(); + std::time_t tt = event->get_time_stamp(); + std::tm *btm = std::localtime(&tt); + std::strftime(buffer, 22, "%a %T", btm); + + fstr << "--------------------------------\n" + << buffer + << "\nEvent:\t" << Profiler::type_to_string(event->get_type()); + // event->type_to_string(); + + + + const Chunk *chunk = event->get_chunk(); + + if (event->get_type() == AllocStart) + { + fstr << "\nSize: " << event->get_size(); + } + else if (chunk) + { + fstr << "\nChunk: " << chunk->m_start + << "\n Size: " << chunk->m_size + << "\n Mark: " << chunk->m_marked; + } + fstr << "\n"; } /** @@ -122,8 +223,6 @@ namespace GC { Profiler::record(ProfilerDispose); Profiler::dump_trace(); - auto profiler = Profiler::the(); - delete profiler; } /** @@ -189,4 +288,24 @@ namespace GC #endif return folder + "/logs"; } + + const char *Profiler::type_to_string(GCEventType type) + { + switch (type) + { + case HeapInit: return "HeapInit"; + case AllocStart: return "AllocStart"; + case CollectStart: return "CollectStart"; + case MarkStart: return "MarkStart"; + case ChunkMarked: return "ChunkMarked"; + case ChunkSwept: return "ChunkSwept"; + case ChunkFreed: return "ChunkFreed"; + case NewChunk: return "NewChunk"; + case ReusedChunk: return "ReusedChunk"; + case ProfilerDispose: return "ProfilerDispose"; + case SweepStart: return "SweepStart"; + case FreeStart: return "FreeStart"; + default: return "[Unknown]"; + } + } } \ No newline at end of file diff --git a/src/GC/tests/advance.cpp b/src/GC/tests/advance.cpp index 92ce506..89dca71 100644 --- a/src/GC/tests/advance.cpp +++ b/src/GC/tests/advance.cpp @@ -5,40 +5,79 @@ #include #include -int main() { - using namespace std; - using TimeStamp = std::chrono::_V2::system_clock::time_point; +// void time_test() +// { +// using TimeStamp = std::chrono::_V2::system_clock::time_point; - list l; - char c = 'a'; - for (int i = 1; i <= 5; i++) { - l.push_back(c++); - } +// std::list l; +// char c = 'a'; +// for (int i = 1; i <= 5; i++) { +// l.push_back(c++); +// } - auto iter = l.begin(); - auto stop = l.end(); +// auto iter = l.begin(); +// auto stop = l.end(); - while (iter != stop) { - cout << *iter << " "; +// while (iter != stop) { +// std::cout << *iter << " "; +// iter++; +// } +// std::cout << std::endl; +// iter = l.begin(); +// while (*iter != *stop) { +// std::cout << *iter << " "; +// iter++; +// } +// std::cout << std::endl; + +// std::cout << "rebased" << std::endl; +// std::cout << "iter: " << *iter << "\nstop: " << *stop << std::endl; + +// TimeStamp ts = std::chrono::system_clock::now(); +// std::time_t tt = std::chrono::system_clock::to_time_t(ts); +// std::string tstr = std::ctime(&tt); +// tstr.resize(tstr.size()-1); +// std::cout << tstr << std::endl; +// } + +void iter_test() +{ + std::list list; + list.push_back(1); + list.push_back(2); + list.push_back(4); + list.push_back(5); + + auto iter = list.begin(); + + while (iter != list.end()) + { + if (*iter == 4) + { + iter = list.erase(iter); + std::cout << *iter << "\n"; + list.insert(iter, 3); + // list.insert(iter, 3); + // std::cout << "n: " << *(++iter) << "\n"; + // iter = list.erase(++iter); + } iter++; } - cout << endl; - iter = l.begin(); - while (*iter != *stop) { - cout << *iter << " "; - iter++; + + for (int i : list) + { + std::cout << i << " "; } - cout << endl; + std::cout << std::endl; +} - cout << "rebased" << endl; - cout << "iter: " << *iter << "\nstop: " << *stop << endl; - TimeStamp ts = std::chrono::system_clock::now(); - std::time_t tt = std::chrono::system_clock::to_time_t(ts); - std::string tstr = std::ctime(&tt); - tstr.resize(tstr.size()-1); - std::cout << tstr << std::endl; + +int main() { + std::cout << "hello" << std::endl; + + iter_test(); return 0; } \ No newline at end of file diff --git a/src/GC/tests/alloc_free_list.cpp b/src/GC/tests/alloc_free_list.cpp new file mode 100644 index 0000000..a0d1a27 --- /dev/null +++ b/src/GC/tests/alloc_free_list.cpp @@ -0,0 +1,250 @@ +#include +#include + +#include "heap.hpp" + +using GC::Chunk; + +void alloc_test(); +void add_to_free_list(Chunk *chunk); +void merge_free_list(Chunk *chunk, bool do_merge); +void do_merge_list(); +void print_free_list(); + +std::list m_free_list; + +int main() +{ + alloc_test(); + + // std::list test; + + // test.push_back(1); + // test.push_back(2); + // test.push_back(3); + // test.push_back(4); + // test.push_back(5); + + // auto iter = test.begin(); + + // std::cout << "First? " << *(iter++) << "\n"; + // std::cout << "Second? " << *(iter--) << "\n"; + // std::cout << "First? " << *iter << std::endl; + + // auto i = test.begin(); + // while (i != test.end()) + // { + // std::cout << *i << " "; + // ++i; + // } + + // if (i == test.end()) + // std::cout << "great success!"; + + // std::cout << std::endl; + + return 0; +} + +void alloc_test() +{ + auto tmp = static_cast(__builtin_frame_address(0)); + + auto c1 = new Chunk((size_t)(8), tmp); + auto c2 = new Chunk((size_t)(4), c1->m_start + (size_t)(8)); + auto c3 = new Chunk((size_t)(16), c2->m_start + (size_t)(4)); + auto c4 = new Chunk((size_t)(4), c3->m_start + (size_t)(16)); + auto c5 = new Chunk((size_t)(32), c4->m_start + (size_t)(4)); + + // std::cout << "test: " << (uintptr_t *)(tmp + (size_t)(2)) << std::endl; + + std::cout << "tmp: " << tmp << "\ntmp: " << (tmp + (size_t)(28)) << std::endl; + + // add_to_free_list(c1); + // add_to_free_list(c2); + // add_to_free_list(c3); + // add_to_free_list(c4); + // add_to_free_list(c5); + + merge_free_list(c1, false); + merge_free_list(c2, false); + merge_free_list(c3, false); + merge_free_list(c4, false); + merge_free_list(c5, false); + + std::cout << "----- BEFORE MERGE ----------------------"; + // print_free_list(); + + do_merge_list(); + + std::cout << "----- AFTER MERGE -----------------------"; + // print_free_list(); +} + +void add_to_free_list(Chunk *chunk) +{ + Chunk *curr; + auto iter = m_free_list.begin(); + uintptr_t *prev_start = nullptr; + uintptr_t *prev_end = nullptr; + + if (m_free_list.size() == 0) + { + m_free_list.push_back(chunk); + return; + } + + while (iter != m_free_list.end()) + { + curr = *iter; + + // If the curr chunk is aligned before param + if (curr->m_start + curr->m_size == chunk->m_start) + { + Chunk *merged = new Chunk( + curr->m_size + chunk->m_size, + curr->m_start); + iter = m_free_list.erase(iter); + m_free_list.insert(iter, merged); + return; + } + + // If the curr chunk is aligned after param + if (chunk->m_start + chunk->m_size == curr->m_start) + { + Chunk *merged = new Chunk( + curr->m_size + chunk->m_size, + chunk->m_start); + iter = m_free_list.erase(iter); + m_free_list.insert(iter, merged); + return; + } + + // If the first chunk starts after param + if (prev_start == nullptr && curr->m_start > chunk->m_start) + { + m_free_list.insert(iter, chunk); + return; + } + + if (prev_end < chunk->m_start && (chunk->m_start + chunk->m_size) < curr->m_start) + { + m_free_list.insert(iter, chunk); + return; + } + + prev_start = curr->m_start; + prev_end = prev_start + curr->m_size; + iter++; + } + + // This is only reachable if the chunk is at the end + m_free_list.push_back(chunk); +} + +void merge_free_list(Chunk *chunk, bool do_merge) +{ + auto i = m_free_list.begin(); + uintptr_t *prev_start = nullptr, *prev_end; + bool chunk_inserted = false; + + while (i != m_free_list.end()) + { + + // if chunk is left-aligned + if ((*i)->m_start + (*i)->m_size == chunk->m_start) + { + m_free_list.insert(++i, chunk); + chunk_inserted = true; + break; + } + + // if chunk is right-aligned + if (chunk->m_start + chunk->m_size == (*i)->m_start) + { + m_free_list.insert(i, chunk); + chunk_inserted = true; + break; + } + + // is new first + if (prev_start == nullptr && (*i)->m_start > chunk->m_start) + { + m_free_list.insert(i, chunk); + chunk_inserted = true; + break; + } + + // if between chunks + if (prev_end < chunk->m_start && (chunk->m_start + chunk->m_size) < (*i)->m_start) + { + m_free_list.insert(i, chunk); + chunk_inserted = true; + break; + } + + prev_start = (*i)->m_start; + prev_end = (*i)->m_start + (*i)->m_size; + i++; + } + + // is new last + if (!chunk_inserted && i == m_free_list.end()) + m_free_list.push_back(chunk); + + if (do_merge) + do_merge_list(); +} + +void do_merge_list() +{ + std::cout << "DO MERGE" << std::endl; + auto i = m_free_list.begin(); + Chunk *prev = *(i++), *curr; + print_free_list(); + + while (i != m_free_list.end()) + { + curr = *i; + + if ((prev->m_start + prev->m_size) == curr->m_start) + { + Chunk *merged = new Chunk( + prev->m_size + curr->m_size, + prev->m_start + ); + + // replace current and previous with merged + i = m_free_list.erase(i); + i = m_free_list.erase(--i); + m_free_list.insert(i, merged); + + prev = merged; + } + else + { + prev = curr; + i++; + } + print_free_list(); + } + print_free_list(); +} + +void print_free_list() +{ + std::cout << "free-list count: " << m_free_list.size() << "\n"; + + auto iter = m_free_list.begin(); + size_t cnt = 1; + + while (iter != m_free_list.end()) + { + std::cout << "C" << cnt << ":\n\tstart: " << (*iter)->m_start + << "\n\tsize: " << (*iter)->m_size << "\n"; + iter++; + cnt++; + } + + std::cout << std::endl; +} \ No newline at end of file diff --git a/src/GC/tests/h_test.cpp b/src/GC/tests/h_test.cpp index c871721..625e36a 100644 --- a/src/GC/tests/h_test.cpp +++ b/src/GC/tests/h_test.cpp @@ -80,6 +80,7 @@ int main() { GC::Heap::init(); GC::Heap &gc = GC::Heap::the(); gc.set_profiler(true); + GC::Profiler::set_log_options(GC::FunctionCalls); gc.check_init(); auto stack_start = reinterpret_cast(__builtin_frame_address(0)); diff --git a/src/GC/tests/linkedlist.cpp b/src/GC/tests/linkedlist.cpp new file mode 100644 index 0000000..61ab3c4 --- /dev/null +++ b/src/GC/tests/linkedlist.cpp @@ -0,0 +1,74 @@ +#include +#include + +#include "heap.hpp" + +#define allocNode static_cast(GC::Heap::alloc(sizeof(Node))) + +using std::cout, std::endl; + +struct Node // sizeof(Node) = 16 +{ + int value; + Node *next {nullptr}; +}; + +Node *create_list(size_t length) +{ + Node *head = allocNode; + head->value = 0; + + Node *prev = head; + + for (size_t i = 1; i < length; i++) + { + Node *next = allocNode; + next->value = i; + prev->next = next; + prev = next; + } + + return head; +} + +void print_list(Node* head) +{ + cout << "\nPrinting list...\n"; + while (head != nullptr) + { + cout << head->value << " "; + head = head->next; + } + cout << endl; +} + +void clear_list(Node *head) +{ + while (head != nullptr) + { + Node *tmp = head->next; + head->next = nullptr; + head = tmp; + } +} + +void run_list_test() +{ + Node *list = create_list(10); + print_list(list); +} + +int main() +{ + GC::Heap::init(); + GC::Heap &heap = GC::Heap::the(); + heap.set_profiler(true); + GC::Profiler::set_log_options(GC::FunctionCalls); + + for (int i = 0; i < 10; i++) + run_list_test(); + + GC::Heap::dispose(); + + return 0; +} \ No newline at end of file diff --git a/src/GC/tests/linker.cpp b/src/GC/tests/linker.cpp index 36717c5..fb5b979 100644 --- a/src/GC/tests/linker.cpp +++ b/src/GC/tests/linker.cpp @@ -9,22 +9,8 @@ struct Obj { }; int main() { - auto heap = GC::Heap::debug_the(); - - std::cout << "heap:\t" << heap << std::endl; - auto obj = static_cast(GC::Heap::alloc(sizeof(Obj))); - - std::cout << "obj: \t" << obj << std::endl; - - obj->a = 3; - obj->b = 4; - obj->c = 5; - - std::cout << obj->a << ", " << obj->b << ", " << obj->c << std::endl; - - heap->print_contents(); - //delete heap; + return 0; } \ No newline at end of file diff --git a/src/GC/tests/wrapper.c b/src/GC/tests/wrapper.c index bcd4859..d6f042c 100644 --- a/src/GC/tests/wrapper.c +++ b/src/GC/tests/wrapper.c @@ -21,23 +21,23 @@ void test_init() /* Uncomment ONLY if run with DEBUG defined in cheap.h */ -// cheap_t *test_the() -// { -// printf("----- IN TEST_THE -----------------------------\n"); +cheap_t *test_the() +{ + printf("----- IN TEST_THE -----------------------------\n"); -// cheap_t *fst_heap = cheap_the(); + cheap_t *fst_heap = cheap_the(); -// printf("Heap 1:\t%p\n", fst_heap->obj); + printf("Heap 1:\t%p\n", fst_heap->obj); -// cheap_t *snd_heap = cheap_the(); + cheap_t *snd_heap = cheap_the(); -// printf("Heap 2:\t%p\n", snd_heap->obj); + printf("Heap 2:\t%p\n", snd_heap->obj); -// printf("----- EXIT TEST_THE ---------------------------\n"); + printf("----- EXIT TEST_THE ---------------------------\n"); -// free(snd_heap); -// return fst_heap; -// } + free(snd_heap); + return fst_heap; +} void test_profiler(cheap_t *heap) { @@ -45,6 +45,7 @@ void test_profiler(cheap_t *heap) cheap_set_profiler(heap, false); cheap_set_profiler(heap, true); + cheap_profiler_log_options(heap, FuncCallsOnly); printf("----- EXIT TEST_PROFILER ----------------------\n"); } @@ -79,8 +80,8 @@ int main() test_init(); /* Uncomment ONLY if run with DEBUG defined in cheap.h */ - // cheap_t *heap = test_the(); - // test_profiler(heap); + cheap_t *heap = test_the(); + test_profiler(heap); Object *o = test_alloc(); printf("Object size: %lu\n", sizeof(Object)); From 59da6d8864f94b43c974472909c5777e0c6419e1 Mon Sep 17 00:00:00 2001 From: Rakarake Date: Mon, 1 May 2023 16:14:01 +0200 Subject: [PATCH 346/372] Fixed printing bug in MorbIr, fixed Monomorphizer forgetting to output constructors on EInj --- sample-programs/mono-4.chrf | 12 ++++++++++++ src/Monomorphizer/Monomorphizer.hs | 5 ++++- src/Monomorphizer/MorbIr.hs | 1 + 3 files changed, 17 insertions(+), 1 deletion(-) create mode 100644 sample-programs/mono-4.chrf diff --git a/sample-programs/mono-4.chrf b/sample-programs/mono-4.chrf new file mode 100644 index 0000000..79d1495 --- /dev/null +++ b/sample-programs/mono-4.chrf @@ -0,0 +1,12 @@ +data Either (a b) where + Left : a -> Either (a b) + Right : b -> Either (a b) + +unwrap : Either (a a) -> a +unwrap x = case x of + Left y => y + Right y => y + +main : Int +main = unwrap (Left 3) + diff --git a/src/Monomorphizer/Monomorphizer.hs b/src/Monomorphizer/Monomorphizer.hs index 5b746e9..62aa601 100644 --- a/src/Monomorphizer/Monomorphizer.hs +++ b/src/Monomorphizer/Monomorphizer.hs @@ -64,7 +64,7 @@ Binds, Polymorphic Data types (monomorphized in a later step) and Marked bind, which means that it is in the process of monomorphization and should not be monomorphized again. -} -data Outputted = Marked | Complete M.Bind | Data M.Type T.Data +data Outputted = Marked | Complete M.Bind | Data M.Type T.Data deriving (Show) -- | Static environment. data Env = Env @@ -214,6 +214,7 @@ morphExp expectedType exp = case exp of T.ELit lit -> return $ M.ELit (convertLit lit) -- Constructor T.EInj ident -> do + morphCons expectedType ident return $ M.EVar ident T.EApp (e1, _t1) (e2, t2) -> do t2' <- getMonoFromPoly t2 @@ -234,6 +235,8 @@ morphExp expectedType exp = case exp of bs' <- mapM morphBranch bs exp' <- morphExp t' exp return $ M.ECase (exp', t') (catMaybes bs') + -- Ideally constructors should be EInj, though this code handles them + -- as well. T.EVar ident -> do isLocal <- localExists ident if isLocal diff --git a/src/Monomorphizer/MorbIr.hs b/src/Monomorphizer/MorbIr.hs index 20f9496..3e5db6b 100644 --- a/src/Monomorphizer/MorbIr.hs +++ b/src/Monomorphizer/MorbIr.hs @@ -175,6 +175,7 @@ instance Print Type where prt i = \case TLit uident -> prPrec i 1 (concatD [prt 0 uident]) TFun type_1 type_2 -> prPrec i 0 (concatD [prt 1 type_1, doc (showString "->"), prt 0 type_2]) + TData uident types -> prPrec i 1 (concatD [prt 0 uident, doc (showString "("), prt 0 types, doc (showString ")")]) instance Print Lit where prt i = \case From 22dcbc6a1315c1faa085bf44560e72d30547f2fc Mon Sep 17 00:00:00 2001 From: Samuel Hammersberg Date: Mon, 1 May 2023 22:50:22 +0200 Subject: [PATCH 347/372] Various codegen fixes --- sample-programs/insertion-sort.chrf | 9 +++++- sample-programs/loop.crf | 18 +++++++++++ src/Codegen/CompilerState.hs | 46 +++++++++++++------------- src/Codegen/Emits.hs | 50 ++++++++++++++--------------- src/Compiler.hs | 9 +++--- src/GC/include/cheap.h | 2 +- src/GC/include/heap.hpp | 42 ++++++++++++------------ 7 files changed, 99 insertions(+), 77 deletions(-) create mode 100644 sample-programs/loop.crf diff --git a/sample-programs/insertion-sort.chrf b/sample-programs/insertion-sort.chrf index 573f2de..fc61691 100644 --- a/sample-programs/insertion-sort.chrf +++ b/sample-programs/insertion-sort.chrf @@ -16,8 +16,15 @@ insertionSort xs = case xs of Nil => xs Nil => Nil -main = head (insertionSort (Cons 5 (Cons 4 (Cons 3 (Cons 2 (Cons 1 Nil)))))) +main = head (insertionSort (revRange 1250)) head xs = case xs of Cons x _ => x +revRange x = case x of + 0 => Cons x Nil + x => Cons x (revRange (x + minusOne)) + +-- represents minus one :) +minusOne : Int ; +minusOne = 9223372036854775807 + 9223372036854775807 + 1; \ No newline at end of file diff --git a/sample-programs/loop.crf b/sample-programs/loop.crf new file mode 100644 index 0000000..e3c3c38 --- /dev/null +++ b/sample-programs/loop.crf @@ -0,0 +1,18 @@ +main = for 0 1000 + +for x n = case n of + 0 => 0 + n => for (revRange 1000) (n + minusOne) + +data List (a) where + Nil : List (a) + Cons : a -> List (a) -> List (a) + +-- create a list of x to 0 +revRange x = case x of + 0 => Cons x Nil + x => Cons x (revRange (x + minusOne)) + +-- represents minus one :) +minusOne : Int ; +minusOne = 9223372036854775807 + 9223372036854775807 + 1; \ No newline at end of file diff --git a/src/Codegen/CompilerState.hs b/src/Codegen/CompilerState.hs index 1379d2f..523cc54 100644 --- a/src/Codegen/CompilerState.hs +++ b/src/Codegen/CompilerState.hs @@ -1,42 +1,39 @@ module Codegen.CompilerState where -import Auxiliary (snoc) -import Codegen.Auxillary (type2LlvmType, typeByteSize) -import Codegen.LlvmIr as LIR (LLVMIr (UnsafeRaw), LLVMType) -import Control.Monad.State ( - StateT, - gets, - modify, - ) -import Data.Map (Map) -import Data.Map qualified as Map -import Grammar.ErrM (Err) -import Monomorphizer.MonomorphizerIr as MIR -import TypeChecker.TypeCheckerIr qualified as TIR +import Auxiliary (snoc) +import Codegen.Auxillary (type2LlvmType, typeByteSize) +import Codegen.LlvmIr as LIR (LLVMIr (UnsafeRaw), + LLVMType) +import Control.Monad.State (StateT, gets, modify) +import Data.Map (Map) +import qualified Data.Map as Map +import Grammar.ErrM (Err) +import Monomorphizer.MonomorphizerIr as MIR +import qualified TypeChecker.TypeCheckerIr as TIR -- | The record used as the code generator state data CodeGenerator = CodeGenerator - { instructions :: [LLVMIr] - , functions :: Map MIR.Id FunctionInfo - , customTypes :: Map LLVMType Integer - , constructors :: Map TIR.Ident ConstructorInfo + { instructions :: [LLVMIr] + , functions :: Map MIR.Id FunctionInfo + , customTypes :: Map LLVMType Integer + , constructors :: Map TIR.Ident ConstructorInfo , variableCount :: Integer - , labelCount :: Integer - , gcEnabled :: Bool + , labelCount :: Integer + , gcEnabled :: Bool } -- | A state type synonym type CompilerState a = StateT CodeGenerator Err a data FunctionInfo = FunctionInfo - { numArgs :: Int + { numArgs :: Int , arguments :: [Id] } deriving (Show) data ConstructorInfo = ConstructorInfo - { numArgsCI :: Int - , argumentsCI :: [Id] - , numCI :: Integer + { numArgsCI :: Int + , argumentsCI :: [Id] + , numCI :: Integer , returnTypeCI :: MIR.Type } deriving (Show) @@ -146,4 +143,5 @@ gcStart = , UnsafeRaw "declare external void @cheap_dispose()\n" , UnsafeRaw "declare external ptr @cheap_the()\n" , UnsafeRaw "declare external void @cheap_set_profiler(ptr, i1)\n" - ] \ No newline at end of file + , UnsafeRaw "declare external void @cheap_profiler_log_options(ptr, i64)\n" + ] diff --git a/src/Codegen/Emits.hs b/src/Codegen/Emits.hs index 66cad6e..9eca23e 100644 --- a/src/Codegen/Emits.hs +++ b/src/Codegen/Emits.hs @@ -1,25 +1,22 @@ -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} module Codegen.Emits where -import Codegen.Auxillary -import Codegen.CompilerState -import Codegen.LlvmIr as LIR -import Control.Applicative ((<|>)) -import Control.Monad (when) -import Control.Monad.State ( - gets, - modify, - ) -import Data.Bifunctor qualified as BI -import Data.Char (ord) -import Data.Coerce (coerce) -import Data.Map qualified as Map -import Data.Maybe (fromJust, fromMaybe) -import Data.Tuple.Extra (dupe, first, second) -import Monomorphizer.MonomorphizerIr as MIR -import TypeChecker.TypeCheckerIr qualified as TIR +import Codegen.Auxillary +import Codegen.CompilerState +import Codegen.LlvmIr as LIR +import Control.Applicative ((<|>)) +import Control.Monad (when) +import Control.Monad.State (gets, modify) +import qualified Data.Bifunctor as BI +import Data.Char (ord) +import Data.Coerce (coerce) +import qualified Data.Map as Map +import Data.Maybe (fromJust, fromMaybe) +import Data.Tuple.Extra (dupe, first, second) +import Monomorphizer.MonomorphizerIr as MIR +import qualified TypeChecker.TypeCheckerIr as TIR compileScs :: [MIR.Def] -> CompilerState () compileScs [] = do @@ -132,6 +129,7 @@ firstMainContent :: Bool -> [LLVMIr] firstMainContent True = [ UnsafeRaw "%prof = call ptr @cheap_the()\n" , UnsafeRaw "call void @cheap_set_profiler(ptr %prof, i1 true)\n" + , UnsafeRaw "call void @cheap_profiler_log_options(ptr %prof, i64 30)\n" , UnsafeRaw "call void @cheap_init()\n" ] firstMainContent False = [] @@ -150,12 +148,12 @@ lastMainContent False var = ] compileExp :: ExpT -> CompilerState () -compileExp (MIR.ELit lit, _t) = emitLit lit -compileExp (MIR.EAdd e1 e2, t) = emitAdd t e1 e2 -compileExp (MIR.EVar name, _t) = emitIdent name -compileExp (MIR.EApp e1 e2, t) = emitApp t e1 e2 +compileExp (MIR.ELit lit, _t) = emitLit lit +compileExp (MIR.EAdd e1 e2, t) = emitAdd t e1 e2 +compileExp (MIR.EVar name, _t) = emitIdent name +compileExp (MIR.EApp e1 e2, t) = emitApp t e1 e2 compileExp (MIR.ELet bind e, _) = emitLet bind e -compileExp (MIR.ECase e cs, t) = emitECased t e (map (t,) cs) +compileExp (MIR.ECase e cs, t) = emitECased t e (map (t,) cs) emitLet :: MIR.Bind -> ExpT -> CompilerState () emitLet (MIR.Bind id [] innerExp) e = do @@ -241,7 +239,7 @@ emitECased t e cases = do emitCases _rt ty label stackPtr vs (Branch (MIR.PLit (i, ct), t) exp) = do emit $ Comment "Plit" let i' = case i of - MIR.LInt i -> VInteger i + MIR.LInt i -> VInteger i MIR.LChar i -> VChar (ord i) ns <- getNewVar lbl_failPos <- (\x -> TIR.Ident $ "failed_" <> show x) <$> getNewLabel @@ -341,7 +339,7 @@ emitLit :: MIR.Lit -> CompilerState () emitLit i = do -- !!this should never happen!! let (i', t) = case i of - (MIR.LInt i'') -> (VInteger i'', I64) + (MIR.LInt i'') -> (VInteger i'', I64) (MIR.LChar i'') -> (VChar $ ord i'', I8) varCount <- getNewVar emit $ Comment "This should not have happened!" @@ -357,7 +355,7 @@ emitAdd t e1 e2 = do exprToValue :: ExpT -> CompilerState LLVMValue exprToValue = \case (MIR.ELit i, _t) -> pure $ case i of - (MIR.LInt i) -> VInteger i + (MIR.LInt i) -> VInteger i (MIR.LChar i) -> VChar $ ord i (MIR.EVar (TIR.Ident "True"), _t) -> pure $ VInteger 1 (MIR.EVar (TIR.Ident "False"), _t) -> pure $ VInteger 0 diff --git a/src/Compiler.hs b/src/Compiler.hs index 72598cb..3fb1fe1 100644 --- a/src/Compiler.hs +++ b/src/Compiler.hs @@ -1,9 +1,6 @@ module Compiler (compile) where -import System.Process.Extra ( - readCreateProcess, - shell, - ) +import System.Process.Extra (readCreateProcess, shell) -- spawnWait s = spawnCommand s >>= \s >>= waitForProcess @@ -31,7 +28,9 @@ compileClang True = , "src/GC/lib/event.cpp" , "src/GC/lib/heap.cpp" , "src/GC/lib/profiler.cpp" - , "-Wall -Wextra -g -std=gnu++20 -stdlib=libstdc++ -O3" + , "-Wall -Wextra -g -std=gnu++20 -stdlib=libstdc++" + , "-O3" + --, "-tailcallopt" , "-Isrc/GC/include" , "-x" , "ir" -- , "-Lsrc/GC/lib -l:gcoll.a" diff --git a/src/GC/include/cheap.h b/src/GC/include/cheap.h index 7d803a8..d74af9d 100644 --- a/src/GC/include/cheap.h +++ b/src/GC/include/cheap.h @@ -7,7 +7,7 @@ extern "C" { #endif -#define WRAPPER_DEBUG +//#define WRAPPER_DEBUG #ifdef WRAPPER_DEBUG typedef struct cheap diff --git a/src/GC/include/heap.hpp b/src/GC/include/heap.hpp index eb161c0..909ac99 100644 --- a/src/GC/include/heap.hpp +++ b/src/GC/include/heap.hpp @@ -7,8 +7,8 @@ #include "chunk.hpp" #include "profiler.hpp" -#define HEAP_SIZE 65536 -#define FREE_THRESH (uint) 100 +#define HEAP_SIZE 240240240 +#define FREE_THRESH (uint)100 #define HEAP_DEBUG namespace GC @@ -16,14 +16,15 @@ namespace GC /** * Flags for the collect overlead for conditional * collection (mark/sweep/free/all). - */ - enum CollectOption { - MARK = 1 << 0, - SWEEP = 1 << 1, - MARK_SWEEP = 1 << 2, - FREE = 1 << 3, - COLLECT_ALL = 0b1111 // all flags above - }; + */ + enum CollectOption + { + MARK = 1 << 0, + SWEEP = 1 << 1, + MARK_SWEEP = 1 << 2, + FREE = 1 << 3, + COLLECT_ALL = 0b1111 // all flags above + }; /** * The heap class to represent the heap for the @@ -32,7 +33,7 @@ namespace GC * inside the heap class. The heap is represented * by a char array of size 65536 and can enable * a profiler to track the actions on the heap. - */ + */ class Heap { private: @@ -44,11 +45,11 @@ namespace GC } char *const m_heap; - size_t m_size {0}; - char *m_heap_top {nullptr}; + size_t m_size{0}; + char *m_heap_top{nullptr}; // static Heap *m_instance {nullptr}; - uintptr_t *m_stack_top {nullptr}; - bool m_profiler_enable {false}; + uintptr_t *m_stack_top{nullptr}; + bool m_profiler_enable{false}; std::vector m_allocated_chunks; std::vector m_freed_chunks; @@ -69,6 +70,7 @@ namespace GC // Temporary Chunk *try_recycle_chunks_new(size_t size); void free_overlap_new(Heap &heap); + public: /** * These are the only five functions which are exposed @@ -86,13 +88,13 @@ namespace GC void set_profiler_log_options(RecordOption flags); // Stop the compiler from generating copy-methods - Heap(Heap const&) = delete; - Heap& operator=(Heap const&) = delete; + Heap(Heap const &) = delete; + Heap &operator=(Heap const &) = delete; #ifdef HEAP_DEBUG - void collect(CollectOption flags); // conditional collection - void check_init(); // print dummy things - void print_contents(); // print dummy things + void collect(CollectOption flags); // conditional collection + void check_init(); // print dummy things + void print_contents(); // print dummy things void print_allocated_chunks(Heap *heap); // print the contents in m_allocated_chunks void print_summary(); #endif From eba91ec6462192102c28c0a9f3acb00bef0c879d Mon Sep 17 00:00:00 2001 From: Samuel Hammersberg Date: Mon, 1 May 2023 22:50:37 +0200 Subject: [PATCH 348/372] The log folder is now created as well. --- src/Main.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Main.hs b/src/Main.hs index 7e703ba..0e2e5c0 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -134,6 +134,7 @@ main' opts s = check <- doesPathExist "output" when check (removeDirectoryRecursive "output") createDirectory "output" + createDirectory "output/logs" when opts.debug $ do writeFile "output/llvm.ll" generatedCode debugDotViz From e70eae776a274dffb4bb2269a682267f13185ae1 Mon Sep 17 00:00:00 2001 From: Rakarake Date: Tue, 2 May 2023 17:25:22 +0200 Subject: [PATCH 349/372] =?UTF-8?q?Maybe=20made=20lets=20work=20in=20monom?= =?UTF-8?q?orphizer=20=F0=9F=99=83?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- src/Monomorphizer/Monomorphizer.hs | 13 ++++++++++++- 1 file changed, 12 insertions(+), 1 deletion(-) diff --git a/src/Monomorphizer/Monomorphizer.hs b/src/Monomorphizer/Monomorphizer.hs index 62aa601..5a0783e 100644 --- a/src/Monomorphizer/Monomorphizer.hs +++ b/src/Monomorphizer/Monomorphizer.hs @@ -253,7 +253,18 @@ morphExp expectedType exp = case exp of -- New bind to process newBindName <- morphBind expectedType bind' return $ M.EVar (coerce newBindName) - T.ELet (T.Bind{}) _ -> error "lets not possible yet" + T.ELet (T.Bind (identB, tB) args (expB, tExpB)) (exp, tExp) -> + if length args > 0 then error "only constants in lets allowed" + else do + tB' <- getMonoFromPoly tB + tExpB' <- getMonoFromPoly tExpB + tExp' <- getMonoFromPoly tExp + expB' <- morphExp tExpB' expB + exp' <- morphExp tExp' exp + return $ M.ELet (M.Bind (identB, tB') [] (expB', tExpB')) (exp', tExp') + +-- ELet (Bind' t) (ExpT' t) +-- Bind (Id' t) [Id' t] (ExpT' t) -- | Monomorphizes case-of branches. morphBranch :: T.Branch -> EnvM (Maybe M.Branch) From 4038f34cc53db2146acd42c2d1cd16580dc50704 Mon Sep 17 00:00:00 2001 From: Rakarake Date: Wed, 3 May 2023 15:08:07 +0200 Subject: [PATCH 350/372] Fixed woring order of monomorphization in ECase --- src/Monomorphizer/Monomorphizer.hs | 6 +----- 1 file changed, 1 insertion(+), 5 deletions(-) diff --git a/src/Monomorphizer/Monomorphizer.hs b/src/Monomorphizer/Monomorphizer.hs index 5a0783e..ff17fc4 100644 --- a/src/Monomorphizer/Monomorphizer.hs +++ b/src/Monomorphizer/Monomorphizer.hs @@ -47,7 +47,6 @@ import Data.Coerce (coerce) import Data.Map qualified as Map import Data.Maybe (catMaybes) import Data.Set qualified as Set ---import Debug.Trace import Grammar.Print (printTree) {- | EnvM is the monad containing the read-only state as well as the @@ -232,8 +231,8 @@ morphExp expectedType exp = case exp of morphExp t' exp T.ECase (exp, t) bs -> do t' <- getMonoFromPoly t - bs' <- mapM morphBranch bs exp' <- morphExp t' exp + bs' <- mapM morphBranch bs return $ M.ECase (exp', t') (catMaybes bs') -- Ideally constructors should be EInj, though this code handles them -- as well. @@ -263,9 +262,6 @@ morphExp expectedType exp = case exp of exp' <- morphExp tExp' exp return $ M.ELet (M.Bind (identB, tB') [] (expB', tExpB')) (exp', tExp') --- ELet (Bind' t) (ExpT' t) --- Bind (Id' t) [Id' t] (ExpT' t) - -- | Monomorphizes case-of branches. morphBranch :: T.Branch -> EnvM (Maybe M.Branch) morphBranch (T.Branch (p, pt) (e, et)) = do From f8a70b4cf400f817b51617b68878c71468690582 Mon Sep 17 00:00:00 2001 From: sebastianselander Date: Wed, 3 May 2023 17:58:50 +0200 Subject: [PATCH 351/372] Improved error messages --- src/AnnForall.hs | 90 +++++++++++++++++++++++--------------------- src/Codegen/Emits.hs | 52 ++++++++++++------------- 2 files changed, 74 insertions(+), 68 deletions(-) diff --git a/src/AnnForall.hs b/src/AnnForall.hs index 16222bd..f309a37 100644 --- a/src/AnnForall.hs +++ b/src/AnnForall.hs @@ -1,16 +1,16 @@ -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedRecordDot #-} module AnnForall (annotateForall) where -import Auxiliary (partitionDefs) -import Control.Applicative (Applicative (liftA2)) -import Control.Monad.Except (throwError) -import Data.Function (on) -import Data.Set (Set) -import qualified Data.Set as Set -import Grammar.Abs -import Grammar.ErrM (Err) +import Auxiliary (partitionDefs) +import Control.Applicative (Applicative (liftA2)) +import Control.Monad.Except (throwError) +import Data.Function (on) +import Data.Set (Set) +import Data.Set qualified as Set +import Grammar.Abs +import Grammar.ErrM (Err) annotateForall :: Program -> Err Program annotateForall (Program defs) = do @@ -21,30 +21,31 @@ annotateForall (Program defs) = do ss' = map (DSig . annSig) ss (ds, ss, bs) = partitionDefs defs - annData :: Data -> Err Data annData (Data typ injs) = do - (typ', tvars) <- annTyp typ - pure (Data typ' $ map (annInj tvars) injs) - + (typ', tvars) <- annTyp typ + pure (Data typ' $ map (annInj tvars) injs) where annTyp typ = do (bounded, ts) <- boundedTVars mempty typ unbounded <- Set.fromList <$> mapM assertTVar ts let diff = unbounded Set.\\ bounded typ' = foldr TAll typ diff - (typ', ) . fst <$> boundedTVars mempty typ' + (typ',) . fst <$> boundedTVars mempty typ' where boundedTVars tvars typ = case typ of - TAll tvar t -> boundedTVars (Set.insert tvar tvars) t - TData _ ts -> pure (tvars, ts) - _ -> throwError "Misformed data declaration" + TAll tvar t -> boundedTVars (Set.insert tvar tvars) t + TData _ ts -> pure (tvars, ts) + _ -> throwError "Misformed data declaration" assertTVar typ = case typ of TVar tvar -> pure tvar - _ -> throwError $ unwords [ "Misformed data declaration:" - , "Non type variable argument" - ] + _ -> + throwError $ + unwords + [ "Misformed data declaration:" + , "Non type variable argument" + ] annInj tvars (Inj n t) = Inj n $ foldr TAll t (unboundedTVars t Set.\\ tvars) @@ -55,20 +56,22 @@ annBind :: Bind -> Err Bind annBind (Bind name vars exp) = Bind name vars <$> annExp exp where annExp = \case - EAnn e t -> flip EAnn (annType t) <$> annExp e - EApp e1 e2 -> liftA2 EApp (annExp e1) (annExp e2) - EAdd e1 e2 -> liftA2 EAdd (annExp e1) (annExp e2) + -- Annotated types should not be + -- foralled without the consent of the user + EAnn e t -> flip EAnn t <$> annExp e + EApp e1 e2 -> liftA2 EApp (annExp e1) (annExp e2) + EAdd e1 e2 -> liftA2 EAdd (annExp e1) (annExp e2) ELet bind e -> liftA2 ELet (annBind bind) (annExp e) - EAbs x e -> EAbs x <$> annExp e - ECase e bs -> liftA2 ECase (annExp e) (mapM annBranch bs) - e -> pure e + EAbs x e -> EAbs x <$> annExp e + ECase e bs -> liftA2 ECase (annExp e) (mapM annBranch bs) + e -> pure e annBranch (Branch p e) = Branch p <$> annExp e annType :: Type -> Type annType typ = go $ unboundedTVars typ where go us - | null us = typ + | null us = typ | otherwise = foldr TAll typ us unboundedTVars :: Type -> Set TVar @@ -79,22 +82,25 @@ unboundedTVars' bs typ = tvars.unbounded Set.\\ tvars.bounded where tvars = gatherTVars typ gatherTVars = \case - TAll tvar t -> TVars { bounded = Set.singleton tvar - , unbounded = unboundedTVars' (Set.insert tvar bs) t - } - TVar tvar -> uTVars $ Set.singleton tvar - TFun t1 t2 -> uTVars $ on Set.union (unboundedTVars' bs) t1 t2 - TData _ typs -> uTVars $ foldr (Set.union . unboundedTVars' bs) mempty typs - _ -> TVars { bounded = mempty, unbounded = mempty } + TAll tvar t -> + TVars + { bounded = Set.singleton tvar + , unbounded = unboundedTVars' (Set.insert tvar bs) t + } + TVar tvar -> uTVars $ Set.singleton tvar + TFun t1 t2 -> uTVars $ on Set.union (unboundedTVars' bs) t1 t2 + TData _ typs -> uTVars $ foldr (Set.union . unboundedTVars' bs) mempty typs + _ -> TVars{bounded = mempty, unbounded = mempty} data TVars = TVars - { bounded :: Set TVar - , unbounded :: Set TVar - } deriving (Eq, Show, Ord) + { bounded :: Set TVar + , unbounded :: Set TVar + } + deriving (Eq, Show, Ord) uTVars :: Set TVar -> TVars -uTVars us = TVars - { bounded = mempty - , unbounded = us - } - +uTVars us = + TVars + { bounded = mempty + , unbounded = us + } diff --git a/src/Codegen/Emits.hs b/src/Codegen/Emits.hs index 9eca23e..112839b 100644 --- a/src/Codegen/Emits.hs +++ b/src/Codegen/Emits.hs @@ -1,22 +1,22 @@ -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} module Codegen.Emits where -import Codegen.Auxillary -import Codegen.CompilerState -import Codegen.LlvmIr as LIR -import Control.Applicative ((<|>)) -import Control.Monad (when) -import Control.Monad.State (gets, modify) -import qualified Data.Bifunctor as BI -import Data.Char (ord) -import Data.Coerce (coerce) -import qualified Data.Map as Map -import Data.Maybe (fromJust, fromMaybe) -import Data.Tuple.Extra (dupe, first, second) -import Monomorphizer.MonomorphizerIr as MIR -import qualified TypeChecker.TypeCheckerIr as TIR +import Codegen.Auxillary +import Codegen.CompilerState +import Codegen.LlvmIr as LIR +import Control.Applicative ((<|>)) +import Control.Monad (when) +import Control.Monad.State (gets, modify) +import Data.Bifunctor qualified as BI +import Data.Char (ord) +import Data.Coerce (coerce) +import Data.Map qualified as Map +import Data.Maybe (fromJust, fromMaybe) +import Data.Tuple.Extra (dupe, first, second) +import Monomorphizer.MonomorphizerIr as MIR +import TypeChecker.TypeCheckerIr qualified as TIR compileScs :: [MIR.Def] -> CompilerState () compileScs [] = do @@ -148,12 +148,12 @@ lastMainContent False var = ] compileExp :: ExpT -> CompilerState () -compileExp (MIR.ELit lit, _t) = emitLit lit -compileExp (MIR.EAdd e1 e2, t) = emitAdd t e1 e2 -compileExp (MIR.EVar name, _t) = emitIdent name -compileExp (MIR.EApp e1 e2, t) = emitApp t e1 e2 +compileExp (MIR.ELit lit, _t) = emitLit lit +compileExp (MIR.EAdd e1 e2, t) = emitAdd t e1 e2 +compileExp (MIR.EVar name, _t) = emitIdent name +compileExp (MIR.EApp e1 e2, t) = emitApp t e1 e2 compileExp (MIR.ELet bind e, _) = emitLet bind e -compileExp (MIR.ECase e cs, t) = emitECased t e (map (t,) cs) +compileExp (MIR.ECase e cs, t) = emitECased t e (map (t,) cs) emitLet :: MIR.Bind -> ExpT -> CompilerState () emitLet (MIR.Bind id [] innerExp) e = do @@ -226,10 +226,10 @@ emitECased t e cases = do emit $ SetVariable deref (ExtractValue botT' (VIdent casted Ptr) i) emit $ SetVariable x (Load topT' Ptr deref) else emit $ SetVariable x (ExtractValue botT' (VIdent casted Ptr) i) - PLit (_l, _t) -> undefined - PInj _id _ps -> undefined + PLit (_l, _t) -> error "Nested pattern matching to be implemented" + PInj _id _ps -> error "Nested pattern matching to be implemented" PCatch -> pure () - PEnum _id -> undefined + PEnum _id -> error "Nested pattern matching to be implemented" ) cs val <- exprToValue exp @@ -239,7 +239,7 @@ emitECased t e cases = do emitCases _rt ty label stackPtr vs (Branch (MIR.PLit (i, ct), t) exp) = do emit $ Comment "Plit" let i' = case i of - MIR.LInt i -> VInteger i + MIR.LInt i -> VInteger i MIR.LChar i -> VChar (ord i) ns <- getNewVar lbl_failPos <- (\x -> TIR.Ident $ "failed_" <> show x) <$> getNewLabel @@ -339,7 +339,7 @@ emitLit :: MIR.Lit -> CompilerState () emitLit i = do -- !!this should never happen!! let (i', t) = case i of - (MIR.LInt i'') -> (VInteger i'', I64) + (MIR.LInt i'') -> (VInteger i'', I64) (MIR.LChar i'') -> (VChar $ ord i'', I8) varCount <- getNewVar emit $ Comment "This should not have happened!" @@ -355,7 +355,7 @@ emitAdd t e1 e2 = do exprToValue :: ExpT -> CompilerState LLVMValue exprToValue = \case (MIR.ELit i, _t) -> pure $ case i of - (MIR.LInt i) -> VInteger i + (MIR.LInt i) -> VInteger i (MIR.LChar i) -> VChar $ ord i (MIR.EVar (TIR.Ident "True"), _t) -> pure $ VInteger 1 (MIR.EVar (TIR.Ident "False"), _t) -> pure $ VInteger 0 From 5a28f9d90945197e8e93c37fe61e472260996d6c Mon Sep 17 00:00:00 2001 From: sebastianselander Date: Wed, 3 May 2023 17:59:09 +0200 Subject: [PATCH 352/372] Bind now does correct subtype check. --- src/TypeChecker/TypeCheckerHm.hs | 78 ++++++++++++++++++++------------ 1 file changed, 49 insertions(+), 29 deletions(-) diff --git a/src/TypeChecker/TypeCheckerHm.hs b/src/TypeChecker/TypeCheckerHm.hs index 3a505b4..4e7e7d6 100644 --- a/src/TypeChecker/TypeCheckerHm.hs +++ b/src/TypeChecker/TypeCheckerHm.hs @@ -22,7 +22,7 @@ import Data.Map qualified as M import Data.Maybe (fromJust) import Data.Set (Set) import Data.Set qualified as S -import Debug.Trace (trace) +import Debug.Trace (trace, traceShow) import Grammar.Abs import Grammar.Print (printTree) import TypeChecker.TypeCheckerIr qualified as T @@ -158,36 +158,31 @@ freeOrdered _ = mempty checkBind :: Bind -> Infer (T.Bind' Type) checkBind (Bind name args e) = do let lambda = makeLambda e (reverse (coerce args)) - (e, lambda_t) <- inferExp lambda + (e, infSig) <- inferExp lambda s <- gets sigs case M.lookup (coerce name) s of - Just (Just t') -> do - let fvs0 = nub $ freeOrdered t' - let m0 = M.fromList $ zip fvs0 letters - let fvs1 = nub $ freeOrdered lambda_t - let m1 = M.fromList $ zip fvs1 letters - let t0 = replace m0 t' - let t1 = replace m1 lambda_t - -- Not sure if this is actually correct - sub <- unify t' lambda_t + Just (Just typSig) -> do + let genInfSig = generalize mempty infSig + (trace ("Inferred: " ++ printTree infSig ++ "\nGeneralized inferred: " ++ printTree genInfSig ++ "\nGiven: " ++ printTree typSig ++ "\n") pure ()) + sub <- genInfSig `unify` typSig unless - (t1 <<= t0) + (genInfSig <<= typSig) ( throwError $ Error ( Aux.do "Inferred type" - quote $ printTree t1 + quote $ printTree infSig "doesn't match given type" - quote $ printTree $ mkForall t0 + quote $ printTree typSig ) False ) - -- Applying sub to t' will worsen error messages. + -- Applying sub to typSig will worsen error messages. -- Unfortunately I do not know a better solution at the moment. - return $ T.Bind (coerce name, apply sub t') [] (apply sub e, lambda_t) + return $ T.Bind (coerce name, apply sub typSig) [] (apply sub e, typSig) _ -> do - insertSig (coerce name) (Just lambda_t) - return (T.Bind (coerce name, lambda_t) [] (e, lambda_t)) + insertSig (coerce name) (Just infSig) + return (T.Bind (coerce name, infSig) [] (e, infSig)) checkData :: (MonadState Env m, Monad m, MonadError Error m) => Data -> m () checkData err@(Data typ injs) = do @@ -276,7 +271,7 @@ algoW = \case quote $ printTree t' ) let comp = sub2 `compose` sub1 `compose` sub0 - return (comp, (apply comp e', skolemize t)) + return (comp, (apply comp e', t)) -- \| ------------------ -- \| Γ ⊢ i : Int, ∅ @@ -384,7 +379,9 @@ algoW = \case return (comp, apply comp (T.ECase (e', t) injs, ret_t)) checkCase :: Type -> [Branch] -> Infer (Subst, [T.Branch' Type], Type) -checkCase _ [] = catchableErr "Atleast one case required" +checkCase _ [] = do + fr <- fresh + return (nullSubst, [], fr) checkCase expT brnchs = do (subs, branchTs, injs, returns) <- unzip4 <$> mapM inferBranch brnchs let sub0 = composeAll subs @@ -608,15 +605,37 @@ currently this is not the case, the TAll pattern match is incorrectly implemente -} -- Is the left a subtype of the right (<<=) :: Type -> Type -> Bool -(<<=) (TVar _) _ = True -(<<=) t1@TAll{} t2 = skipForalls t1 <<= t2 -(<<=) t1 t2@TAll{} = t1 <<= skipForalls t2 -(<<=) (TFun a b) (TFun c d) = a <<= c && b <<= d -(<<=) (TData n1 ts1) (TData n2 ts2) = - n1 == n2 - && length ts1 == length ts2 - && and (zipWith (<<=) ts1 ts2) -(<<=) a b = a == b +(<<=) a b = case (a,b) of + (TVar _, _) -> True + (TFun a b,TFun c d) -> a <<= c && b <<= d + (TAll tvar1 t1, TAll tvar2 t2) -> ungo [tvar1, tvar2] t1 t2 + (TAll tvar t1, t2) -> ungo [tvar] t1 t2 + (t1, TAll tvar t2) -> ungo [tvar] t1 t2 + (TData n1 ts1, TData n2 ts2) -> n1 == n2 + && length ts1 == length ts2 + && and (zipWith (<<=) ts1 ts2) + (t1,t2) -> t1 == t2 + where + ungo :: [TVar] -> Type -> Type -> Bool + ungo tvars t1 t2 = case run (go tvars t1 t2) of + Right (b,_) -> b + _ -> False + go :: [TVar] -> Type -> Type -> Infer Bool + go tvars t1 t2 = do + fr <- fresh + let sub = M.fromList [(coerce x, fr) | (MkTVar x) <- tvars] + return (apply sub t1 <<= apply sub t2) + +{- + +typSig = TAll (MkTVar "a") (TAll (MkTVar "b") ((TVar (MkTVar "a") `TFun` (TVar (MkTVar "b"))))) + +infSig = generalize mempty $ TFun (TVar $ MkTVar "x") (TVar $ MkTVar "x") + +a = TAll (MkTVar "a") (TFun (TVar $ MkTVar "a") (TVar $ MkTVar "a")) +b = TAll (MkTVar "b") (TFun (TVar $ MkTVar "b") (TVar $ MkTVar "b")) +int = TFun (TLit "Int") (TLit "Int") +-} skipForalls :: Type -> Type skipForalls = \case @@ -897,6 +916,7 @@ data Error = Error {msg :: String, catchable :: Bool} type Subst = Map T.Ident Type newtype Warning = NonExhaustive String + deriving (Show) newtype Infer a = Infer {runInfer :: StateT Env (ReaderT Ctx (WriterT [Warning] (ExceptT Error Identity))) a} deriving (Functor, Applicative, Monad, MonadReader Ctx, MonadError Error, MonadState Env) From c7b76cbbb4f9d118ee2cb13c17eb5e2164d5f77e Mon Sep 17 00:00:00 2001 From: sebastianselander Date: Wed, 3 May 2023 18:56:16 +0200 Subject: [PATCH 353/372] Fixed a bug of repeated application of same function to arguments of differing types. More bufs appeared --- src/TypeChecker/TypeCheckerHm.hs | 93 ++++++++++++-------------------- 1 file changed, 34 insertions(+), 59 deletions(-) diff --git a/src/TypeChecker/TypeCheckerHm.hs b/src/TypeChecker/TypeCheckerHm.hs index 4e7e7d6..edd7db3 100644 --- a/src/TypeChecker/TypeCheckerHm.hs +++ b/src/TypeChecker/TypeCheckerHm.hs @@ -163,7 +163,6 @@ checkBind (Bind name args e) = do case M.lookup (coerce name) s of Just (Just typSig) -> do let genInfSig = generalize mempty infSig - (trace ("Inferred: " ++ printTree infSig ++ "\nGeneralized inferred: " ++ printTree genInfSig ++ "\nGiven: " ++ printTree typSig ++ "\n") pure ()) sub <- genInfSig `unify` typSig unless (genInfSig <<= typSig) @@ -289,7 +288,9 @@ algoW = \case Nothing -> do sig <- gets sigs case M.lookup (coerce i) sig of - Just (Just t) -> return (nullSubst, (T.EVar $ coerce i, t)) + Just (Just t) -> do + t <- freshen t + return (nullSubst, (T.EVar $ coerce i, t)) Just Nothing -> do fr <- fresh return (nullSubst, (T.EVar $ coerce i, fr)) @@ -300,7 +301,9 @@ algoW = \case EInj i -> do constr <- gets injections case M.lookup (coerce i) constr of - Just t -> return (nullSubst, (T.EVar $ coerce i, t)) + Just t -> do + t <- freshen t + return (nullSubst, (T.EVar $ coerce i, t)) Nothing -> uncatchableErr $ Aux.do "Constructor:" @@ -344,8 +347,12 @@ algoW = \case EApp e0 e1 -> do fr <- fresh (s0, (e0', t0)) <- algoW e0 + traceShow e0 pure () + trace ("S0: " ++ show s0) pure () applySt s0 $ do (s1, (e1', t1)) <- algoW e1 + traceShow e1 pure () + trace ("S1: " ++ show s1) pure () s2 <- unify (apply s1 t0) (TFun t1 fr) let t = apply s2 fr let comp = s2 `compose` s1 `compose` s0 @@ -590,77 +597,48 @@ fresh = do modify (\st -> st{count = succ (count st)}) return $ TVar $ MkTVar $ LIdent $ show n -{- - -The following definition of id should type check -id : forall a. a -> a -id x = (x : a) - -but not this one, according to haskell atleast - -id : a -> a -id x = (x : a) - -currently this is not the case, the TAll pattern match is incorrectly implemented. --} -- Is the left a subtype of the right (<<=) :: Type -> Type -> Bool -(<<=) a b = case (a,b) of +(<<=) a b = case (a, b) of (TVar _, _) -> True - (TFun a b,TFun c d) -> a <<= c && b <<= d + (TFun a b, TFun c d) -> a <<= c && b <<= d (TAll tvar1 t1, TAll tvar2 t2) -> ungo [tvar1, tvar2] t1 t2 (TAll tvar t1, t2) -> ungo [tvar] t1 t2 (t1, TAll tvar t2) -> ungo [tvar] t1 t2 - (TData n1 ts1, TData n2 ts2) -> n1 == n2 - && length ts1 == length ts2 - && and (zipWith (<<=) ts1 ts2) - (t1,t2) -> t1 == t2 + (TData n1 ts1, TData n2 ts2) -> + n1 == n2 + && length ts1 == length ts2 + && and (zipWith (<<=) ts1 ts2) + (t1, t2) -> t1 == t2 where ungo :: [TVar] -> Type -> Type -> Bool ungo tvars t1 t2 = case run (go tvars t1 t2) of - Right (b,_) -> b + Right (b, _) -> b _ -> False + -- TODO: Fix the following + -- Maybe locally using the Infer monad can cause trouble. + -- Since the fresh count starts from zero go :: [TVar] -> Type -> Type -> Infer Bool go tvars t1 t2 = do - fr <- fresh - let sub = M.fromList [(coerce x, fr) | (MkTVar x) <- tvars] - return (apply sub t1 <<= apply sub t2) - -{- - -typSig = TAll (MkTVar "a") (TAll (MkTVar "b") ((TVar (MkTVar "a") `TFun` (TVar (MkTVar "b"))))) - -infSig = generalize mempty $ TFun (TVar $ MkTVar "x") (TVar $ MkTVar "x") - -a = TAll (MkTVar "a") (TFun (TVar $ MkTVar "a") (TVar $ MkTVar "a")) -b = TAll (MkTVar "b") (TFun (TVar $ MkTVar "b") (TVar $ MkTVar "b")) -int = TFun (TLit "Int") (TLit "Int") --} + fr <- fresh + let sub = M.fromList [(coerce x, fr) | (MkTVar x) <- tvars] + return (apply sub t1 <<= apply sub t2) skipForalls :: Type -> Type skipForalls = \case TAll _ t -> skipForalls t t -> t -foralls :: Type -> [T.Ident] -foralls (TAll (MkTVar a) t) = coerce a : foralls t -foralls _ = [] - -mkForall :: Type -> Type -mkForall t = case map (TAll . MkTVar . coerce) $ S.toList $ free t of - [] -> t - (x : xs) -> - let f acc [] = acc - f acc (x : xs) = f (x acc) xs - (y : ys) = reverse $ x : xs - in f (y t) ys - -skolemize :: Type -> Type -skolemize (TVar (MkTVar a)) = TEVar $ MkTEVar a -skolemize (TAll x t) = TAll x (skolemize t) -skolemize (TFun t1 t2) = (TFun `on` skolemize) t1 t2 -skolemize (TData n ts) = TData n (map skolemize ts) -skolemize t = t +freshen :: Type -> Infer Type +freshen (TAll (MkTVar (LIdent var)) t) = do + fr <- fresh + let getName (TVar (MkTVar (LIdent i))) = i + let sub = (M.singleton (coerce $ getName fr) fr) + return $ TAll (MkTVar . coerce $ getName fr) (apply sub (coerce t)) +freshen (TFun t1 t2) = TFun <$> freshen t1 <*> freshen t2 +freshen (TData name tvars) = TData name <$> mapM freshen tvars +freshen (TVar _) = fresh +freshen t = return t -- | A class for substitutions class SubstType t where @@ -932,6 +910,3 @@ quote s = "'" ++ s ++ "'" letters :: [T.Ident] letters = map T.Ident $ [1 ..] >>= flip replicateM ['a' .. 'z'] - -ctrace :: (Monad m, Show a) => String -> a -> m () -ctrace str a = trace (str ++ ": " ++ show a) pure () From 122bff7436674950fb49a0089c38147f7edacfe7 Mon Sep 17 00:00:00 2001 From: sebastian Date: Thu, 4 May 2023 21:29:24 +0200 Subject: [PATCH 354/372] Sugar has arrived --- Grammar.cf | 32 ++++++++++++++++--------- src/Desugar/Desugar.hs | 53 +++++++++++++++++++++++++++++++++++++----- 2 files changed, 68 insertions(+), 17 deletions(-) diff --git a/Grammar.cf b/Grammar.cf index 35c3a56..46795f2 100644 --- a/Grammar.cf +++ b/Grammar.cf @@ -13,8 +13,10 @@ DBind. Def ::= Bind; DSig. Def ::= Sig; DData. Def ::= Data; -Sig. Sig ::= LIdent ":" Type; -Bind. Bind ::= LIdent [LIdent] "=" Exp; +internal Sig. Sig ::= LIdent ":" Type; + SigS. Sig ::= VarName ":" Type; +internal Bind. Bind ::= LIdent [LIdent] "=" Exp; + BindS. Bind ::= VarName [LIdent] "=" Exp; ------------------------------------------------------------------------------- -- * Types @@ -42,15 +44,22 @@ Inj. Inj ::= UIdent ":" Type ; -- * Expressions ------------------------------------------------------------------------------- -EVar. Exp4 ::= LIdent; -EInj. Exp4 ::= UIdent; -ELit. Exp4 ::= Lit; -EApp. Exp3 ::= Exp3 Exp4; -EAdd. Exp2 ::= Exp2 "+" Exp3; -ELet. Exp1 ::= "let" Bind "in" Exp1; -EAbs. Exp1 ::= "\\" LIdent "." Exp1; -ECase. Exp1 ::= "case" Exp "of" "{" [Branch] "}"; -EAnn. Exp ::= Exp1 ":" Type; +internal EVar. Exp4 ::= LIdent; + EVarS. Exp4 ::= VarName ; + EInj. Exp4 ::= UIdent; + ELit. Exp4 ::= Lit; + EApp. Exp3 ::= Exp3 Exp4; + EAdd. Exp2 ::= Exp2 "+" Exp3; + ELet. Exp1 ::= "let" Bind "in" Exp1; + EAbs. Exp1 ::= "\\" LIdent "." Exp1; + ECase. Exp1 ::= "case" Exp "of" "{" [Branch] "}"; + EAnn. Exp ::= Exp1 ":" Type; + +VSymbol. VarName ::= "." Symbol; +VIdent. VarName ::= LIdent; + +infixSymbol. Exp2 ::= Exp2 Symbol Exp3 ; +define infixSymbol e1 vn e3 = EApp (EApp (EVarS (VSymbol vn)) e1) e3; ------------------------------------------------------------------------------- -- * LITERALS @@ -93,6 +102,7 @@ coercions Type 1 ; token UIdent (upper (letter | digit | '_')*) ; token LIdent (lower (letter | digit | '_')*) ; +token Symbol (["@#%^&*_-+=|?/<>,•"]+) ; comment "--"; comment "{-" "-}"; diff --git a/src/Desugar/Desugar.hs b/src/Desugar/Desugar.hs index a2a5ffd..14abef1 100644 --- a/src/Desugar/Desugar.hs +++ b/src/Desugar/Desugar.hs @@ -5,27 +5,68 @@ module Desugar.Desugar where import Data.Function (on) import Grammar.Abs +{- + +The entire module should never have any catch all pattern matches as that +will disble warnings for when the grammar is expanded. + +-} + desugar :: Program -> Program desugar (Program defs) = Program (map desugarDef defs) +desugarVarName :: VarName -> LIdent +desugarVarName (VSymbol (Symbol i)) = LIdent i +desugarVarName (VIdent i) = i + desugarDef :: Def -> Def desugarDef = \case DBind b -> DBind (desugarBind b) - DSig sig -> DSig sig - DData d -> DData d + DSig sig -> DSig (desugarSig sig) + DData d -> DData (desugarData d) desugarBind :: Bind -> Bind +desugarBind (BindS name args e) = Bind (desugarVarName name) args (desugarExp e) desugarBind (Bind name args e) = Bind name args (desugarExp e) +desugarSig :: Sig -> Sig +desugarSig (SigS ident typ) = Sig (desugarVarName ident) (desugarType typ) +desugarSig (Sig ident typ) = Sig ident (desugarType typ) + +desugarData :: Data -> Data +desugarData (Data typ injs) = Data (desugarType typ) (map desugarInj injs) + +desugarType :: Type -> Type +desugarType t = t + +desugarInj :: Inj -> Inj +desugarInj (Inj ident typ) = Inj ident (desugarType typ) + desugarExp :: Exp -> Exp desugarExp = \case - EApp e1 e2 -> (EApp `on` desugarExp) e1 e2 - EAdd e1 e2 -> (EAdd `on` desugarExp) e1 e2 + EApp e1 e2 -> EApp (desugarExp e1) (desugarExp e2) + EAdd e1 e2 -> EAdd (desugarExp e1) (desugarExp e2) EAbs i e -> EAbs i (desugarExp e) ELet b e -> ELet (desugarBind b) (desugarExp e) ECase e br -> ECase (desugarExp e) (map desugarBranch br) EAnn e t -> EAnn (desugarExp e) t - e -> e + EVarS (VSymbol (Symbol symb)) -> EVar (LIdent symb) + EVarS (VIdent ident) -> EVar ident + EVar i -> EVar i + ELit l -> ELit l + EInj i -> EInj i desugarBranch :: Branch -> Branch -desugarBranch (Branch p e) = Branch p (desugarExp e) +desugarBranch (Branch p e) = Branch (desugarPattern p) (desugarExp e) + +desugarPattern :: Pattern -> Pattern +desugarPattern = \case + PVar ident -> PVar ident + PLit lit -> PLit (desugarLit lit) + PCatch -> PCatch + PEnum ident -> PEnum ident + PInj ident patterns -> PInj ident (map desugarPattern patterns) + +desugarLit :: Lit -> Lit +desugarLit (LInt i) = LInt i +desugarLit (LChar c) = LChar c From c309c439cb5228e65103c17f3077766791ce3b18 Mon Sep 17 00:00:00 2001 From: sebastianselander Date: Thu, 4 May 2023 21:30:19 +0200 Subject: [PATCH 355/372] Fixed bug when freshening types --- src/TypeChecker/TypeCheckerHm.hs | 27 ++++++++++++++------------- 1 file changed, 14 insertions(+), 13 deletions(-) diff --git a/src/TypeChecker/TypeCheckerHm.hs b/src/TypeChecker/TypeCheckerHm.hs index edd7db3..6250ac1 100644 --- a/src/TypeChecker/TypeCheckerHm.hs +++ b/src/TypeChecker/TypeCheckerHm.hs @@ -347,12 +347,8 @@ algoW = \case EApp e0 e1 -> do fr <- fresh (s0, (e0', t0)) <- algoW e0 - traceShow e0 pure () - trace ("S0: " ++ show s0) pure () applySt s0 $ do (s1, (e1', t1)) <- algoW e1 - traceShow e1 pure () - trace ("S1: " ++ show s1) pure () s2 <- unify (apply s1 t0) (TFun t1 fr) let t = apply s2 fr let comp = s2 `compose` s1 `compose` s0 @@ -499,6 +495,7 @@ unify t0 t1 = (t@(TData _ _), TVar (MkTVar b)) -> return $ M.singleton (coerce b) t (TVar (MkTVar a), t) -> occurs (coerce a) t (t, TVar (MkTVar b)) -> occurs (coerce b) t + -- Forall unification should change (TAll _ t, b) -> unify t b (a, TAll _ t) -> unify a t (TLit a, TLit b) -> @@ -630,15 +627,19 @@ skipForalls = \case t -> t freshen :: Type -> Infer Type -freshen (TAll (MkTVar (LIdent var)) t) = do - fr <- fresh - let getName (TVar (MkTVar (LIdent i))) = i - let sub = (M.singleton (coerce $ getName fr) fr) - return $ TAll (MkTVar . coerce $ getName fr) (apply sub (coerce t)) -freshen (TFun t1 t2) = TFun <$> freshen t1 <*> freshen t2 -freshen (TData name tvars) = TData name <$> mapM freshen tvars -freshen (TVar _) = fresh -freshen t = return t +freshen t = do + let frees = S.toList (free t) + xs <- mapM (const fresh) frees + let sub = M.fromList $ zip frees xs + return $ apply sub t + +{- + +a = TVar $ MkTVar "a" +single = TData "single" [a] +arr = a `TFun` single + +-} -- | A class for substitutions class SubstType t where From 0dc06eaf80989087682211dc44f0485b5386893d Mon Sep 17 00:00:00 2001 From: sebastian Date: Thu, 4 May 2023 22:50:15 +0200 Subject: [PATCH 356/372] Parens removed on types and infix symbols work almost, just need to adapt in LLVM --- Grammar.cf | 14 +-- src/Desugar/Desugar.hs | 25 ++++- src/Main.hs | 93 ++++++++++-------- test_program.crf | 30 +++--- tests/TestAnnForall.hs | 177 ++++++++++++++++++---------------- tests/TestLambdaLifter.hs | 119 +++++++++++------------ tests/TestRenamer.hs | 136 ++++++++++++++------------ tests/TestReportForall.hs | 59 +++++++----- tests/TestTypeCheckerBidir.hs | 133 +++++++++++++------------ tests/TestTypeCheckerHm.hs | 145 +++++++++++++--------------- 10 files changed, 494 insertions(+), 437 deletions(-) diff --git a/Grammar.cf b/Grammar.cf index 46795f2..da40cbc 100644 --- a/Grammar.cf +++ b/Grammar.cf @@ -22,12 +22,14 @@ internal Bind. Bind ::= LIdent [LIdent] "=" Exp; -- * Types ------------------------------------------------------------------------------- - TLit. Type1 ::= UIdent; -- τ - TVar. Type1 ::= TVar; -- α -internal TEVar. Type1 ::= TEVar; -- ά - TData. Type1 ::= UIdent "(" [Type] ")"; -- D () - TFun. Type ::= Type1 "->" Type; -- A → A +internal TLit. Type3 ::= UIdent; -- τ + TIdent. Type3 ::= UIdent; + TVar. Type3 ::= TVar; -- α + TApp. Type2 ::= Type2 Type3 ; + TFun. Type1 ::= Type1 "->" Type; -- A → A TAll. Type ::= "forall" TVar "." Type; -- ∀α. A +internal TEVar. Type1 ::= TEVar; -- ά +internal TData. Type1 ::= UIdent "(" [Type] ")"; -- D () MkTVar. TVar ::= LIdent; internal MkTEVar. TEVar ::= LIdent; @@ -98,7 +100,7 @@ separator nonempty Pattern1 " "; coercions Pattern 1; coercions Exp 4; -coercions Type 1 ; +coercions Type 3 ; token UIdent (upper (letter | digit | '_')*) ; token LIdent (lower (letter | digit | '_')*) ; diff --git a/src/Desugar/Desugar.hs b/src/Desugar/Desugar.hs index 14abef1..02eb4d9 100644 --- a/src/Desugar/Desugar.hs +++ b/src/Desugar/Desugar.hs @@ -1,9 +1,12 @@ {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} -module Desugar.Desugar where +module Desugar.Desugar (desugar) where import Data.Function (on) +import Debug.Trace (traceShow) import Grammar.Abs +import Grammar.Print {- @@ -37,7 +40,25 @@ desugarData :: Data -> Data desugarData (Data typ injs) = Data (desugarType typ) (map desugarInj injs) desugarType :: Type -> Type -desugarType t = t +desugarType = \case + TIdent (UIdent "Int") -> TLit "Int" + TIdent (UIdent "Char") -> TLit "Char" + TIdent ident -> TData ident [] + TApp t1 t2 -> + let (name : tvars) = flatten t1 ++ [t2] + in case name of + TIdent ident -> TData ident (map desugarType tvars) + _ -> error "desugarType in Desugar.hs is not implemented correctly" + TLit l -> TLit l + TVar v -> TVar v + (TAll i t) -> TAll i (desugarType t) + TFun t1 t2 -> TFun (desugarType t1) (desugarType t2) + TEVar v -> TEVar v + TData ident typ -> TData ident (map desugarType typ) + where + flatten :: Type -> [Type] + flatten (TApp a b) = flatten a <> flatten b + flatten a = [a] desugarInj :: Inj -> Inj desugarInj (Inj ident typ) = Inj ident (desugarType typ) diff --git a/src/Main.hs b/src/Main.hs index 0e2e5c0..6088a7c 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -2,38 +2,47 @@ module Main where -import AnnForall (annotateForall) -import Codegen.Codegen (generateCode) -import Compiler (compile) -import Control.Monad (when, (<=<)) -import Data.List.Extra (isSuffixOf) -import Data.Maybe (fromJust, isNothing) -import Desugar.Desugar (desugar) -import GHC.IO.Handle.Text (hPutStrLn) -import Grammar.ErrM (Err) -import Grammar.Layout (resolveLayout) -import Grammar.Par (myLexer, pProgram) -import Grammar.Print (Print, printTree) -import LambdaLifter (lambdaLift) -import Monomorphizer.Monomorphizer (monomorphize) -import OrderDefs (orderDefs) -import Renamer.Renamer (rename) -import ReportForall (reportForall) -import System.Console.GetOpt (ArgDescr (NoArg, ReqArg), - ArgOrder (RequireOrder), - OptDescr (Option), getOpt, - usageInfo) -import System.Directory (createDirectory, doesPathExist, - getDirectoryContents, - removeDirectoryRecursive, - setCurrentDirectory) -import System.Environment (getArgs) -import System.Exit (ExitCode (ExitFailure), - exitFailure, exitSuccess, - exitWith) -import System.IO (stderr) -import System.Process (spawnCommand, waitForProcess) -import TypeChecker.TypeChecker (TypeChecker (Bi, Hm), typecheck) +import AnnForall (annotateForall) +import Codegen.Codegen (generateCode) +import Compiler (compile) +import Control.Monad (when, (<=<)) +import Data.List.Extra (isSuffixOf) +import Data.Maybe (fromJust, isNothing) +import Desugar.Desugar (desugar) +import GHC.IO.Handle.Text (hPutStrLn) +import Grammar.ErrM (Err) +import Grammar.Layout (resolveLayout) +import Grammar.Par (myLexer, pProgram) +import Grammar.Print (Print, printTree) +import LambdaLifter (lambdaLift) +import Monomorphizer.Monomorphizer (monomorphize) +import OrderDefs (orderDefs) +import Renamer.Renamer (rename) +import ReportForall (reportForall) +import System.Console.GetOpt ( + ArgDescr (NoArg, ReqArg), + ArgOrder (RequireOrder), + OptDescr (Option), + getOpt, + usageInfo, + ) +import System.Directory ( + createDirectory, + doesPathExist, + getDirectoryContents, + removeDirectoryRecursive, + setCurrentDirectory, + ) +import System.Environment (getArgs) +import System.Exit ( + ExitCode (ExitFailure), + exitFailure, + exitSuccess, + exitWith, + ) +import System.IO (stderr) +import System.Process (spawnCommand, waitForProcess) +import TypeChecker.TypeChecker (TypeChecker (Bi, Hm), typecheck) main :: IO () main = getArgs >>= parseArgs >>= uncurry main' @@ -85,12 +94,12 @@ chooseTypechecker s options = options{typechecker = tc} tc = case s of "hm" -> pure Hm "bi" -> pure Bi - _ -> Nothing + _ -> Nothing data Options = Options - { help :: Bool - , debug :: Bool - , gc :: Bool + { help :: Bool + , debug :: Bool + , gc :: Bool , typechecker :: Maybe TypeChecker } @@ -169,12 +178,12 @@ prelude :: String prelude = unlines [ "\n" - --, "customHelperFunctionCuzPoorImplementation : Bool () -> Int -> Bool ()" - --, "customHelperFunctionCuzPoorImplementation x y = x" - , "data Bool () where" - , " False : Bool ()" - , " True : Bool ()" - , "lt : Int -> Int -> Bool ()" + , -- , "customHelperFunctionCuzPoorImplementation : Bool () -> Int -> Bool ()" + -- , "customHelperFunctionCuzPoorImplementation x y = x" + "data Bool where" + , " False : Bool" + , " True : Bool" + , "lt : Int -> Int -> Bool" , "lt x y = True" , "\n" ] diff --git a/test_program.crf b/test_program.crf index 435a071..5f35a1d 100644 --- a/test_program.crf +++ b/test_program.crf @@ -1,23 +1,15 @@ -data List (a) where { - Nil : List (a) - Cons : a -> List (a) -> List (a) -}; +data List a where + Cons : a -> List a -> List a + Nil : List a -main = length (Cons 1 (Cons 2 Nil)) ; -id x = x; -const x y = x ; +.++ xs ys = case xs of + Nil => ys + Cons z zs => Cons z (zs ++ ys) -map : (o -> g) -> List (o) -> List (g) ; -map f xs = case xs of { - Nil => Nil ; - Cons x xs => Cons (f x) (map f xs) ; -}; +length xs = case xs of + Cons x xs => 1 + length xs -length : List (Int) -> Int ; -length xs = case xs of { - Nil => 0 ; - Cons _ xs => 1 + length xs ; -}; +main = length (list1 ++ list2) -id_int : a -> b ; -id_int x = (x : a) ; +list1 = Cons 0 (Cons 1 (Cons 2 (Cons 3 Nil))) +list2 = Cons 4 (Cons 5 (Cons 6 (Cons 7 Nil))) diff --git a/tests/TestAnnForall.hs b/tests/TestAnnForall.hs index 98776fe..9280f33 100644 --- a/tests/TestAnnForall.hs +++ b/tests/TestAnnForall.hs @@ -1,97 +1,112 @@ {-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE QualifiedDo #-} {-# HLINT ignore "Use camelCase" #-} {-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} -{-# LANGUAGE QualifiedDo #-} module TestAnnForall (testAnnForall, test) where -import AnnForall (annotateForall) -import Control.Monad ((<=<)) -import qualified DoStrings as D -import Grammar.ErrM (Err, pattern Bad, pattern Ok) -import Grammar.Layout (resolveLayout) -import Grammar.Par (myLexer, pProgram) -import Grammar.Print (printTree) -import Renamer.Renamer (rename) -import ReportForall (reportForall) -import Test.Hspec (describe, hspec, shouldBe, - shouldNotSatisfy, shouldSatisfy, - shouldThrow, specify) -import TypeChecker.ReportTEVar (reportTEVar) -import TypeChecker.TypeChecker (TypeChecker (Bi, Hm)) -import TypeChecker.TypeCheckerBidir (typecheck) -import qualified TypeChecker.TypeCheckerIr as T +import AnnForall (annotateForall) +import Control.Monad ((<=<)) +import Desugar.Desugar (desugar) +import DoStrings qualified as D +import Grammar.ErrM (Err, pattern Bad, pattern Ok) +import Grammar.Layout (resolveLayout) +import Grammar.Par (myLexer, pProgram) +import Grammar.Print (printTree) +import Renamer.Renamer (rename) +import ReportForall (reportForall) +import Test.Hspec ( + describe, + hspec, + shouldBe, + shouldNotSatisfy, + shouldSatisfy, + shouldThrow, + specify, + ) +import TypeChecker.ReportTEVar (reportTEVar) +import TypeChecker.TypeChecker (TypeChecker (Bi, Hm)) +import TypeChecker.TypeCheckerBidir (typecheck) +import TypeChecker.TypeCheckerIr qualified as T test = hspec testAnnForall testAnnForall = describe "Test AnnForall" $ do - ann_data1 - ann_data2 - ann_bad_data1 - ann_bad_data2 - ann_bad_data3 - ann_sig1 - ann_sig2 - ann_bind + ann_data1 + ann_data2 + ann_bad_data1 + ann_bad_data2 + ann_bad_data3 + ann_sig1 + ann_sig2 + ann_bind -ann_data1 = specify "Annotate data type" $ - D.do "data Either (a b) where" - " Left : a -> Either (a b)" - " Right : b -> Either (a b)" - `shouldBePrg` - D.do "data forall a. forall b. Either (a b) where" - " Left : a -> Either (a b)" - " Right : b -> Either (a b)" +ann_data1 = + specify "Annotate data type" $ + D.do + "data Either a b where" + " Left : a -> Either a b" + " Right : b -> Either a b" + `shouldBePrg` D.do + "data forall a. forall b. Either a b where" + " Left : a -> Either a b" + " Right : b -> Either a b" -ann_data2 = specify "Annotate constructor with additional type variable" $ - D.do "data forall a. forall b. Either (a b) where" - " Left : c -> a -> Either (a b)" - " Right : b -> Either (a b)" - `shouldBePrg` - D.do "data forall a. forall b. Either (a b) where" - " Left : forall c. c -> a -> Either (a b)" - " Right : b -> Either (a b)" +ann_data2 = + specify "Annotate constructor with additional type variable" $ + D.do + "data forall a. forall b. Either a b where" + " Left : c -> a -> Either a b" + " Right : b -> Either a b" + `shouldBePrg` D.do + "data forall a. forall b. Either a b where" + " Left : forall c. c -> a -> Either a b" + " Right : b -> Either a b" -ann_bad_data1 = specify "Bad data type variables" $ - D.do "data Either (Int b) where" - " Left : a -> Either (a b)" - " Right : b -> Either (a b)" - `shouldBeErr` - "Misformed data declaration: Non type variable argument" +ann_bad_data1 = + specify "Bad data type variables" $ + D.do + "data Either Int b where" + " Left : a -> Either a b" + " Right : b -> Either a b" + `shouldBeErr` "Misformed data declaration: Non type variable argument" -ann_bad_data2 = specify "Bad data identifer" $ - D.do "data Int -> Either (a b) where" - " Left : a -> Either (a b)" - " Right : b -> Either (a b)" - `shouldBeErr` - "Misformed data declaration" +ann_bad_data2 = + specify "Bad data identifer" $ + D.do + "data Int -> Either a b where" + " Left : a -> Either a b" + " Right : b -> Either a b" + `shouldBeErr` "Misformed data declaration" -ann_bad_data3 = specify "Constructor forall duplicate" $ - D.do "data Int -> Either (a b) where" - " Left : forall a. a -> Either (a b)" - " Right : b -> Either (a b)" - `shouldBeErr` - "Misformed data declaration" +ann_bad_data3 = + specify "Constructor forall duplicate" $ + D.do + "data Int -> Either a b where" + " Left : forall a. a -> Either a b" + " Right : b -> Either a b" + `shouldBeErr` "Misformed data declaration" +ann_sig1 = + specify "Annotate signature" $ + "f : a -> b -> (forall a. a -> a) -> a" + `shouldBePrg` "f : forall a. forall b. a -> b -> (forall a. a -> a) -> a" -ann_sig1 = specify "Annotate signature" $ - "f : a -> b -> (forall a. a -> a) -> a" - `shouldBePrg` - "f : forall a. forall b. a -> b -> (forall a. a -> a) -> a" +ann_sig2 = + specify "Annotate signature 2" $ + D.do + "const : forall a. forall b. a -> b -> a" + "const x y = x" + "main = const 'a' 65" + `shouldBePrg` D.do + "const : forall a. forall b. a -> b -> a" + "const x y = x" + "main = const 'a' 65" -ann_sig2 = specify "Annotate signature 2" $ - D.do "const : forall a. forall b. a -> b -> a" - "const x y = x" - "main = const 'a' 65" - `shouldBePrg` - D.do "const : forall a. forall b. a -> b -> a" - "const x y = x" - "main = const 'a' 65" - -ann_bind = specify "Annotate bind" $ - "f = (\\x.\\y. x : a -> b -> a) 4" - `shouldBePrg` - "f = (\\x.\\y. x : forall a. forall b. a -> b -> a) 4" +ann_bind = + specify "Annotate bind" $ + "f = (\\x.\\y. x : a -> b -> a) 4" + `shouldBePrg` "f = (\\x.\\y. x : forall a. forall b. a -> b -> a) 4" shouldBeErr s err = run s `shouldBe` Bad err @@ -104,10 +119,10 @@ run' s = do p <- run'' s reportForall Bi p pure p -run'' = pProgram . resolveLayout True . myLexer +run'' = fmap desugar . pProgram . resolveLayout True . myLexer runPrint = (putStrLn . either show printTree . run) $ - D.do "data forall a. forall b. Either (a b) where" - " Left : c -> a -> Either (a b)" - " Right : b -> Either (a b)" - + D.do + "data forall a. forall b. Either a b where" + " Left : c -> a -> Either a b" + " Right : b -> Either a b" diff --git a/tests/TestLambdaLifter.hs b/tests/TestLambdaLifter.hs index d209819..d10e7ee 100644 --- a/tests/TestLambdaLifter.hs +++ b/tests/TestLambdaLifter.hs @@ -1,35 +1,36 @@ -{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE QualifiedDo #-} {-# HLINT ignore "Use camelCase" #-} {-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QualifiedDo #-} module TestLambdaLifter where -import Test.Hspec - -import AnnForall (annotateForall) -import Control.Monad ((<=<)) -import Control.Monad.Error.Class (liftEither) -import Control.Monad.Extra (eitherM) -import Grammar.ErrM (Err, pattern Bad, pattern Ok) -import Grammar.Layout (resolveLayout) -import Grammar.Par (myLexer, pProgram) -import Grammar.Print (printTree) -import LambdaLifter -import Renamer.Renamer (rename) -import ReportForall (reportForall) -import TypeChecker.RemoveForall (removeForall) -import TypeChecker.ReportTEVar (reportTEVar) -import TypeChecker.TypeChecker (TypeChecker (Bi)) -import TypeChecker.TypeCheckerBidir (typecheck) -import TypeChecker.TypeCheckerIr +import Test.Hspec +import AnnForall (annotateForall) +import Control.Monad ((<=<)) +import Control.Monad.Error.Class (liftEither) +import Control.Monad.Extra (eitherM) +import Desugar.Desugar (desugar) +import Grammar.ErrM (Err, pattern Bad, pattern Ok) +import Grammar.Layout (resolveLayout) +import Grammar.Par (myLexer, pProgram) +import Grammar.Print (printTree) +import LambdaLifter +import Renamer.Renamer (rename) +import ReportForall (reportForall) +import TypeChecker.RemoveForall (removeForall) +import TypeChecker.ReportTEVar (reportTEVar) +import TypeChecker.TypeChecker (TypeChecker (Bi)) +import TypeChecker.TypeCheckerBidir (typecheck) +import TypeChecker.TypeCheckerIr test = hspec testLambdaLifter testLambdaLifter = describe "Test Lambda Lifter" $ do undefined + -- frees_exp1 -- frees_exp1 = specify "Free variables 1" $ @@ -43,67 +44,63 @@ testLambdaLifter = describe "Test Lambda Lifter" $ do -- ),TVar (MkTVar (Ident "a"))) -- } - abs_1 = undefined where - input = unlines [ "data List (a) where" - , " Nil : List (a)" - , " Cons : a -> List (a) -> List (a)" - , "map : (a -> b) -> List (a) -> List (b)" - , "add : Int -> Int -> Int" - - , "f : List (Int)" - , "f = (\\x.\\ys. map (\\y. add y x) ys) 4 (Cons 1 (Cons 2 Nil))" - ] - - + input = + unlines + [ "data List a where" + , " Nil : List a" + , " Cons : a -> List a -> List a" + , "map : (a -> b) -> List a -> List b" + , "add : Int -> Int -> Int" + , "f : List Int" + , "f = (\\x.\\ys. map (\\y. add y x) ys) 4 (Cons 1 (Cons 2 Nil))" + ] runFreeVars = either putStrLn print (runFree s2) runAbstract = either putStrLn (putStrLn . printTree) (runAbs s2) runCollect = either putStrLn (putStrLn . printTree) (run s2) +s1 = + unlines + [ "add : Int -> Int -> Int" + , "f : Int -> Int -> Int" + , "f x y = add x y" + , "f = \\x. (\\y. add x y)" + ] -s1 = unlines [ "add : Int -> Int -> Int" - , "f : Int -> Int -> Int" - , "f x y = add x y" - , "f = \\x. (\\y. add x y)" - ] - -s2 = unlines [ "data List (a) where" - , " Nil : List (a)" - , " Cons : a -> List (a) -> List (a)" - , "add : Int -> Int -> Int" - , "map : (a -> b) -> List (a) -> List (b)" - -- , "map f xs = case xs of" +s2 = + unlines + [ "data List a where" + , " Nil : List (a)" + , " Cons : a -> List a -> List a" + , "add : Int -> Int -> Int" + , "map : (a -> b) -> List a -> List b" + , -- , "map f xs = case xs of" -- , " Nil => Nil" -- , " Cons x xs => Cons (f x) (map f xs)" - , "f : List (Int)" - , "f = (\\x.\\ys. map (\\y. add y x) ys) 4 (Cons 1 (Cons 2 Nil))" - ] + "f : List Int" + , "f = (\\x.\\ys. map (\\y. add y x) ys) 4 (Cons 1 (Cons 2 Nil))" + ] s3 = "main = (\\plussq. (\\f. f (f 0)) (plussq 3)) (\\x. \\y. y + x + x)" - - run = fmap collectScs . runAbs runAbs = fmap abstract . runFree runFree s = do - Program ds <- run' s - pure $ freeVars [b | DBind b <- ds] + Program ds <- run' s + pure $ freeVars [b | DBind b <- ds] -run' = fmap removeForall - . reportTEVar - <=< typecheck - <=< run'' +run' = + fmap removeForall + . reportTEVar + <=< typecheck + <=< run'' run'' s = do - p <- (pProgram . resolveLayout True . myLexer) s + p <- (fmap desugar . pProgram . resolveLayout True . myLexer) s reportForall Bi p (rename <=< annotateForall) p - - - - diff --git a/tests/TestRenamer.hs b/tests/TestRenamer.hs index acdbb87..dc71d38 100644 --- a/tests/TestRenamer.hs +++ b/tests/TestRenamer.hs @@ -1,39 +1,49 @@ -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE QualifiedDo #-} {-# HLINT ignore "Use camelCase" #-} {-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE QualifiedDo #-} module TestRenamer (testRenamer, test, runPrint) where - -import AnnForall (annotateForall) -import Control.Exception (ErrorCall (ErrorCall), - Exception (displayException), - SomeException (SomeException), - evaluate, try) -import Control.Exception.Extra (try_) -import Control.Monad (unless, (<=<)) -import Control.Monad.Except (throwError) -import Data.Either.Extra (fromEither) -import qualified DoStrings as D -import GHC.Generics (Generic, Generic1) -import Grammar.Abs (Program (Program)) -import Grammar.ErrM (Err, pattern Bad, pattern Ok) -import Grammar.Layout (resolveLayout) -import Grammar.Par (myLexer, pProgram) -import Grammar.Print (printTree) -import Renamer.Renamer (rename) -import System.IO.Error (catchIOError, tryIOError) -import Test.Hspec (anyErrorCall, anyException, - describe, hspec, shouldBe, - shouldNotSatisfy, shouldReturn, - shouldSatisfy, shouldThrow, - specify) -import TypeChecker.ReportTEVar (reportTEVar) -import TypeChecker.TypeCheckerBidir (typecheck) -import qualified TypeChecker.TypeCheckerIr as T +import AnnForall (annotateForall) +import Control.Exception ( + ErrorCall (ErrorCall), + Exception (displayException), + SomeException (SomeException), + evaluate, + try, + ) +import Control.Exception.Extra (try_) +import Control.Monad (unless, (<=<)) +import Control.Monad.Except (throwError) +import Data.Either.Extra (fromEither) +import Desugar.Desugar (desugar) +import DoStrings qualified as D +import GHC.Generics (Generic, Generic1) +import Grammar.Abs (Program (Program)) +import Grammar.ErrM (Err, pattern Bad, pattern Ok) +import Grammar.Layout (resolveLayout) +import Grammar.Par (myLexer, pProgram) +import Grammar.Print (printTree) +import Renamer.Renamer (rename) +import System.IO.Error (catchIOError, tryIOError) +import Test.Hspec ( + anyErrorCall, + anyException, + describe, + hspec, + shouldBe, + shouldNotSatisfy, + shouldReturn, + shouldSatisfy, + shouldThrow, + specify, + ) +import TypeChecker.ReportTEVar (reportTEVar) +import TypeChecker.TypeCheckerBidir (typecheck) +import TypeChecker.TypeCheckerIr qualified as T -- FIXME tests sucks @@ -47,50 +57,58 @@ testRenamer = describe "Test Renamer" $ do rn_bind2 rn_data1 = specify "Rename data type" . shouldSatisfyOk $ - D.do "data forall a. forall b. Either (a b) where" - " Left : a -> Either (a b)" - " Right : b -> Either (a b)" + D.do + "data forall a. forall b. Either a b where" + " Left : a -> Either a b" + " Right : b -> Either a b" rn_data2 = specify "Rename data type forall in constructor " . shouldSatisfyOk $ - D.do "data forall a. forall b. Either (a b) where" - " Left : forall c. c -> a -> Either (a b)" - " Right : b -> Either (a b)" + D.do + "data forall a. forall b. Either a b where" + " Left : forall c. c -> a -> Either a b" + " Right : b -> Either a b" -rn_sig = specify "Rename signature" $ shouldSatisfyOk - "f : forall a. forall b. a -> b -> (forall a. a -> a) -> a" +rn_sig = + specify "Rename signature" $ + shouldSatisfyOk + "f : forall a. forall b. a -> b -> (forall a. a -> a) -> a" -rn_bind1 = specify "Rename simple bind" $ shouldSatisfyOk - "f x = (\\y. let y2 = y + 1 in y2) (x + 1)" +rn_bind1 = + specify "Rename simple bind" $ + shouldSatisfyOk + "f x = (\\y. let y2 = y + 1 in y2) (x + 1)" rn_bind2 = specify "Rename bind with case" . shouldSatisfyOk $ - D.do "data forall a. List (a) where" - " Nil : List (a) " - " Cons : a -> List (a) -> List (a)" + D.do + "data forall a. List a where" + " Nil : List a " + " Cons : a -> List a -> List a" - "length : forall a. List (a) -> Int" - "length list = case list of" - " Nil => 0" - " Cons x Nil => 1" - " Cons x (Cons y ys) => 2 + length ys" + "length : forall a. List a -> Int" + "length list = case list of" + " Nil => 0" + " Cons x Nil => 1" + " Cons x (Cons y ys) => 2 + length ys" runPrint = putStrLn . either show printTree . run $ - D.do "data forall a. List (a) where" - " Nil : List (a) " - " Cons : a -> List (a) -> List (a)" + D.do + "data forall a. List a where" + " Nil : List a " + " Cons : a -> List a -> List a" - "length : forall a. List (a) -> Int" - "length list = case list of" - " Nil => 0" - " Cons x Nil => 1" - " Cons x (Cons y ys) => 2 + length ys" + "length : forall a. List a -> Int" + "length list = case list of" + " Nil => 0" + " Cons x Nil => 1" + " Cons x (Cons y ys) => 2 + length ys" shouldSatisfyOk s = run s `shouldSatisfy` ok ok = \case - Ok !_ -> True + Ok !_ -> True Bad !_ -> False shouldBeErr s err = run s `shouldBe` Bad err -run = rename <=< run' -run' = pProgram . resolveLayout True . myLexer +run = rename <=< run' +run' = fmap desugar . pProgram . resolveLayout True . myLexer diff --git a/tests/TestReportForall.hs b/tests/TestReportForall.hs index d4e49d7..2d3371d 100644 --- a/tests/TestReportForall.hs +++ b/tests/TestReportForall.hs @@ -4,19 +4,26 @@ module TestReportForall (testReportForall, test) where -import AnnForall (annotateForall) -import Control.Monad ((<=<)) -import qualified DoStrings as D -import Grammar.ErrM (Err, pattern Bad, pattern Ok) -import Grammar.Layout (resolveLayout) -import Grammar.Par (myLexer, pProgram) -import Grammar.Print (printTree) -import Renamer.Renamer (rename) -import ReportForall (reportForall) -import Test.Hspec (describe, hspec, shouldBe, - shouldNotSatisfy, shouldSatisfy, - shouldThrow, specify) -import TypeChecker.TypeChecker (TypeChecker (Bi, Hm)) +import AnnForall (annotateForall) +import Control.Monad ((<=<)) +import Desugar.Desugar (desugar) +import DoStrings qualified as D +import Grammar.ErrM (Err, pattern Bad, pattern Ok) +import Grammar.Layout (resolveLayout) +import Grammar.Par (myLexer, pProgram) +import Grammar.Print (printTree) +import Renamer.Renamer (rename) +import ReportForall (reportForall) +import Test.Hspec ( + describe, + hspec, + shouldBe, + shouldNotSatisfy, + shouldSatisfy, + shouldThrow, + specify, + ) +import TypeChecker.TypeChecker (TypeChecker (Bi, Hm)) testReportForall = describe "Test ReportForall" $ do rp_unused1 @@ -25,23 +32,23 @@ testReportForall = describe "Test ReportForall" $ do test = hspec testReportForall -rp_unused1 = specify "Unused forall 1" $ - "g : forall a. forall a. a -> (forall a. a -> a) -> a" - `shouldBeErrBi` - "Unused forall" +rp_unused1 = + specify "Unused forall 1" $ + "g : forall a. forall a. a -> (forall a. a -> a) -> a" + `shouldBeErrBi` "Unused forall" -rp_unused2 = specify "Unused forall 2" $ - "g : forall a. (forall a. a -> a) -> Int" - `shouldBeErrBi` - "Unused forall" +rp_unused2 = + specify "Unused forall 2" $ + "g : forall a. (forall a. a -> a) -> Int" + `shouldBeErrBi` "Unused forall" -rp_forall = specify "Rank2 forall with Hm" $ - "f : a -> b -> (forall a. a -> a) -> a" - `shouldBeErrHm` - "Higher rank forall not allowed" +rp_forall = + specify "Rank2 forall with Hm" $ + "f : a -> b -> (forall a. a -> a) -> a" + `shouldBeErrHm` "Higher rank forall not allowed" shouldBeErrBi = shouldBeErr Bi shouldBeErrHm = shouldBeErr Hm shouldBeErr tc s err = run tc s `shouldBe` Bad err -run tc = reportForall tc <=< pProgram . resolveLayout True . myLexer +run tc = reportForall tc <=< fmap desugar . pProgram . resolveLayout True . myLexer diff --git a/tests/TestTypeCheckerBidir.hs b/tests/TestTypeCheckerBidir.hs index 916b688..15e0c1f 100644 --- a/tests/TestTypeCheckerBidir.hs +++ b/tests/TestTypeCheckerBidir.hs @@ -1,28 +1,28 @@ -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE PatternSynonyms #-} {-# HLINT ignore "Use camelCase" #-} {-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} module TestTypeCheckerBidir (test, testTypeCheckerBidir) where -import Test.Hspec - -import AnnForall (annotateForall) -import Control.Monad ((<=<)) -import Grammar.Abs (Program) -import Grammar.ErrM (Err, pattern Bad, pattern Ok) -import Grammar.Layout (resolveLayout) -import Grammar.Par (myLexer, pProgram) -import Grammar.Print (printTree) -import Renamer.Renamer (rename) -import ReportForall (reportForall) -import TypeChecker.RemoveForall (removeForall) -import TypeChecker.ReportTEVar (reportTEVar) -import TypeChecker.TypeChecker (TypeChecker (Bi)) -import TypeChecker.TypeCheckerBidir (typecheck) -import qualified TypeChecker.TypeCheckerIr as T +import Test.Hspec +import AnnForall (annotateForall) +import Control.Monad ((<=<)) +import Desugar.Desugar (desugar) +import Grammar.Abs (Program) +import Grammar.ErrM (Err, pattern Bad, pattern Ok) +import Grammar.Layout (resolveLayout) +import Grammar.Par (myLexer, pProgram) +import Grammar.Print (printTree) +import Renamer.Renamer (rename) +import ReportForall (reportForall) +import TypeChecker.RemoveForall (removeForall) +import TypeChecker.ReportTEVar (reportTEVar) +import TypeChecker.TypeChecker (TypeChecker (Bi)) +import TypeChecker.TypeCheckerBidir (typecheck) +import TypeChecker.TypeCheckerIr qualified as T test = hspec testTypeCheckerBidir @@ -120,9 +120,9 @@ tc_pair = describe "Pair. Type variables in Pair a b typechecked" $ do specify "Correct arguments are accepted" $ run (fs ++ correct) `shouldSatisfy` ok where fs = - [ "data Pair (a b) where" - , " Pair : a -> b -> Pair (a b)" - , "main : Pair (Int Char)" + [ "data Pair a b where" + , " Pair : a -> b -> Pair a b" + , "main : Pair Int Char" ] wrong = ["main = Pair 'a' 65"] correct = ["main = Pair 65 'a'"] @@ -132,9 +132,9 @@ tc_tree = describe "Tree. Recursive data type" $ do specify "Correct tree is accepted" $ run (fs ++ correct) `shouldSatisfy` ok where fs = - [ "data Tree (a) where" - , " Node : a -> Tree (a) -> Tree (a) -> Tree (a)" - , " Leaf : a -> Tree (a)" + [ "data Tree a where" + , " Node : a -> Tree a -> Tree a -> Tree a" + , " Leaf : a -> Tree a" ] wrong = ["tree = Node 1 (Node 2 (Node 4) (Leaf 5)) (Leaf 3)"] correct = ["tree = Node 1 (Node 2 (Leaf 4) (Leaf 5)) (Leaf 3)"] @@ -201,30 +201,30 @@ tc_pol_case = describe "Polymophic and recursive pattern matching" $ do run (fs ++ correct4) `shouldSatisfy` ok where fs = - [ "data List (a) where" - , " Nil : List (a)" - , " Cons : a -> List (a) -> List (a)" + [ "data List a where" + , " Nil : List a" + , " Cons : a -> List a -> List a" ] wrong1 = - [ "length : List (c) -> Int" + [ "length : List c -> Int" , "length = \\list. case list of" , " Nil => 0" , " Cons 6 xs => 1 + length xs" ] wrong2 = - [ "length : List (c) -> Int" + [ "length : List c -> Int" , "length = \\list. case list of" , " Cons => 0" , " Cons x xs => 1 + length xs" ] wrong3 = - [ "length : List (c) -> Int" + [ "length : List c -> Int" , "length = \\list. case list of" , " 0 => 0" , " Cons x xs => 1 + length xs" ] wrong4 = - [ "elems : List (List(c)) -> Int" + [ "elems : List (List c) -> Int" , "elems = \\list. case list of" , " Nil => 0" , " Cons Nil Nil => 0" @@ -232,27 +232,27 @@ tc_pol_case = describe "Polymophic and recursive pattern matching" $ do , " Cons (Cons Nil ys) xs => 1 + elems (Cons ys xs)" ] correct1 = - [ "length : List (c) -> Int" + [ "length : List c -> Int" , "length = \\list. case list of" , " Nil => 0" , " Cons x xs => 1 + length xs" , " Cons x (Cons y Nil) => 2" ] correct2 = - [ "length : List (c) -> Int" + [ "length : List c -> Int" , "length = \\list. case list of" , " Nil => 0" , " non_empty => 1" ] correct3 = - [ "length : List (Int) -> Int" + [ "length : List Int -> Int" , "length = \\list. case list of" , " Nil => 0" , " Cons 1 Nil => 1" , " Cons x (Cons 2 xs) => 2 + length xs" ] correct4 = - [ "elems : List (List(c)) -> Int" + [ "elems : List (List c) -> Int" , "elems = \\list. case list of" , " Nil => 0" , " Cons Nil Nil => 0" @@ -261,16 +261,16 @@ tc_pol_case = describe "Polymophic and recursive pattern matching" $ do ] tc_if = specify "Test if else case expression" $ do - run [ "data Bool () where" - , " True : Bool ()" - , " False : Bool ()" - - , "ifThenElse : Bool () -> a -> a -> a" + run + [ "data Bool where" + , " True : Bool" + , " False : Bool" + , "ifThenElse : Bool -> a -> a -> a" , "ifThenElse b if else = case b of" , " True => if" , " False => else" - ] `shouldSatisfy` ok - + ] + `shouldSatisfy` ok tc_infer_case = describe "Infer case expression" $ do specify "Wrong case expression rejected" $ @@ -279,9 +279,9 @@ tc_infer_case = describe "Infer case expression" $ do run (fs ++ correct) `shouldSatisfy` ok where fs = - [ "data Bool () where" - , " True : Bool ()" - , " False : Bool ()" + [ "data Bool where" + , " True : Bool" + , " False : Bool" ] correct = @@ -296,33 +296,38 @@ tc_infer_case = describe "Infer case expression" $ do , " _ => 1" ] -tc_rec1 = specify "Infer simple recursive definition" $ - run ["test x = 1 + test (x + 1)"] `shouldSatisfy` ok +tc_rec1 = + specify "Infer simple recursive definition" $ + run ["test x = 1 + test (x + 1)"] `shouldSatisfy` ok -tc_rec2 = specify "Infer recursive definition with pattern matching" $ run - [ "data Bool () where" - , " False : Bool ()" - , " True : Bool ()" - - , "test = \\x. case x of" - , " 10 => True" - , " _ => test (x+1)" - ] `shouldSatisfy` ok +tc_rec2 = + specify "Infer recursive definition with pattern matching" $ + run + [ "data Bool where" + , " False : Bool" + , " True : Bool" + , "test = \\x. case x of" + , " 10 => True" + , " _ => test (x+1)" + ] + `shouldSatisfy` ok run :: [String] -> Err T.Program -run = fmap removeForall - . reportTEVar - <=< typecheck - <=< run' +run = + fmap removeForall + . reportTEVar + <=< typecheck + <=< run' run' s = do - p <- (pProgram . resolveLayout True . myLexer . unlines) s + p <- (fmap desugar . pProgram . resolveLayout True . myLexer . unlines) s reportForall Bi p (rename <=< annotateForall) p -runPrint = (putStrLn . either show printTree . run') - ["double x = x + x"] +runPrint = + (putStrLn . either show printTree . run') + ["double x = x + x"] ok = \case - Ok _ -> True + Ok _ -> True Bad _ -> False diff --git a/tests/TestTypeCheckerHm.hs b/tests/TestTypeCheckerHm.hs index fd88ab2..8137937 100644 --- a/tests/TestTypeCheckerHm.hs +++ b/tests/TestTypeCheckerHm.hs @@ -2,19 +2,20 @@ module TestTypeCheckerHm where -import Control.Monad (sequence_, (<=<)) -import Test.Hspec +import Control.Monad (sequence_, (<=<)) +import Test.Hspec -import AnnForall (annotateForall) -import qualified DoStrings as D -import Grammar.Layout (resolveLayout) -import Grammar.Par (myLexer, pProgram) -import Grammar.Print (printTree) -import Renamer.Renamer (rename) -import ReportForall (reportForall) -import TypeChecker.TypeChecker (TypeChecker (Hm)) -import TypeChecker.TypeCheckerHm (typecheck) -import TypeChecker.TypeCheckerIr (Program) +import AnnForall (annotateForall) +import Desugar.Desugar (desugar) +import DoStrings qualified as D +import Grammar.Layout (resolveLayout) +import Grammar.Par (myLexer, pProgram) +import Grammar.Print (printTree) +import Renamer.Renamer (rename) +import ReportForall (reportForall) +import TypeChecker.TypeChecker (TypeChecker (Hm)) +import TypeChecker.TypeCheckerHm (typecheck) +import TypeChecker.TypeCheckerIr (Program) testTypeCheckerHm = describe "Hindley-Milner type checker test" $ do sequence_ goods @@ -47,10 +48,10 @@ goods = "Pattern matching on a nested list" ( D.do _List - "main : List (List (a)) -> Int ;" + "main : List (List a) -> Int;" "main xs = case xs of {" - " Cons Nil _ => 1 ;" - " _ => 0 ;" + " Cons Nil _ => 1;" + " _ => 0;" "};" ) ok @@ -78,7 +79,7 @@ bads = ( D.do _Bool _not - "f : a -> Bool () ;" + "f : a -> Bool ;" "f x = not x ;" ) bad @@ -102,7 +103,7 @@ bads = "Pattern matching on literal and _List should not succeed" ( D.do _List - "length : List (c) -> Int;" + "length : List c -> Int;" "length _List = case _List of {" " 0 => 0;" " Cons x xs => 1 + length xs;" @@ -120,29 +121,29 @@ bads = " };" ) bad - -- FIXME FAILING TEST - -- , testSatisfy - -- "id with incorrect signature" - -- ( D.do - -- "id : a -> b;" - -- "id x = x;" - -- ) - -- bad - -- FIXME FAILING TEST - -- , testSatisfy - -- "incorrect signature on const" - -- ( D.do - -- "const : a -> b -> b;" - -- "const x y = x" - -- ) - -- bad - -- FIXME FAILING TEST - -- , testSatisfy - -- "incorrect type signature on id lambda" - -- ( D.do - -- "id = ((\\x. x) : a -> b);" - -- ) - -- bad + -- FIXME FAILING TEST + -- , testSatisfy + -- "id with incorrect signature" + -- ( D.do + -- "id : a -> b;" + -- "id x = x;" + -- ) + -- bad + -- FIXME FAILING TEST + -- , testSatisfy + -- "incorrect signature on const" + -- ( D.do + -- "const : a -> b -> b;" + -- "const x y = x" + -- ) + -- bad + -- FIXME FAILING TEST + -- , testSatisfy + -- "incorrect type signature on id lambda" + -- ( D.do + -- "id = ((\\x. x) : a -> b);" + -- ) + -- bad ] bes = @@ -187,42 +188,33 @@ bes = , testBe "length function on int list infers correct signature" ( D.do - "data List () where {" - " Nil : List ()" - " Cons : Int -> List () -> List ()" - "};" + "data List where " + " Nil : List" + " Cons : Int -> List -> List" - "length xs = case xs of {" - " Nil => 0 ;" - " Cons _ xs => 1 + length xs ;" - "};" + "length xs = case xs of" + " Nil => 0" + " Cons _ xs => 1 + length xs" ) ( D.do - "data List () where {" - " Nil : List ()" - " Cons : Int -> List () -> List ()" - "};" + "data List where" + " Nil : List" + " Cons : Int -> List -> List" - "length : List () -> Int ;" - "length xs = case xs of {" - " Nil => 0 ;" - " Cons _ xs => 1 + length xs ;" - "};" + "length : List -> Int" + "length xs = case xs of" + " Nil => 0" + " Cons _ xs => 1 + length xs" ) ] testSatisfy desc test satisfaction = specify desc $ run test `shouldSatisfy` satisfaction testBe desc test shouldbe = specify desc $ run test `shouldBe` run shouldbe -run = fmap (printTree . fst) . typecheck <=< pProgram . myLexer - -run' s = do - p <- (pProgram . resolveLayout True . myLexer) s - reportForall Hm p - (rename <=< annotateForall) p +run = fmap (printTree . fst) . typecheck <=< fmap desugar . pProgram . myLexer ok (Right _) = True -ok (Left _) = False +ok (Left _) = False bad = not . ok @@ -232,14 +224,13 @@ _const = D.do "const : a -> b -> a ;" "const x y = x ;" _List = D.do - "data List (a) where" - " {" - " Nil : List (a);" - " Cons : a -> List (a) -> List (a)" - " };" + "data List a where {" + " Nil : List a;" + " Cons : a -> List a -> List a;" + "};" _headSig = D.do - "head : List (a) -> a ;" + "head : List a -> a ;" _head = D.do "head xs = " @@ -248,13 +239,13 @@ _head = D.do " };" _Bool = D.do - "data Bool () where {" - " True : Bool ()" - " False : Bool ()" + "data Bool where {" + " True : Bool" + " False : Bool" "};" _not = D.do - "not : Bool () -> Bool () ;" + "not : Bool -> Bool ;" "not x = case x of {" " True => False ;" " False => True ;" @@ -262,9 +253,9 @@ _not = D.do _id = "id x = x ;" _Maybe = D.do - "data Maybe (a) where {" - " Nothing : Maybe (a)" - " Just : a -> Maybe (a)" + "data Maybe a where {" + " Nothing : Maybe a" + " Just : a -> Maybe a" " };" _fmap = D.do From 4f21a58200b67290ec351ba1530f5a2fb646bb67 Mon Sep 17 00:00:00 2001 From: sebastian Date: Thu, 4 May 2023 23:00:51 +0200 Subject: [PATCH 357/372] more symbols and changed err msg --- Grammar.cf | 2 +- src/Desugar/Desugar.hs | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/Grammar.cf b/Grammar.cf index da40cbc..3f89e86 100644 --- a/Grammar.cf +++ b/Grammar.cf @@ -104,7 +104,7 @@ coercions Type 3 ; token UIdent (upper (letter | digit | '_')*) ; token LIdent (lower (letter | digit | '_')*) ; -token Symbol (["@#%^&*_-+=|?/<>,•"]+) ; +token Symbol (["@#%^&*_-+=|?/<>,•:[]"]+) ; comment "--"; comment "{-" "-}"; diff --git a/src/Desugar/Desugar.hs b/src/Desugar/Desugar.hs index 02eb4d9..bcfe627 100644 --- a/src/Desugar/Desugar.hs +++ b/src/Desugar/Desugar.hs @@ -48,7 +48,7 @@ desugarType = \case let (name : tvars) = flatten t1 ++ [t2] in case name of TIdent ident -> TData ident (map desugarType tvars) - _ -> error "desugarType in Desugar.hs is not implemented correctly" + _ -> error "desugarType is not implemented correctly" TLit l -> TLit l TVar v -> TVar v (TAll i t) -> TAll i (desugarType t) From 988d0dbb533d3c33249f3a1a54d60352fd892299 Mon Sep 17 00:00:00 2001 From: sebastian Date: Thu, 4 May 2023 23:03:11 +0200 Subject: [PATCH 358/372] moved stuff --- Grammar.cf | 26 +++++++++++++------------- 1 file changed, 13 insertions(+), 13 deletions(-) diff --git a/Grammar.cf b/Grammar.cf index 3f89e86..f422fd7 100644 --- a/Grammar.cf +++ b/Grammar.cf @@ -14,7 +14,7 @@ DSig. Def ::= Sig; DData. Def ::= Data; internal Sig. Sig ::= LIdent ":" Type; - SigS. Sig ::= VarName ":" Type; + SigS. Sig ::= VarName ":" Type; internal Bind. Bind ::= LIdent [LIdent] "=" Exp; BindS. Bind ::= VarName [LIdent] "=" Exp; @@ -42,6 +42,18 @@ Data. Data ::= "data" Type "where" "{" [Inj] "}" ; Inj. Inj ::= UIdent ":" Type ; +------------------------------------------------------------------------------- +-- * PATTERN MATCHING +------------------------------------------------------------------------------- + +Branch. Branch ::= Pattern "=>" Exp ; + +PVar. Pattern1 ::= LIdent; +PLit. Pattern1 ::= Lit; +PCatch. Pattern1 ::= "_"; +PEnum. Pattern1 ::= UIdent; +PInj. Pattern ::= UIdent [Pattern1]; + ------------------------------------------------------------------------------- -- * Expressions ------------------------------------------------------------------------------- @@ -70,18 +82,6 @@ define infixSymbol e1 vn e3 = EApp (EApp (EVarS (VSymbol vn)) e1) e3; LInt. Lit ::= Integer; LChar. Lit ::= Char; -------------------------------------------------------------------------------- --- * PATTERN MATCHING -------------------------------------------------------------------------------- - -Branch. Branch ::= Pattern "=>" Exp ; - -PVar. Pattern1 ::= LIdent; -PLit. Pattern1 ::= Lit; -PCatch. Pattern1 ::= "_"; -PEnum. Pattern1 ::= UIdent; -PInj. Pattern ::= UIdent [Pattern1]; - ------------------------------------------------------------------------------- -- * AUX ------------------------------------------------------------------------------- From 15025a67f996b967093d0f4adac624acca3be60c Mon Sep 17 00:00:00 2001 From: sebastian Date: Thu, 4 May 2023 23:15:24 +0200 Subject: [PATCH 359/372] removed unused imports --- src/Desugar/Desugar.hs | 3 --- 1 file changed, 3 deletions(-) diff --git a/src/Desugar/Desugar.hs b/src/Desugar/Desugar.hs index bcfe627..251c5ce 100644 --- a/src/Desugar/Desugar.hs +++ b/src/Desugar/Desugar.hs @@ -3,10 +3,7 @@ module Desugar.Desugar (desugar) where -import Data.Function (on) -import Debug.Trace (traceShow) import Grammar.Abs -import Grammar.Print {- From 0a588c4e14ea89dfdadd1f2750791cf9f29df623 Mon Sep 17 00:00:00 2001 From: Martin Fredin Date: Thu, 4 May 2023 23:54:19 +0200 Subject: [PATCH 360/372] Revert AnnForall change --- src/AnnForall.hs | 90 ++++++++++++++++++++++-------------------------- 1 file changed, 42 insertions(+), 48 deletions(-) diff --git a/src/AnnForall.hs b/src/AnnForall.hs index f309a37..16222bd 100644 --- a/src/AnnForall.hs +++ b/src/AnnForall.hs @@ -1,16 +1,16 @@ -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedRecordDot #-} module AnnForall (annotateForall) where -import Auxiliary (partitionDefs) -import Control.Applicative (Applicative (liftA2)) -import Control.Monad.Except (throwError) -import Data.Function (on) -import Data.Set (Set) -import Data.Set qualified as Set -import Grammar.Abs -import Grammar.ErrM (Err) +import Auxiliary (partitionDefs) +import Control.Applicative (Applicative (liftA2)) +import Control.Monad.Except (throwError) +import Data.Function (on) +import Data.Set (Set) +import qualified Data.Set as Set +import Grammar.Abs +import Grammar.ErrM (Err) annotateForall :: Program -> Err Program annotateForall (Program defs) = do @@ -21,31 +21,30 @@ annotateForall (Program defs) = do ss' = map (DSig . annSig) ss (ds, ss, bs) = partitionDefs defs + annData :: Data -> Err Data annData (Data typ injs) = do - (typ', tvars) <- annTyp typ - pure (Data typ' $ map (annInj tvars) injs) + (typ', tvars) <- annTyp typ + pure (Data typ' $ map (annInj tvars) injs) + where annTyp typ = do (bounded, ts) <- boundedTVars mempty typ unbounded <- Set.fromList <$> mapM assertTVar ts let diff = unbounded Set.\\ bounded typ' = foldr TAll typ diff - (typ',) . fst <$> boundedTVars mempty typ' + (typ', ) . fst <$> boundedTVars mempty typ' where boundedTVars tvars typ = case typ of - TAll tvar t -> boundedTVars (Set.insert tvar tvars) t - TData _ ts -> pure (tvars, ts) - _ -> throwError "Misformed data declaration" + TAll tvar t -> boundedTVars (Set.insert tvar tvars) t + TData _ ts -> pure (tvars, ts) + _ -> throwError "Misformed data declaration" assertTVar typ = case typ of TVar tvar -> pure tvar - _ -> - throwError $ - unwords - [ "Misformed data declaration:" - , "Non type variable argument" - ] + _ -> throwError $ unwords [ "Misformed data declaration:" + , "Non type variable argument" + ] annInj tvars (Inj n t) = Inj n $ foldr TAll t (unboundedTVars t Set.\\ tvars) @@ -56,22 +55,20 @@ annBind :: Bind -> Err Bind annBind (Bind name vars exp) = Bind name vars <$> annExp exp where annExp = \case - -- Annotated types should not be - -- foralled without the consent of the user - EAnn e t -> flip EAnn t <$> annExp e - EApp e1 e2 -> liftA2 EApp (annExp e1) (annExp e2) - EAdd e1 e2 -> liftA2 EAdd (annExp e1) (annExp e2) + EAnn e t -> flip EAnn (annType t) <$> annExp e + EApp e1 e2 -> liftA2 EApp (annExp e1) (annExp e2) + EAdd e1 e2 -> liftA2 EAdd (annExp e1) (annExp e2) ELet bind e -> liftA2 ELet (annBind bind) (annExp e) - EAbs x e -> EAbs x <$> annExp e - ECase e bs -> liftA2 ECase (annExp e) (mapM annBranch bs) - e -> pure e + EAbs x e -> EAbs x <$> annExp e + ECase e bs -> liftA2 ECase (annExp e) (mapM annBranch bs) + e -> pure e annBranch (Branch p e) = Branch p <$> annExp e annType :: Type -> Type annType typ = go $ unboundedTVars typ where go us - | null us = typ + | null us = typ | otherwise = foldr TAll typ us unboundedTVars :: Type -> Set TVar @@ -82,25 +79,22 @@ unboundedTVars' bs typ = tvars.unbounded Set.\\ tvars.bounded where tvars = gatherTVars typ gatherTVars = \case - TAll tvar t -> - TVars - { bounded = Set.singleton tvar - , unbounded = unboundedTVars' (Set.insert tvar bs) t - } - TVar tvar -> uTVars $ Set.singleton tvar - TFun t1 t2 -> uTVars $ on Set.union (unboundedTVars' bs) t1 t2 - TData _ typs -> uTVars $ foldr (Set.union . unboundedTVars' bs) mempty typs - _ -> TVars{bounded = mempty, unbounded = mempty} + TAll tvar t -> TVars { bounded = Set.singleton tvar + , unbounded = unboundedTVars' (Set.insert tvar bs) t + } + TVar tvar -> uTVars $ Set.singleton tvar + TFun t1 t2 -> uTVars $ on Set.union (unboundedTVars' bs) t1 t2 + TData _ typs -> uTVars $ foldr (Set.union . unboundedTVars' bs) mempty typs + _ -> TVars { bounded = mempty, unbounded = mempty } data TVars = TVars - { bounded :: Set TVar - , unbounded :: Set TVar - } - deriving (Eq, Show, Ord) + { bounded :: Set TVar + , unbounded :: Set TVar + } deriving (Eq, Show, Ord) uTVars :: Set TVar -> TVars -uTVars us = - TVars - { bounded = mempty - , unbounded = us - } +uTVars us = TVars + { bounded = mempty + , unbounded = us + } + From 1d551e5874a908b2583fdf0959f5f585f2315e07 Mon Sep 17 00:00:00 2001 From: sebastian Date: Fri, 5 May 2023 00:35:48 +0200 Subject: [PATCH 361/372] added alternative better implemenatation of checkBind --- src/TypeChecker/TypeCheckerHm.hs | 32 ++++++++++++++++++++++++++++++++ 1 file changed, 32 insertions(+) diff --git a/src/TypeChecker/TypeCheckerHm.hs b/src/TypeChecker/TypeCheckerHm.hs index 6250ac1..24a8272 100644 --- a/src/TypeChecker/TypeCheckerHm.hs +++ b/src/TypeChecker/TypeCheckerHm.hs @@ -2,6 +2,7 @@ {-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QualifiedDo #-} +{-# OPTIONS_GHC -Wno-incomplete-patterns #-} -- | A module for type checking and inference using algorithm W, Hindley-Milner module TypeChecker.TypeCheckerHm where @@ -155,6 +156,35 @@ freeOrdered (TFun a b) = freeOrdered a ++ freeOrdered b freeOrdered (TData _ a) = concatMap freeOrdered a freeOrdered _ = mempty +-- Much cleaner implementation, unfortunately one minor bug +-- checkBind :: Bind -> Infer (T.Bind' Type) +-- checkBind (Bind name args expr) = do +-- fr <- fresh +-- let lambda = makeLambda expr (reverse (coerce args)) +-- withBinding (coerce name) fr $ do +-- (sub, (e, infSig)) <- algoW lambda +-- env <- asks vars +-- let genInfSig = generalize (apply sub env) infSig +-- maybeSig <- gets (join . M.lookup (coerce name) . sigs) +-- case maybeSig of +-- Just typSig -> do +-- unless +-- (genInfSig <<= typSig) +-- ( throwError $ +-- Error +-- ( Aux.do +-- "Inferred type" +-- quote $ printTree infSig +-- "doesn't match given type" +-- quote $ printTree typSig +-- ) +-- False +-- ) +-- return $ T.Bind (coerce name, typSig) [] (apply sub e, typSig) +-- _ -> do +-- insertSig (coerce name) (Just genInfSig) +-- return $ T.Bind (coerce name, genInfSig) [] (apply sub e, genInfSig) + checkBind :: Bind -> Infer (T.Bind' Type) checkBind (Bind name args e) = do let lambda = makeLambda e (reverse (coerce args)) @@ -162,6 +192,8 @@ checkBind (Bind name args e) = do s <- gets sigs case M.lookup (coerce name) s of Just (Just typSig) -> do + env <- asks vars + trace ("ENV IN CHECKBIND: " ++ show env) pure () let genInfSig = generalize mempty infSig sub <- genInfSig `unify` typSig unless From 4aa72beccb1953a1ec47a59367a6ec1d7628837f Mon Sep 17 00:00:00 2001 From: Martin Fredin Date: Fri, 5 May 2023 09:02:10 +0200 Subject: [PATCH 362/372] Add missing clauses. Still broken --- src/TypeChecker/TypeCheckerBidir.hs | 57 ++++++++++++++++------------- 1 file changed, 31 insertions(+), 26 deletions(-) diff --git a/src/TypeChecker/TypeCheckerBidir.hs b/src/TypeChecker/TypeCheckerBidir.hs index fcef885..04a8d91 100644 --- a/src/TypeChecker/TypeCheckerBidir.hs +++ b/src/TypeChecker/TypeCheckerBidir.hs @@ -482,35 +482,37 @@ subtype (TEVar alpha) a | notElem alpha $ frees a = instantiateL alpha a -- Γ[ά] ⊢ A <: ά ⊣ Δ subtype a (TEVar alpha) | notElem alpha $ frees a = instantiateR a alpha -subtype t1 t2 = case (t1, t2) of - (TData name1 typs1, TData name2 typs2) - -- D₁ = D₂ - -- ---------------- - -- Γ ⊢ D₁ () <: D₂ () - | name1 == name2 - , [] <- typs1 - , [] <- typs2 - -> pure () +subtype (TData name1 typs1) (TData name2 typs2) - -- Γ ⊢ ά₁ <: έ₁ ⊣ Θ₁ - -- ... - -- D₁ = D₂ Θₙ₋₁ ⊢ [Θₙ₋₁]άₙ <: [Θₙ₋₁]έₙ ⊣ Δ - -- ------------------------------------------- - -- Γ ⊢ D (ά₁ ‥ άₙ) <: D (έ₁ ‥ έₙ) ⊣ Δ - | name1 == name2 - , t1:t1s <- typs1 - , t2:t2s <- typs2 - -> do - subtype t1 t2 - zipWithM_ go t1s t2s - where - go t1' t2' = do - t1'' <- apply t1' - t2'' <- apply t2' - subtype t1'' t2'' + -- D₁ = D₂ + -- ---------------- + -- Γ ⊢ D₁ () <: D₂ () + | name1 == name2 + , [] <- typs1 + , [] <- typs2 + = pure () - _ -> throwError $ unwords ["Types", ppT t1, "and", ppT t2, "doesn't match!"] + -- Γ ⊢ ά₁ <: έ₁ ⊣ Θ₁ + -- ... + -- D₁ = D₂ Θₙ₋₁ ⊢ [Θₙ₋₁]άₙ <: [Θₙ₋₁]έₙ ⊣ Δ + -- ------------------------------------------- + -- Γ ⊢ D (ά₁ ‥ άₙ) <: D (έ₁ ‥ έₙ) ⊣ Δ + | name1 == name2 + , t1:t1s <- typs1 + , t2:t2s <- typs2 + = do + subtype t1 t2 + zipWithM_ go t1s t2s + where + go t1' t2' = do + t1'' <- apply t1' + t2'' <- apply t2' + subtype t1'' t2'' + +subtype (TIdent t1) (TIdent t2) | t1 == t2 = pure () + +subtype t1 t2 = throwError $ unwords ["Types", show t1, "and", show t2, "doesn't match!"] --------------------------------------------------------------------------- -- * Instantiation rules @@ -788,6 +790,7 @@ applyType' cxt typ | typ == typ' = typ' TFun t1 t2 -> on TFun (applyType' cxt) t1 t2 -- [Γ](∀α. A) = (∀α. [Γ]A) TAll tvar t -> TAll tvar $ applyType' cxt t + TIdent t -> typ applyExp :: T.Exp' Type -> Tc (T.Exp' Type) applyExp exp = case exp of @@ -841,6 +844,8 @@ ppT = \case TEVar (MkTEVar (LIdent s)) -> "tevar_" ++ s TData (UIdent name) typs -> name ++ " (" ++ unwords (map ppT typs) ++ " )" + TIdent (UIdent name) -> name + ppEnvElem = \case EnvVar (LIdent s) t -> s ++ ":" ++ ppT t EnvTVar (MkTVar (LIdent s)) -> "tvar_" ++ s From fe25f18eb7847d3983fe98de7f7a905d800cbea9 Mon Sep 17 00:00:00 2001 From: Rakarake Date: Fri, 5 May 2023 11:28:40 +0200 Subject: [PATCH 363/372] Fixed naming-cons bug in monomorphizer --- src/Monomorphizer/Monomorphizer.hs | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/src/Monomorphizer/Monomorphizer.hs b/src/Monomorphizer/Monomorphizer.hs index ff17fc4..eea9b37 100644 --- a/src/Monomorphizer/Monomorphizer.hs +++ b/src/Monomorphizer/Monomorphizer.hs @@ -196,11 +196,13 @@ appear as expressions in the tree, or as patterns in case-expressions. -} morphCons :: M.Type -> Ident -> EnvM () morphCons expectedType ident = do + --trace ("Tjofras:" ++ show (newName expectedType ident)) $ return () + let ident' = newName expectedType ident maybeD <- getInputData ident case maybeD of Nothing -> error $ "identifier '" ++ show ident ++ "' not found" Just d -> do - modify (\output -> Map.insert ident (Data expectedType d) output) + modify (\output -> Map.insert ident' (Data expectedType d) output) -- | Converts literals from input to output tree. convertLit :: T.Lit -> M.Lit From 747de6a34e6d89e9e423563d9950f5707f4dcc64 Mon Sep 17 00:00:00 2001 From: sebastianselander Date: Fri, 5 May 2023 11:43:17 +0200 Subject: [PATCH 364/372] Renaming symbols in desugar, removed incorrect comment in emits --- src/Codegen/Emits.hs | 2 +- src/Desugar/Desugar.hs | 33 ++++++++++++++++++++++++++++++--- 2 files changed, 31 insertions(+), 4 deletions(-) diff --git a/src/Codegen/Emits.hs b/src/Codegen/Emits.hs index 112839b..f020871 100644 --- a/src/Codegen/Emits.hs +++ b/src/Codegen/Emits.hs @@ -15,6 +15,7 @@ import Data.Coerce (coerce) import Data.Map qualified as Map import Data.Maybe (fromJust, fromMaybe) import Data.Tuple.Extra (dupe, first, second) +import Debug.Trace (traceShow) import Monomorphizer.MonomorphizerIr as MIR import TypeChecker.TypeCheckerIr qualified as TIR @@ -268,7 +269,6 @@ emitECased t e cases = do emitCases rt ty label stackPtr vs (Branch (MIR.PEnum (TIR.Ident "False"), _) exp) = do emitCases rt ty label stackPtr vs (Branch (MIR.PLit (MIR.LInt 0, TLit "Bool"), t) exp) emitCases rt ty label stackPtr vs (Branch (MIR.PEnum consId, _) exp) = do - -- //TODO Penum wrong, acts as a catch all emit $ Comment "Penum" cons <- gets constructors let r = fromJust $ Map.lookup consId cons diff --git a/src/Desugar/Desugar.hs b/src/Desugar/Desugar.hs index 251c5ce..550d7c3 100644 --- a/src/Desugar/Desugar.hs +++ b/src/Desugar/Desugar.hs @@ -16,7 +16,7 @@ desugar :: Program -> Program desugar (Program defs) = Program (map desugarDef defs) desugarVarName :: VarName -> LIdent -desugarVarName (VSymbol (Symbol i)) = LIdent i +desugarVarName (VSymbol (Symbol i)) = LIdent $ fixName i desugarVarName (VIdent i) = i desugarDef :: Def -> Def @@ -68,8 +68,8 @@ desugarExp = \case ELet b e -> ELet (desugarBind b) (desugarExp e) ECase e br -> ECase (desugarExp e) (map desugarBranch br) EAnn e t -> EAnn (desugarExp e) t - EVarS (VSymbol (Symbol symb)) -> EVar (LIdent symb) - EVarS (VIdent ident) -> EVar ident + EVarS (VSymbol (Symbol symb)) -> EVar (LIdent $ fixName symb) + EVarS (VIdent (LIdent ident)) -> EVar $ LIdent $ fixName ident EVar i -> EVar i ELit l -> ELit l EInj i -> EInj i @@ -88,3 +88,30 @@ desugarPattern = \case desugarLit :: Lit -> Lit desugarLit (LInt i) = LInt i desugarLit (LChar c) = LChar c + +fixName :: String -> String +fixName = concatMap mapSymbols + where + mapSymbols :: Char -> String + mapSymbols c = case c of + '@' -> "$at$" + '#' -> "$octothorpe$" + '%' -> "$percent$" + '^' -> "$hat$" + '&' -> "$and$" + '*' -> "$star$" + '_' -> "$underscore$" + '-' -> "$minus$" + '+' -> "$plus$" + '=' -> "$equals$" + '|' -> "$pipe$" + '?' -> "$questionmark$" + '/' -> "$fslash$" + '<' -> "$langle$" + '>' -> "$rangle$" + ',' -> "$comma$" + '•' -> "$bullet$" + ':' -> "$semicolon$" + '[' -> "$lbracket$" + ']' -> "$rbracket$" + c -> c : "" From 010ca29ced7f58a51cfd396d7036cff5d63886c0 Mon Sep 17 00:00:00 2001 From: Rakarake Date: Fri, 5 May 2023 11:44:08 +0200 Subject: [PATCH 365/372] Fixed wrong name bug -- samuel --- src/Monomorphizer/Monomorphizer.hs | 18 ++++++++++-------- 1 file changed, 10 insertions(+), 8 deletions(-) diff --git a/src/Monomorphizer/Monomorphizer.hs b/src/Monomorphizer/Monomorphizer.hs index eea9b37..4df4c42 100644 --- a/src/Monomorphizer/Monomorphizer.hs +++ b/src/Monomorphizer/Monomorphizer.hs @@ -193,16 +193,16 @@ getInputData ident = do {- | Monomorphize a constructor using it's global name. Constructors may appear as expressions in the tree, or as patterns in case-expressions. +'newIdent' has a unique name while 'ident' has a general name. -} -morphCons :: M.Type -> Ident -> EnvM () -morphCons expectedType ident = do +morphCons :: M.Type -> Ident -> Ident -> EnvM () +morphCons expectedType ident newIdent = do --trace ("Tjofras:" ++ show (newName expectedType ident)) $ return () - let ident' = newName expectedType ident maybeD <- getInputData ident case maybeD of Nothing -> error $ "identifier '" ++ show ident ++ "' not found" Just d -> do - modify (\output -> Map.insert ident' (Data expectedType d) output) + modify (\output -> Map.insert newIdent (Data expectedType d) output) -- | Converts literals from input to output tree. convertLit :: T.Lit -> M.Lit @@ -215,8 +215,9 @@ morphExp expectedType exp = case exp of T.ELit lit -> return $ M.ELit (convertLit lit) -- Constructor T.EInj ident -> do - morphCons expectedType ident - return $ M.EVar ident + let ident' = newName expectedType ident + morphCons expectedType ident ident' + return $ M.EVar ident' T.EApp (e1, _t1) (e2, t2) -> do t2' <- getMonoFromPoly t2 e2' <- morphExp t2' e2 @@ -248,8 +249,9 @@ morphExp expectedType exp = case exp of case bind of Nothing -> do -- This is a constructor - morphCons expectedType ident - return $ M.EVar ident + let ident' = newName expectedType ident + morphCons expectedType ident ident' + return $ M.EVar ident' Just bind' -> do -- New bind to process newBindName <- morphBind expectedType bind' From 513cb34eb51de1e7edc5b99b9dcb3f1c96d140cb Mon Sep 17 00:00:00 2001 From: sebastianselander Date: Fri, 5 May 2023 12:22:36 +0200 Subject: [PATCH 366/372] back to inj --- src/TypeChecker/TypeCheckerHm.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/TypeChecker/TypeCheckerHm.hs b/src/TypeChecker/TypeCheckerHm.hs index 24a8272..f4ec70a 100644 --- a/src/TypeChecker/TypeCheckerHm.hs +++ b/src/TypeChecker/TypeCheckerHm.hs @@ -335,7 +335,7 @@ algoW = \case case M.lookup (coerce i) constr of Just t -> do t <- freshen t - return (nullSubst, (T.EVar $ coerce i, t)) + return (nullSubst, (T.EInj $ coerce i, t)) Nothing -> uncatchableErr $ Aux.do "Constructor:" From 7562949909c12b736afe6d88e3d0ceae89a61cad Mon Sep 17 00:00:00 2001 From: Rakarake Date: Fri, 5 May 2023 12:24:13 +0200 Subject: [PATCH 367/372] Finally, bug nr4 fixed --- src/Monomorphizer/Monomorphizer.hs | 28 ++++++++++++++-------------- 1 file changed, 14 insertions(+), 14 deletions(-) diff --git a/src/Monomorphizer/Monomorphizer.hs b/src/Monomorphizer/Monomorphizer.hs index 4df4c42..3a8bd9e 100644 --- a/src/Monomorphizer/Monomorphizer.hs +++ b/src/Monomorphizer/Monomorphizer.hs @@ -38,7 +38,7 @@ import Control.Monad.Reader ( runReader, ) import Control.Monad.State ( - MonadState, + MonadState (get), StateT (runStateT), gets, modify, @@ -48,6 +48,7 @@ import Data.Map qualified as Map import Data.Maybe (catMaybes) import Data.Set qualified as Set import Grammar.Print (printTree) +import Debug.Trace (trace) {- | EnvM is the monad containing the read-only state as well as the output state containing monomorphized functions and to-be monomorphized @@ -215,9 +216,9 @@ morphExp expectedType exp = case exp of T.ELit lit -> return $ M.ELit (convertLit lit) -- Constructor T.EInj ident -> do - let ident' = newName expectedType ident - morphCons expectedType ident ident' - return $ M.EVar ident' + let ident' = newName (getDataType expectedType) ident + morphCons expectedType ident ident' + return $ M.EVar ident' T.EApp (e1, _t1) (e2, t2) -> do t2' <- getMonoFromPoly t2 e2' <- morphExp t2' e2 @@ -247,11 +248,7 @@ morphExp expectedType exp = case exp of else do bind <- getInputBind ident case bind of - Nothing -> do - -- This is a constructor - let ident' = newName expectedType ident - morphCons expectedType ident ident' - return $ M.EVar ident' + Nothing -> error $ "unbound variable: '" ++ printTree ident ++ "'" Just bind' -> do -- New bind to process newBindName <- morphBind expectedType bind' @@ -285,12 +282,15 @@ morphPattern p expectedType = case p of T.PVar ident -> return $ Just (M.PVar (ident, expectedType), Set.singleton ident) T.PLit lit -> return $ Just (M.PLit (convertLit lit, expectedType), Set.empty) T.PCatch -> return $ Just (M.PCatch, Set.empty) - T.PEnum ident -> do --morphCons expectedType ident - return $ Just (M.PEnum ident, Set.empty) - T.PInj ident pts -> do --morphCons expectedType ident - isMarked <- isConsMarked ident + T.PEnum ident -> return $ Just (M.PEnum (newName expectedType ident), Set.empty) + T.PInj ident pts -> do let newIdent = newName expectedType ident + outEnv <- get + trace ("WOW: " ++ show (newName expectedType ident)) $ return () + trace ("WOW2: " ++ show (outEnv)) $ return () + isMarked <- isConsMarked newIdent if isMarked then do + trace ("WOW3") $ return () ts' <- mapM (getMonoFromPoly . snd) pts let pts' = zip (map fst pts) ts' psSets <- mapM (uncurry morphPattern) pts' @@ -298,7 +298,7 @@ morphPattern p expectedType = case p of case maybePsSets of Nothing -> return Nothing Just psSets' -> return $ Just - (M.PInj ident (map fst psSets'), Set.unions $ map snd psSets') + (M.PInj newIdent (map fst psSets'), Set.unions $ map snd psSets') else return Nothing -- | Creates a new identifier for a function with an assigned type. From 63fef958a78f5abb21c917358783398e65dbe060 Mon Sep 17 00:00:00 2001 From: sebastianselander Date: Fri, 5 May 2023 14:09:54 +0200 Subject: [PATCH 368/372] Improved prelude --- src/Main.hs | 11 ++++++----- 1 file changed, 6 insertions(+), 5 deletions(-) diff --git a/src/Main.hs b/src/Main.hs index 6088a7c..b70a80c 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -178,12 +178,13 @@ prelude :: String prelude = unlines [ "\n" - , -- , "customHelperFunctionCuzPoorImplementation : Bool () -> Int -> Bool ()" - -- , "customHelperFunctionCuzPoorImplementation x y = x" - "data Bool where" + , "data Bool where" , " False : Bool" , " True : Bool" - , "lt : Int -> Int -> Bool" - , "lt x y = True" + , -- The function body of lt is replaced during code gen. It exists here for type checking purposes. + "lt : Int -> Int -> Bool" + , "lt x y = case x of" + , " _ => True" + , " _ => False" , "\n" ] From 22d9dd8efa1a965294bae210094a87fda2947ab8 Mon Sep 17 00:00:00 2001 From: sebastianselander Date: Fri, 5 May 2023 14:28:05 +0200 Subject: [PATCH 369/372] Fixed incorrect constructor name with Gilliam --- src/Codegen/Emits.hs | 16 +++++++++------- 1 file changed, 9 insertions(+), 7 deletions(-) diff --git a/src/Codegen/Emits.hs b/src/Codegen/Emits.hs index f020871..5ab9801 100644 --- a/src/Codegen/Emits.hs +++ b/src/Codegen/Emits.hs @@ -13,9 +13,10 @@ import Data.Bifunctor qualified as BI import Data.Char (ord) import Data.Coerce (coerce) import Data.Map qualified as Map -import Data.Maybe (fromJust, fromMaybe) +import Data.Maybe (fromJust, fromMaybe, isNothing) import Data.Tuple.Extra (dupe, first, second) -import Debug.Trace (traceShow) +import Debug.Trace (trace, traceShow) +import Grammar.Print import Monomorphizer.MonomorphizerIr as MIR import TypeChecker.TypeCheckerIr qualified as TIR @@ -264,14 +265,15 @@ emitECased t e cases = do emit $ Br label lbl_failPos <- (\x -> TIR.Ident $ "failed_" <> show x) <$> getNewLabel emit $ Label lbl_failPos - emitCases rt ty label stackPtr vs (Branch (MIR.PEnum (TIR.Ident "True"), t) exp) = do + emitCases rt ty label stackPtr vs (Branch (MIR.PEnum (TIR.Ident "True$Bool"), t) exp) = do emitCases rt ty label stackPtr vs (Branch (MIR.PLit (MIR.LInt 1, TLit "Bool"), t) exp) - emitCases rt ty label stackPtr vs (Branch (MIR.PEnum (TIR.Ident "False"), _) exp) = do + emitCases rt ty label stackPtr vs (Branch (MIR.PEnum (TIR.Ident "False$Bool"), _) exp) = do emitCases rt ty label stackPtr vs (Branch (MIR.PLit (MIR.LInt 0, TLit "Bool"), t) exp) - emitCases rt ty label stackPtr vs (Branch (MIR.PEnum consId, _) exp) = do + emitCases rt ty label stackPtr vs br@(Branch (MIR.PEnum consId, _) exp) = do emit $ Comment "Penum" cons <- gets constructors - let r = fromJust $ Map.lookup consId cons + let r = Map.lookup consId cons + when (isNothing r) (error $ "Constructor: '" ++ printTree consId ++ "' does not exist in cons state:\n" ++ show cons ++ "\nin pattern\n'" ++ printTree br ++ "'\n") lbl_failPos <- (\x -> TIR.Ident $ "failed_" <> show x) <$> getNewLabel lbl_succPos <- (\x -> TIR.Ident $ "success_" <> show x) <$> getNewLabel @@ -280,7 +282,7 @@ emitECased t e cases = do emit $ SetVariable consVal (ExtractValue rt vs 0) consCheck <- getNewVar - emit $ SetVariable consCheck (Icmp LLEq I8 (VIdent consVal I8) (VInteger $ numCI r)) + emit $ SetVariable consCheck (Icmp LLEq I8 (VIdent consVal I8) (VInteger $ numCI (fromJust r))) emit $ BrCond (VIdent consCheck ty) lbl_succPos lbl_failPos emit $ Label lbl_succPos From a720b9ffd8c347c7bda56eb752c62b1588e9b614 Mon Sep 17 00:00:00 2001 From: sebastianselander Date: Fri, 5 May 2023 15:09:51 +0200 Subject: [PATCH 370/372] Peano --- src/Codegen/Emits.hs | 5 +++-- src/Main.hs | 4 ++++ test_program.crf | 37 ++++++++++++++++++++++++++----------- 3 files changed, 33 insertions(+), 13 deletions(-) diff --git a/src/Codegen/Emits.hs b/src/Codegen/Emits.hs index 5ab9801..bc19f87 100644 --- a/src/Codegen/Emits.hs +++ b/src/Codegen/Emits.hs @@ -325,6 +325,7 @@ emitApp rt e1 e2 = appEmitter e1 e2 [] let call = case name of TIR.Ident ('l' : 't' : '$' : _) -> Icmp LLSlt I64 (snd (head args')) (snd (args' !! 1)) + TIR.Ident ('$' : 'm' : 'i' : 'n' : 'u' : 's' : '$' : '$' : _) -> Sub I64 (snd (head args')) (snd (args' !! 1)) _ -> Call FastCC (type2LlvmType rt) visibility name args' emit $ Comment $ show rt emit $ SetVariable vs call @@ -359,8 +360,8 @@ exprToValue = \case (MIR.ELit i, _t) -> pure $ case i of (MIR.LInt i) -> VInteger i (MIR.LChar i) -> VChar $ ord i - (MIR.EVar (TIR.Ident "True"), _t) -> pure $ VInteger 1 - (MIR.EVar (TIR.Ident "False"), _t) -> pure $ VInteger 0 + (MIR.EVar (TIR.Ident "True$Bool"), _t) -> pure $ VInteger 1 + (MIR.EVar (TIR.Ident "False$Bool"), _t) -> pure $ VInteger 0 (MIR.EVar name, t) -> do funcs <- gets functions cons <- gets constructors diff --git a/src/Main.hs b/src/Main.hs index b70a80c..ea6103a 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -187,4 +187,8 @@ prelude = , " _ => True" , " _ => False" , "\n" + , -- The function body of - is replaced during code gen. It exists here for type checking purposes. + ".- : Int -> Int -> Int" + , ".- x y = 0" + , "\n" ] diff --git a/test_program.crf b/test_program.crf index 5f35a1d..6e528dc 100644 --- a/test_program.crf +++ b/test_program.crf @@ -1,15 +1,30 @@ -data List a where - Cons : a -> List a -> List a - Nil : List a +-- Peano naturals +data Nat where + Zero : Nat + Succ : Nat -> Nat -.++ xs ys = case xs of - Nil => ys - Cons z zs => Cons z (zs ++ ys) +toInt : Nat -> Int +toInt a = case a of + Succ n => 1 + toInt n + Zero => 0 -length xs = case xs of - Cons x xs => 1 + length xs +fromInt a = case a of + 0 => Zero + n => Succ (fromInt (a - 1)) -main = length (list1 ++ list2) +-- Peano arithmetic -- -list1 = Cons 0 (Cons 1 (Cons 2 (Cons 3 Nil))) -list2 = Cons 4 (Cons 5 (Cons 6 (Cons 7 Nil))) +-- Peano addition +add : Nat -> Nat -> Nat +add left right = case left of + Zero => right + Succ n => Succ (add n right) + +-- Peano multiplication +mul : Nat -> Nat -> Nat +mul left right = case right of + Zero => Zero + Succ n => add left (mul left n) + +-- Returns 10_000 +main = toInt (mul (fromInt 100) (fromInt 100)) From 677a200a15b19e293467c73b14b7a9b13b3038a6 Mon Sep 17 00:00:00 2001 From: sebastianselander Date: Fri, 5 May 2023 15:12:37 +0200 Subject: [PATCH 371/372] Removed GC, merge it into main to save correct commit history --- src/Accurate_GC/Makefile | 5 - src/Accurate_GC/gc.cpp | 16 - src/Accurate_GC/gc_printer.cpp | 16 - src/Accurate_GC/sample.ll | 4 - src/Accurate_GC/shadow_stack.cpp | 63 --- src/GC/Makefile | 96 ----- src/GC/docs/benchmarking.md | 21 - src/GC/docs/lib/cheap.md | 40 -- src/GC/docs/lib/chunk.md | 26 -- src/GC/docs/lib/event.md | 47 --- src/GC/docs/lib/heap.md | 54 --- src/GC/docs/lib/profiler.md | 30 -- src/GC/docs/ref-guide.md | 83 ---- src/GC/include/cheap.h | 36 -- src/GC/include/chunk.hpp | 25 -- src/GC/include/event.hpp | 55 --- src/GC/include/heap.hpp | 102 ----- src/GC/include/profiler.hpp | 71 ---- src/GC/lib/cheap.cpp | 63 --- src/GC/lib/event.cpp | 71 ---- src/GC/lib/gcoll.a | Bin 712746 -> 0 bytes src/GC/lib/heap.cpp | 671 ------------------------------- src/GC/lib/profiler.cpp | 311 -------------- src/GC/tests/MarkSweep.cpp | 87 ---- src/GC/tests/advance.cpp | 83 ---- src/GC/tests/alloc_free.cpp | 32 -- src/GC/tests/alloc_free_list.cpp | 250 ------------ src/GC/tests/events.cpp | 44 -- src/GC/tests/extern_lib.cpp | 94 ----- src/GC/tests/file.cpp | 77 ---- src/GC/tests/game.cpp | 95 ----- src/GC/tests/h_test.cpp | 107 ----- src/GC/tests/linkedlist.cpp | 74 ---- src/GC/tests/linker.cpp | 16 - src/GC/tests/player.hpp | 51 --- src/GC/tests/stack.cpp | 76 ---- src/GC/tests/stack2.cpp | 51 --- src/GC/tests/struct_test.cpp | 41 -- src/GC/tests/wrapper.c | 96 ----- src/GC/tests/wrapper_test.c | 45 --- src/GC/todo.md | 11 - src/Main.hs | 6 +- 42 files changed, 4 insertions(+), 3238 deletions(-) delete mode 100644 src/Accurate_GC/Makefile delete mode 100644 src/Accurate_GC/gc.cpp delete mode 100644 src/Accurate_GC/gc_printer.cpp delete mode 100644 src/Accurate_GC/sample.ll delete mode 100644 src/Accurate_GC/shadow_stack.cpp delete mode 100644 src/GC/Makefile delete mode 100644 src/GC/docs/benchmarking.md delete mode 100644 src/GC/docs/lib/cheap.md delete mode 100644 src/GC/docs/lib/chunk.md delete mode 100644 src/GC/docs/lib/event.md delete mode 100644 src/GC/docs/lib/heap.md delete mode 100644 src/GC/docs/lib/profiler.md delete mode 100644 src/GC/docs/ref-guide.md delete mode 100644 src/GC/include/cheap.h delete mode 100644 src/GC/include/chunk.hpp delete mode 100644 src/GC/include/event.hpp delete mode 100644 src/GC/include/heap.hpp delete mode 100644 src/GC/include/profiler.hpp delete mode 100644 src/GC/lib/cheap.cpp delete mode 100644 src/GC/lib/event.cpp delete mode 100644 src/GC/lib/gcoll.a delete mode 100644 src/GC/lib/heap.cpp delete mode 100644 src/GC/lib/profiler.cpp delete mode 100644 src/GC/tests/MarkSweep.cpp delete mode 100644 src/GC/tests/advance.cpp delete mode 100644 src/GC/tests/alloc_free.cpp delete mode 100644 src/GC/tests/alloc_free_list.cpp delete mode 100644 src/GC/tests/events.cpp delete mode 100644 src/GC/tests/extern_lib.cpp delete mode 100644 src/GC/tests/file.cpp delete mode 100644 src/GC/tests/game.cpp delete mode 100644 src/GC/tests/h_test.cpp delete mode 100644 src/GC/tests/linkedlist.cpp delete mode 100644 src/GC/tests/linker.cpp delete mode 100644 src/GC/tests/player.hpp delete mode 100644 src/GC/tests/stack.cpp delete mode 100644 src/GC/tests/stack2.cpp delete mode 100644 src/GC/tests/struct_test.cpp delete mode 100644 src/GC/tests/wrapper.c delete mode 100644 src/GC/tests/wrapper_test.c delete mode 100644 src/GC/todo.md diff --git a/src/Accurate_GC/Makefile b/src/Accurate_GC/Makefile deleted file mode 100644 index 347e2dc..0000000 --- a/src/Accurate_GC/Makefile +++ /dev/null @@ -1,5 +0,0 @@ -LEVEL := ../.. -LIBRARYNAME = GC -LOADABLE_MODULE = 1 - -include $(LEVEL)/Makefile.common \ No newline at end of file diff --git a/src/Accurate_GC/gc.cpp b/src/Accurate_GC/gc.cpp deleted file mode 100644 index ddf8bc0..0000000 --- a/src/Accurate_GC/gc.cpp +++ /dev/null @@ -1,16 +0,0 @@ -// TODO: include these properly -#include "llvm/CodeGen/GCStrategy.h" -#include "llvm/CodeGen/GCMetadata.h" -#include "llvm/Support/Compiler.h" - -using namespace llvm; - -namespace { - class LLVM_LIBRARY_VISIBILITY GC : public GCStrategy { - public: - GC() {} - }; - - GCRegistry::Add - X("gc", "The bespoken garbage collector."); -} \ No newline at end of file diff --git a/src/Accurate_GC/gc_printer.cpp b/src/Accurate_GC/gc_printer.cpp deleted file mode 100644 index f392c4b..0000000 --- a/src/Accurate_GC/gc_printer.cpp +++ /dev/null @@ -1,16 +0,0 @@ -#include "llvm/CodeGen/GCMetadataPrinter.h" -#include "llvm/Support/Compiler.h" - -using namespace llvm; - -namespace { - class LLVM_LIBRARY_VISIBILITY GCPrinter : public GCMetadataPrinter { - public: - virtual void beginAssembly(AsmPrinter &AP); - - virtual void finishAssembly(AsmPrinter &AP); - }; - - GCMetadataPrinterRegistry::Add - X("gc", "The bespoken garbage collector."); -} \ No newline at end of file diff --git a/src/Accurate_GC/sample.ll b/src/Accurate_GC/sample.ll deleted file mode 100644 index d737d38..0000000 --- a/src/Accurate_GC/sample.ll +++ /dev/null @@ -1,4 +0,0 @@ -define void @f() gc "gc" { -entry: - ret void -} \ No newline at end of file diff --git a/src/Accurate_GC/shadow_stack.cpp b/src/Accurate_GC/shadow_stack.cpp deleted file mode 100644 index 2c75629..0000000 --- a/src/Accurate_GC/shadow_stack.cpp +++ /dev/null @@ -1,63 +0,0 @@ -/// The map for a single function's stack frame. One of these is -/// compiled as constant data into the executable for each function. -/// -/// Storage of metadata values is elided if the %metadata parameter to -/// @llvm.gcroot is null. -struct FrameMap { - int NumRoots; //< Number of roots in stack frame. (int32_t) - int NumMeta; //< Number of metadata entries. May be < NumRoots. - const void *Meta[0]; //< Metadata for each root. -}; - -/// A link in the dynamic shadow stack. One of these is embedded in -/// the stack frame of each function on the call stack. -struct StackEntry { - StackEntry *Next; //< Link to next stack entry (the caller's). - const FrameMap *Map; //< Pointer to constant FrameMap. - void *Roots[0]; //< Stack roots (in-place array). -}; - -/// The head of the singly-linked list of StackEntries. Functions push -/// and pop onto this in their prologue and epilogue. -/// -/// Since there is only a global list, this technique is not threadsafe. -StackEntry *llvm_gc_root_chain; - -/// Calls Visitor(root, meta) for each GC root on the stack. -/// root and meta are exactly the values passed to -/// @llvm.gcroot. -/// -/// Visitor could be a function to recursively mark live objects. Or it -/// might copy them to another heap or generation. -/// -/// @param Visitor A function to invoke for every GC root on the stack. -void visitGCRoots(void (*Visitor)(void **Root, const void *Meta)) { - for (StackEntry *R = llvm_gc_root_chain; R; R = R->Next) { - unsigned i = 0; - - // For roots [0, NumMeta), the metadata pointer is in the FrameMap. - for (unsigned e = R->Map->NumMeta; i != e; ++i) - Visitor(&R->Roots[i], R->Map->Meta[i]); - - // For roots [NumMeta, NumRoots), the metadata pointer is null. - for (unsigned e = R->Map->NumRoots; i != e; ++i) - Visitor(&R->Roots[i], nullptr); - } -} - - // To access the stack map -void traverseStackMap() { - for (auto I = GCFunctionMetadata::roots_begin(), E = GCFunctionMetadata::end(); I != E; ++I) { - GCFunctionInfo *FI = *I; - unsigned FrameSize = FI->getFrameSize(); - size_t RootCount = FI->roots_size(); - - for (GCFunctionInfo::roots_iterator RI = FI->roots_begin(), - RE = FI->roots_end(); - RI != RE; ++RI) { - int RootNum = RI->Num; - int RootStackOffset = RI->StackOffset; - Constant *RootMetadata = RI->Metadata; - } - } -} \ No newline at end of file diff --git a/src/GC/Makefile b/src/GC/Makefile deleted file mode 100644 index 1c2690a..0000000 --- a/src/GC/Makefile +++ /dev/null @@ -1,96 +0,0 @@ -CC = clang++ -CWD = $(shell pwd) -LIB_INCL = -I$(CWD)/include -LIB_SO = -L$(CWD)/lib -LIB_LINK = $(CWD)/lib -CFLAGS = -Wall -Wextra -v -g -std=gnu++20 -stdlib=libc++ -I -VGFLAGS = --leak-check=full --show-leak-kinds=all -STDFLAGS = -std=gnu++20 -stdlib=libc++ -WFLAGS = -Wall -Wextra -DBGFLAGS = -g - -advance: - $(CC) $(WFLAGS) $(STDFLAGS) tests/advance.cpp -o tests/advance.out - -file: - $(CC) $(WFLAGS) $(STDFLAGS) tests/file.cpp -o tests/file.out - -heap: - $(CC) $(WFLAGS) $(STDFLAGS) $(LIB_INCL) lib/heap.cpp - -h_test: static_lib - rm -f tests/h_test.out -# $(CC) $(WFLAGS) $(STDFLAGS) $(LIB_INCL) tests/h_test.cpp lib/heap.cpp lib/profiler.cpp lib/event.cpp -o tests/h_test.out - $(CC) $(STDFLAGS) $(WFLAGS) $(LIB_INCL) -O3 -g -o tests/h_test.out tests/h_test.cpp lib/gcoll.a - -h_test_vg: h_test - valgrind $(VGFLAGS) tests/h_test.out - -h_test_dbg: h_test - lldb tests/h_test.out launch - -linker: - rm -f tests/linker.out - $(CC) $(WFLAGS) $(STDFLAGS) $(LIB_INCL) tests/linker.cpp lib/heap.cpp -o tests/linker.out - -linker_vg: linker - valgrind $(VGFLAGS) tests/linker.out - -game: - rm -f tests/game.out - $(CC) $(WFLAGS) $(STDFLAGS) $(LIB_INCL) tests/game.cpp lib/heap.cpp lib/profiler.cpp lib/event.cpp -o tests/game.out - -wrapper_test: - rm -f lib/event.o lib/profiler.o lib/heap.o lib/coll.a tests/wrapper_test.out -# compile object files - $(CC) $(STDFLAGS) $(WFLAGS) $(LIB_INCL) -g -c -o lib/event.o lib/event.cpp -fPIC - $(CC) $(STDFLAGS) $(WFLAGS) $(LIB_INCL) -g -c -o lib/profiler.o lib/profiler.cpp -fPIC - $(CC) $(STDFLAGS) $(WFLAGS) $(LIB_INCL) -g -c -o lib/heap.o lib/heap.cpp -fPIC - $(CC) $(STDFLAGS) $(WFLAGS) $(LIB_INCL) -g -c -o lib/cheap.o lib/cheap.cpp -fPIC -# compile object files into library - ar rcs lib/gcoll.a lib/event.o lib/profiler.o lib/heap.o lib/cheap.o - clang -stdlib=libc++ $(WFLAGS) $(LIB_INCL) -o tests/wrapper_test.out tests/wrapper_test.c lib/gcoll.a -lstdc++ - -extern_lib: -# remove old files - rm -f lib/heap.o lib/libheap.so tests/extern_lib.out -# compile heap to object file - $(CC) $(STDFLAGS) -c -fPIC -o lib/heap.o lib/heap.cpp - - $(CC) $(STDFLAGS) -shared -o lib/libheap.so lib/heap.o - $(CC) $(STDFLAGS) $(WFLAGS) $(LIB_INCL) -v tests/extern_lib.cpp lib/heap.cpp -o tests/extern_lib.out - $(CC) $(STDFLAGS) $(LIB_INCL) $(LIB_SO) -v -Wall -o tests/extern_lib.out tests/extern_lib.cpp -lheap - LD_LIBRARY_PATH=$(LIB_LINK) tests/extern_lib.out - -static_lib: -# remove old files - rm -f lib/event.o lib/profiler.o lib/heap.o lib/gcoll.a tests/extern_lib.out -# compile object files - $(CC) $(STDFLAGS) $(WFLAGS) $(LIB_INCL) -O3 -c -o lib/event.o lib/event.cpp -fPIC - $(CC) $(STDFLAGS) $(WFLAGS) $(LIB_INCL) -O3 -c -o lib/profiler.o lib/profiler.cpp -fPIC - $(CC) $(STDFLAGS) $(WFLAGS) $(LIB_INCL) -O3 -c -o lib/heap.o lib/heap.cpp -fPIC -# create static library - ar r lib/gcoll.a lib/event.o lib/profiler.o lib/heap.o - -# create test program -static_lib_test: static_lib - $(CC) $(STDFLAGS) $(WFLAGS) $(LIB_INCL) -o tests/extern_lib.out tests/extern_lib.cpp lib/gcoll.a - -alloc_free_list: static_lib - $(CC) $(STDFLAGS) $(WFLAGS) $(LIB_INCL) -o tests/alloc_fl.out tests/alloc_free_list.cpp lib/gcoll.a - -linked_list_test: static_lib - $(CC) $(STDFLAGS) $(WFLAGS) $(LIB_INCL) -o tests/linkedlist.out tests/linkedlist.cpp lib/gcoll.a - -wrapper: -# remove old files - rm -f lib/event.o lib/profiler.o lib/heap.o lib/coll.a tests/wrapper.out -# compile object files - $(CC) $(STDFLAGS) $(WFLAGS) $(LIB_INCL) -O3 -c -o lib/event.o lib/event.cpp -fPIC - $(CC) $(STDFLAGS) $(WFLAGS) $(LIB_INCL) -O3 -c -o lib/profiler.o lib/profiler.cpp -fPIC - $(CC) $(STDFLAGS) $(WFLAGS) $(LIB_INCL) -O3 -c -o lib/heap.o lib/heap.cpp -fPIC - $(CC) $(STDFLAGS) $(WFLAGS) $(LIB_INCL) -O3 -c -o lib/cheap.o lib/cheap.cpp -fPIC -# compile object files into library - ar rcs lib/gcoll.a lib/event.o lib/profiler.o lib/heap.o lib/cheap.o -# compile test program wrapper.c with normal clang - clang -stdlib=libc++ $(WFLAGS) $(LIB_INCL) -o tests/wrapper.out tests/wrapper.c lib/gcoll.a -lstdc++ diff --git a/src/GC/docs/benchmarking.md b/src/GC/docs/benchmarking.md deleted file mode 100644 index c2b9279..0000000 --- a/src/GC/docs/benchmarking.md +++ /dev/null @@ -1,21 +0,0 @@ -# Benchmarking - -free_overlap(): - 9_000 nodes: - With indexing: - Execution time: 22624 ≈ 22ms ≈ 0s. - Without indexing: - Execution time: 24891 ≈ 24ms ≈ 0s. - - 90_000 nodes: - With indexing: - Execution time: 693642 ≈ 693ms ≈ 0s. - Without indexing: - Execution time: 712297 ≈ 712ms ≈ 0s. - -Linked list test: - 50_000 nodes: - With marking all: - Execution time: 13911478 ≈ 13911ms ≈ 13s. - Without marking: - Execution time: 234361 ≈ 234ms ≈ 0s. \ No newline at end of file diff --git a/src/GC/docs/lib/cheap.md b/src/GC/docs/lib/cheap.md deleted file mode 100644 index e5c5993..0000000 --- a/src/GC/docs/lib/cheap.md +++ /dev/null @@ -1,40 +0,0 @@ -# cheap.h & cheap.cpp - -A wrapper interface for the class `GC::Heap` for easier use -in LLVM (no nasty namespaces). This interface is relatively -straight-forward and only defines functions to use the already -public functions in the class `GC::Heap`. - -The functions are declared in a normal C-style header and -defined as "pure" C-functions. Because the public functions -exposed in `GC::Heap` are static, some of the functions -just call the static functions but are wrapped as C-functions. - -For the non-static function `GC::Heap::set_profiler()` and the -singleton get-instance function `GC::Heap::the()` a struct -is used to encapsulate the heap-object. If this library is -compiled with `DEBUG` defined a struct is typedef-ed and -can be used everywhere, otherwise this struct is opaque -and cannot be used explicitly. This struct only contains -a pointer to the heap instance and is called `cheap_t`. - -## Functions -`cheap_t *cheap_the()`: Returns an encapsulated singleton -instance. It is encapsulated in an opaque struct as the -instance itself is not meant to be used outside the C++ -library. - -`void cheap_init()`: Simply calls the `Heap::init()` -function. - -`void cheap_dispose()`: Only calls the `Heap::dispose()` -function. - -`void *cheap_alloc(unsigned long size)`: Calls `Heap::alloc(size_t size)` -and returns whatever `alloc` returns. - -`void cheap_set_profiler(cheap_t *cheap, bool mode)`: -The argument `cheap` is the encapsulated Heap singleton instance. -`mode` is the same as for `Heap::set_profiler(bool mode)`. - -For more documentation on functionality, see `src/GC/docs/lib/heap.md`. \ No newline at end of file diff --git a/src/GC/docs/lib/chunk.md b/src/GC/docs/lib/chunk.md deleted file mode 100644 index 97230f5..0000000 --- a/src/GC/docs/lib/chunk.md +++ /dev/null @@ -1,26 +0,0 @@ -# chunk.hpp - -A chunk struct object is the basic element of what can be -stored on the heap. When `Heap::alloc` is called a -chunk may be created to represent the space of memory -that was allocated on the heap by `alloc`. - -## Members -`bool m_marked`: A boolean flag to mark an object during mark/sweep. - -`uintptr_t *const m_start`: A constant pointer pointing to the start -address of the memory space that was allocated. - -`const size_t m_size`: The size of the memory space that was allocated. - -## Constructors -There are three constructors for a chunk. One regular constructor -and two copy constructors. - -`Chunk(size_t size, uintptr_t *start)`: Used for creating new chunks in -`Heap::alloc`. - -`Chunk(const Chunk *const c)`: A copy constructor used by the profiler -to store chunk data after the initial chunk is deleted. - -`Chunk(const Chunk &c)`: A secondary copy constructor used for debugging. \ No newline at end of file diff --git a/src/GC/docs/lib/event.md b/src/GC/docs/lib/event.md deleted file mode 100644 index 8884205..0000000 --- a/src/GC/docs/lib/event.md +++ /dev/null @@ -1,47 +0,0 @@ -# event.hpp & event.cpp - -An event class used by the profiler to track actions -on the heap. - -## Members -`const GCEventType m_type`: The type of event recorded. - -`const std::time_t m_timestamp`: The timestamp of the event, -initialized to the current time by `std::time(NULL)`. - -`const Chunk *m_chunk`: The chunk an event is related to. -For example, in `alloc` when a new chunk is created, a -new event is recorded with the type of `NewChunk` and -`m_chunk` then contains a copied version of that new chunk. -If an event is not related to a chunk this member is initialized -to a nullptr. - -`const size_t m_size`: In an `AllocStart` event, this member -stores the amount of bytes requested to `alloc`. Otherwise -this member is initialized to 0. - -## Constructors -`GCEvent(GCEventType type)`: Used for creating events that are -independent of a chunk and size (like `ProfilerDispose`). - -`GCEvent(GCEventType type, Chunk *chunk)`: Used for creating events -that are connected to a chunk (like `ChunkMarked`). - -`GCEvent(GCEventType type, size_t size)`: Used for creating events -that are related to a size (only `AllocStart`). - -## Destructors -`~GCEvent()`: Default destructor and also frees the member -`m_chunk` if it's not the `nullptr`. - -## Functions -`GCEventType get_type()`: Getter for the type of the event. - -`std::time_t get_time_stamp()`: Getter for the timestamp of -the event. - -`const Chunk *get_chunk()`: Getter for the Chunk the event -is related to. The chunk data is constant. - -`const char *type_to_string()`: Translates the type of the -event to a string. \ No newline at end of file diff --git a/src/GC/docs/lib/heap.md b/src/GC/docs/lib/heap.md deleted file mode 100644 index a0c31ab..0000000 --- a/src/GC/docs/lib/heap.md +++ /dev/null @@ -1,54 +0,0 @@ -# heap.hpp & heap.cpp - -## Members -`char *const m_heap`: This is the pointer to the simulated heap which -collection occurs on. It's a byte array with a constant pointer. - -`size_t m_size`: The size of bytes that has been allocated on the heap. - -`inline static Heap *m_instance`: The singleton instance of Heap. Before -the heap is initialized this is initialized to the null pointer. - -`uintptr_t *m_stack_top`: The address of the topmost stack frame which -serves as the stop for scanning the stack. Initialized as the null pointer -but assigned to the correct address in `Heap::init()`. - -`bool m_profiler_enable`: The state of the profiler, `true` if the -profiler is enabled, `false` otherwise. It is initialized as `false`. - -`std::vector m_allocated_chunks`: Contains pointers to all -chunks that are allocated on the heap and can be reachable (if -a collection has been triggered previously). - -`std::vector m_freed_chunks`: Contains pointer to -chunks that have been freed, used to try and recycle chunks. - -## Constructors -`Heap()`: Default constructor which guarantees to initialize -the `m_heap` pointer and the byte array. Declared private -in accordance with the singleton pattern. - -## Destructors -`~Heap()`: Frees the `m_heap` byte array. Declared private -in accordance with the singleton pattern. - -## Functions -`static void init()`: Initializes the heap singleton and the member -`m_instance`. Must be called before any calls to `alloc()`. - -`static void dispose()`: Disposes the heap singleton which frees -the heap. If the profiler is enabled the profiler is also disposed. - -`static void *alloc(size_t size)`: Tries to allocate `size` amount -of bytes on the heap. The allocation is C-style, meaning `alloc()` -returns a `void *` similar to `malloc` and the user should cast -this pointer to an appropriate type. If this function is called with -the argument of 0, it will return the null pointer. This function can throw -runtime errors on two occasions. One if there is not enough memory -on the heap after a collection is triggered, it will throw a runtime -error with the message "Out of memory". The other occasion is when -a collection is triggered and the heap has not been initialized -properly by calling `init()`. - -`static void set_profiler(bool mode)`: Enables or disables (`true` -or `false`) the profiler. \ No newline at end of file diff --git a/src/GC/docs/lib/profiler.md b/src/GC/docs/lib/profiler.md deleted file mode 100644 index cd925d6..0000000 --- a/src/GC/docs/lib/profiler.md +++ /dev/null @@ -1,30 +0,0 @@ -# profiler.hpp & profiler.cpp - -## Members -`inline static Profiler *m_instance`: The pointer to the profiler -singleton instance. - -`std::vector m_events`: A vector of events recorded -by the profiler. The contents are always sorted by time. - -## Constructors -`Profiler()`: Default constructor, declared private because of -the singleton pattern. - -## Destructors -`~Profiler()`: Default destructor, declared private because of -the singleton pattern. This destructor also deletes any events -that were recorded by the profiler to free memory. - -## Functions -`static void record(GCEventType type)`: Records an event independent -of a size and a chunk (like `ProfilerDispose`). - -`static void record(GCEventType type, size_t size)`: Records an event independent -of a chunk but not a size (only `AllocStart`). - -`static void record(GCEventType type, Chunk *chunk)`: Records an event independent -of a size but not a chunk (like `NewChunk`). - -`static void dispose()`: Disposes the profiler by dumping a log file of all -events and deleting events to free memory. \ No newline at end of file diff --git a/src/GC/docs/ref-guide.md b/src/GC/docs/ref-guide.md deleted file mode 100644 index 7ee627e..0000000 --- a/src/GC/docs/ref-guide.md +++ /dev/null @@ -1,83 +0,0 @@ -# GC library - reference guide - -The Heap class is the core of the library and contains all necessary -functions for using the library. This class exposes four public functions -which are `init`, `dispose`, `alloc`, and `set_profiler`. - -To use the library, simply include it as `#include "heap.hpp"` and link -it during compilation. Or you can compile it to a static library using -the target `make static_lib` which compiles everything to an .a file. -It can also be compiled to a shared library if necessary with the target -`make shared_lib` which produces an .so file. - -## Quick guide -1. If you want a profiler, call `Heap::set_profiler(true)`. Otherwise this can be skipped. -2. Call `Heap::init()` to initialize the heap before using `alloc` (**crucial**). -3. Use `Heap::alloc()` as you want. -4. At program exit, call `Heap::dispose()` to free up all the memory used. - -## Functions - -### Heap::init() -When using the library, the user has to, at the start of the program, -call the `void init()` function, which initiates the Heap singleton -and the class member `m_stack_top`. **It is crucial** that this -functions is called from the `main` function of the end program, -as `init` uses the intrinsic function `__builtin_frame_address` -to find the address of the **first** stack frame of the end program. -If the function **is not** called from the `main` function -of the end program, it is not guaranteed that the garbage collector -will collect all objects. - -The intrinsic function used is technically unsafe for this use, -but during testing it has only shown to segfault for values greater -than the one used in `init`. If you run into a segfault, please -contact the developers. - - -### Heap::set_profiler(bool mode) -This function is used to enable or disable the profiler connected -to the Heap. The profiler is primarily used for testing, but can -also be used in general to keep track of the programs history. - -This function takes a single boolean as an argument to represent -the state of the profiler. `true` means that the profiler is enabled -and `false` means that the profiler is disabled. This function -can theoretically be called at any time during program execution, -but it's probably a bad idea. It is recommended to call this function -before the call to `init` or at least at before the first call to -`alloc`. - -### Heap::alloc(size_t size) -The probably most important function in this library. This function -is called to request memory from the "heap". `alloc` takes a single -argument which is a `size_t` (unsigned long) to represent the amount -of bytes to allocate on the heap. The allocation is C-style, meaning -that alloc returns a `void` pointer similar to `malloc`, which -is then supposed to be cast by the user to a proper pointer. When -`alloc` is called and there is already not enough memory left on -the heap to accommodate the request, a collection is triggered -to free up memory for the allocation. Hence the user does not -need to make their own calls to `free` or manually free up memory. - -`alloc` can also return a null pointer, if the user requests to -allocate 0 bytes. This is not recommended. - -`alloc` can also throw runtime errors in two cases. The first one -is of there is not enough memory on the heap available after -a collection, which in case the allocation cannot complete. -The second case is during a collection, where the function -`collect` throws a runtime error if the heap is not already -initialized by a call to `init`. Calls to `alloc` can technically -take place without properly initializing the heap, but this is -not recommended. - -### Heap::dispose() -This function is used to dispose the heap at the program exit. -If the profiler is enabled, it is also disposed from a call -to `dispose`. When the profiler is disposed, a log file is -dumped containing the events on the heap. If the profiler -is disabled, nothing happens to the profiler during `dispose`. -After the profiler is disposed, the heap is deleted which -frees up all the memory used and deletes (hopefully) all -the remaining objects in memory. \ No newline at end of file diff --git a/src/GC/include/cheap.h b/src/GC/include/cheap.h deleted file mode 100644 index d74af9d..0000000 --- a/src/GC/include/cheap.h +++ /dev/null @@ -1,36 +0,0 @@ -#ifndef CHEAP_H -#define CHEAP_H - -#include - -#ifdef __cplusplus -extern "C" { -#endif - -//#define WRAPPER_DEBUG - -#ifdef WRAPPER_DEBUG -typedef struct cheap -{ - void *obj; -} cheap_t; -#else -struct cheap; -typedef struct cheap cheap_t; -#endif - -#define FuncCallsOnly 0x1E -#define ChunkOpsOnly 0x3E0 - -cheap_t *cheap_the(); -void cheap_init(); -void cheap_dispose(); -void *cheap_alloc(unsigned long size); -void cheap_set_profiler(cheap_t *cheap, bool mode); -void cheap_profiler_log_options(cheap_t *cheap, unsigned long flag); - -#ifdef __cplusplus -} -#endif - -#endif /* __CHEAP_H__ */ \ No newline at end of file diff --git a/src/GC/include/chunk.hpp b/src/GC/include/chunk.hpp deleted file mode 100644 index 595b50b..0000000 --- a/src/GC/include/chunk.hpp +++ /dev/null @@ -1,25 +0,0 @@ -#pragma once - -#include -#include - -namespace GC -{ - /** - * The basic element of what can be stored on - * the heap. A chunk contains a start address - * on the actual heap, the size of memory that - * is allocated at that address and if the - * chunk is reachable (marked). - */ - struct Chunk - { - bool m_marked {false}; - uintptr_t *const m_start {nullptr}; - const size_t m_size {0}; - - Chunk(size_t size, uintptr_t *start) : m_start(start), m_size(size) {} - Chunk(const Chunk *const c) : m_marked(c->m_marked), m_start(c->m_start), m_size(c->m_size) {} - Chunk(const Chunk &c) : m_marked(c.m_marked), m_start(c.m_start), m_size(c.m_size) {} - }; -} \ No newline at end of file diff --git a/src/GC/include/event.hpp b/src/GC/include/event.hpp deleted file mode 100644 index c18b1ce..0000000 --- a/src/GC/include/event.hpp +++ /dev/null @@ -1,55 +0,0 @@ -#pragma once - -#include - -#include "chunk.hpp" - -namespace GC -{ - /** - * Types of events that can occur on the heap. - */ - enum GCEventType - { - HeapInit = 1 << 0, - AllocStart = 1 << 1, - CollectStart = 1 << 2, - MarkStart = 1 << 3, - SweepStart = 1 << 4, - ChunkMarked = 1 << 5, - ChunkSwept = 1 << 6, - ChunkFreed = 1 << 7, - NewChunk = 1 << 8, - ReusedChunk = 1 << 9, - ProfilerDispose = 1 << 10, - FreeStart = 1 << 11 - }; - - /** - * Stores metadeta about an event on the heap. - */ - class GCEvent - { - private: - const GCEventType m_type; - const std::time_t m_timestamp {std::time(NULL)}; - const Chunk *m_chunk {nullptr}; - const size_t m_size {0}; - - public: - GCEvent(GCEventType type) : m_type(type) {} - GCEvent(GCEventType type, Chunk *chunk) : m_type(type), m_chunk(chunk) {} - GCEvent(GCEventType type, size_t size) : m_type(type), m_size(size) {} - - ~GCEvent() { - if (m_chunk != nullptr) - delete m_chunk; - } - - GCEventType get_type(); - std::time_t get_time_stamp(); - const Chunk *get_chunk(); - size_t get_size(); - const char *type_to_string(); - }; -} \ No newline at end of file diff --git a/src/GC/include/heap.hpp b/src/GC/include/heap.hpp deleted file mode 100644 index 909ac99..0000000 --- a/src/GC/include/heap.hpp +++ /dev/null @@ -1,102 +0,0 @@ -#pragma once - -#include -#include -#include - -#include "chunk.hpp" -#include "profiler.hpp" - -#define HEAP_SIZE 240240240 -#define FREE_THRESH (uint)100 -#define HEAP_DEBUG - -namespace GC -{ - /** - * Flags for the collect overlead for conditional - * collection (mark/sweep/free/all). - */ - enum CollectOption - { - MARK = 1 << 0, - SWEEP = 1 << 1, - MARK_SWEEP = 1 << 2, - FREE = 1 << 3, - COLLECT_ALL = 0b1111 // all flags above - }; - - /** - * The heap class to represent the heap for the - * garbage collection. The heap is a singleton - * instance and can be retrieved by Heap::the() - * inside the heap class. The heap is represented - * by a char array of size 65536 and can enable - * a profiler to track the actions on the heap. - */ - class Heap - { - private: - Heap() : m_heap(static_cast(malloc(HEAP_SIZE))) {} - - ~Heap() - { - std::free((char *)m_heap); - } - - char *const m_heap; - size_t m_size{0}; - char *m_heap_top{nullptr}; - // static Heap *m_instance {nullptr}; - uintptr_t *m_stack_top{nullptr}; - bool m_profiler_enable{false}; - - std::vector m_allocated_chunks; - std::vector m_freed_chunks; - std::list m_free_list; - - static bool profiler_enabled(); - // static Chunk *get_at(std::vector &list, size_t n); - void collect(); - void sweep(Heap &heap); - Chunk *try_recycle_chunks(size_t size); - void free(Heap &heap); - void free_overlap(Heap &heap); - void mark(uintptr_t *start, const uintptr_t *end, std::vector &worklist); - void print_line(Chunk *chunk); - void print_worklist(std::vector &list); - void mark_step(uintptr_t start, uintptr_t end, std::vector &worklist); - - // Temporary - Chunk *try_recycle_chunks_new(size_t size); - void free_overlap_new(Heap &heap); - - public: - /** - * These are the only five functions which are exposed - * as the API for LLVM. At the absolute start of the - * program the developer has to call init() to ensure - * that the address of the topmost stack frame is - * saved as the limit for scanning the stack in collect. - */ - - static Heap &the(); - static void init(); - static void dispose(); - static void *alloc(size_t size); - void set_profiler(bool mode); - void set_profiler_log_options(RecordOption flags); - - // Stop the compiler from generating copy-methods - Heap(Heap const &) = delete; - Heap &operator=(Heap const &) = delete; - -#ifdef HEAP_DEBUG - void collect(CollectOption flags); // conditional collection - void check_init(); // print dummy things - void print_contents(); // print dummy things - void print_allocated_chunks(Heap *heap); // print the contents in m_allocated_chunks - void print_summary(); -#endif - }; -} \ No newline at end of file diff --git a/src/GC/include/profiler.hpp b/src/GC/include/profiler.hpp deleted file mode 100644 index f70ca3b..0000000 --- a/src/GC/include/profiler.hpp +++ /dev/null @@ -1,71 +0,0 @@ -#pragma once - -#include -#include -#include - -#include "chunk.hpp" -#include "event.hpp" - -// #define FunctionCallTypes -// #define ChunkOpsTypes - -namespace GC { - - enum RecordOption - { - FunctionCalls = (GC::AllocStart | GC::CollectStart | GC::MarkStart | GC::SweepStart), - ChunkOps = (GC::ChunkMarked | GC::ChunkSwept | GC::ChunkFreed | GC::NewChunk | GC::ReusedChunk), - AllOps = 0xFFFFFF - }; - - struct ProfilerEvent - { - uint m_n {1}; - const GCEventType m_type; - - ProfilerEvent(GCEventType type) : m_type(type) {} - }; - - class Profiler { - private: - Profiler() {} - ~Profiler() - { - for (GCEvent *c : m_events) - delete c; - } - - static Profiler &the(); - inline static Profiler *m_instance {nullptr}; - std::vector m_events; - ProfilerEvent *m_last_prof_event {new ProfilerEvent(HeapInit)}; - std::vector m_prof_events; - RecordOption flags; - - std::chrono::microseconds alloc_time {0}; - // size_t alloc_counts {0}; - std::chrono::microseconds collect_time {0}; - // size_t collect_counts {0}; - - static void record_data(GCEvent *type); - std::ofstream create_file_stream(); - std::string get_log_folder(); - static void dump_trace(); - static void dump_prof_trace(); - static void dump_chunk_trace(); - // static void dump_trace_short(); - // static void dump_trace_full(); - static void print_chunk_event(GCEvent *event, char buffer[22]); - static const char *type_to_string(GCEventType type); - - public: - static RecordOption log_options(); - static void set_log_options(RecordOption flags); - static void record(GCEventType type); - static void record(GCEventType type, size_t size); - static void record(GCEventType type, Chunk *chunk); - static void record(GCEventType type, std::chrono::microseconds time); - static void dispose(); - }; -} \ No newline at end of file diff --git a/src/GC/lib/cheap.cpp b/src/GC/lib/cheap.cpp deleted file mode 100644 index 42179b6..0000000 --- a/src/GC/lib/cheap.cpp +++ /dev/null @@ -1,63 +0,0 @@ -#include -#include - -#include "heap.hpp" -#include "cheap.h" - -#ifndef WRAPPER_DEBUG -struct cheap -{ - void *obj; -}; -#endif - -cheap_t *cheap_the() -{ - cheap_t *c; - GC::Heap *heap; - - c = static_cast(malloc(sizeof(cheap_t))); - heap = &GC::Heap::the(); - c->obj = heap; - - return c; -} - -void cheap_init() -{ - GC::Heap::init(); -} - -void cheap_dispose() -{ - std::cout << "In dispose\n"; - GC::Heap::dispose(); - std::cout << "Out dispose" << std::endl; -} - -void *cheap_alloc(unsigned long size) -{ - return GC::Heap::alloc(size); -} - -void cheap_set_profiler(cheap_t *cheap, bool mode) -{ - GC::Heap *heap = static_cast(cheap->obj); - - heap->set_profiler(mode); -} - -void cheap_profiler_log_options(cheap_t *cheap, unsigned long flags) -{ - GC::Heap *heap = static_cast(cheap->obj); - - GC::RecordOption cast_flag; - if (flags == FuncCallsOnly) - cast_flag = GC::FunctionCalls; - else if (flags == ChunkOpsOnly) - cast_flag = GC::ChunkOps; - else - cast_flag = GC::AllOps; - - heap->set_profiler_log_options(cast_flag); -} \ No newline at end of file diff --git a/src/GC/lib/event.cpp b/src/GC/lib/event.cpp deleted file mode 100644 index 89a2a71..0000000 --- a/src/GC/lib/event.cpp +++ /dev/null @@ -1,71 +0,0 @@ -#include "chunk.hpp" -#include "event.hpp" - -namespace GC -{ - /** - * @returns The type of the event - */ - GCEventType GCEvent::get_type() - { - return m_type; - } - - /** - * @returns The time the event happened in - * the form of time_t. - */ - std::time_t GCEvent::get_time_stamp() - { - return m_timestamp; - } - - /** - * If the event is related to a chunk, this - * function returns the chunk that it is - * related to. If the event is independent - * of a chunk, it returns the nullptr. - * - * @returns A chunk pointer or the nullptr. - */ - const Chunk *GCEvent::get_chunk() - { - return m_chunk; - } - - /** - * If the event is an AllocStart event, this - * returns the size of the alloc() request. - * otherwise this returns 0. - * - * @returns A number representing the number - * of bytes requested to alloc() - * or 0 if the event is not an - * AllocStart event. - */ - size_t GCEvent::get_size() - { - return m_size; - } - - /** - * @returns The string conversion of the event type. - */ - const char *GCEvent::type_to_string() - { - switch (m_type) - { - case HeapInit: return "HeapInit"; - case AllocStart: return "AllocStart"; - case CollectStart: return "CollectStart"; - case MarkStart: return "MarkStart"; - case ChunkMarked: return "ChunkMarked"; - case ChunkSwept: return "ChunkSwept"; - case ChunkFreed: return "ChunkFreed"; - case NewChunk: return "NewChunk"; - case ReusedChunk: return "ReusedChunk"; - case ProfilerDispose: return "ProfilerDispose"; - default: return "[Unknown]"; - } - } -} \ No newline at end of file diff --git a/src/GC/lib/gcoll.a b/src/GC/lib/gcoll.a deleted file mode 100644 index dd34d6445a090d8ab0f17d31e151ada266147e5d..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 712746 zcmY$iNi0gvu;bEKKm`U!TnHPPR8TN9GckfFN#J5&V9;S;U|WZY^O+bJh`=l<+ZgDK zkH+?~zcon6aP^GYnzQ%mAYDhpCw%NS5)3{AjNnYpR)#U+Wk1sDn}LGsBNrFq#H zQeabyGpn$f3bHJ|BtO2mq$o2l9ir7cxWqIWB;lFtYLSv3U!Iwgn&+Afb&*9tQGQxx zPHK@^QEGC2QHrZyaJ-=*)B_9##GK5M%J?z^ z3_~oEi&7IyQsY7128C2=VlE`4jNF~!!C`2SQkq*3Us9Bqj0kABta(aiaY24DR0e+t zn|P!q7PuI}t$^@Bj)tTOFyFW&18SI&yE9nC(4wTMGQKD^xiUE?H6EN4id|u$2vK2H z0FAr&)V#!`oYWLlJ4`b3GD}c}P~8o)$|N_jDBCq4H^4hLD7eI|EH$|#zsM6Q9)c4+ zgU#YyVX+Oi-L$woHMPJsDA*t#8p2>%S@ zH90#T#WR*57sr>R7MHla`KZCOHxx{DJlRh{)~(; zlU;mXYB_q+1H~0AmcjC{gb-X}9v=_RmWD=2iN%@8pe&Y|m+qMyTw-XLoRL@r%2b&p z#h%Ho!HJ&9uCC5Tp248t3h+)2@(wlzCnqvYF~l?lmcZem1S^NZQDO=X4A)$SR8V29 zmk+P3AaxR?9)hqTq?w5cSkTDK%)|oBO5mz@^>JfjWMqH=Mg}_u1P><4zz~suU^{@B z4h-@Patz(G8|AfCVRbbh~pLo`4YW=yn%C<4Yj(o9#LI+t)KNFm$tf^ooMa z@JME9@?gC1{{g?e3j>2kFDpp!FwBC%!iTv7R5*I(WtK2Ff>LI1Nn%k612h>!IKGKR z*$@`EP5^OJQy9SP;PTXh5(v|+C^a>O!7sHOEWr?zT3Vc%0%5}{I2TBf%@7@$mz|ei zo)-%W7m{(XN3SeMlSk+M7ht;E7EE>Ci-v~(OAsH9VQE2B10n?DSIjAm;w}k!y45Z{ z&1mM#+Gi6}j4Bxw9Xw7LOmI+p_?JheQQ*+;wR>1qb;T#Fz9y!*<&ctrp#>aVx6&`lh{MuO9vTeLMZ1rLfbrS)bqT-M{z$^`G(2 z|4$Cil!$D5X?!K#zHW-7`Onw;%kBm#Z@;wUSwrHJO-J{d3y3^i?Qr4gOaK4gZ4W<% zTrNK#^(nfCSwlX;`*?$A6=#HddgIqGas>vyjC>1O4=mgwWYP1ErEh_qXLXBZcV`0^U|EsJhQev$VeqDtU~gL~uS7rGBBb}{8F$v$v0gf(aJoDGR0 zh0Rs`EcXq04>#3l#PIGBX`Z*&q{r?2x>E1g>Hn|IWKWU2*jPMoMT)=* z-d!0Yy1grkE|>kXIo0U4?7zJHfcc5&0~K9b4a-+@{!m-XFmEC6fz4awe~9g6 ztC?-b_;22w)}H4pSSsed%ALcw$00lS4r@(&->nM1ii!U+7Vq!)7`tjiVUv@R@wIaq zGdHg7aWpQQvGE8`q3w#%I4kz;^A>S&B!#8aj8ZHgc9}f0xnAbMCX0 zn{L%c)9GrOM|qR#KE#^Nl2E*Ux(wC;47DxM(uY zx~XpUOe+KLCZ0JSdD9X_R?UBJo0hok-HEgptJg4Z3MxFbrCDJ1MJ*G5v0U(Pt5MJO9>E*yqOPa< z_Uk-cwQEgVk{OSagY-0sJm$&0ZkDTe{ynoUfAxif9sgD;#U50tJ$hF+!u_Psv8pWX zjmr;RV3>LR(A6hhISZK2xW8Ncz0rQ@!dQvzmvSDQ&(JNf&SibK;O~LCB|d8d24E+ekim2La_&nukh9Mlren29Qc5-O17dyk751-?*s9ZZuWlk)MB=CUEH{T z(ai(OCFURW4edYu&3=*(eaFSRVfIUf59(jIKGf~vxZ@Pwcw6I2bD^~; zb9qoHfAzwXb2Iwn4tWR1MVDwuxBcQxmf%kN!mejD+3W4uS8U?;_3L+C+x_Z!b|5E5 zp?rt-sUOot6l?1(ZZDo4^J3q!nQMbieZ4LB%%@MDvHz@I&!oy6v)?II5{-xN%#8gR zoGB`9TQ8-{;x~P&LA~8yfnP?qm}4B(8?;~M@bA_>{_CQL+w~SDKb=h(AEO?dnc1uk zs)%`-zDePmWKO-$)PE|sBL#k^Z1WF$y5~Td*b%#lZx>JfC3)LDyIT47>?u`q-}>I_ zGrPHVlJ0|x`=XckH|`Ez`S<3zrofFQPpckF+^)QEP_5;m`Nb!7@!K*a-qmHM?^nNl z(ltkX{f-pFo=+)j|J<{BI!SdNlOQ9%LV>}7K%qBX9Lx`X9?{S_zh8aAq-yaqmx^3J zy6J|O?Q}g|yXcNGQ~lMpRX2=uzw6#w`P9X8_O$F`|4hr7<$B>D7h)q z{pt&@cxzUA#I2jw?zTH~r>6Pb{LRYuZTmjG(e*t2TjtZhq-pNIU93Zo&HB#uav5KY zXKHZBjCF2-fxBL~9)0;pZ0eHkh?p7cvI+xtRUJM0QcHCDlGTAi`fDx~-CtxFJ_B`*?WUn&4G6-&WTzmCO=Y`{1 ztAl;!G9A@bzv3AnZ~WD81+P_Bv0QqgZ*bCGChhvlPSIfBn{1aKP4nC!$-jqRzkWq; zYWp2eHQB@A=S>f-yOu0ewlz}i<2te8n*O4#zLw6L&eS_>+7qu9dGCLFO5}d0O>64i zHrI9??iwY2~u*zZPsdc6_(wl1R%76CG3M&W~SF^5ayM z#--!h?2Z%jVl5@Qw)j33(6}^NyWMG}SgOPn$3;BtMqX0_17^8M@-FqAVi=IteM#W< zg1GZefydm zcB&JvOx&<} zV-Kf}QfT*u_djQNbe-h9apmoavf6!{W6ZX4URif;MWn|Ek95v`9h>&dlvI5>=N;Sk z)PKEaOTE@tgvuZ6JilVjNj>Mjnxv`c1V5VH?>p4jo4RFv^ZfoFs&kKc-%RtC&g)%z zOJLGs@8SlPuUay2J$%}->oA+~5qX>WX;vP)&(N}3U;O5#pgJm?T9?HIyzXLZ_?qv8b7<5W}6`>v7b8~q&{3y&(^ zcDWe8JM+*qi<+X~_6~~=Cl^>O;I@`|cIw9i<-qxZ!zjW<*se4f1`50+iDuWx%IPZ z$K#(SrXR1_e|4j9*PNeT#)qCt&vmH2cs8nPvEYKP1E|B zOIJ_%R;JGP_~yaW?b&g5_PP(;7x#Zy9hbOL zS83!1EbBB9JyjC8%z38bDH{!A*O~mO(=@g_P3(=S5u9SVNT<;#d`fD-v(8Oir)mOk zE!3HCP;Ni_e5o1>&EGO{lb^m;|9ALCjcUbDh0D8RJbf+X-byd8o_a|}D(Htw{e<$b zs%?r7nO9DqDDm$2>NgwHB6k}yZF1k1);Td!=CT~kfk|TDreR;~;t5*o*w^sQ)SoGoNs+}v2)Oob~+)?{{ zEacgb#ESHl&s}`vIz#pDsBb(R^|s;K>+lw44ZB%W+a_Pho6cEO&;I$l?;NAKSJIYT zwC}q7-&^wNBvsb_nsaMg_b(CBzN?s*V)t_D^r><|ow9m+Jna6KKC5iEKGS=q{a|0Q z-ow6AW?NN7A4%Nne4Z-!%=t0jZu{F0cd)#FaYRv`@A93RLp{4n*PKBtteb+MG z>gyz{v+t(eY}5CS{?NEx=a=lXrALf~zE3Fg$PX62Uta!L@AUlBef$Xzug$)2?!})a zGtv#KHU(7ss`wE-SEoCE3OW~D#F4LypN?v{I(D8X|Sq}d> zo6W!O)r8rHqa)Y#v{xBby$=-AuP=GXJZt~Y4~%PjvZv_S*TqR|C{NlYDV}&r2bl;FTXGiv8pEG}Vr7!!axrSGE zj_*v4XQc-9%FpWkX8KO!(H9Sqxs~$cEb zL`J_)e{KOeXO2TnnD-d^(c%KJOBH9xLHke9CG{?4z)3 z<7@4Ve|>Euva5EMFFBRE{k_}~nKucwEZ4$~UL~l1WWVk@w=rVYnbo^iMBH0yp=;#* z;i&hl$!y0LxV+4YbIJBx_xwZAkF;Ym&)KaMTjz3V{pr)@l8k0zA9#HkSHGCcT)n(M zAbWN9`yjbEW7F?EH8PnWeLHKsKE-wgZ2kJC)lEA&a@1&wwp6ukqI(NQlzL6I=qMK6G(i(l@i3a!f2`4v- z)vrvo2_%lPE9>xN3DuauwGLrVG&~rqa{P8G|L4ZJP4-q3Ies znH{Ti68AXS_}au)?E3iS!OYg>;^%X0YAb&A9*CQI$Yk2?>*eZKmhDUDRM-Bx=6&cP z^`k-Oe|?e=4=UUDb#LHHr#tM|zB_ihuaFJe{OhM!!Ai@_ogwSjGwpQp}Z> z@2?yiu9tj!%(?4T?0lZ1y{C5h{(ZE@=V4*&*Ezm#gP*Azt&nVcy#A0|aeSjtx>(2( z%{eKvh0jJ7rtYb$Et|= zoYIinLBfs#wv#t(vf8A=qY}xO_(W+D%fZl-Y@82RAH|9=>id5>!yd6T>}OKszX|ix zzn?kxE=S{j*|O#5U)n9Nc5T?lq@@^ibE@pkMb4!xS5L_O&T?jQ=6%n^achzI?Cu7A zvt-BV;%3B>0-RwRq}E-%=lBJ{+!9JX2s@=*zU7G zLJZ@kxPIBhYdP=U%b4un74)pgWODA5P?lvq`c>;zC)UmkJM?j` z>ztCUy5B-pvEHAvYL|rcy}Vk}qi03l{uOI6)poi6A%iVibwhTGU(s5TZRa&lB|iH3 z{{*9sNdOPih8HoC>9K9a$J0z_yx#SB$+Jo(otyi_?$q2p5zQa-`gHEbW#^Q%&-yM` zD_Gs{_1d~~myiU{yBKb^%`pz4Dk;^CToRs!;*RS0% z6KXflyzcgO-RxI#Q;yG@`Hv%WoD;KPDa&}C=~tHd!8yLOy)~ky zCPar#Uf#U*{|`^`KgKt1tLm8L)ldAkdVbaa#mj|nuCbfF;KJve4zK$8;&tphL-eKZ z?SB&5WP9}YcPr`Up8scm{$=KCTk%Bqq^PL={a<~|?}d!p_F8mCPCsnsI{8NYuJ4yk zwz5BZzs@E{?zC{FOQbvFwJRYEGPC)2S>6=Ce}w46 zb@a_OKk*+)nD-euokGTrk<;ns#Ds)|BnC!4Hjx7zr$W;Y@G*#*GvpgGFfgz(aDenO zK+`q@0}BHK3!@Z^v^oPjSb~9pp@9j`RA)e#8^Q!p0Lvd0bEZzx>jVp?_5%w%FU()-D^=dHa<(i1?+Yt{N8meV%`?B8DF1CZGN|Si@T*~rRv!~GV4BNJ&1jAkKJ=~$D$S0`#raRSpF&O{@s%%6&lMTt)A|g z$daJGb^2W6TThO4CzM+y6wedCzf(&hZeMM4)to^cVvLsuX*KCQeMWx;c@Azs2$z5l8Hbc*TY33sJd{gsXe812Axzx0` z`|$E=GFEj7fC6*)|K zAUbJvr1nCyZ6`MfuKl1j(f`zadHZ#XziIA$YrXDu;L}yd_}a?!Gc7i5V3eMG=bhB$ zjF{y!W&LZFKCXE0e8%jz{UhPhUM`U?%VohceP%XgsLiz3IzCh3V=LRfwW>^h)=R#x z4p_PC*KrRQ(-YUEbv+igEUzx?+R0G;PG^U`ZlTEU{-E;xEj~xLEr6(g*)dk?@3+0<;?0$TycLALyrIMJgh7<-4Lu!nwcyS6CSJaAs|qd?{(fm@btt_|O+8qKk4*TiJ6?8mm7Pn3H| zbZR`2-Kul1Nn=K?(2Mr|_WeWY*kqh+&}DMT=LHSeDAqHxaL+r`>btRHW`$97Nlw}yzE@Pd;z z-Al#a?~vQkK4HQ`v5EtRlMNLNjOFh?aXPP=a_q$s9bYyju@8}a38kDWaaS%{vs{^# z!srp{v)x@!Qr^K~*=lQtvnIY-7yG%mYNrRU>bFpta=r7X=QrciYh`6Cclzi)Zks%} zD8%KW>$dM6^|9XmH!X#jyqJxWw@r>J+?-PS@Zi6eTXXm>Ty?CzQ+-KokLsMniL>{J zzMWJ#;kI0F)3gp*w`ccG@qStKOm_S2Yww~oT?Kijta)JPAEsYF`&zH6v)&K?OE1r- ziO)8uX1aAtXV=rOG3kQYfmhXLUQwEMQ(#A>?-ZY$B}e}rJaE)Zx6@(+@8bIIMQYD& z^-N+{&zc;NcYIZXS^?|igSxxs9XiHx@r#eAy0vqboY_?MeFf}~wlhkH6h63UcNw7VD(8%qX4HWTu{Ba6osBMHyrI%4t=7`;vCrEEA{;-kk8lvv$Us zoK=1iXSCV7S(NovjXQFsB@3U~zP4U@)um^X=cR`Bi%tgN%lV=Ys42WP_ta>N@IJ=; zD`L^?+NLM&mk-DMlr5dp{pD35XV0bHhZ{MWC%w9GYLVp(d4+RZ5+^c!Y!N(vT!&3v zw=QHJtM>grGixMLCw3fZYEhoxG~xbn;j1?kBDefn$)b|<-3!0=aVA*eBs+@1fwUcV~Z7_&EWZ=_z>^wq0RUwv9sc(G-l z>3i?XQsJ2~mn0wmJ^l9V(X(G4EsBY$*%=k{W5WLSqK_=%M=w9N{j@!BW6}yyv*T~y zr&sTq{e-=t_-=pvj-pq6}gzD@KEL$$-s{eFZ#D&hL{lzC2ocbxs8uoc1^KSXr z-lyMqquu1K!!94+^Thx7A-T%W`f-aVYzMVCVC||q%pe}3-BmGXYS8Vhy9NSR{8Xsh3HvSf#dB|dJyVsE-g`ux$HvLaN$=v~ zGq=P`K3&}OXJMkFxTlruvqjHusZ8j%|DSv*QaR%^^2+kG7?x1|Gh8*R7#8`@dL_+$ zR6zP8SGQW@bF;kUfXl^*-5t=7p$`YnHe6 zV&k&*Z97-&lf0^S3=N>3A-cl_xm;jORu z%kGA6V{mtNwo=e=_Y2ijFf`IL(lb;rGB7eWFfsr&wOJS#7!<%wZUzQ-zfcAy2F3#* zF-Yu!;upe)#XGdw$-r0@#K2e~z$neb&M|?JfkA+Qfk6hU37Ry(Vg^t#SW_OP&IOBD z1QxLzsMrB0EdgrwL)oASmAEdJYl|Z9B7(l&;kN?qx!CYo|uNlmR6U?Cg z2AqdrFf*_rI8YWOTv!=6p?nwxQ3>-kOq79v8_Z;7NCMLc0u(Nwjt?w+VKU&QF$}B> zzAynOEd{1o8N$Fcf{+I@Ss4_;G=fk8Gg%q5!8C%<1T$F~%)vB*&;v7B8Jxg0f-nX% zSs9AJG%CRi?Y1F{S~4&&Fd>P9lFI6`zXGw?tdXe2WOADRe+%gi7M zVW5%B48mw45H2$VBvc_h1j)=GhTuS1i3|)3LP+TZmbR;*;*fX)#T-P#9H=-bPk}^W zDF9S>g3LkB4;P{8Vf|xRTK~iV$x|RRkTDlDuOW+p*a|qrEkNSXJ~2og47-BFVH{*y z&&S!2LC?q807O`V2qO?-4k9c-gfWOP0THGk!VE+h8ZgAW`}jLK`ozZnButD?EJ>}%EP;ltACv|~1t``3`40if zNaCQh0uwJr5(kwfF!5$2anJw=OnfquIH){?i7!SH2bEDU@y$r$pe5@t@xw^spt1@k zei=y|lsjSK&|wJ%kiU2t7#LvU;K3ho-e&;kTA286By;$Y)I){A=77v9fC_-Z3d977 zfp7|l!@vM9Q9xoKJOe5YavO*V5(D8gAP!Pq0*Qg}1E@HxyakDY@E52!sICDqL1G}x z0WF|lbsR_xg!h0HLF-Tu6C?)07eE{a1_nsE3n~L4cnMS-* zBreXtz_1zW5FwBt0|Ns{92Qm}Ay^3t6Ni=9kopRu9#r~5>L~^WHIOE#IWWB-Aqx-z z6$jZn8RS6*1_nno@jIY^VqjpH1dSh%y&(0gp%%|W69<)(AS0Hci5o-t>!38u95ztq zV_;y|h99M-x8?DpVL47|x-IOFRIY&vYozpP1T{wzO&sQa1vGIXXa+Jy6Njm{LKEkK`YQ-c9Hu@JO}q%| z?m{$inEDDd@m45*0+a@M6O>LKfEWx64AarX-Js>bW;Ah_`dw(^ccBHzH8k-WP-bLc zV7QAWt`3d&uV~`^pu!SVo}r2FhMFS+O-CSSgWMkl4L4~t@uSf6X^bXb1$Cztn)q?3 zds5KE&qMQLHk!B{)O}TG;yO_Gx1)(4huXUmO&nIfZ$uNH2`#)QLi0V$zj+`A0|Ub% zH1XL`cdkYgzW_CN7Y^|QXyW!zcV0#l-wI97H_^o9q50?|nmEkfpJ?LJQ1gYM;SKT* zC>~+yN*YZ(3uW32UTy1CN2u~mk*kFCX^oxr9l)Z+ybMj;8S1ZEH1XR|^IOow*`e`12~8Z-Rsdz~nP}oapy_4- zn)qpGdRvYrZVnaSj3#aa4d-2G;%w0PJBTI@YnLBG6JGT2G669d7#O}mX%Gbx7lpc?9cm9uJQ|v>h0(;XLizGg8m4|Jv>w++6E}j2o1=-# zK*PrwP5eHT?+>M6=5K(ew`er+Ur_g_qlu?M?JY(V?}V01^=RTzpv1tyz|f5*UIk5u z)6v9@pyG?s#Cf6Vc|Dr=YH0be8%?|uTHhT<6MqZMN3igQg~J38gMoqJ1)BOsXuAD` zCT<56|A!|26`GH@pz#bc7L*<)Ld$geJZUnoi!Ki9@}`@C!{G zmj2kF;R-YV7c|`pp^3xdTMkWp88jTU(8NDN%`rn0=Z5AN7c}v?&~Wxf6Q2yt7eQ#^ ztk85EjwXH;8a^3l;(1W<5;XBJXu6$a zF;M?rLK8m&&8PR##FL=rzd;iRjpKoeteR)3r(O^XyU6to?>8Nn2IKD1T}vHns@}rgA5D| zr_sc(L(|(cH1QHB{|}S~X$R%6SZI0>g8C08J`>6}hSD%`*tkFhnz$LXUYm<1eg&Ey zwxEftLDTbYH1Qy)`wpOqH$dx=Gic%)q2YE7O`IRU(DXnOdHCSC&- zXNA(RaNvTvQyfiP5^Ap!ns_x-y&jr)EHvD#(ZtQ5=`a#a{3JBoQqjcELCr5i6Mqj) z4^3#|0Z@KFl!p0h4%9t!(8Noi>3JoZ_(N#E+lD6Y4^8KX(ZqK^!{-8;cqueq?xKm8 zL(A1yXyV7A>ESz?_%CRBV1b$k^OqWk!N9;Eh$j9G8a{Gp;`LDXYom!Tho)x>G;tQF zdtA}Pr$WoIAT;qLsQP#`aTln6a?r#VL(9)fH1WC6^w5ST-VF_h$!OxIq3L@8nz$0Q zoLP$|?gDlHE;R7~XuKas6Q2W(uPbQcKcM0N5KY_;>i&0V;%(6M{~JwwA2i%Jq3!}1 z3o6HapyHxv;;W$U)Ik&P1ZiYoVDLZ_hxJ49(8Q&o=5(QndqTxmqlq7Yrk~?z;%A`# zd4eYX3!3lVpo!0g@>!wz59Dl+e?_6`Rt8Nx7FrHyqKU7C)|dWh;?~e~Rf;D59qO-% zXyWP6{JRHDdw@hL*Q>XyW})_1p=6%W;AhQX!&^n zO}qgb&S%lY*FwvmTWI1Jq3(H(CVmI1{tKG;PiQzWN~5OpOHlvvp^5K+#)~wXcmcGW z(LfVF4lQrZ(8NWc=_C+M{0UTj2Aa4PwES#D6Yqh>R~MRiAhg_Af+h~@KWsr0pA8L% zy=dYvbFQO_ABU=cjwW6Rwf6&>ILsU_=t2rmvIJEH!q9jZLlgf74IdjcaS5osk!a#i zpz)Q6L%ak{ToGz-7n-;pRD2})ZTw+;*iwDz#s}feF?Ju0pwrUyn-Q` z_*JNXebK}xLBlf-O*|BukNVNXk3rMJ1~l7^-$C=sBQ)_jPkOvtU7?jY&1)=sjqlp_q#iP)~-Jt2D5KVj$G@aCxu!_+6DiMv9>zY{Imx05PA=f}kf3yO z3>rRyXyQW9^dpBR4oeT(XyPz?jnKqlK@3iq$8dQ5s5s0Vm|1_ {k6 zIH3%XdT7=H+baPT2bm8F|1_utN@(Icq4BPRCe8-Z2wL|G6$hCQ%8Ic45)n{wkTQ_@ zu<*%)io?{y_Fc3>#nIKzhKj?~Lz@8%o1o(8>Q6w$Vd`Pwa~~>>uKpWT9Ht%|I1CI7 zoEi`ox_W4EfXfqTmjkR2W)HeKF!zGQVQN4cpxFasy*ILYPJjW7 z&=3)9eKs^Xz{O$vnn3H+LFR${1yY{|;xI5UK=u_u`avM^I;gl2l!mFF4dt6bX_)v< zDBlW7!^B@f`F2nmCjJM?hwWp6iF1NH$iTqh29<}2TSCRX(8L3w;vs0_%~0`3H1S@j zcpRGebf`FN-v`Xz1yJz}H1%ts;<;$zTcF~weONGaVEwytH1&s}>S60`Vd}3##T(Jo zKY@z3p^3kNio@pXVCH;tDju^FR|FY&wk7kYxR2;T{0;XOC zD!vj;y$)1-9h$f?R2;Vd1!fMc9^8SZ-Uq6FFPeBbRQwQ{csx}6IGT7qR2;S+1!iw0 zRQw{E`bMbuH8k;lsQ7I(@p({j*uEB+`LOxlr)cV7>t0~_2Bv-&)SUNd>JLN3Vf$lX z>d!;Pf1;^>2o?W_CjJ5{&J0Z#FmrxF#bNtwVB##$$^^Dv4<^nF6&FG?M;aCh_%ogiOY02Ko5l#EX-DoU(`3Z$eam8QpM z=B4E`=t0BH<2_o(5g9(9#n?YSNxO%8W0kr)E+y4a`rUlspZ8kH2+9DvOp!N(% z9GbjALSXCw5(KkQ33Oo{=-xzJ`q9;+^Fe#^L1M7>5X?51{jmBQCJs^yV#8=x@V;tD zx&?{D@E)iFXmb-LjIq-l6mHnUZvs@~2dGX^_<`aGJ^Ud1x*0Hb%71{`4~+(>DVTel zLHpdX+1~)!sLoIU)d{j6WH$(dgkbRpN`auR8G86jfHF5UZb0f`7^WXaCqVa1g2Dl& z21NgW+7Gh_WIw3vgz1BcmqEiHzCjhF8MJ2;YCmk;94d^ijG+*R{Q}Si^#omrPLTbe zt`xfcO*rg70PRF9fw}`?3Su8Ej1Ow3fujm$FjOJ~y50bkKA}Qj3QZXUsQrg6{uYFT zl{3J~XOR0rLkTebuXJvq*1g0P6|5H%=4PX*bgLi;Bw+svnHE7~6 zE-W0b;?QpaDp(m97&gHaLd`|j4{9fZl)&mos4|9E(D7hUyurjkG)OHn{SInBNDLXX z!8(x0f>_jo+KZr}542>;zyZ~d?k<@7VaAFvg3c_#EdMN^`eFOTVd~NK3o?Sv3t?bD z&;Ki+9XU|?2I&Qb1852vrXLo6pzuImd)uLq!U%hTmKbpLn!h;%|xg|Ns9>o&W#;d-Q_u2?AT?x$g(W!1|Y3 z|NsA=0E-XD&OhMz2=(aviX0~{oeGFZ0oPj|o!Jtg2=VOBWq?Oe>)R4tk8W2E5A+D} zz>E+g;sX@OovsYT#m7-_e8ku?c=yKGf+IxBqxEg6t8b@{if3nx3WslJi3(;|dSeCGj+nB6du*Ka(Cj1bSxHy-E_@)jH+;h+f7#vLJ=|Ns9-jt@|h4Gs3_ z{0z?{;3)FwJj%a~xx)R3|M3kKa ztxJaFA+V8Xc?f<<82)@jVZ14U;>{Lsym{b{ufx=guXs>=8RL#GLvVcU`p?Y304>yl zJvx6wbDKxwn+z5Ph7^x(7FAHY+oQ8ZC4z;4!SH}jZ;DEQPv1N^PKnHd;-I$wBn z=BP*-wKx-hsiR^N>gL3r5F=8Wu)<{+6d8 zBbtBwFMaOQTchIO(^;cp;L-e-pTGSXSmrMyf2$$LU;NuxR61N#96WkmR2)GTS@`rO z3mjtr+hyU?sqE8T0@DiW-*`0tW#n%u0~yl#mcLaI?7{~go!J}^2WE4?OW1l3%@-cc zKUnzNte8ROG5hqEvU*w`;co#AzXCn?9qALqcdB;qw|$d=QoI8H}lJRV6EUp#Nf!k zjjh93;AJ~l%z?qf@+#QL9{ldF5V71Q_3!_GP(tZA4T>q4Rn-WqTvQCemgT58fNg`O z)^3nEv_Z?Gmqo~J}MkYkp|**v#5AkEJjBq2c1$ z{Ewf%ZOPyN|G_>09rfec{7;s@-Sz+f|NB7;V<5qMoJ9q+y2zvRAjq}Ne;G^cJv#q+ zbiVTFJP%RPdGIBujNq4txCfN`9{&CR->38c%R``0?mX_%dVs(4%fJ7S#s~j4_729E z%>O}3Uc9^xR{H#dE*ZInkf4h&!zqC#tfqyTL{)HL{ zEpWgZiDGvi1>Y0s(Rmn!o&YK*AoY)D=U2xNP}TF>@V`gnn-dIZ1sQ0B9aNBQQ3183 zK?Rxv)cP6~4N&6OfO17aakLNA&;uof&VyiKpU&?-ohd2?U=F-|(*h-WaQOz>uL}yZ zR(%#w`St)@?0EFns1*2gz5^8_5RIU;=+j-JQUNOVEI?@wQMCAI{_wDT!QZ680?J=L zDg{2hTU0<1H%iv@Ak-w!0T0uGOE2LaFSx)(m3#^7LJyzkM;4s|ftc#qy}4v)_F9=!peRp!9`W_NKw^4CUX}0#0L~I_TvGq?Qr>2^^m@aR0~+xovm)wB6Ow7&D{JO*l?cOLfv75?CW1*sGO6&=ksDhwsY zpv0wzNL-rW_yi{|kQND#P9JEU57H;$(e0xm;A{DzL)-P ze3plb-oKmysV_Uf!Fo9_|NH?}ItTbWm%$3VvI)W54zMKUv)?L8G#mmp&WCE!Vq27TOrecu76jXme3R5v? zVfy+nyqg3oDZpU{CQu4hc%ca^L}4_nFm+Mk02ix}ekY_n1sA4`Z#=+B4>W9m+Ag$U z0<{Z0x{W8>r zJOt*!GjHd6&(0%YA#llR#t5phpOj?o0*z64^nyp?U(FXf?76G^T)NG^~S-8XVw*k$gbaHuU0LX!p*u^9ZO=Yuygc7%nOb z9^Dn7k`A0{AkDd#8^I}yVHapX3(YcEICyj(g9Y15p8uc(>%ahBn~JW!8*GKc3yg2sM2pZjP+o7BxmID9(agSA6~2<%1_|ALK0_Niy*QHW1p!_JxoH6lQ` z^TXk?)Z~)*fO}u@s)_Nc9`UNa@v6akB^4zMs)-7!Aq-rupi9iHI2pKtGpkaq6d1Ui zGfMNatrQd(xD*s%VhReN`?Eo^Aa}YJ73CLMDHNq9rsQPiWhOLQLQE>oEA9qo)05QNu;dT+Y zS?$pcExsWoEm*Zj=V5HUVQ6^=FIYMczXtoaz{m1?i6E?ffz+_T(Sn0|8J@Vib5uAy zyWL)Rbn~cy8=pMP(1O9I^FO3i0k>b_-oe^l?0o&Y7vVIBZ@@ah1UNe|{Qu8r)5F5b z!0?QP^)M&HMON0`oD8ek+L<f zWnjo*ZDwLv%E)?yk>N6<0RzZfgQbkD3%D3gF|)4VVtCKYx`B(~7qj63E`~L%tPBkE z*jRUPFHZVCsT^ip#hf>L+2@EHy~cj)>gLTW z)62}x=yAW9RCY46k#*Xf;y&*-)pS8mB}a!zT`J5TVMT5Ntd5Q>f-bDCg2mUmo4OWt z9I{@xdskIjnd|!d-`{<|H}`(NU+ZW4JPR>zeG+r1QYS3UjI?KbKE z+nTKhKTKl{(llb)yXQqky;+AOGS^Qt zaJ{wqx42hz*deaW^$+b8-kJ*cc~|THXU)u)s}H*st?^LrbpCIB{fyh;THm&^UfAd6 zvgxyHYv~@1TfMd)a`wz_IpeNhC9o*L<&eecc|x-F`b_bRo5Fgem!>XtbMd=ks>`-> zWuV}U;$_OSWD?&PoDe+8$8Tx#=EEfAX|je-K5Rbh-j`B#WRh~LY~d4)Lwx($g#)@| zJNIb{%;q^;Etr&H(_QG=Z*-zZH^t@MmPb(<*P1mAWji~y4+ySYD_q_yy+Tx5wI_dp zPpkO4Tp6*9Yld-(o7WXiJo8I!f8$5vnY_Iuc$^ZVPuF_|b5OyEl6A#h4V8yN%D178}jSJ7r(i z9fi+56Ak3fUhnBzc5~X9>%D=?ek#n&m$>coS!8B+o1Jm93o4$F{aR8uFHAL)_tbv2Nv0?7Y4Gvdf7tXO zUi{y>?gJ(}&j#z{h5z_I=}uCub^pbHlS}s1s!w2b>gEV{`fbpEA&n_t`Oo&n`}&!j zo!@zXuvguAa3SYe>o~Rxs$9hS&z@0v+{@ktUtIz>u1%JC;iEFDoach zFFjIUSmXHUyh5Gh7hU#0uO{{xNEqKfwuQaUf4Lmrb4R{(o)7Of{?N;6o3Vew&+dlp zPNx=oz4g@E@={yl^2e(( zF3x4S73|Jh?6hF{F@0y&iB&>PEBr6nB?Rr%__t)c^$qFCwaxjqM_2q%_k0qVw4mQB zu+v9ee7Vr?n9d`bk@rs$b@kF-X%Ekp#}ECHKB?yQz3-X$qAv|Eo(e=w z*8DNWXT9RZ+ZVI@9+@irV*L`8SM8eft%iHu$rlbgmR*z<*(_8s$>W2U|Gy03Jz?iX z?=XAjSO+q6<%!*_<~sF?O+lyYaj=&0?Nj@1@Ga8#8Ze>q`~vH(2M<+cBroz+Is9JI z(ob4%Cik2(PD`?N+M83KXg&#_lPkDprO$;NwuR>(^~FzO~+f z`|~?dZ+`9DDr|QRBf4#qPj5OBdHZpc!-=^rfi=6{ywK^I_H{-oqr7VP?9@2jh(pQy z#NGs&^X@Kwn5r#xbMwVB25b`|Pwr?wbLyCFN}ANqXA2^)dMIz66*%$CD>q%EY>D#% z>y{PvoQXR2I^~+#J>|{oHclw`+S8e0X7FrMy>qhW%-$Z;6f?7J6K`J0aNCjQrfxJ_ zy7pvFVvoY+sUJljMoEXC%t^kZw0Ui!!2Z1(o6hhZ(=j<6YHBty^6Za1y;)a#PgI7b z28Jy;!B-V^Tq7rC#Y=&}NH?dR$jz=>pU=v*xbh+S!TT)x_{|Y>XP8Rw5s%cl$ow;8 zqg&zA-n+FMS%0vru;o5df6<(^lp|ud!BmrLzXY;t`3^QY(x(zx(L(YfVOKMeFAp>NEZCx#Fm=Qg{;X=JQ=21a?^=rs8k6szxzZ)Pw`^J1oMVQkJ~)Yls=L%M=~1|XdEimCDer7DzBsIXM6|EF0oC-#pJ; zso79_F0G#7$!3OctVzk+y6!hFJ#KmP{p~kR2ehOP{JW8Moh9rq!?*BFVPbb1ubQ8m z$(g+O_Vd#|Kl(Os2ySlF*|g!$3G3%Qm$m+>D9(QHe~R$IsJvTIe$1BI&QG?T*UkB- zs$kD@B!fp>g01?7OOHoe`Idk^ta=WADxP)wd{{4@FKXY#!^}0KLGQpDajt+9EItg+ zcsL_ck8j_y!MK8zp)5M^!T0HZJmn9sp7ra(ZxILmW2+;VD80Thm-D0Wf;`V98ywGy z1pH%JAtuyxW#xx3u056x?N6BayL{YT3)nbpHCR{rB?N@CZV_ZS-+E!)fohEppBeT} z;*RM(?yy^2anYX-FQ4&G)N~dNU}d;6K_N?3!X${Xl*vK9zC)xp&|xxzfp$nix%Prk zh8r?kJ63YNaAlaoDS9VpsZK3xL%htvl|MhsXzKB9*=`re8|-SgP9d9dRqZ0Ff(y-Y zOAoX&mlPS?aak8UfuA|6HYso7-31Es*{@{pbSvB3^hYY7{)z0(TrQhY^#m4yn&i8*f^#^}(9aN?9UL>3+a#dxzZ9)1y<)YoB=BU^PEGMPK8D zb_199Ipa<5wLds9tQFufpEzIh#IuH1)8<5{><^oe%xG$Cx&1_3&;)J9t?KVj#05TB z&iE^?e&7PWU`*zWUXr6@TV@Ij3T>UUjegzx`@|ot}MNvW@$~A6?D1Gt!=-C;r%GO3a%2 zOFF#JX4fSKPNUym>^yKnv3Q|j;Y7Y12=(;TLj+WW2e1#_e9Y!=@G8y>p~dS14Se(`x(g!aV+<-IL0k)l3~tdJBHVEt|Mx-2+Pt)_B(*J*OX!`wW+J8cWu^FHicG z@FZi;)$dg%zcPYNKX1S1^eJ4SJigZ0_}g9HqRR!J&X?c&%+_$IW1(;V*Vv99f_HLH z{LMS`&vn}0B&J`prIv-(iJDei?B4gd_O#Yx?zomWuQfj(3R2wrK|JH3V#596BP+S( zav#38YRq(yUOxHx#+utn&z43pS!-S_Z>Ton`m^iArQAuUW4$TgdnRzkT@~y+5K4lsS7A?%n87r0<=l zRd9)GCf6CB*`Z%K(j=VM3yUb8eRw}i%S$~^V)|{y2e!K=C`+B`Px`0x!1l?LaP_)5 zcTeAD`6C--yZJMxAQh+atT+2xNc^ja%r2TVzER8D?_5IjDqw@E%BRL!Hki161hy%Z}uwx@&?i6h@v!L=V=9f`-X0FN?O-*hvU%10K z^t#ATR|h%X3D*z333<x@@_jR z=9t2;K8j&~)1iF+J?j|%__W%yRS2uhKV7Z-tegE{eQM`}uxWv^K39SpEZ#WGY>-oX z;G3{7`q0dy%2PFBSnqvp&^Tk3TB};98pZLH+t-23V09$JNLdTh#WI_#V7F>x93?*8!N`Aqj7c>~olr&74*7xwc_J^qqcjKbCbN2c?F=DM`3P|^E z_jnV=TEfX-?!~@8uBRr-QSH!o?}VB`$CHF+9W1~UWSw3Ej7tF%6BXZTe)^UkN-B~5!cSFG5i_$hZ5lNYnY)J;2| z-u7a>$rf<;RGWt8^TTh;a&;Jm|_xv)JuE~je$jp56R zmc_n*MWTZ^iaV+!_r0GQu#fG*`hyE2j+$NKQ`l!y^J7Xlvw`DDt`$}cvn(BYo?Krd zqwJdRz_TG>*|cR7%a$x-%J=;FV2O7B+U-pD`7T`Ed7yccNub~#rk1=`0iK$MZqb>4 zL>F9JEf95VRg6eQalX^8{%UWHH5D|nIHV%Hba#Si;aQkeGMad#(&FW zQha{svi4~!d57|}u`gScHbwWcz=yp~CvME|de$7CqQ+1c$RYXr^~6*wEu(10|3Ms* zzl*1*{?ag#XZm+t!04O1{%M~suPH_!C1-^h9S(eWV=G_%&-q)LSMZ;ZldQBY7qd+6 zzQg)~Rng_m^Ak$Xb0+pO+@HVj+T~Zw|K~I=dBW>ZJ2A1e@C_sLQtk5AhmYLY_`VYH4ihFRDbArBn z?(%fq5A(MDI3>Pj(w|#ge@YwbR32_h+R)Y3w1;oSic^kVzE31rXR@u(658o*G4ZlU zinPPmb#tO$_-mZ#Y^XA@C=uP~-k8tw;$Mt%wU6UI#ufd=y>Bd8e@ZV{wEBtI&3KU% zs|8shCyh5fY~y{;a)I$+fpBDiqaW*)Cas;W+txJQVOf!0)SFYyS}7I~|4jDgKCYP4 zSGL?Zb4SVA&v6=K$XO7}+p&!8%7HU?ly*lt`Y~U*^x#714`Z$xb_f3FQa6LSKFK=N zPR&ly*YXGqz5Hm^GqIb|T$^+jyb3>Syva~b`X2Lw!_5!XHmzvd!ymvOepYwWRLPlb zC+0R(#VIj6=b!S3Vk%+`m~S~LwaH9#fjxsjyspPwuKK{n>C73cV;(q8v|P`@$F$J! z>XkJHj?+ai{AGv`cG}I<|LxWXW`mxf%_{41|s zT{dw1DH2f1V6sL|$(2(}`4`1($T*mS$I4Vp@<>1?=Da98y={(3zwOnA5A!+08CpOFR zOVY-tGY{W5CE8nNdZw@HX%=fm(>xi|$L-0_n=C^oXI@n;&QiU@KF6c0>gg_#OTiC5 zD!D!8?_s-jq;^|L={4`uTH5AMN@vbz{vAJ!W&P~ccX}?hG#z4{*wwV(J6`AJ+791S z-HCHlXNP%(<*DEN+ITsnsQYVf(z>}v?*-Me2ri6VsFmB5lvnZl%7(HTDc5?XV$Sze zrY*M6x_(ddKwh`q--&0~#jV*R{2b3UP779lu5en??cBj>#*^ka>!j;gwnv>)y6tlA z#Kfp)8=8VDZBOkw^Kna1n8>=7nMWVK?>hX%Fk5PKR#Ulfw5o%lV4oE8O z{1$Zm%<+gSp$}pfOU@n&cYakVbTaBd&SZ;z*>2l4&pAGvv;JBk7F{J#*)s7z(-mFy zO$%It*iz@Ira0;PYKNR=(dzCqzOQb^8OmOFII8c6aa*{=V`VYh#`(=Nl+1pMZG1U* z9?zPaVzWap6ra@5=O|%+6%l^=QSNe^lWUaTc$|44t1?s0cAZmf@l&rf!Mpb*<}>W> zdevFVD0OmO(k}kT;-}Y{JX77Q9sAw1M!<{Zta57DgWMghS=mume`1dsa-CUqW{uQ? zSpA03`H^!ERxdazlsh3{o52dk=67rdYB(3AuWyht$}nZv<}u+={+i1Zo_;=1ee}`i z#YuI+)BX!o+_y+d`V?*OU+u%9R~A3Myq$P6YC8Wai4Wda3)M_!-z+__yI17BhPQBY zmB9*ohGSNaXLEh`N}7l>^jkWn<^l>Bt2|zJbxWvt+^HFJb?#3+oo;sG`}*v?@+>nv z8{WCxyw|O9c5>RcRLe8_++SIJ-e|vhThn*$(&Ebc^3Fu&g?4|Pj&!d3x@JYJaHrR$ z`gBwKhOYa8zG__856pP$_VCQ?GyTjTr&RI%lY7)&_^<2Kfis&JZUxVI!;uzr`YPYd zFJDab-FDdBth(mhrT;bV;`Z#++=S|S|CAjYuc+M>tlTtjXPK+O(@(N)CX+IBE-Jaa zF2DFf-DK09U8UK-bhlVzbh<;D#I9wtW!oDc7|Q%xCv!$5>2CI>WzFCJigm{)+_|zy_3WaeZBh}@I@=@~ zAN|%?u;h2iEdxuozefYrT|Qr9@8@cf{f?2?S3K$jxTEsf17b8q9;u~*=FY4%EM(>q`8QX1L4iYp~8R+2E~e(g)VyqkNon`>WEF*%*$sU70r0O z&L`<^(-%SKyT^}ISFZAs=lgR~Y*x`l({lC;f-Q%PCAWMO*nX5DQk?17tl6P1Jnt8H z$ecWE@cZE7)Cm^qi;a@^Pn~gOuGur859>{N&Ye0kKevZp&aKhy;LJ%ot{w|vth?*h z7sI#FXUe>{uYJ#SJfA(+@%LY&lMkP9-j{2*mb^ED;n|^j&Q~=&T{9fo%H&0lmU*;o zb6CLMxcgzf3)6karWoTXk#j!AxfBGvf8`axmi0sMU%f?h(hECLsn!cuj$LTa%5gf& zF?GALNaqZ;1Md?OkNh@rTJu@)+Q}arNA7dp=nPU{toHKLZohtB_bbT_5vqZ6c34VY zf1@LFP^sf$@?DK0t~KJRE)x{bU7hauCG=xr$N#m4er!<{TRQt+MLWqny2CTwz3s+K zQ-!Gh(uHle6fW=bEVz^&?DjPK5L4Bfz6Xg6GU^AfEKT0)el@4x?Zsh+>N`!JeouTa z5|r|e@t9)w$*F;POV_&xZ+-+uAf=l2fpv`%e1e0}CCgN^b2E`eR$8D}={>1bqc zT)Lg(g~shGB7t`PMbElw?gPcmbaZ(0q?}Ctv{aJX8mzkwe6R0#HyCRx)ZP7 zc014XB&hRP%>$zo2kOiUtQ+_|6>4?04ltU1uxYrrxk0UZgYB#j!W-(G%PdpMlu+Xro(CXJZEvkD|hdJV^%51yYo7{wVtNtk4XmKh%_}bh}Tmp+5?bq&9PJYpw z_`pK?heX3S7UpIbwVO)I8R`PNE^KIL+SA^!V{>GTYXCR5N1Xi4n-*u~lDrrLHj15F zGb52bg4=`nWEj_<6U&~7*Y|$fxWjJV+ti@V&!T59msSsJ;d8q?=U;iIY5Rp$OH?n! zR&Z=xbo5Dy;yKldl-U!T#U@|wv&d%rrBrn7meJad%`!Ik+|L!wzT9K6@xqc=XTB&O zKiO%FUpMLo9^+H*wn#TTb;7Ybto*?S&ZuK@j~=XR7ZYp0S;V|$f9L_W7lI6Xg#WFJ z*51;!F~2K+k={>ESQnZY*N+Y=(G6Y zd#x76%WN;aC0zB@eDfOq@d-3*Z0zH`z}p?^y3S>r7kGQ&Y-ZQu<*A z-<#ia1&*`5FgtnOIL-4FV#{Z@(l@pl1{GKGJymOX$y>|8V!)MG+>9Mm|mRa6m zNx6CL#(Bq&RtcNSEfc0iZG8c|Wx_m7P8D_Z#qz!QtkWd5<_c4p zWkSroDLOk(Gs-W!bE9G6GlqQ5U&k~qvdym)uY0!jf;wkSRxsy-j(~H#F{>k+IITFh z1+nHX`PLI~)jITk=c@TP9)=G~*rYmQb`M^m<%M!S~Je_>@&alCKelLy7S z?)*J*(3<%Uv&NNjg*p5W-oI)xOgd-q=nuob{n0WPuczJj%#l&hxp6It-{o73SAVt9 z$J3toHcSnfBDT#?+qArY1>5D+GwH{FEPQ>7rFb`|lSR+ZCCM@`X7p6K-Cn4#a?bg| z?mLerLsAeJpFF`OH>NsP<91J=3SSpHqEx z^rHxmY2uTelbzogJ)4xvaE)c>|QE|Oni9xd*%Yjqh zvYf6=IHP;4nxWtX)5qpT7v;Xk9=gA1Z4H;OWUv0Q^oD(R>|A~=pZ&7^yY9l~qwbt+ zq7Rg^>-J4!b4g=w7rPl0aJ%0>^m9^fmRz>!(PDS@*98++hD6@7kcn&Do-+9chy1>) z2Tc67n(I#2J*{}UNwr7ksP5^C4LpYyl&t!HC;jbOiTttyyI9-xXOvz{i*>t}UXk;_ zBdIoH^NZ*MwINfEJ=y#q{LEffr>#~^3Q;1PN|%cAO@HmYNNJx^+>uR9r?)j}?$lgx z!{E;<-upAS=NxalWBA2Np5=nzkKJX8?PdBqJ_|qB{qXn1qYma1&%W%{;<~WA-A7Er zlj)t`ht~Tig&byUm3oOBIR4hPUQc-DvlpSVA6~wgQf;SjLRm?Enn1q0W=@@Z*U1OQ z(OmMIC!4oC+9DJ2TJ`r6uSkWn`tgMVGnUJIderlGn@_?OcZMG)7q%)L=kJ^N-N0y- zu}#OhgC12*GMj!H>Kid$yTNIjd^~?{=PSmJheD+*woldX*_E*99qSQhF|U^oB-RJ{ zKb1MPj{V=dbA5A^62F&*IV}ih_%Ka5NbSV)O^(wU3+@W48(Tf=<9hgdQD*CI7TZAK zs~25D-yU+_&?QxO>$vM&)yr!e*o~wblQ<>>PHW+;i*%8hpV;VbEMfR4QK4V?hb+tG zd#vA8rZ0W1`NLj2)UbTnX`wpifBD{#d@n>N7H-)tdZAfHAnAxa$D3C@S3Lv2wy@Y| zz1z;vqrt4Qc=ghmKeI(sbsMk8X(j&)bFH(OV95B%Uwh>~`HF6)ANm@9)*iSmd!XL+ zVm;RhX~sY1qW|_c)W{#G@BjH_&f?7rzfXSqq<+zd(+v8~pLROb(j!7dN*?Fmx=vc}~Zq|AOj7*#ozw1&&6YVrw=&P#yf~rSqYTBb&wI zo4<#q^Zcxo7oK|igwpKfzW)pXA}^L@9^KtKp~5rdy`Ji^jVw&A*$OxBo_TOJX2vmv zS`hnXqWXP;+8?S|Pt>3Ov+TrthCP~h=cc|a z-z=cR_&;>onkcV5&mR5Wd!Qzc$!;U#QQrg62li+w@)}NCrVW?R3215^}yyZ;hUZn-Eo_5IyD8AO(YrUZDYta4RdDhEJ z`QBaR`t&cZ&rh6LO{<}o(7U0Qx@H4~{`zTJ|4!$qcoBVHv!C}9)h_n0O{HN6$vGH%u_hVj91%iXOd=v5ixKC}# zHxsL4i#cvS4-&Fx+xoE9aOLVXYgXINJ$F>Wb#{x@CT-=*>+@fnP`K0Ob4$y$U3Zs~ zcwmjC&c%+Sr%u^?mi%V!ZuNI@_5!YXOlvn!_bM!(6J*7@PyFHgSDT}P)nqGr_W4ya z#j*YK7dv*v+-K&@HIq+mWlQ=Jq0bhwW&X0MuhUn$vYi*by7N>(ah}k^wT#zR&sS#q z7LqX6zje_qhd&|*&hakYHIb{=>4jRu+YJlUvZhKkdbrGGJi;Ed(3bVUk4sJm-4*`v zA9-f6_1}@#OlNj_xGZH{RMKaBxlOxxV(GFC97$gy%)3fhUnh9GC^*mTUK1RDv|X`| zFCyH-<`&a)rN7D*dXr=qXFUj6AXy`|`uALQwZOZT0UugJ)URc{QrTGVAv#OtS>!3J zcLsSLNu^W1I2vkSxIbyj^{rQT=8137I(8Io`g)Why0c0w;oU_ZgU{ZZXW1UGR{6O@r*(e7 zp&Bpss*cYG>iG>nn`fs@otH4raoK-{fBPdo#V83yg)bIzY-m}WqvR&ibYrSqhSsCb z*e;(#T6yxXnARV4a8KE>$zMZZ&6!vHe*(qSu0Ma{s`0$q`P6q&=CyLnw#V3VpKO}E znOT&#a2ngk$uaI8skI_TD_T{fmuI-+O1u=BIbn_z z#|+UAVh_bLCuu3O|9^U7e(jcR2Y$-S{r(h|d^6bCZ^xzIP-K@zk&8JY7T5(pL zCv28us;AXl|8u)`s^ z=y}-bno3%W*iFG#20HIKYL&mIujm&&eRfacshhXHL@aOe&wcZ1=2C5^XL*;xR?R5L zeYh;~hhpG)6}8#zzYAg?bEYhA<>-ICT=t`oy#3!3iz8;}*=~u;$i8ADrhi7$>sy&! z40l6)s^v=y|g#Nf&>3a`CPI6&N?K=8Vu3l|BF3lP8|< zVW@nZ>+tPoz_M+Xp|lDvesDU?zI&*w$8&{ZD!f zKCkA~>@OG4+?ZUqMYq3PSo5H<{h4X`rbaG5Zf^V2F;Vf*`-Ic>4|w(m32LpKT5+&g zHI6xV*F5EgPt>IJ)-N?(Y%*CbH*xRU$T(%3tACFUQ)j=w`>Ij5OwHA> z(^5|!+};{>O@;mbx~rSSERAji&X$RMv%qRlg9YZrYee4pliKci;qyi|Al zuG@lTU;6j(8R>si&J=a*Z@G8v+Sir?MXlx8n)-#W*O$syO?S^%nRU^>Ye#J1+ymVI z7fn`8U$pCP)_X^ht`%d$!x30GO;#% zzv#)rwz5CFw#Kcw%oV_Lhl63m7jqfiJ>osiwGHanjTsV26ZS*N0&fABWA)}^Lp5P4Yh#>M2T6*JdF9+@TIHPx5vdV5es$D>b8!CjAU z-gMoge~c~tI>XKB8Gi*E^Lk2G$+{>$DlIDO@Vb4!O2k!c{mkG`;Sawn{hX)x#4_)$ z1%LXT)TfF!rzrI@t$D?vc>S)ZQtM>a(rbL)a<@ztPhO+2tXm@H^UsCC2deagMDnc` zd(=$3tN5sZQ$4OT{qq&6XPWyo*VS<_v>QxM>MMWIdagyS=|aU$xxHq~ws)^?N`2g9 zJe^UnX;Ga*_)$5wm@}dRryHb&F6c5`Xui+C=luCVQJbXw(xSO>f{$z+-M=mJkM2JD zm1pzyNohR1`OI6IO>e3%`O^IOYRl|5)0ceN_AzUf&$lwoTCI>9(M!LWFFa(Yz4Rl~ zp#>Y_r(dejPYk%R-}7ad@Rbcy?`6M^U)p7@#`659VpdGoRzbG75Q(@iZ3o50+Blo_ zbxOFI^>vFMKjM_GY>? zvwNh(A~Vx`VuuRf799I1OM+l=zh6A@x#S0@sc$uf3LI21)lG|dj2vy>#6v| z1_h1Q>x-Um5}q&EtIpEiY`H;U_EF!@ftQbLzCOExYu3cR^9#ipem~^>sN-hE*4P#I z=YUYg7q|F554t+qtRGj%v3+ihIV`&_kng%g`)j?^uKh}OtF`7mepmY`@AP7~P#eB^ zZ%tSKQ+vC0RhoD8-Bqi_BEMCI&W}(Dwlh>q+;nut6$K^Nz5l)YvObuHrIa{Dtk#^> zcG=|1O}EFVE@?}cqr|Dv-%Qg5 z7R~utQLv$x`#+8T0d8xvh+KTzl519+`1}?#~jv zEp_}U&uzoLtT0Rth<#Ue;PL*{{D@&N@xWIz* ziRqLT?=+0c*~KJ}bj)wOGaun|HNVz*4??t)`jnj8o5NY-YP;nZotQ95j^Ty) zf|QO$DMlaC+QCkiV#t}Bbu47TSv{l0Ox--J)nW$ky|=17)G!kHX8J+wvP_n&YnzEE zi$iCoqRH6+ldJ3ws{>}8QEEQ#$HR1hgImPl;W1aX(vznorUxV~y}ikFc3Y;Oq3<1~ zOHYo6ojWCQ{D1uXWiw}ITsie4{zY^wpV9x#Qw{UXKc@L?*G|5(H7Ru0+BI7_172>6 zUm3FN^O6Hg*yOi|eV1X?5j<}G;snoU-b0N=&!xZEyr|5y;4 z5A7K91(;mF?7bj$`2N%4J&x7CSoSz}2wrWxGBM$}^b~pKGi-71tJii|-czXAm8A3` zE$WXzzJO*VXM;M^6rR8-GEDbQFPzd7H0diR!@jLaS{KsxJ4%Dh5XoVBQoc}fTGXV1 zJ&qz}VhmDe3s#iwaa^*}oT07ll8N(06JZ8!r%a>!3N>X(!VF~*3mRtX#|ST}3=FUJ z)it+2e`@QU80OIZi+AZYK2q+F_xGIUO*$g$aLjwd;yXNt z8N`|13u;%S?_BuuTIK>^JhZ!%gtwIaBX=S zn5S_gtl_2A=^$^Rz9Q$ue#ZCJbFyTgwwc&6-OF~)oV75+isRmK=ggqfXWbwCZDrkb z`fTE_KbQ8b=&%!5q`mtkGh=uB&fiW`4K~(o_uTT_)2hmQMoi)i^*etK%v1cc!(Y_? zeUqCUUzf_8e*N+fKTd{pmE5-K>pJAlSZt!w7xb6u=vtxodp{@L;n{QQ-T~=n+DC{q59G_4eYq55DRHrrSWUlZ0ym;B(vO|%X>lfd6 zt@SPKD%i7RU!T4We@-G**GRy zZJM%jGGFP`m6Q2;L4+@e>kDF?1+mV8Sh^sVE{L^O>HCS5llj)3yx1t4d-CE$*|#Sz zcFM}0yf{;K?#YX-vbHBLPLSYjs~}lJps4|<(>-gT-xR{~v$IenO#lCh~*N(&d8-q7$ z@Z31xXHulHQTgtDk(iUW1OrzUC$D18J7c{3la;yWOO3a_%DMm3sH;`|ax)wO^B#A-b^*Qvg)6xXw%F+8>U>GyT4nqGIVy`zS?A(4l5Q^P5# zdy_PtOtA@nchk9op9r`)57Ho2VwIy@jGG~=0uA=XMN@g(L+pyxyiFE$w z8=swL+VftZ#P4AKrP(E4K3q0FdRyXc#m5&m6W2-H@@8_Mys3R>lEL|p$K2`)-w1ws z(_T`w@`ISW=>*p2cvYDFi!(=`Tbh4(3Eb>LQ;jD6X(A@JcZoK6_Gkxvy_GcG;+po8u<~*}~ZF&#)QU43f*^y>!!K)HYKO>GS6o`ZtsdRrm8>_^A5RPJlryM%qU3!C&oa`}|7oEtw^MHJERG zmhSl8aVtA0gm+hm;&mtO_iu%+z4n~zB@t&O_2ZO=)S?Jy<90UD4_xj-@3o$KT(Zs= z{}5Mi@W77KVRo9zsgOO(E^BWoOLVvs`A+hs@7dD#T~7Pf?!6TId~LhP`qRHixqP_c z&CEaJ%cGxtZ1di|a9`f|JV)y9g)l+Y4;Ep~9{MQ{ZuYzV{iV>>F7oSq!`Xhns_Va| zY^dH-Ys{tN(CB+D`PJsOA~t^hC#7r^dlWYR3R|wqp{|>fL^eMYJ}|7e8-mRMogy&g!qrhZA~M+q>VzyuE(s>d%ca z=Vz2?rbq1RY!mJc@Y~v>B;|WW;g#YmRVn8y%jeWfx|__)U<$Oq=(5Pu<+Gr#+N}8* zjEh)1mkIc)Ms;K)E~?p-7P#nW$1*|R=WCa{cnj!yZV|b7$>p?wuJ;z1i=SMy1=f0) z9F95Hw#De8mWy#`m}*pSM(LtRmu!Kxo?FB&-r`#8yhZO~mCI}4T!$@+7u{T>g>#*@ zXkJWnnJt{_xJC71m`k*9uJab%i)Ajih2J`CQNHNsVlDjEX^Zy7oJDs#%G7T)XZSDL z+wo29R(nSLqQ4!_1m2#%?C!!YByAFfD)oyS zUEV8M^}VQAB;4VrV%7QLu8X?x-u4$Fi-J4-l&$8z*z1xmFxRt0?Bef^b81%YFJcyb z?l`AjWq*;q!_K3G@nU<2p31I{7fFk}JM>h483f+*_^Wa8c!!?yt~oCryMznGdX|V@ zyy|jYAlAD?_M&=+oo9*dMP3(kp}Q_q%+vA}cTIg^w&-@}JB3}7U+68`-T6-Om&nDv zF5d-fXT7LfbY7r#+6%@-?45S*Uj!~5cA2mKi|L}WOTSR<#21E(^aXAGzOY=J-WjL# zOE+*I+k2yn+AjOme=%Q_?~GIZC46yyXPojc?u+rAaq7Qji_HtZ8 zuKxVs!_MDNKfm(j!rxDpTWw3$ThB<1+T{8D?DH#MFVudv{Aycrzs66Q|E~G`%Qu|A zpM7rf5hQ%p1|(d}f7f{a4NQN%eA&8=WG0=!NS+T!rwu{vNks&>myCF zmmF=8Ru7Lj?tJuz&3=93-CGR{OYSUw*`Z&M)@mvsFnL1D?9v|zt7jb1(6U!3WBIqP zSbNPp$yHCA=OsCpe$tHZ6VIkc9DSnv@B5_hs-H~WUr2qm@wi@m$?m8B;}$Qg zJX-YnP)WF8^8d$apJFmu1Gm2P(65N&3)|VHp6F6J=Wu9~&^({&wJ}RIFC}Sn*zwkj zzn$aocaQk#(6*n;4?JJgtbgug^S78($r9E*`Ie4Xf|CO(*?ubSYLz#4JT+5i-Ki39 z5zkb{{p(r{Z-#dGR>ylUMrcV-LQvLGLZYf~7?LZup(s{i8H5a#ji?vZtFr#9Z- zd)qQGfwN%|jfUGrj*99tzTlqMtnyuCwVrRz ztO%X z?>_sYYkg^s~SBn=aqqE-YZJvYCyaNfE34UCVMtQJ?l{pZAo$6|%{bvZvi z%CRvoU;Wp3fsWLUJqP>!n8R%)b~qgCH?z+(GcBk)+CABV&F@%cq0q7Zx^xzC+ZVl$ z4!-y?n}5&J)f?V5+)sFOYWWu9$kzv}mp6ZvI(a!RNUrOM?TWaP`9?L3nW4(}cRFI#tG z+V|PF>tALUP5%0EjpS>^*BQIFi<|$Fs#vm1oIl9_=QW>uIt4l#m}Fab2l3wFdF5(v zweeQ>?u1~yZ>c|mA6TRuWLL0ZJ)eL4zGT7P$5%?03EKH6Xl~CkdU5>fp72=?o-_24 zi~0Dv87iBDGL~;XA*J0Oyvj8Fqt}Dh<6;vknCAV-dN7eK?u+q<=2P9ro1`ngZ4&?f zJ<#-0hC;8lPxRt6-sd8^KFgkRF+Y10D0r(#+b3@S@ijA#+)`Z}+)}e#bc52bQ&QaZ zVHu~^FUjnh`t|xDbq=A|$1VPLSg3Eh{)m?$zbhO)#?+O z`*!>DJpvKB`+Q?=@kige(tUMx*7a8pyQg*C&JADBd*^Y*|ETO_-AZCo4e;= znD<{kt?B;P+2$?#*(7r6{`P!6xt%kcmS;63^H@nO>T*4Fsd0Cu_L|eh<$7BK?kOcM zog99vk8RuHj0l~ziXR_t+_d%jL!}j^X@MTf|GndWh&cVXoA%$K=3r1^_y_OTpYGf| ztr)`X-5r@}oprPCRpL*9e9KeGE~_RjPK+=rGKpU~b5~v#(vY8)ANDbzlX-{pz3m(?436k?9tbw*;1u-4PJg?-5jNT*Ry%d!SBJ=ygYnr0n;*V+<1DZI;(PS$b>aCTayG7~f}NLK;ER=)duJ`p9GA!% zaIcDGV)f^X(sR3JZ{W9EnZmMP$y+Gm=;;r0{1$c9+rF&n`eKn3cB{YH&))B-?`_s= z+TPziVh=N_ic||%_iua8^QGR4@!r*jqenN^*sJ37rp&AZpf%TKxVt#itykUL8Mj{iEa{lrGrIrD!`*s!RKQ9>x} za2XG;cZh6=$(E3q#ITZP(Ye=M1vg7c_V#s^ux;e`f4GK2BD|M3ZBy6;9l3auJCjQN zdo=zo4ZU?ISgEFJ$I}_d_|EpX%Po22_wBg3hV^pq#XFvR+pl7(uHUfyvfZnYn0MRK zn?(Ymt?=9?7&^e5R$;^?)bGABLR{WRn$mzxzU<{B7%JCPE)iEbQsbR{C^zQeT=9 zpXJ|Q-(*)GH5K1?cZZF^R~eD%wbH&XKb)#k*3;W4Fje1dmgv6sxf8ouCmKA^SZuW^ zV~eHe_kYLpxU_zG2a8sRw(Vp6yIp9u#>eEXw~D(j>{ML2L(Zmp@>iX89Z42xXWyO` z4HOhlDqgu$>D8lG*=NPWSnL=a4t#x~X1w`a^vtKxDqJVdFu6z0RNbd~s9J7+XKlr~ zQ&l4NJ3U{14CwoHyZg`$UFE`pkmb%{LDmip*Dc$aP45dg#RUj4xJ%Zsh&UHqSr9E0 zT)49ORoc=wvppYeI=}Ko6w|&lW{=%(rKySr81p_%=6y2BZ?#t78{apV1^(R7_BzTe z{4Cn3f{!WXV}kC&q(Cdag9n5I_ni3t&`|xg!Ij*w75on?)$I02KW4b`C0zIa)Uf(I z`AH&29=~Tcuy5WkeR11&|Ac>PdxJkRe3%qH~XR{-tE+1gR_^=kC3* zPuU%G`h-Vt-0@f)rPZ@{bca4+oqOeP=kEi}6Bi_IIjp+D;zT4L27e)XLqJo5FXj5kuO#u)#+t>4(@sId||G(Zg_IBy}E(r+y(5uBZzy84WdLFi`SG{W&TV&1X7xD_SwH1@S z^Zc{vmE@m%yQh4;ZMklp?1k#~{nDYk=Q|e(ovc(SujN{DD!t{)+s5{|Om@A~cLYNw zy?eN84)=N6MK-Mu4;O!BTW}=Cd(l6s)xYfC1+9AjSa01v-Zvc8f^T2n3AlW%!L|O} zq}-ium0Bs40{&;cBlk25f6|)qKEWyA%wG1|+6ta4;wzqZEluUDHQK-VuvXB81&8kU zD(G$%+Opzmd6e#}>a6Zx^G;0QwXl#X=9=y>&*WyOyp8o#_e-nfzfGuRc44x$$i2f? zv8S;3PPszS$8!tJlkyt7x7jw|R<*hE?83PP+fp-EC9Oa8USnSN=T_FzIcJLCh@|yn4=ah?}MU5Jl-(aeAk+{&GzSq1FKUW?ACe{w5i9*Ct|8kd(6)dHJfi8 zxOV$((5=*^oKBH{zA_gZ{JGn)ZLfNhWoXs!4{=-A1MV)1t^c%U`7Ew^te+*c91Oo} zU20M5=UotT z#OY}5w}pZqCDdQM;JLa*th#B}YxAk^e)+yz_xnT7%bbQ?MOP+l3E88Ua(LbW#h#hf zYjn;Qa~#e&@o~-4{_ibTUY*s)-o~^(z0PZqb;Diz=ZAL5 zQd!%UB@}QRt1^`ZOp@~x?mqv$MR^S+ZWan2q^+wNKU`yUX>vdyZsITI%%HI<|;^snpSr z)7d^~{r<3}*yn4hm;E*Medhwcn={N_ebr9Y=)+D{!54l1m}UO03|Bwk{@>2{#EsqD zkJcq#j+DIg zRZP^!tZy3?-W__aoLVe)MRUqqsS>WIvTqcvTg%^sTelu}_{zTG-;>K0cmA39@iKng z&wQlYZ)@-m+Z~6$&t52gdw%tD1N#qJD;@M#onIT=@$m6_S%&I2$2T?otdOmh7n6|t z*QTUwZ@I=#(e-@)_gbmqZ;xLkoLS`lahmTIhc>2k+Z!?L-?e#_p9VcTQL^i~u_%A% z@0|K~Yyao%<=OtP!tn+F3Y|xiu9CfZD(}v?PrhKcN5SNyq>K>nfu4&(^?EL=r`A?D zX7C=_!hLP?Ru13pC67K92hZc|IxVo5=~%0mvV~NEI@k6Ocli@)=Ptb-@5Hgo^~f``5ob9ccK>z1}7Y5%^uwztS!XXhuso!!gkJZJb)|KR<< zSxI+?SkFBVya#$H*(Q>uwR%(?y|Ll+Z zxSsj;n0xKG?-YN3j)})V$AEwz3l=$?Ts(VO0o#Yw2k-Z0oHdsZx+?K>ldh%A>(D0x z-TN0N^ttUkrXn848OOh2=QEiQ;YnS~W9C?7xY>pYcUAHe!@x)-}nwnKL{s{)_eqgRaAAGr!Y4xaQz(l&1LqWAhU%S7JmGW5l{CcaJ; zX-^Mb^mf78ybp=1+DvxnoUPUOk;lo z{u2{zELrpHw1m7$l0Pv`3cd7-@#e3q@psk>b{nqv^E-5=owf7Hi1lH2)bCZge{d4q zs&Qwzm6~Q>&+Avl>8#paulJqpTEEUBsc_Z#UxikO?+a*F^*vf!9xU_GLNw>Eg|!m@ z)Lp_!FOJQO|Gq{2!`C2#Z`Ix1QXlrtb?EH5FA>9F_fhWH61lMX_wBy^Og+OP_RGXC zei@fe2&+kq&AJe?JlzlNp-biFKdI;npUjl4@|At-Czmx-UF{Z%)_Ja-+Pq+*_T{_J zIRYtq2)>HC%Djk0U>FHc@MKYY*E z$*Ue)Ui~=b(T5n`tn0O3zpj{j{EX6+k3j)Hw{-Wq>+TT@`Y|{8N9lU8sPoIcHug_C z(5OFC{^PIGud+Ym3R70hZOE8bv(>5K@ce~lf7p&2Pd|2Vu~?a+vhi=#)h+tM^JiIx zJTf+2edSZ)vnuDkPd-j(I^C|G+y2&I_I|fr_Ma>mW^3x~UG{3l5(^XmZ9&1aEN@4g z&uGbdYyA&vROHEA-(#*0RvN&9jwm&kJ91{)XhQo{5W^?Hd0$l{@++*(HcSSzl&*Y=J_V z?VQ-YClB=6mAM!E-uUq80e2DUJAWs{@|izBKfm0xuHJIPYQgnorapJn@3n;I?XDJF zU#9QFs@?U!NQnDXZmFTgqRMhZqbquB&rM4Vi(bZ^;MaN+TT>eJ&EQnzzxTW<&eK}7 znK^}*ZaKJcx6;}8lbf}JBHni0IF-WuBXf@QZdJ#-f*k7_Kdm^+zxVm)=~eu}%k~{? z7Gb|C9J;Kz|G3oRZO(@uw#eUO=#((smUr}FhT9&UDXZK?tweA1sD$50vwm~0>Fa0F zORvkE7T)6W@%9UgQM6N5T(ae|LP$uX=rL2*Yx+NojrP?m*Dh}I;K*BYCB8z`HcWoG z!<`#NqI`K9ugGtStI`cUmUUDnccuTbhfiMG=X%S^U)dP-KtE;otB%x|6%lQD$>J>a zr$jEk{?{P6*J-Wyq-N=4_cSFo7yZYao*5Ca$y*gmBg|As>Uw_=~X$h=f zzVCafz4xE_zL!ti%}my$$N#pz|7HK)Z~nEH|1X#_c>?cS1)szjm-M`ER~@r{DAc_g6nlDQ&wtXYsl0l6m(m zFTT?ctz3AjMEc?HhkyRZ&CFZclYO&CMB7Z(^-l8phLCdBX*F6YFSpd~3laQ(;P!#Q z_)jhNFIn04f8e}4)$DR#q@DMo2^|;ZL))*4Y4qI?a#X&%uO!eXe__@2Fj>*7KDq)n z@BZ4lZ0L*X&|29S^h%-P<^#tMlQWAA#IskVu3h^oV+CK=X{8ox){oCQFPfAI8K&Pm zxjFYsiv<6Boky|a3^S@1&p17yMJ6^^HE5F_%h&5yn{;#*yf@=6EGpP9TEB8xC+n}f z-1Xb}XQ#iv`YYnk<$K!8KcyA?{k!7&+UhC!8vd&n988UO3_s*8&K#$7e&vEb?tK>L z_epwy`B;~o`OV0xX1U{lMaqH?e}2VXxPE@ZgsE%OxTjt`Zrv53r>b{s(hvKvM_u(F z&QG^^UA|k@?@_b&oW*-?@`q~XPn3Tidhd>-Qp7#8x+&q6o7sO{`Sk5ad*#&a4|dw= z)pS3e?D8UTW*p)tNP1|gYkd1KJ6>B zR#X1D{IqQI^KJi1b|zoVXPR!ks+(;`&ciNOakW445f%&hPJXx&dPn`<C_gWM9keIC3=B*XGC6Z`;LU zXO*6RyS~1l=kW~Pm+_LvFFtbCtK0o4bl&}6eU_5{#QJ_8-Toq5cfI482l|;ZzHb^`)pQdwZd7vi5n(tYWwi4QDNP(8l^XS(cf1^DzAfdAz5g`wos&+{&;K<$Pw)6s zzvs^0x|>?%MO|$ET6+pD6aKmC{VaC9Uv$&+C&Mj$%^#{3T`?1v-}kJyk=tnXyZhHR zbGg+wuD19eU?_OsclOw133u;pZ~Kp1o!j_V`09nT6Mjypj#>9tPj)AVq1^8Mo0iR8 z9(rSkTFkroi<)^J-MjWuf!QweW$xY;wQ8qWZTrg49!qmt_dspwq5JGzzmG|>F14_D z!J+;(FtDn1*;(%uS?korwKp=$>|xB>DPitc&CnlEs(a5yH~q|xz+259pSIs-xOI1n zf!h6=TX#+7&gnjT)^GRniJvz%9X|QCit4_%+})V=6`uNyw1KdHLicv>s?n` zBhvIsmRK)6rXLkIdwL72&gK8p7c8<@sZbTmxFR1Q9`740`}k^U_$w=8V>|9Ug){eO z)o0J0sa*N2+QNT{`hTezd-m_z_GV#yU2f#g*SF&1qn~l^-S+0!`pR#=oNErVfB#h+ zJ>l6;-`#hQTJKy_y+Lfs#a->Mx8KcRS$CH=y5{|sg6zM}IURws?K53$6mL!FU34IQ z|5HmVkzJe;|DqGx?z?4g{=3~KdiMUEM|8Js+2nE7=USEEa{kckDc?h6b3@&kuTETQ zu|uIheEQ+1yUg?=bsrs^snaJJeg^xD)<1b^W`qc`<9Zq~7A72mQD6be#2X z?*6&^+x(42KR>+>sczMuXRd4WcKupEzOB|oabx(Kcyecz)^?Xy^#v^O@PY=5t=HmG}-28uD)NYrAsO8y5nX(VZ zOsd^|_jSxM-|nc$3xP+z9?xsF@|$|P$Sr%})B1Ns$9g85mdr11(8#FK*uJ#qw88$O z_e+np#hv=0em7)-waguvx8J5+y&trjb-Ac}(bNg6x2&0;-+OP%tcDe40SV{ce-#LQ zD`lI-!u52Yx^)bb_e+M7)f0E@{hOkgrW3#R!Huuq#MAX;ci(UNHof&l_1epyeGi=Y z|8?u%lLt#zD=W?}eQ$Q<%^QcDGrO4?o$kM^6k8?mI=MFb%MO$2C$i7!T)DREYgJJ8 zl%l+~+-z1sTfNQGSU4-I*tdS-s9|f|S>7tcYTy#EyY&9{bqAPUoH!sL%O$W%U|Kqx zm6=P6#PVB<)%zTIcYYId){CzXI{)2#b#?8ko$0*wAJ1#(3-%vWmJEDO?NiU8`Jd@kp@*YrgGoUKzD~!Inv~PVbg;ZBLzK7|*_%b#41C&dG0Yc;E;JnqGUWbit#a9D*kE8=k(Xyr)h@PwUh~KT#Ms5GygGLu*&UJI;-1%2;|MRa& z+TZ#QDo^IGIUe^g?%CPZds^fAW6#bGujJkeu{u9f|N|5sQ2w_o-D?c?vIOuL^}Ir+zfPip&9 zwD_-YF|GSGsj*+@t$KIg8kTj@FL&a9Vv6N6mUI<)1=b%k5uxF6(>0 zT(NA`vluq9BE@O>J>rjAPnStCEOce9n7H&sW4P1Oh{sv72akNTv@-7s`!$LPhYi7 zKfO^ed+p`+gg7@-jW@?c{kB~5^!~eze~;0J1#51<<+_+V{hd=l)`9D--D{?B%L;8a z;k_R8a&Kt;zOdv?acA~4YO~9R8Ztc#^)`MI>V0j|+KUNEf<=qX%-3CA6dGOrkZGCL zo{G#n$(kVs8zf#@Pnz;XYk61n(GQgdg)cMCPz;#TIsa7H7hu| zE-dWO(f_MGAFN*Fue(tzGUH>sDesz!LtQH8+57%&K6KI}OKgS0na9^Ji{8JX*3}%Z zU*03Pusq1{qu1Bt`pwqfE-zd~-v2Ne7nD}z6^?$%!S;9=f`i|ra6 zhayissr#Uj_~cZ{-j~-L?jKOqTV#3Uy;nh;U-w@t)<@sl4@tf^-kcxFxNvGm=%-CC zjz$ZqJF?%=_Dnx>!6t);ZY|RL#8&ei7UvH*+`U-t&Wr*jrHVhSC9eOP zR(}xjvu*Dz7hHI?Zn|T&)mFg^Mdfd=oZQXoeXikJuWrp<&xQI`2NIhadZfJaDx7~T zQnLAZIKwXCS?jH@?IlYk?ndt2l62{w-G0MY=QsEKGRmyGv^n~)r?2+yunBJ7lX!~v zg&#AuF04!~V#m+2R>982L8$-JW#ZS1MQbzUHZKv*Hg&@ju(v^y=~pF6&MX|LM8+ zLyrH@Kfd#6`zjs}6^I=VtI)C*ZF55zh^&L(f)Y^-7W(f^kAugU!z5B*aLyte=G zj61J8JaR5NbU%M?l5N9Ly3kwgT!r|e#Jh~TM(!TIspXFkZV(cj*N}T9YhlpEcLi?Z zX4bFSzqY*5F|y81Im7hjvzNl(<~s+7K0D9ZpPh2Z z|Le^AJU$d=2RE4#%F$p%Nfzw53;3+>ES=hg!va$_p?i{Q@ztN>!|;?+ikOV~eIzd(0ahv6%tuG!w2~KHq#HNM{R!FmH!}y!?#|&fkh( z+obm_G2M6IO2+4yTUR1xKab--a>i!*n)6>Q zmjwiGecr^f^v5j0z+G_y`}AslYWlo!b$N8WgQIejaGl%aW&X_-zH|07+cNy?U%W~n zZ_1n-9UT|e`R}_lvudLYPyPqrvPm;~C7c-3YI=*aj8ejSzp^(<8#_n`i;H(H=o>*HWil6nfCC$;K?=8vD|fK z8a@(v`^~#04#({aarw|?_n?$EpH56!Rq4l3C4HY`(m(_OKwN1V(hm%drM zGRhrFig#jJ|FZqpoA&kFGv9^O^`>n&ZSk|e<3T#hLH|zq@0(}ofBjZkSox;*Pe^_1 z{8xoHrj#u4-)r=jsqVyd-N4gE>!#)Q)^*EY_S||o`KOp?i=cJLe9kGpYxH{!l8OzI zULVWu55Dci)y^f!>TJgDY{t&K?P$Too!HhoZM!+LZV4MV>;9OZ4H6U5B*SUbw-`T=69}Y=zq*-OX#N zpH4cx!tnCT_mQVXFT9GjP2AyIHtPZx&nqGKpCuVjwGYQzOk1$h<9OiFF!oojXXTG} zF^RiAyiw6pV|RSP<5hFZvp6I|-e}JipUPw32GvujS zY}J+!;QI5%!3F;5e2mR|o+h(37isOwFnGZ(x?O_p?TVh%9s@OljJQyp`%0Z$&F|L! zv*$7DztQUWt>XE|c^{6apWqXI&oF7i1GTG79OrvhOIzC%FDm1( z`8@rW;bG(HulI3OxP3J{U>sZQb~|tCw%JFF`|rt~p8Qv#!mVnl>MBXD^GnY4K8;oh z{MfU-E~Mhv8zJRm#$H8FD%?E#7|!Q}E&3l^k#^YryYM3^0eb=Kv!|qao=fgIc9m!2 z{&fCWzeh1M8IsMM9#!u>Hvg9D3x35o(OGvjzBs(lXJ0ET&>71mcw?zRrEK30G0W>V ziXt8R`_!c;-0s`4u45e&vuBt<;D{$Gv0AO;+bZm$Gkn3*@>?wMW@tm z(qwB-ncz(fC#3%Wy_EDk)NO~-LB2XqzC$uOc`;EBWAZr!3+y(T?sBpZdhy*md{wxm z`F^!?3{93C#UE0OUfwNvE2zX!eN!+tabt+b9xmJY0_g?Yiv%7BS?>0Gr_Aza<(o;9 z?6seCPoKPGil=yr;FRWXyDY4wTNO4GznoAyk?mrx%Pi(5sU=^S*?Y~EFYhcoc|1jU zp3)43j)NOL(zD7>Y}cQ>=54lXtl6at=jKeAZtQn<+U}BBNB=YYQIBkAJuWvnIXZ3m z$&G7S{t1V7^$S$UE`Ho`isRm8pG`rm#~L4)+}v@uJu@rP+^};}=G{#Oxeg(*t%gdk zO*hWjt;O`&00la@aNrthD{zC54%&_$&s8c+1|R>j7wY!2DiYV39LrzUpQvY4 zY(2UVd;<~e{-C-1U@ilUUoj^){CjeUtH8XSyQk05DSuL-Ha%VFgqFf0H5EHgy>c}P z?m11Yy$!LQvFFxx1nHVoAG}xnzG-jLdtUAOZtLiKx3`!7RQ;V+eyYy+^IMs!fUk@} za$kO~e6;PNlEW;QM1~17IbYVOGk?esU!ckDyylG8n%EkX?+-jCoa1f`Puf~@^?mx( zggfpVr>=EcRauw@Zy$p$3u6x z>D;n0n66xTabND$^(-lC_BI+$Vs|o^e*JEui`KD~%C{2qTISjwD$!kUx9i2FyEeYB zHTB+TO<9?z(ev)=TdRQfow{a+Y*`D0n)XieD)hNLX8VQS1mxh;}cGP6wmbh|u>1TVRtW&jlUKMLPzS&r$$2Ljj zZed>%Z5R3C6W>yvf{v{9nn{%znqEo=66Y#4Ir1^IN1H!ByQt10tSQy%S!JL@R&d&x zm<+qt^-61Yc`7~>>Y(^0fs1QEn`8Ybo1e!FRksuz39s zt809g%jf8F2_NgzcKyL1^Zrm)Y?4n=n(zV6K%jRmWB6p zzK;iPmiBm@$aCy_^~RFVT=ULu%L~tT_Qt8)vhdIUU^csP>$RV~uS~yHG(MfU&Gmoz z&7b=WoNQhdG(25a+2*Oe)|fNkv?oKk)1L*gPhRuwxxq41ac-C_$Icxoi!;6`-ivv* zd%=-(#+X$K`TCH^HCtKxpC@v-LA{SI(Du z{Hl#pLVT9CZ_Qb?MuzJz+#cu#+OM9l-n4zQ)V336w6+GHZf_J?bMApbe%Y%EU%_0t z=Ztpeq?{fv{RhSoni zcH-QEbMxHtj9&>$Z}>Nt@rK09N-4+P-^^a#HQ2zFXKcm#I_!zq7VjX@C%#_ODmWSP zj)k3Fu{}ZKRg=e;u-tiC&QCv?g?zmp@+{l9sg@z{c#6==E3y}Txmq07O^a8n)^VL( zu4Zm*a^uC?-4}eU7|N4pNHA|pI-|R2#__JUsCSOW5m`dJ#6vro@3b3wehm9+aHrqI zj=`p(=#=Or_Cmf3|Jye-T>fn5?f-U$RhUjf_l6G!uO2FJf8gk{4Bc{cv4(_2_Vg#o z8ZUf{m22($Bn2;hatJUop33uq<=R)_?$_Tud*)y8)e!n5a_oGMh)u5x|1tdo#)Wda zyDG1Jbh6u~5bQV4`Rw6SYMt|r&#B{z+aPe=UnN-oN%spO>9-7fo_uLq^?3U0CC~cS z2jr(MzBeUeZ`U=6gtIa0Ek9L!sgac~w63gcRyZ9cvG3-G6)nsUbhl5AoW5pGWo!3bR*>H$&9d(OBOb%5J?$S`yrtepdoFs*S(&yXwjl~mUqA3 zyT1JQJ@fnzn{RR%tJd!NU9-!-e136W{W0r*CqLKde>!FF$mEePls$2>oZgAvHA{_M zBaei}9n5?vac#<>t!qwxmb#SFt5I|7CFeZNhdS4^#5-QIsKh?9^~vM-C*n|KP-EQk z#b^g)&sApT zRpjSYl;%}b=T$Ub8y5HMMCHN>E2FNlNTsSS^=JsJpWwXJ@m*P=__KFSE$6=~{54Js zz3uH4+R!Z3H0PDm$w~oADUTiKIl5TIPdb6T!+6Zeb+7}R5Nrg%Da5UH(}xz|0%ZrdL1rUh#ccDWinXB zR1~|&yLU%cxaaoOOMdZM+=xA)$*8KTa4IVsA%>#WDuSaePnG{@zy4QRsAw zV{HS2>DoNs+3PZmXR-XsTpAe^9l&(zX39-TwT&*DK5{+y=3`cnV!)lwchpO)wb9(b zaPCtfyLrz}hlIr|8+MnTTG8e^*_8RH%ru>)b^$pzH{~lWwsbX3c)Dga_l!cxT_1Ce z7pV0retrEy?5WpH&8hVzS&NMyM={Ka$~E3-^)Y>Fh4t2!?XlUP!|Zzk*RVx+@otoy zr{r%byg>C+)yZWQ3#|)htmO(jCOIL>Z}S@2vm!nQ)?E+gNWVLlao%Ny>!$Aa4`=LC zd^d5%Kf4OM10|U|w2pka_#ty@okX1I!!@U$i@6IQ@OM5D=zJpB`9!GmiE!r=mfJq% zF{lJx{(p1!yz_61Gpbnct^Q~Fuy?{UWW+l`+~r61Id+Y;b3#8m{ZHS*`s`ZOgE!(g zc``1Pt=oM2=Uo}Ddjfl#&N4K02#HSSyEC_JL3oDZQK>&~;}5f4d654PHd*)Y2$TCj<5p8*G!}Ym5AGW_YIA;3L zO!dscKRwN{zPHarE?hg!G*qj*L_O@j(qcAel_?KO47=6}@>C!+8}SS1dETFt2)zMZ>T8`_dQs2LE+QNIKwP_4d~^wLOizlU^lSym+Nn zH#zJDSEaF5N%e?~7H+5ID{%P7BsaUUgFj;$%WZc}PBJy5Mt6Z73 ziGK-SvT$ycRQ^?`+`U&9{9-#4bJo0I)9eMJakip8YQ9$mBu%5Ho9G26XZF{o@udBH z-!w1OzvFrG@8^+UU*v2Eb5Gx*_iW`W;eSu%nT?NRc(pY6pU7fO$oJjc`2r+m%+GQ1$yWRs_eXKL5?R z=Wx8J%74p(+;%<|cwTr@%_gtGZfA9Jayt^eMo8ED}-*{8FZi;et z*c%1MxCsi%9uv4#ejjo-sARF|{1!Pk&UdXL_pE~jH#RG5NoHFAV2Z`Yw&yNFak_Vx zDc(#=N>s4!NLxK~cAxC`lx^qy`K+#7pL^%@^$wPO{QG)@e>_~E-fG?wo5*xu+HS^y zoqKMU92FCK!og|O%<|KrN#{n1Q|?9c>|bfV_t(6fZCY!5;r*c$@eP5C#h;iiUUGAa z$?QpK!IyHpc1i9CcFA!tzG}Jp*zzWBQ_=j70`s0~wyW*3IWc|duKRLte7?+eWQ=l7 z@etsjqMp?L>P@N46ZXRYPZa9Ao99~hxU8MUF*hkec#6sWNp6~{3vVp?dt>7_?=7uy z44vEAqMO(BPJFp5ZCCW=RoNZsa%%*7byoJiIL4u8RNUSCuFE5PV&sXb-<>Z_Dr)v` z@!aL0$F}WL=1(rQ_b2%cemc}CT|IMF$;rGoWQLODviFRRkGAFhIU=s$%cLC3q?~(I zuXaZhf4A}rmHv)?53R2MR zZtTh3<0f`_ZM)yqFy;3TlrF1pHQ1h46JvgFt@qUgx!RSibFbdq9B?M=hu`5ZygR+W zer@>Q=Oxeo&%5*dGM{6DD}^O2mn2FTcqTjvDSSDX^{kuQ1O@({;076?C1l_=h{4D zPvw})ajZ#I=h~z1+TWfr9S<;f(B7zJdZo6wz^pZx@7%N6Jn2*MXRr0FIy*B^h|SxV zBhouPWUcAqtl~70)C3QiR$ldmGu2b>F?IZSQ*|lEYU!ecGTXB0Q#NL%Z3}Cy)@xlL z(iHT=MB7-xAak@GwxC7r(NuK33CHn-Pw&nXM3tDWo4 z8fEY-7O`n=3g+_DR5{zl!`5WoDHzxX7m*z2rp*2^g!UVm7groS@D>kU@wNc+k;KUPTKY?9}( zk28wPJWQ;wUt446u=$tK_NcSR%ymAk)XoZ7(7^U?EFY=HD0B z)jbTm-fq>swBw)KXQu;pKRU`M^JcA<+y8Qd*#4JqcBu#*`=#<>^Uv-VTU>r+&b_yw z?&_`F>=hoqW-~oPOfBZ=AM=>FGtkx2V2WGV%AjW#JiVUZE~(?2>;JNck0-c9?(M#~ z&`o6$Yvwswrs-+KY-TuYsl1FYy>i2c2dA?e(gkO-dZg6d+M1HLI(1G?b!($#)<;?9 zXEWTM&2W1+!>#a)Nz~p_-^GoWUs%lD;bPIQ@s8ss-?{j`X~lIslIhKscE1&pb3ZBU zz7=l1{pr=Z_57@R|FtjF`(aRH($wU>SoYVt?RNqrB3qiK9{uVXyJ6oBNp3Uo@1ier zKZxq=DR!mb5*aqL^^X77 z%_xssen(^dq25ia|D^8Iix7TyOnBwphp!jv-H?xM-yLxBZAml#h8OP~#5}q$NV&EM z2x*=$UN`sg&v`Sia(of9nkF(wsOqACw@rHXjf@)~SxZ?hX0=Ygq%Lx$Hh$_(w|g4B zyQEX6n`G^N;ITl=%3j5=lF|PPCKv7(VS?v{iIx%;euC&!dn)t zpP2uc@7ZmIFmWB8`ex^k(zQo(*Sv7w=}J7i@Yz zYxZn|V;rV@rf&Hg_uP|t^*T{Vdh7Q?3KBP!9s4ameRt!ZrTjnPOJPcnjbZ(_jSrJ1 zG#}sl$L9keZ|Q~90|(bdeLrPiEUq0Bw0==HpKP4* zeX+L(uD$ChbG^BIpG`uqPWXIDu!OyiWv#4>e=xf$_gWbP%j;*ZK6(C4MQwJ* z)mY>8{yK>}kL*f|i(j_smz6^-yZnMOgV&qa&rDxdNxne8(=lzF2LzWzhyVX}6vGHtcioJ$*t; z_4~3()xjtCu6%MYq$po&r}@-7v%TIeours8qikJN|Loh3&EGcjXNKw9XW#F!jCp=0 zapte@d&JH%HE;3NJ6NqPec1nk&0TR@K5f~izUc-(HGWCPEsKbY;PZ?u+tob(uvpr1 zoqvlXZ1*$o*#AhI;ioo(ss=-<2E$SfhNlVv(^__R$zJ$%&@O}HXa>jA3=Y;z4%JK! z*QXg%r2LD6nIog5jlZ>uueD#!R<5+c%T{^At2NIi8LPxj`Xdn{-ngdp(}e!T!u#5k zw_8`K7_l8YkQ;O=R=xU*hr&Ll2~8R|o~(~}+cx)5i}YV%#4|?@h=&Hd(`Ta!Bm0C;__t)n;_3B= z3QN1&KgwO}-4va6eqyeVCdb9EMXXG$3ZC~=ZuVPecd-Sl92C(kdME5SIqiko*$ck2 z7S1+NmX16xc%)z4e8Lew$490=QucmZ9XWG)gWF*j*}oPq5(Hm8VBV9t%yffCw!*vv zEzh(Yz6i$my#FTF9oppkb%(M2T}kb^LeF>IR@r_3>Afia-C0+r9~GPFwnA-sO1tn+ z6@#Kvw%_$zF2wFVc!7g^QDMlW?`NFzFRu)9JtLE(-nL3%=FL}|wq+bUC{xw1fAqVx z-)y&y+)q~&CVgGS*ISe*<|TYZ_kd%J!Zfa`7#pK`GoG9~)Ve8AWs`}ZbcTf)i%Mk4 zR)qy+9ZCMD{98jS+3%l??JivvRTq)2V{eqY{N%;uZWksc$ldb`i0L@Ea`Cs-dZ#}< zWM++=US#-DI=A|o$IW_G!-L1ZTLvCJ;M1=a8l$beOO>r}#rDH>KW{$FX_P#2NKK4y z-GY*v9&EhplFwf7k8c*5o$}W7nTH zk-gCQyfJ$tpO3VwTTxZWmDf`g{GL2;;p=;Day7T+nvl7T!p_Z)kLUC*J$`kL-g8-= z{ao(R%3<T^fWgmoMq#SbDeuh=eh2y1HrqeeDqvrXvc1F zy-oVi53X5(#k2D6y+6vWG?RaeTxi4A8`-=0b|i`JJ$SicM%ui0ZZgXyB{#+!ul;9b zdrafpx3ubm-`yTYPLupF`{^Z%0}fS__UH6y=CRcN32lGxlclBaucK*U!8}LEk8f9% z)rn`WF-kl4I@Ok+owPJ%?ZuwkqPFYSzd!!AOYZu|FOSPwUri1!`m$X+X7$=1f@jOh zZ+s8i&~h*O<+}~<*OsK`H42{Hc6-*_bC+_ex5BA1liPEb-u#wjdi!n0w%;?-_B))F zvUn#J662K5^0n-SdDEu7hBs@L+SLZ6J&6}Cd9m-xmEg12g3t1u;&IkAU4G@x!fAe; zD~|XF)P=S>_RU>dzP3u{>^F;9wrS~`-{@2>VQ8#!+0>I}d6sJyZ^pHrw;!bEq#fj$ z`S%B-OXmM`*NlFx{cyEnd%&y}_Ka8N|1qwab@a!bDJqfDxr;QfuVe8QE7IO6Ddb^j zZp6oObPY$TX05T(ihppj+@-2R9q-wZjkC~1n<1)cM0hd#TS zukug$eB9>2l<8I1T|VttJ|m;~i{`ggY;md4wXAQxi?egxkhNLbFy(#5naX4F+Zp06 znoiV=N|UvFWVkfuXvFF}XRCKwX{Mz8&H3XUn=^Mow9MCM@AgFI*_0d2xY9h~*F}ZL ziu>fZ|M~X$|HF61mo9#={UC77;=QDZtz7b~=$LB}G}i4#|FJ@gwB)fxbPZ627bZo93oJW51-o`rwx%tzRZi z&26=cGW;xAud&Ljly@onW#^a6?)5+Yh~9JI&uPo) zZr7%{an~Mpk@@jq&OW~LRV%+aN0@d0LOXN%q2z?KL6G zZO*KFRCcrbkLd0*x#tc3=`PtfHTjoPy=bud2gcP+q3`l?bc6ODHPg`A&9`Dhm*4C4 zSw4?m=sN9b5$x-hx0yJLb%+0^dHK(dY2V(Jqr7aMt?z`@=J6Lbr+=t_%%vr~a?Q;? zLBEq0*EjJpFFUO8;?L1LYoeQvu=q{>s(sOKeM~_bQ#XdQ|%SIwv zUw>BXP0>H8eJ>sBI$j@-w3Ip4G-c!R&ymwlUk+b*D}3YYnfBLbKcB1cK8auDLESee zrhNy#shw+hYREcU!+m~?$Mx<%|6C1jh~I7Nx_N5e(I=7HSo)t$`{27`j&F_hvuz)L z@64{#c~%jnXcTvVm!0kK@d*8k$9Bm1Mm{u*U&i^UETF!qNa^d}-j~c**S@KncdY+I z{LlVVk#EljzB~3$J3OVOziCz$k6{EG>td0{tPK}We4d;a`{(nP_SZM1UnVze>UZMfTmi4O>9Ia0j2Dh>GqhxHQrp@4Hf3w(`sR%h+a`ZCxY-xLU+pGr!yOb7c;@Q9 ztJBXc`0QwW!QxN#UInJF%zG5BH*4u=nq8ZJ*y3&cp0pXP( zalpN_e7z+<{3?6&i$2W#Bq4uxVdAPN-y5rZ)I;1Ry8qv`=xBRb*c0U?C!RZNYk!(} z?vUn|>+Ho>W=$4W|24ge!^duaOqP7#p%te(pI=_6d+BA!lF#g$pHvoV|K($U(s0FG zvVikhM`y3JfLoqlh_A}0;Ed1y>8}-%zeUAd$yR)H`DgUc$uGF)wIsNR@9D1R-4hz8 z88%TvrG0;w$3EU~4{sa)eDkpAS&nEf&-BgW250my6h#G`t7%mId~~W+NubaImHFSV zE4=w}>!w80oWI^Yj&&#VyqbD{-~7i?GgsE@fb*M||JoITmp7iAU1prMwA;4*WO0t= zucJ@@gk3qa_K)A0yC>zh>`B@Cb?RKgG_ zvYEN!;eW=4y*-vGpX)^e|LnLgcywn((L2_sljQ&G=;}~<`<*#&zqY%`?8YN!}K z*Ux_iv>o_v2ISWE>DBqo>$d0QIW1}5m0Pza!>T-b=^EGexZ4t2)%pJN?9Kd8{&dnZ z`K1N>y8VCeJ^r>lReV3E$C*EM3RY6$_13%Je=hr&a)RxGu*8{Df7U#GlzQyd1jpTv zAF1{>r5+P9JfRaFJ!!dLk*~!8GPYvtZUWfna)9(Lh9JBw>_L!PZ3)$00x9`^5 zYJ2=>u-&xo^+%2ueVo$&^pW<*lLa4(Un!p3WX2nHYU#Re{ga)#B^li%R-!Ne9Mma% zsQT)W_tco0=u~lg@n2u|S8YnWf;z900O2Cd^K>UBBqSs;F!Hgb2x#;iO1*Ka<5ara zQ==8e3G57cE{vZ+{94c)t!pt6AFC3#3R6V*ADn(eiYdspAGM~n7So%pPqEfVx zNlC%6^+g=_+q3rybw9M1pL{y|{+V-U&Ye4VrhIa;4BzQQ>p$|R3*R%dFHm~u>r@n_ zuyrs}{$bt)aaw_gW*&wS;O zB^Ek!qT|n->)RH~I{HO!i0$ZeugU-7yL98bYrJ{-Lcbnu{ccdmwXEjPi-&S{LW|v# z-vqUFO?Wu3VdYewsX1XM3f8BrJ(J8cotKmS(+#J#rE6v^jQAgL&noPp{W2-#JFjo{ z>9tpXFj!?|J^RyqdC|Ty7R#$*?;b>KXZ`i@bJY`V33I;3-4b4rz9$^~FKI@c`=@hzbxpd_pCyQGb zpM~sx7nT0|agJYXL9ffc2-OX~PZ;b^tQNX{^*)!~?mNrGV&*wS9Wa%tOxk%s%~1A+ zg1%QwV7=CvP2M@q25J-Pn96tfC$#R+2~gnolnGuwW!ulGxhkt8)HNRU=CXdAY_%vO zVf|-Gr_X%cCSAr%pP$-wa%)Y`C|Trjh3iUpGSlX#Wu0nMlQ}{Ro)dXScP`rU{QM#IC1vi!8GV**nF9R67tAB$ zyJ{MpABo&t!d|%7Ao`4G$Z}t!fb7|)FB~!F_@AfqX45pUDZeJ~bTsq&qjlc%$x5eI z)2#Jb`!9TK>q@_EQlhgm;OeOfhL5slhR;>W)%y0)DOTZ$UT0LK{>GTK#v&%4)08Lu z+VsnD%4sj5()DfY3-3JOX4$Ku{-d(5`_Ht%c~U?1+ny=^u~_ct|7N+rTlo6L7Ti)_ zW>nk}EALcg^pvR*=3T`2^`801J4m_CLg3^fw~c~7WOwV%*^n1u z^}u(MRM17XTo>ORhdwShys{ytPjt_u-g;&Z=z;(d2U{hV~4Bap!w2^my@%GCTJlxeJU0L5KN|-Ta zKinL!Ku>$l7I917&UcMp7;L6CGTmXUd9~zFUG=n!ueQI+519D5dBsNQ6UX++tl>e2J<&v z%=w>~W3#GW`#6K=wqAF|cTqD|uhR&*&EBzwdtQo&RPL#!aD!TV4eVMVy zqq}smYuw~ChvoypJlB7iG$sYEUmm+g-F;f;n}xYKlZAWd?Jd1*ox5lCg+3dG%PxAF zOZ*r0T%Tm>wOzQR`<;rQ2LqdOw#KP7^L0f|8fC6A;h%b8TVRfk?LHlYRcn+yXEpHK zFMa2B&G60%3!|TUg=((>;w(s&uw}=05g7!gbptr~F4-zNx%R{PBxPqM7SW!8f%R zC$rn@&+PTR^XZZNx86GU$NL3uNVd2#Tr3VshD*N64x_ymU?Yiv0ze8;KiWDM}DtZvU`7}`0fWntlFQBpPBvd*X#AW z_s7fM-+m@@o6eS)*CDqzO$n0cU;SwMrWf8Ey`k6se>fl3TlST8+C-=Mt?>aBH`qT( zWV8kUXl*?nH-DDAVcia9n+<;g4I4zN_s{<%Vbq}UCx=nA^|-_0-%CQpIqh+VX zeL1PsJyjQ`j_5O7edye4j@hxTqJ=##qkR0fi7q^~QPA7+ zRV!oX!k=|VHgDK@mT?Y~DPv!@;=QyTOIkTZrLt`1EDC*K5y3rOGjWyA%=L1gpSGJc zTBK_$_4_1*IW3UzH1vcC_g_U@bIZ#>*111%3{3bVI6e^pYIrC zeDd^~8rS=H>!CJ=udB++idkXF;?wKss5*wxfcQp@}m~=o?kxo zv5@MzIb1)S-7;Nywk^v)t7UfJSI;8VsI5j_Nfn`dt>y`2ov$$QjOA-s!g_B))nA-nd-6=lVr*=nk&-IfH z%W8PVv|4-DTI{cexC2eq_$^u#Jz~ zx!i^1rrcJVQ@iby(Cd&JjCPiPU(Imee}De`(;weFo%#3Y#2f27UGMFw^m7n?<$OMw z->31e^IoxOA3oYl`_SW|uuc8s4y)Ql(eAguS1o;&xY{IV)?Rh~$DT}&J-az4uf1HT z)m(9DBhy3Sji&q$EO{Q}JBOZ{K6icM0ilTsr!Sj?XdZs{`%kXj>IA=x4?NDi0o(ZG zE|wcFijHErR1o=2plR2l1+S-byn67UVVADJ^Ltm9Ix)X$zjM#A$?6XKisDM2=lgPe z?9F%cYrlFKF6vh!@Udi0g|J`l;m&l+!xiz%t9g|8{Xcy8VsL8DS+3<-ZQn8tv=1zn z{2jdToH1w3wD#psKh95DHaQ`K%l|X4*XAY_RAK$4j21o%X;Jaod?>?zkR2Fo4DoJ%8vAe$5}_bgSO0lH-*J4>*$3U`!20K zCMY%O)XK)QU9l5ec3+m`=X6RF5e!=UFs|r`b?l-AZD!327qm2Q`xV>0Nb_7SjoladBDh=H`q5H>+WX&XWY)@G&T8ZAn>)Adck@H8b-Oz* zeh3PmdA&&M(~a{z$Ioeey&?EPu~NstYQFs08Ov^HdQaIi$wy`FJgFt0AN0?hvtwyf zSTE~ZM(;h^oAduqT(a2oPn&?}<%hYazkAKqH2c>v-T8)<)5hpDt%&K*Hd@Ine)!6y zJ)379`?kNmMYr?s&VOtAVfzdv{yW$F7;c_se3BF>x-H}5pXsBzRb4WZcSFWh-6BY zZH#2_UZ%}gWpi%#`uWyY6Aow_kw~7 zp7QP&++NO~Y&k{2>(k^2GqGt}=Z-5sTwF5EC9tS%aQDmL8iduU^xt*0~yZ z@Kw>(V1rersRy>%*1lj`#q}!We}qx=k%!E-l3UNd`F@Jyx&PE~y=kqFA9w^mO#9i$ zc+l+DTDMFkw?khX?v%GYRDJR<>453Ut)Y;$n|5Vx z;8C8(^7BQv@1ON;QyO!6?Z3a)4K*HdKV#L(55#e@eeyDx5dP~ufAvzqGPk(Mm4{+( zzI(9IyRc@4Y415U>#f_J*7%>h;&Nljiv#Xz`!Xt3I~(UtF`W7E{j~YUv-ZvFV+vaI zL83MJ{K-$bN7CIF$-At$6Vl~%-+0BD!;B9tyQSFUO4^SazMA!^Vq?)v&dLB>j zVt&5)JTCsh#2FV2jHOHY ztV22X>^a$(@L^TYCk-yG2gi8Y&9i?lSbOI{?xZD?rY^b2P#@^X?Ez$TR-+xWB z{fCaUKi? z^O@OMYj`G1`?Pnp^SK)0Z?Q*H3tO^V1xS^GBCW z%C>VlxXLF|b6Ln=@24sq8@N0b?l?$W^`2i;>nHU1L&34-p*cTRUv0V^RN~|-I8&@r zLwM~!9m^$|e8MNM>0F%jp=WB>zTJlJ+890a+j>);t`IR>UNGf$i}U$3#qJREnA<1Q z?^|4a^`N%>PoZ?!eGyZ}^V?=C6>HsQc@Z zFePG=VctG}ZO-}Jy*^Sq?Iy2JmFwgGv^D4Uy{$UY8tWD(hKIz2r*s|d{p)jo&Glq2 zUV-wwZWWsyy-z~dn;zSj@Kf-4V8G19#<}}aW@tKYR4|ghdN4!(&=koXldj3S1b$)H z=yLS@(fV`Ij^5^$bHDi9Pj)|9)*W%DfQ7d`u(0QGxoNu#)3Y-t!f)m1SS6hLSARi~ zRsU&KMF?~G{=9B)!KJH@%GvC+p5V1(cIi~F6Kz)xM;mTE&QY;=?-G?|M{e&wx5Y!~ z{{^n1W45gyPu4zVsV`a=;9PxlwZF#Gwh*hGDf8CG_$%yo@iSVSP!_OacF6n{mkx@o z^71S?|7;6a>WiwQ&U38FEVQn#-_Ryo^nA7AfVWthI9N=WlN-;GAYwB09s2(Kz>wkU?ceB)Om@@wUf<-N~bpHOxOFOKJoFP zfAgli4xP2#{ad2{@)y2wMY}v_v;5uD=%jSA#qDe)X}T{r{?~ReHS!u{qz0d zq4N1|!_~9vco!ERFX#FEdueouWu<&#_u+5H&z`zzk}A?-zT4uU>L$LW%X;U05`MAf z!6EnA6Tn z7bzzm=Ji^4{`BU9$6p@0@9OUJ%wD56LWTG1j1|q#mTXW8KEt)M!F1n^BY(ct7$u~; z)t|36l6}hPTx?OhU*(4Tj-`hrE^zFAZq(YZlqWH<>iI>niM|fA&D9R9+7WqSdAPJ$ z#;Fv(ImgrNH5dLm|h7Sr>H?F;t9=KHH$(kar?dP@!whK=0P7iju zzoF^Vrk0WmH$t7q=f*zfX*LoVt78y!ZNbK3|`PxNyDT=HYsG=8F;6 zqQB>B1Aou=-)b$%SmYhCP5armo#wGVXCAGae)`T)t+jKP=WLns@}c*|kE?{1tiQKg z^0UXu#q2j*TK~>Ac)y^mf<17X=Wk9M^Id`Y4;ZY)^>~(S&*E;WNNUtbH@kJ0*`hv( zJKx)CdYryhw$h#Xk{c9F>t|_hTX@I*LZ!A-w?r9eI@^%Of_}=V_W=6DAZeT>FNhhGLB{Y6$E^9oMt(FSHQdS zzT)N$@?PBPXU}it+b)r&`*Z4z$DZ+}%G)fix-5KDq4t?!z4rT^&qQZ5o1Qo*b>^YW zje^SA#U?ya8|OLmeqzyC>YP4l*6zMIy`I{qr3Tq%-#;~P*_T=2pV`@UO>XzCKjm_v zvu2uUEi(OZ|M&Ecu6h0~h==GeR?OL3`@8tI z+a|q#BL7QX&B@uM8g%9K(;Z#Q5+t*`o(N45etvDOCI^eE%;SR$3aPnwKi#j}T`ebJ zozLRZrdj*aVD*9&ZaA$_v!v^sl0f} zW6#>@OXmH0VqJQ3d%pJc+H&Kn-(fMIr^naTPEI?$J%9VW=sM3mk60YvgxP)n$NTp_ z#~q7XQazT9{{=28-;7*;e&2HH+NJg)j`HQRgc3tS3 zH*@aqNu6)B=a**8U6}{r-KTF##<1#Nd;Rs{^?j!=>3m$we!8{#?aqF`Lz|9#+~1=?1z(Uql@#TS5ANUn04O4HJaXY*SZUF#u5RekH5#XcO;+ZeEsf5 z%j)y?@2gM93H!6k+og)lX?}UD`%nev{r}VFeyy%M<)Cu;Oylye+x#{Z8s+bNy8S}g zOFc)I#J7$U4o#SM^IuBeakk$tcEqKn7(SM-imQGk=>N0yZU#clBWK{~fru4}o{zZ6V^!@5pwVMu} z>Yt|8;ggY~xI$e#mDx<`^RBgaYfcFC^HqPD9>+Avuy}dFj-~&a>p$Ldy7l3Gfv^21 zWBHPc^$(U?B>8Pg@#f!`@%Ykt^)`zhIq}4WGuq{SzkSRzii)`0>AU_;uO096k|i&% zo!{9p-;mqS;l0d}Ly>xskJj!v(j9Zj_|KigGtG9y8Hf27+-}=(TDIE8W4`j8xE~yx zy7!)2$8?*2d9455a|LsNY`;7+o%I*Z;INE8OutVVGG+WhkRc}>SF!;}m$Xs~3e1%fX zuP=i89!obr-u~&JhSV*^l>5K#zI(lE{g%I~TF0X&sNC40kg)EtUDb*k^Y2`GDcxbK zzoPW|o4HfNxYo%uy|GpKn8s_a80xyI)5xCXr|%>S$*+7b_QtA<=gs1CNY3?>5}Q`d zbvt3rwSoy3#7b=D&$_Xw)adNnrkm4wzI-^T2eL{k5y_+w67T<5+A2XdguM3b-c+Rt=?`}6SH1t z-=>ovu1(=ua&+VC*ac#&C;cw*Eaf<}^ktju-5Hy!-yiJXA#ndgbLVE}E1Z*(pv?Qxs=n~Y z(LHI`OkX7Ie9QXx_V?*O?{Z&^JhS#BuWpH6=1(yXX972s!&oR>R=^b#v28S^s{Y`*q0e@xrrztFJS9ze+!!!LwAj zF#FcG564oBD}*~1-MC_0I(>s$b?w1Lftq`tip;SSJ!(?>MSBB>X7#7d?w9W>Ca-9y zPR}+7nzuRSq1xwtr)NCyFkj1FwEE4@*FRP*d}(ea@w{`{|2J>C>KQ9izAki+-}kYB z-{`?TMh;DHg#!lswolW4NOWw<^n0k!woBr{u>(n)fA`9#)E#lspCWfPTldDd)|@>C zAH{opY&s5#2G9B~KeuNiBlqMrOa)8lJYoFzRi=5*vNZ>@Oiv1TY^|L6!R2%EZp}N6 z$NjC%jvaok_3NXM*pEy$ea_4J;fyUcNt@&R|LkB`e^W)bEVpi>!9+u2_iOIiDp%ZI zo-Uee)$Sm3==Xt24_+UaM){TQA%FPS89O$dsM@@AvgMD-2gtN0DROBwZHx2|b$TyyVTX*&45B^-aF#TPwgT zrFQ83`Xwzj%6IP^KDyMm&HD4aPb{&S%Uf7aEUhq`-*;e#@$bt8d2yGujZZVZ&rLk1 z{;X-yH}~^@k1^?2osipYb>(S=S@**j6~8G`rxGrPH!et(i_!O+!>(VR;h7)S^5Sl- z4Ez3lj_05Ky}f+~`{$INH;o2A3$L7LnYZXdJ};N>$IFo?{*=rtGVEMGMU_Q+yKBBd zoB>za^m(rr8>~x~FP9bj6Pw1Y&ch=22R(<~n@(Nie0p%=`G{=6s%02Uo^W#T%fXVQd!IcrU&eoN>d6hHmm_czP+cROpIwmn zV0&d}WJ=AIM%Mn?yUp7VZ+#G0VU%Rks_={1O|&fhairc|4Mn9~w3#V_{j?-QM^ z+-bt=+7nC7{=9R0{PM--6U!nlbMD#n<()bI9*&|zJM2|>gyY?!?za8A$WwQCv#V_X z?rlpGU7Ptl+>3>;`!4)?L9Q!ePR%CMsctVq-(4&@YsX=qzuY{xdotVp)C>)|M^AP> zNsdnv6ZEXV;p`YA$8~K9GRLOz8o8dcZdtZMZkzwg*DgDbT@*gQ{7#hc?Ohwi=fB<0 z6RDc)H%)zUKlgGEw<*_`^%&|UzTfgeIp@2`=SF)k&gq-3eAR1ZZnf{+UdsD-NlClj z5ysaIUD{{fb{kD;=N7U|FyQ{0ye=Z*7mv3jiw9WJ%-X~t0 zZ@>G_FIl?2EYrh+nf3h>rnOS@n6FImpE%uQ)89__ee&Pe_niq__qs=Cil5AL{Y<@L06b-M89r=R}iiDk_G z9`PW#boFWDXUl4Rx8}~{+7kJSwLp|Ditn`U3d^b=^Y<+*U`%=Qc!|)rMITR#E^PCE zp(B^5!TZxYq1Zxh>1Dkyze3~=i}bANIe8*NRx$AO+1ICMY(B_fk|K96)QhW6=zitP zEpuKTGBr*~`+GuH&m zZd&wQW{bmhr={AmC#oY3Et~frs#ZF^ z(Mv|0=?A-gcJL%M&eN~cpD4E-yL7z0+&0eUeb!>r5)ON%?K0`Y_RpiQCr{f~elvNG zr>x1_mEn8|-uEwl|JU}kbas=ImgE+;s#VddsWY9qK2Q20DVK6*!;#6UbM!3z78X8m z2>6%v(~0xm*IQqHiiRKGY2h2&l2+Q`=quaw?$d0K`;tPTH}nFI9bxgGw8a11tmQi% zC?s}8xEq{2@N(%Yk7<%6XZY7lvN#p8A^7#nDME(NUbeoIcA5FO`M9=&8dE{RAto-q`*>tBFQ%|y?m!Md{cTc`W zRppCsN7?RK5q8BQIy|IBX}g1aZc#tmCRd zvI|vR+fs1S_@dF<|K4%D;q||L|Gxcxf40+SODA5}fRw*0nylsOR0Fp0S+Bl)v}mS5 ztv2)0Tc>VG=BQ2OndhYMv-cf?;91G%taIlE?v3I;;$Fe8)O?6hxM08h+x3$#dQY|c zU3KzrLx1DeIlix+N^Wb(Z}H@_Abip(r35O~P3yZ^p~==p22-*D<@mb?(W=#c+dQ$~|5{FR#PEZ0ok zhUb+RA_6+!sX6+7ICJUw2Rpu7t8NARUj3Btg*|ijy6rccTm3hwt<<;Sye47u`e;&K z?T+Xf-};1oLV085KOJcOTVf%=e@az^<@4rGOa9w)S^CfYz2(iPcPmzZd-(c>Rp<3{ z%+HEln_SwepFVoS{q3TLz^Nzt#df(<3inRY6}Y-2d-A849*ELnc;{0p ze0J4}^4${*Y?YclCDw}<74Yb;%uukn*`HEir&waJhi%fNB-smJ6(USmr1s`I8l5=! zbka;^oA{K4JLWxf?=L?!b(N61;(HT^dY2WCZ+|SYQkM3cctOoTAT)Lql0$}%pV+rYPJuZ@e~%24M}{u6g(LJyqIUwdnJaK_t)@@Jjf&plr} zW7?DWbJJQ(-CH^D&)>zQ_b1HNF2w8?YT?@!uLzeL9* zV8)t977M>W?0NS@AZYLP>%SEr=B@ac$jpA|xKGcUTivd`O@Yf})a6+cXTIoqz9NWM z>W1d7&;$0;G7mZbxGRKj6uj`yB>qH$*Y!K%QVUkqDsRv7*Q>C2|H|NkjPi%Lg}f^h z_~-3hq4D`}b&TxnZogk=wzofKFu3r`WWL|Ba+io)T|VjF zBKAjY+0`f0Y~q=w@17Fb>ea)wX{Tz>RT;fLR!7m#cjj}z7uJnPyecz*urL(d#96#w?gUAg{QtKhUNs?7zq z_I?)x!yl>@Zwh+n_`kDx#lP3J;<@4!swMACDlR^87-NH3% zSCpL2t=WDmd}A>Gxib}PB%3VxNv)^rMG{I>#OU?U3ziy?zwHr|Bs|_ zZ)012lvi)sJm~}9CeCd9pQ!)sYt^aT5Y?1jAxv|ctUXR_oAfL=QY~gp!0DfN8!MBZ zi5G7=u~Xy}|LQpc<^OJm?pzS6{Q9c%o*uWwMXMaHu=8~^1c@gcu$=Npz-sR;rVmA` z&n_k`*OPiMzvGeH2hF*!k5qr^{KuZSXOZ+*vAgO^?j2BxE>BWu4Y2K!TakTjceRSi ztB+soUI^dpd$N3Eb?MO{)}+5DbJ+hRzEirRZT9^V?~Btr*%i+esWcYHURl;rBNEMB z({Q_X<)W4B9Nez=13YGkt~H+-T2r1d;rRQNVt?#4Ek8bgvn>A4$CByRj1%v7@)<2W z(;o3Lci)rVkzU3 z9_1oBFSXF|XK_&5+CFV}uBr0B$~{V)eGP-Q@O71&=Ak?-n1&ZU#vF5O?r&ybjJ|0QmQ^EaVKK2A5+8~JbHUn%FA-PJpZJL#*#`X?!x zr=O+HKXT`sSWi-=&Yr2=dDgqsh1edKi^ZA_MAV88^@egyOz~6=jyYqvNNtZ zG_NhVU-5rQ&LW$JYHgEf!JJ%Q(O*laTh>h|6G_v3sb;JnVU)K#J+$hjyXNAy=W`4@ zRb6x4yq35eOxB%o(>nT>cH@qRD-%NkYeTA^SHF_ieNa#(en9haM?q)ED+$J|SXr4% zw{0JNp6wMA+O5;SM8Wxr$n?smKMy}jnAWyo@7-zqpFeGCzZS}?^827t zXOsOq%c!L}rw^`YaI<=L^AJ7;drxg)K+{))yPoeitji5~ja`dZ~mSkY;VeQN@pJ2j35 zol2_z*&2E}{gAl3iNt2{!xx`F{Q5P9`*7%|u&R!~N#VSIZq2F-Tz#&%+$MMVEXnXW zOqZvd9y;8=Bq_&#BSwz_Kql`%8+#k5CQ4b2~~W$sDWr zX6+ok%<{$V$aBrNbDy2tX*feb7zsB14Uf~ooA9uF!xjR?v$b4s$mjRv2b(cg+E$3o!R&T1Uoc?*f z{F}{Qs#{*Z+#$e{ydaO=BO+V$LQbj6gW@jjHj%IuE$W8JJSoY^dmK#f-jFCy(at*ZHzp zt@E=_WR6@~4r@b?aA*DN&fZ_=;&w4?4%YL^rAtyc*^hwRUo%Nb2`Ecn>x$SN5rlkLV>%To_{xd(vW~=gz z_WL3$e+NynUUm865;eWqL2CCVubF@2re=rQn){QVT#5<2?&N;In)lPW6XvDalYCN~ z;u}k&mUM}Df9}b?7@fI=<#f!63r`M3@?Ot9mF+Qea&yzxW$BY1a>xl>&W_b)?do~{ zT)6j>^THa(%0nvWJOZvfxwMx-|KYUn-Y;}wzIW~OOH!T1^<>5OS-Quwugd&lVs!C; zu>H|R!Mi4*Yl<@(Ed4f|)y!R@y~X3J>JJr;*RIQt)iK$#?A5&R`FmaZlInwZUFZ95 z2wkWsb+Rp5uJdH1mh9>5M){`OqMxSlEe)H=^yomA)~$_dMK|vGSLx3Dy8m=p#!)#5 zceyn$H)j_3NWT*dnwcB$dvWRa4UV;`e(|PSd#ff?D8=thjYn4>pc4`^- zxlZ@~8R3_egwIQ>DSTQK(|xclQs&U{c^uytCU5JsT4?+?va!bY2}eZI49zckH+?@9 z+?~CKWs#`leD0tU!CWW(kCrnXZtwDmXFd`9Ugmvu$Ocs<{zW$CoEnpM@9byWxv%%g z`m}AQCvSe%m)M=qz9#b9i{)+8;!k%zQ?cW7(vbArDfIfcQO*rJ)pZ>zy`Nv{#QXbu zh}1AzY_QriqvO}C1G>_Dc^A*!`e)?)m3Qhqwv*o@xtksNz2%P<7|*Md=#%s||9yRt zl2i52_UZYLzEc)XHGKU4=l&f^f#OGS(BVa2J>4*IhC*=mlapRS)bd9$0XAUL)vzU}dDS>?m4 zqCN}Eo4rfbA?{x0$4k}c7OwF5>NhL1Q^lTbv9isCYnA_ZMHVl5J*hdXN2W3Q1mE=s zpSYM73YWi_d}deUPS-X!g^=wV_h0$;JiU42Y4z313}dcscGZl2FR*-7*4dVemu%YZ z9)DxIZ${qNqBGs)i!}K>cq4Z+vmZFfTFQKTmQbKLms^+5bl1I$yLwKk+uxh8NWJLb zu61AgDr;CT>=c};mYbw}>~2M(X3Vv&kdyb)?jO1(UVZzX^lXlAx1Tz6?o(VI@=8ki zi}a@p?^GAAwF=)bU*6%dQPI-XL7%uy)!L;OnM^dDt|Jn9R#55Q6A=XqbCr2+yyDYk zn0Gw5`e^P}pLr#ZudVZY;Ji3#|EIdl$Pbq;2x~eCJXK&``*zK@M~70^%*~6qXW(-$ zu}RKR=TLN@))x+~$eGg@zRBkLUwda_?TZ+#Qzyh887R2^xSCV+c_HVrYNN!^v@)L3 zqchg;*A0&c7~PA=}MfdIAi+N@3FH5 z*zWX-UA8>D?~9^5zs^aH(AeENW^Wh9ZC`UBYSMY(LtE2N{Y>P0J+=Hzz?6bh+m>Cr zc4P9n3J0_JFCtx!3u>yic1~LqRCUQB?k5jAe=zEuY%broSmt(t^53EW!SmkF zBNd!gCUEc3=R5pzQ=e31&|}3f%eSU&iR=mBh}JNez~k+^zCh7LYrmvqjD$T`1=r#Y zwofg77O!@Yd~-msXMs&4*YD@kf6aJxDbeO(lw;022G#jOe_funmZ-gaku7?T?=JTX zW)GGAKm*C%C$a9Fr(_(ro?puwQ*x{FspH?~`+JUFVcC0g!Ofkmf!w*VYlXZ;Prki) z#ru_A_c@J<3zjM??&gYV_x>qqeBPb6XZa7_St(b!9hgtuR17?EV~?4=R8-!A?q|=| z^)vmN?YK;J!W%cqsJYBProJ$+IP9qT&SHYOSmm2ZLYC_`TrtShU_8%jxHs#9bdG+8 z&z@wplYDtTO^nMdUewa9Vxpa6=Obi-k-Hmmn%Me-JXE6*PrkR$R;dO ze|n)SYf7~9^yy`P*0~>8!%-8Z@-fL}=C#-H&y=lpF>k!B-l-AtWJQ&r`iXB(`~6SL zcz9{1PN#VnP0c-#ZJFH@fcX|6^*jG)~McNa6c^$MSy0@p*qg9nlMY|FkUR zV1oPS^_!2LFIhKX(gjZI={BqOG4(B)bMfJng34Ui>gGp2&c)G{&W0BqmYMnUykO{K z3x3osqZ1aVpI3Ej!-Af9ca^VwG&?cz{Itw7a&t2zOJX-Oy|-t)S>f^JBla!llAKfb3dSY?4!rq&fX|oRcKFfOH5qmf``Vf2FoZB1E z`kZrL;dbeTh`as)@pH1ZeUl?+)JH9m@N4@%_P+4 z@B9A?efCPs@G*;)K9v;6_|HppnU=5rl11ku;}~~MVP)0H37^5|ebrygW*OVBPum{( z{W00Pb=r-$fr+votwgfL+1u?D+KmCb^2sH(_?m68#CCisxllgR9#3B53)$Ti&zo@YrXj?suzP!yb_+QNwr;C{xYk%%7 z@ZD<>^0X?DRW(Wd)WNLXi&k7Tc@jQ-+ijWS0YVi(c%P&IVb%YMfZ=5@hjlr?dIj zrF`vaOMh(Ej{Ldh_fCysrI(BMKX|!rVw$x}a)?~$%0*9$?WX@!jnZk!4{ZJS@#EHv zS)USBW(jmxt=iNXyK=|w+NeoyrzXyCadY|o(8=Lhp0Vc@!{3WNt|X=}Unn1`Sd($k z<4ARziXMI>YiOE;Ba; z7L-Tk>YROk^!h?$tvUZV>_e5Wud%<}vRUBAf|9>)PM&u^^)ULt{rj`hP0Z!q{FgLl z-;-B=@Q3}+j0UZg=x?f@Wv|6Z1}^%QQ}gI$#VG;G84BOM*o|1aj9`UU0^G?>??lvwS@kt(+wDVpR>YYC{=f2d-;wwpe zSn?B&+2n4ulq^xIX)kd3oV0wuisGISuSGmBgcjdE>M={Pq9y98(?q$%v_1{1pwO!# zt@lz5Zcpme;3>_QP&>(F`N>OFGyK4c^1Bus6%P;E8JIby{V)3Fp?#0T*U!wcX zx3%4=^8R{`Gym52-&cwcc6o#yc@uVX`s8ywY6ZtHd-|>4@x!Wl!S`!>j+UKy*j=^V8nh5%rVQPFnWO*64O@wCwYE zd}A%ER?Q5XC6l>@->^5Lqkr9+o7So`Mg0r*Upwhp%URG6t5&#L+U>vp7pWy5;+`|U)sA^)c<+sZ zub#=2=P%wZO21RP$M((FQ`s&KuWo!5I^xajYtXyM#;5eNnMy447tIIEKeGFJC%xsG zq0MWR#;KS3UT53vio)w(wk-M>qj+Maz_xqSHZ3g`Uc`0f_0=U|+hf0OjC-C^dDXLs zW$Vmue=dn$Wj<8QVWYTE{KVS}DzAARzpbrpE@P{aQ5ST+uWh#W%Fnx#=iWb}#8)-r zdemvzeMy_9U9&AKG2ZO>W}DKkDpNj>%2%_FOwf1KyP|07bFyTJ z!mmx8HV&!>9{v9BdVI;A(;7`q6E<9|VB7cE=DnR&&yi~a7uxUDE=^lk%6c(Ib6NO9 z`2|xI*W|mGOTSB=Cb-UfhEQ|bFV2g{;xbxQFPL7?>{zk#N&Kmu9?sYMFW&TW`jqW$ z5WZpSW*g%zGCs3gq8C2rwrMV(T5|38o|l!JWvq`^pIWj*P0`^v^U|~z@4ia*scq8d zIqAB}dM)pw#xLh?J#z0}!l2Z)Y~Jzg;yn^sn>(IzD%T4FVW>Rn{hu7~Wo`ynkbuV~-&Q@$J;{*xC z`CLodd=-i+{@(d?@bf%lz9U`Jnm+brDsDN%)}biyB<;mbU+>4!iyh!s|-le8}t2XZbQq^4A*<8PN$Br)E zy5}`5d8W=EW^F$#`^|pY=j?BdD|9NpFZpoSuzC7-wQ#5BbJVwf3!SI*WbZE<&u>OM ze75I)o@&?m`f5`4x#*}nm-y~Ac)ZxX@K{)=@K=x0Se3^*AGgjG+heL^8JoW;Y4<|6 zlk1ijwSM;sRSaEy>$2^V{z}^$97~?wRngqMFj@1S=M#_AWAW^(IuASlvwHrAWg5$( zdAiGwX1tgnCM~&3ZMWv5L+c8%sxBWiy4-sAPui_5Y4bcK?5aDGd++Y4j9JN_QL(hx zL!w}#OwE`1igFhpZ14Y@;CIbq&F((kb&91cMUJodGvRwl_U274Ymc9tVRv_CW1<`T zO^sgvhb195*6Vmo-mMheRowpIt@hKJmydTGFpr;6+$^xi`q9JFUuKHmI(u{JnvSba z*i{!CPSECv6V^{Pian4k;5K#blh-zP?;Ni7nZ?#1>9lu?*{r*P?-p)*Ej7Jl?Q-eu zI<8{(qFb$391NGN{Ovhc{m}fD-uB7TY4^{jxm>K4SzxI1_@LCs%!St#+b3PPF8^Y` zMz;bzMTK%-XF2F*(ZMgJ=iUfz;2(E z`sn-n>CgAi<-hmm+lOb{U%s4uU%}|V?7JCyA8u!*^=8DW%=6pUrLwjo_2seI&-2@i z*DSkS`1%J6Z!`PVut?T|uBLib)&1^g<<4xiQTdqm);;#DX(PkI?jQGkpQPEW)O0^v z@OJ9+7Ojj4!J(E9uB1LUxhd1lE*j>REW+N=yqov~JCmYa)}yPWIow>BhHvyLn`2mHss8RVSB!YKxw$dBgAO z#`j^B506$B^GPpU;PEv5hUvN4n>KIP$z@gBBjmHHsB1=2zP@`0ir^#{+-C#`Cx2_-h~R`W|~|ebx>K6S2~q z>WWD-Jzah{p4b?fougNIPArtkG`U=YC(69rBSgP6WxLsA-%qCm{_p%!rt!z^-1NLf zs|$`APp?)!Wf1Ts;%MXNza3$QTemNBW0^RkQTh83B^j&Z`ev8*DZW{ABi{BwL{*!i z{3m~rUD>Jvm|9e#(*j?1bT^ zrJ`DA_*U5NI67mp<`mnG`}>#4E2PcQd3L!_a=p=tw8gWQ1ZdUnoFUB_J-z=nZ#~0E$LGDP(l3zW&*`K=?PV_Lj79VvudAen6D_`4uml=-# zWu$$$T9OT)uXqH zl&qcQufFNy790Os@y{P~>|$pqZwb%y=d)7s;;Vh(lKtRo7+-F5j(@}z`3=YR>ZvC+ z1oxFBTfDMP{Vun|W>cL?=7FuIatUpRO|H4VTPgl1L;U4Ir`>1og$UnS`ty0tIkjbH z^Ft4nhV+z1wXJ`)bAj?QhHH2C9Fx2@r$akD;A82$Uv?9C_0GJ_$&pr3De*7ddP#Kk zlod{L`Je6`51-@eaaggxBStlQuZOab@1ARFYQhbt_8T9{S1N9AexlHDg`M}2=(A_N zKbOBcbCv%{>k5{#Z6TF``whOld>*-0R-$~#LWi8xZK;8;O5fhIUc9}dc7b4>$La+$ z!uq?f8SFlOvFy|@&afYO=Fw6f?iTCxU0*F-tUh^Hjl~9)t|@=N=El;7IR>sfO~06ChD2ujZcLw&#kniH|MQx&@9%qC$UJ&+;pUdx z-2wL*Bh42jmGh?6>~7m9^KFsBw5v6zypJTxG=v=aw$~$Dve8e)dPmzdnc3!tFNUvu zFS^=b{_C0}!B#qTY;k5bO_sNB*&aL2FSTd(#O=%$tkSq^ZUEGflP|!+tl_PDBTj&>Rscwfveru=g6G7FYlyXK3VZ8=#rzI;k{0c zZ>n*-I8QCOF1C2roChZ>{bqju-exVr`^r)3)7HM)@&%iPJYQxSZ1@&hqbs*eam)Ox zy&73&E6OKazWm~`jJ~SnoSPH#cEy&u7B7rr{(e=1+ilm>1My4ZAB1?xt*}|^u|{Yc z*KdP`ma_df<(HLy&P-hGcmDRvlwA!G!f|fRIVG9v&RK5q@|b=3&BeuR8+l`bKJxV) zn}3sOpVzAi_v`O#A3L?=;M7WQu}g7h54D-Q8!5lj(>FiKv^-bu(~IK&i@uvo)01-R zY&JVDQS?*dQ{(z#re}|5o;tG1q-*QPEz_UZl{C#Mo^N9Q+w#)%E4-?|T7n)6?{vGA zD*TeYEB4c&-G19{a!WRsN6 zpd%Surr#@Hd@0MJ^knHFcm)=fJsvW`}6o#7O2zpCPh((}{H&uctfz2nB;salM3QU;TPCq4Pn zw|RCWLyL%QNaOiP&YC_k_NUIvPvi;)FE=pyXmoVDgXMY27k709b)Vim+#V$3kSn@b z|9S3beaqtFbq9Xggx^Rp{I;$0vz;%~t7J{r*VF$koYOw%*s_M*$4f4}teV`ZChTQ* zhR@pINOsA_^fkHR--~ST-Q`odros!?8|){OdLw= zU0>eb-g4#HDa-UecHNvizXfC~r=(qr;b+`l)46Kf?KwYd7I^r?^M2DlUL1PyqRYey zKls~HPUhszt=QsOI3aL>z3D&u2Rf5VKs!2M`#Xx*Ks@CA9aBSY=Up)n`1*g%rZDZ0 zj|~+Jj;%-RBl?Uz-7Lyd`e*CLpZ_uG-Lfr0Hb;v;&YW3%Y~zj7rauIATQ*0AE2i&n z=&ABdc&a?<&!V$D*Vr?+&Ym>SLZYYU&oB9zV%3VlJVJ9fW-?^@saKZQ@3X&uQcm-q z^_9L4dNMID_C|ay)-N)0i?g#^(awK2%c@&1cGtJF8Fb=2>Z@8=C_)pwla1-|0&U;UQjac=a)z4+*DT2J1`+VIODWHSJSZ~ z`{O<36P=8aOPZE;qrXoZPJRNgt6ZtWR0it}4np5@&9^c-vV$v?dorcbV|YUpm9dck^YP+IroP0C$! z9k*6nNL0L5)Y`m8wK%f0f%$H#-q!McpL~7`*oawa9sZEiu_+*O_m(dLi&mUnrQWjk z$+P8=?llB<)~w3_@g7pK}4JYwxXoE`78(OndzWSB@`Pn%dry8fKxZ`${j`edW|GePP$# ztEt_jz4gmPlhB{}=e=tGfBbyAlz-M$JJ;Wz{xnSIlI1zI{;O@Onl6Y$s%eVbKye{%**wNj!*RrmK%FWGtvaRUPou4uFQceG(Sh|}8Y6R*TLKJHh+ zPoSU4iBF=B*@;h~m&J)sqleXz&!COXgU_Ow-G$GADTs^D!jaFwkx#>kPr->#!ii77 ziI2mbo2dw^gbO#wjww((K<;3`W``%p4i}gm{#cE2<7O(wD&YyX;|J7^4Y>RPw!;x* zhdZAG4(EE~vcr)Z7IutP0Y2c6WuFbQQ5qJ$0SpWbDj*RC28Pot3=E(+g80=POL&6a z5y-cIlX)#87oUX-Mu@s`L*u;yY9KEPc%VOdxybK-GA$Le-#! zu`4_t!S?#_H83$JFk!XV3uf;JsF{5XP&4@&n9%JN0fjXK1H%+%s2VhT5$OkPuRC7@ zEAvl~y_hM;1!ivs)J%DVy{yRgS}-s$JYj-3?jVSA;uGj)a_5uiVRqzGXk&5Y(`aUO z;WJ<=Sm9|wqy1K$I?KFzA>#Ca7s32~au((cnvmu(;C$B+0`sg8F~;xU{)8HFfhDk0JU`x=?!WeSRXTkFqlRsm>EE^hAzs$z|0_qDaZg4M^8Nv zWz6sz1;U4s%nWicCJN1r;!B9sF9rq%C8T@-&7KURj0_AyNcjs~KQS;c*g@+uh;9Vg z%nYgH5F!wk3l8;Bj0_A58H6B;7#QF#D953`9*1~44)LW>_k-&^1_lNgeI6>V0QD%i zz5<0Y6U4t4z!e9i4gon%hlznfkqOiS0Pzs+^kBm7-#{GV5je!-afnyo5I4pl-ibqe z1`hF!IK=tt#F9@Geg380kmiZ)tR7>Eyba}9*1}b4)NJI#1G;Se~Uxh zhy{E6#^Dg}!66PxPmnSl~&0lb;@+mYBp0P7mZZjmOo=ZpDN0SuMbcylu@|h@&=_QbA=rLHQxMw%L|B3dL$K2f zF^xA!Da|d2FDXh)PK6m8@9yL8=d%b`6OSadh%=jYl`c&>%NHGq1QLF)umQl_57ZH#fg5l_5SV zB`2UP7wk48gZTK8jH3MV_?*tHWNlea;PtM4WPfN_qVTcdSE6>bJi4RIGF3nA4 zh>uUMNQ5W`rJ&S`G)OkXrPhz2fhM5L;TjNJVrU965@KLdX_{wpuwgvd z!Z4C7G&F`71S$m}#$ZH;t1~3b{XjuZShY!hL290BfHx>&jpIG@i{t$ZQuA{2Q$QJt zuoq2}b5awFT!Tvtjlh~c^NULoOQ3p*aV<23Ajg;sB*sv45=sFD$qQ!j@%fMt1(gP= zMI~5cDhLq{P}QCx@gWBBuEA#U0p7vJ@j0M;VC3#>4lRx>K_zrDI6s5ZF31@$DGQJk zsE`9EDZk)+%XnXy-2vWZuC77B`61xq3PmaxmqZeh1dG1t3Sn zm*hjUC58g9LyI%3QXw+I`NjpMCE(IH1eD;2NJXGP3C=f7%PB3+fErRlOnjOq=j0c| ztOcbCP$tYw2G?7j$*$1o2D<`Froc?iV0V<5fwOrkRJR{;Wn*X@?+dAI;=$Ps6lcLD zhGxhGWpZM12}m52Cy2@25PQJIW>RW;W?p=9Vo7oaw3tfGOM&rG>vr>$%;Ewh&%=u# z6VJTN5=6E{6^GiDQk);3k(if~123;jQY$jS^9Qh=FR1$k>RbQ$4*{^@T9CK~0|Nt0 z95z0p#lXM-!Z7hhXj=uO9@(6|IK-Kt9d?j6;vEueLYkhUHvU2ape5+5=qhN#MG^;%fy3N$97)_0 z$(;L0;>hXzI}UMQ9#AO&nTJ76|NC)>zeEy84o^ks5I@LY$l@MI;>hkPM-oSN|92#D zWOKNn<3}L#k@MF)s5mJ7fT9`}KC7YPAoa-kWdo8pa=zOR6$hCE3M!a6d!XXz=CFVg zE3^&=#W7618B`o(jv!LJ*g?fX=GY^Nhaia~r{^RjanKwG%=|1QaX%z;N|D6{0~H6^8;vABA1V$q zKL$yB8B`pk9=TpPjU6$hDvTyAG0 zi6fV91xVs?Naid+5(iy@0t>gLNa8+7>eoQULGA%znELxragckE%lS7r#Cbu52-LsG z>dlbEk^LnGZI^=56{raYaucZLYDa26fW%?$=|>X>*#S~N9Zeim27$znK+AcU`SQ^I z%o#NCXsGxVG;trO_#HHH7O40$G;w>Vcm*_kVD?UeiZ`H%FM^7zAcYUePcZ*NlNEU8 z6ImR@2Kf&?UO;ITn>Z|7LFz$kCSc}+@&Zh~B~p6G1qnjq5jnoVonvUf1LSp>Igoj6 zNPEKy$((&i=78J`Q-2gH4oYj*Nb1iZiQ6EFUxA8)+;58{{vJsj+5GQF;&w>tVGB1v z<{*ayEM0)ak=4$E&ayFlWK3=9ljpvDLTWUK?G9yS&P;)CJ{M1$0W z>}>{BstgPapf(}0_@9L!9s>g?u0brAdRgo2x6kO2{R3ZdZQ zub>6qM>O%)=@5ax5DKn-5;S3Qf)W}7!e9NMOvAtcUVj480&`CwsByu-z@Uhx{vR|k z>Y|B*)#@AfY#JyI6R5LIHqKV%EHQpH*7-G@HS3)biOf>Pk?GSTdp(yu0uwiU4&pH|NTaD=04;|#(8OWt z_0hy{ZiSfRjwb#aG$_Tuz~F}_?g`B=iD=>>{Sb39(8N>MLBy-k#6LsRSreLgBdAlt zz`!sQO&sQa(7F_miLh|s*bm|{Fl@o0em9!9G}Qf9(8OWp-$oOk*a|WK3z|4g{ckjJ z8)!K%0_vO~l|RsB`V7)&;%A{1wFR0uOuapt_#)6C5Ca2444Sw}1H_%lXySp;bXbEX z{sJoAj3z#L8^oNsXyW{!!2<>ch9zj?g`h!A1_p*bXyOvk{CgNpd@g9vf`NhIEtkz~}uzobme12$sF$+z7A++3HizY4$>dY}PFdRS=->nZZ|16sLDQLZX z8BIJ0+U~u9CVpW%#GJQi;!C0K|Ai(FGauY=L&|ra&~(TO@+gux%zP;{@j__(Rt-%& z5!6{^U|`Tg6X%7de03ZPxOh*dmN~n7j(8L#k z2Dca(7;MqRVd3nGCf*EL;LnhRCVm^#>11GF$U+le0rhV!nz$RZHld0CgXYJ}XyP5v{C)>b+#TAEeS#*w4B8Qd&EtTA8`NJr25q;n zKs(ql@iu5ZB8Vm~2<>l5qlpJYJ7nr;;wz!;F<4$xo#Xdf7Kz6NG*A+&z9MHAPC zmcyQC;+vrLP8gc_YiK_r7ERm@+HWmH6Njm9W+SK zz`(EyO&k{f8_~q)L(89YXyUMNzKkY*7`kxg6PkDibmQGGG;tSbe}M@)e*_EX6ll8Q zM-zv|y9}E6PG~zs8BJXN0VF&v(8OWt?a{=gvmojt(Zpfu6VSvbL;K5>XyP#S4QS%4 zmqN^+hb9h--=%2c6QTW)gJ|Mwp#8*iXyUN`)B`ke186>ajwU`0D$WL-4}yiiJ+z%5 zizY6Z330y)nm8Y5(w>2V!3Is-dNM@4Gn)7@X!{2?9|yD7ZX-l}2AX>LB#3xEn)ouP zz3ph?<)Fz!1_p*cG;s-NI$VY(t_mH;TZ<+ha|B}VQ8e)+=s?{WG;y&!i25gJ;(r1m z;;+%ft!_ZXnW5t-uyBC26S&aCJ)rG6B{cEP(DuJ3n)vxy5c3_;#KWKicpm8Dmm%sC z(8TSa#2Z1Ax}bhBnmA1T5j61=phXG{3=AL8#3P{T?FX9pbZEUS3LW2tg#%2z zESh-n9!Pjvp^3xPJE4jHfws5f(Zqd0i)$Dd7}C+i-$2KoThPQ|>U+?{-Jta}YQ;_&_pnmBBIz^JoCRucGn#l9XfmIHfnh0{I86OoH1T@q#;WsZ;xP5s(ZoYRi$EC| z82+J&!_>1u`x&rsXomKiG|iNn-Kp^2{rEs9}aV5mV8hpBHt z6JOZ|3IEk-;xP4_(Zs``<2+Z<#CJi*bMB&v^EE@v|BogPQ_l{aAcTca*&T>_O*Cl6Ety2Xng%a6W;~RFI>=e3M}02L(`80 znmDZgu81bi03G)>Kod`b_TPD-{T`V4vC#P%Ni^|G(D58KG;vseO%F|69kghRfq}sd zO+3CB5}pxg;;{ZyDw;UV{9H6~dr%?*^*7PPC86Ow9Zek8Pn?e?-mn|uo*ii7uy*VL zH1R*sdBn?T;vcR;%(;yw{u|mpe1|3u>mU6_6Nj}AIiURmSiF=&`$ytv;>^(T7Zo(| zG-&_D5KY_~nhualbie;$NWi z=^N3+Vd?M`n)q^Pxp50koENkxn1O-e8Jf5(bbRo{VBy~bIS7P75KTM* znlB{K#GgXPleN*r??K0}jL^hyLED-BXyO&n@y{3>;>l>@=Rk|x85kI<(Zuu4Legg^ znz$u&++Z4-xFcxM4QPA@O+0ZT#GH+2;v1m#)JZh)nb7h13uxjs(D9HLXyP#Q-=m3# zL&sIvpy>h@FHF$(E-#w+vkr(mRnWv?`O6SZ9A=IMnz$g;zy4_AFQDry!qLPPpzh8` z6R(7}&&$!oC7|m}`q9KWpz{mU(Zt)J3s}~ni6=tS$u>0cuh0c?*U`iUpy75OP23+^ z4}C%te-7HT!N9=q3r)NU+MXAJ&S%2nx-Eag!Ag_s>QXmjx{zWME*}geL9EF#X#biOx-JG5p8e4AE?zY8r_l9IdT8Rs&~}I!n)sPh5Pt=s zi64Wu1EbKySA!0$Vqjn>MibYEE`qB@6R(HX`%}=wQ=UNVor5OM3|f@Uz`(E-OEG?Ij_;gH$&@v7U((@SUAJRGX>GaVdhApiO&XUWME)0 zLKBCnw?Y%Qsf2_>Fq$~5eHe`b3W1;wPc*VTR6kfr1Ovbc3nqLKAO-wr7;k#9`{S z(8NDO+b7Ow;xP5zXySs&vhpE4aCJr0F z_<|-5Q~w7|d@r>BA_@vbr1?{rdRa7aZfJkZ8ciIg-Wg5&5oqx*0|P@Mnm9~-CYrb^ zG#$31iT{L_d;MtQBGCT(3N&%pyu$`G@hQ;tDreEeVd}4gCbIS)k*nHfZ87^)6`QhS2fKL^Sc2<)B=|z>tY1{tsIIH=>Ed=1n@$ z#7&{=lNX|i!_==t6L$xBkb!~W1e*9xXglEUK7z#yY~Dv6O`IRv4lzd)ht2!gqluS6*D;2piNpHK@o3_`(0QD4H1Y4y zbY71p-Uyu^nTsY4Q@<2VTok&Va37lZbZC3y7@GJSsDE#viNogUAEAkFfcArap@~nP z4~a)6X!?SMGaqz3QyNVird}CMd>d4~IhuGrbe)eqn)qqxctJ3lIBXs*8cp0DIzLj3 zCJviNYd{l+&7*aoiEo0=6D>s(KMC!}Z9)@=nX?N`d^U7F$z3$@6zF=?|7hYd(DtV^ zwEqDMXV^TQGMe~n=zN(qnmA0oGn%;hEl4~@qlv@j^^(!VJE8N%)o9`{_04GF4bbtT z*=XXi&~<~0(Zr2xAnrMUCJs}70!=&~+CO@VCJs~o7ESyOv_H-TJ#YjTo-p-7XyUhD zLENK{CSC>2r{-wld!YxdhMgeDGCzY9(L548Vs2TdHN{t23RC3KyS0JPl-3m=$z2{iFl(EgP@nmA0oJDPX{ zbiOzfO&q4a5Ka6JH2us#6Njl^fF^DL-G_AuO?(P;9mRPxabxH@itA|Nm!acMKheZt z>KUQ!bXfR=K8D1*9GW;xy&9VMcW67=15NxcbUq>gP5d!*KSBzc_ycJA%s~?m0Ueyo zz`!sWO&q3vHkvqp4aEIt(8OWtub_!{K-=F8(D^i2IKb3%pow3G*30^6;xP5*XyQkp z?Z{*_ahUpSH1X+B_f0|*hpC^1CO)SC;@@Lv;xP5+(8T9KHwb=36Njn)izfaS+Ah_E zt`|cOA44?pBhYcGSTu2%`Kf5)j?jMJL^N@j`k83rnb3awQ8aOw`m<=_=b`Q7pJ?JR z^^DMQeVD&mq3sq8H1RU1xB;5D7c~5%(ZqK`^HDOIxEVD3`_RNML-WNnH1T)Pd64aB z;;?l=`_aTdL+jUPXyUMSNAJ+YgQ4>j?9hFpuyF8$wx9XY#6_Xw%<5?3uyt1YXyPi+ z@k4hsahQ64G;uTNe!X-w@psVnUOt+*Ep)#|JDNCb9Y{Z#xFd8u_BJ$enEHKa;p(uBiNA;L6A^;WKf}@wOuZDE zxF0lp9nr*L>OIlKr$EPPv(dz1>Wk6D+o9{wrlN_%)?v;?6Nin1>_-!atxG(PCT<7a zfBFPX9H#yans_+0ohb}W*Rb$`sh36*cZRM%_dyefsSiODe-2&WQivuFQ(uWD{t;R} zFF+HAsb7I6z7X24zJewWTPJx3P5dh~et)8g!_+fE%MVyMNI=*5$f1eD)T^P1*Fon2 zozcW$>mVd@Le#Kj*%%Ku(8ahUq4XyS*U_3tJ$ac*e46jols{Cfqu zZuuCR`eU6Cd!L|*t3lUGyhamugR1|5CJr-444Q9X_O62NyOcu{pSS~JuML_wY@L-W znmBBol^>dT0Ce3#9GduU=y+E)nmBA8vjR=rAKIU7MH7duSDAz+4qHDqA5DBEbiLd% zG;wxl_#Z|Shs}pxKof_Va~)0G54!&9HJUhV{P`1_cpG$niVIqwz~Tiqe<6q_ZUNoD zV1OoG32iTiqKU)y>qeo8FM;k0h({CO4^2M>XyR7TetRvNxB;|X+K(o#2HkHp1x@@l zv|lg}O`HKbPPG_K{1|k7#ac9RW9azdCNyye=mkT2(8SxI=bs!z6OV$9C!9tTZ-=hS zx_~Cm53M(Ep^49duBW<>CjJY0zRF89aS7;tkauX}d!XY04AA{0u=Jn}fLKC-zw*OC|iNnmlgeJZnYW^!Uaael(geJ}it*^PD z>%U;({|;I%389H^fX-8EqKRif%WXq6@k7vcO@3(NR?z)@VQAv3q3c+R(Zsc`LCUde zH1T85byhRb#J54)nG4Xwr$N^z>_rpb20gFfD4IB|UVMZm9ts_2dxa*>4oyGI(D@Bm zc*4|kqlurt5Al}?nz#nEesM+jP8J#C@Rcy(~2GH_-hu1!&?1(0Q&h zH1R*s^0OLE{5*7?s2NTC3v?V~8k#sGw7i~&CT;^gKjA!@_zY%hX_5jt+8iY9&yx}L`hP5dmhUFw7;ei=Hx7lS4q2raiu(ZqeA^V)4_;#tsh zMS9T0uS54qO+pjj0?ns0(8MQ0=RN14iAzA&RW3mj-vHe&vkFaI6S~iI1DZHHw0*S` zO`H>&?hm7h3qkj9o$ z))&9g!~>z}oE5r{8J14wfi9c`-Oq(4?gP!IGHBvIq3f2F(8Om$=dU%;#GgRdKj@)} zL#MMCEYQRiq3iUV(8RYu*EI#;5D!Nap95`|W}}J!hV~1J(8R5v`@y@>#9{VMLKAO> zmh-F8#9{e#Gn%*qbp69+H1RsOT+_**n_SonNF6OVxQFF2v)A}oH_L)Q@r zqKPkp#+Lz_I0LjlUWO)a0nK0aXyV1t@%A<}@tL4QJsB7nW}t~jLB}7~powpXmd~5f z#D$^r&PUP2VdmUK6X%51cMs6SZ$S6;eL@q5nZpL%_YVuV4(K>GFPiv1=>9bwH1T@q z`U(#;aoD*)p=jb_&~E|GtI4nI} zMiZ}rj-T8{6Ssu!JNt(wJ{dYMzy_QDVPIeYEivqewqsS%#HT{%4Ykn3*`WQDAT;q{ z=sa~4ns_SoT(t@`@qB3ep#e>N6*PU$LlcLcYqT0o9Cj|iW;AgL&>_bR3=Fr?#F?Pu zy^qnvBcS<30Gdu=`5Ja^k}R5d1@!zMRW$Km&~@5=XyU@qa1KKg?}N@ym7LI8XyRs2zB!bJnZp1bcd|nhPpX0Rf5XtkVf9EXn)v&R5cTzF;!^(edG;!ED!pdmk zu=+&{OhvoM`G;wR_I7}>>_$=r+QYM->GjzR24Vt(XG(4xFi3dQ%H=v1& zL&Z;_i5o!E*%LHz73jR_KQ!?#P;(@p`3#nR+@Rt{XyPf*b*Elv;&Y(oZ8(}Z?A*LK zG;vt_vItEaroIwQJRjOmoP;J0+t)u6O*{}fKeQW795&B&0!}fxT4=jp7fl>?Zk`F6coOv71`jlGn0kLSaTn;kd7NCj4&XK4^ z6NiOEE1LKQX!$S?O&qo_W*M6JU1KCGkZ-mwtJJG~p>JOlat3&r$+&~kD zslSgV&Iw)T_Xkb@6p6RLf0*PM-vZ(u4fa0uCIZGvpaPBQwB{u33{%$9hx|7y^}ARI1_Zg zWE7hCJm|c08k+b^=zK~6n)n%L{@sZt-UBTU52A@LfsQ*}K@*3mzk?=T18rZuM-!KT z&R={-6JG*dR}H&(2^Ma!@|G7`uE4|{q3aSw(ZsEx<&h1VIINuULlcLY6NV;k3_YKv z7EPQ7IAlcF){FG;x^v6KLWd(0F`+CJrmdKB0-j%=w8X zt_XF%7_^>*g(s}Nr-3F8Gsgf;Tozit2cwC@+EJ-!;xKb^(Zoxk?V>g`ahUpEH1R6v zdV-~B;xP4V(Zrpg@p2kX9H#y&^t_j= zXyP#SchSUEq5E8Zp^3xxAu>VR%dl{3fX>$|pozoOYoLj|6*zG;x?Yl4#-)(DTF%(ZpfrJXoTMdqCI21fq$<)JLL; ze}v|*LNsyMxe%3T;%A}t`$RNx*trlh(Zu7R?c|MU;;?fecA|+Nh0Z%)L=%Ud3vm-o z+zmRf_7P1Swl4Q4n)o#6K3PF%dkq#Zu>Pzhnz%i5JkStL9CmJlC7Sr64Uh(I5Slnl zeH5B_1$3Qi1)4bQoQDQ9aR=!76WBgfnEPSpJj_8;Uj^-tZ$T3egN{G%K@-o1)<;*+ z#9`+=+(r`@fzES%K@*3apTG!Bk1%(_&QIV(6E}d4GpnJA!_IRsMiYmbV~r+W2OaN< zKofreUFVR1CLRav7u2JP--Wi{7NUvYgsvmnizW^`hv6ui_!a0p#a%RUnEIz^;tbIA z`4>$bb`Aq8wA}{_&tFh=vS{Kk^{Qy%T+scGwrJw8{eZ4$;+)X*9E&CnQxBW}gtX)I3KZDL=?ne`c?RP$oCY}o&pSg`D4%_$r2u=JE zbe@_8+Kzzv3#Oh2P5d6T{Lw=bhp9J16E}f|X9Su!Onm~Hcn$Pi({?m**naSSH1Q+Q z`NTD7;xP4F(8SL`_qks~6Nk-<-9r=q0nMl1(Zpfry8K5IzX9b7L+4Rp;h7Fy44dr)0X_z~OpyS4?(ZugS z*9&b%6Q2P+fAS2PxH+`Ha0N|V8@lfF4Vw4`==|>&H1YM&_JA1l{Ck)?uS56o$)Snc zLdU5c(8L{};pTxReiu5=n1v?p3Y}*yLKByOwx7Gv#MPkTKN(Hj3OXOO98LTQw12lA zO*{@dK6wI79CnW1c{K6k(0SxHXyP#SpV7oqpz8odq5D)|;h6zlZ!C)@?gwq3TcL@= z)H|VxKZB-+cr@{N=s0ycn)p8GynHE|IBeW_E}A%OTw)EHcnfsib1#~>HS|7!LulgA zW*`IX{6$zez~))cpsBwL-Dh_LP5cwI9sCGQd_6QgzoCgQhR#cJLemS(Uf4XlAeuP; zCP@2AA5FX#y3W}QO`H{aKUy4`cmZ@DLMocLGBjVq*2Tcw1DkJ!t^0t9!`73`L^G!g z+Kyd@CVmK7zi&blhmEW3LlcL!qfViTPlJ}*SJ1@6q3fU?qKU)Ie~Tu58k!Ejpo!0g z&NH$@*BQb5%LOfugwe#Aq3eHS(8S+E*NLg2iBE&}3yjgkVc}zsCJuAIH<~yse8SPh zVd0aACY}v#zvZEc!|bg>6NlN`h9(ZPcM_U7%-%U@;)|j4DNE7B&q3Rno6y8z>3=7h zcnP$CDw_CpX#VX$6Njzqn}8-hw+>PctV0urt?Sr^CjJ+?zWpAWIBea;Gc@sD z==eDcbUp+YKCpEiJZR!Gq2nrAXyUMSedcK5uyuX*XyQ)LeIMy);;{86`Do%_q2W9S zO&nH!twa+qhpuDXh9(YM@3#+4{2jDBe1;|tTj%x#O&qok5Vl_g7H*=@_KY+%9l^w5 z>z9(Zpv% z_iHRg6Nioe??Ds)58W?w5=|Ud&Rj(khn3HF(8RYu!~H#)IIMjBjV2B&pIM;c3JXtI z`OJqV?hZ9y6ivJfT8^lqiJL&@bM?{0O`+rMW@zHup#AhPG;x?Yv1sBKpz|^%XyR?q zbM|V{#2ujXYb|KvywGz{=c0+j`Y%h+#51AooV{q`tDyDo5j620Xn*z&nz$`=T=5B- zxGeM@#vf?nu>8deo$rFh7i?W9FPiuRXg^U4P5du({g@$|_-*L=D{nOMc2wODq66pE)u4v-7q3!JiH1U@p2QV-& zRHBKyK-ZBrqKVr;P~(%@#WBcH!^7Au=budn)p)aID-+Icn5Udg%_H5E3{u4h$em& zI$s!vCSC$9hs)8#yP*BAIyCXO(0SNtXyUxk^91IhiAzJr`B$Tf!{TcTnm8=J_M(Zy z;_Eh=_;F}|;SriRA9NiNGj#tSEM6u;=kdAF#5JMo;lwX&_-E+6QaqaYY3MnSIcVZnp#9KlG;t^BcuNzScptRfn1Ln^%fFk@#J_+7 zih+S)Cz^N`v|W1$O&k_q*U-d&LC6n)rF>xbaCe@psVr>l&Ik%-;KG;xK#P zp@|DY>!WXI;ttULkIc~aH7p)s=7^(-!@>u)zXzs%FLXVg4w`zHJ5ABVVdmSRiNnGt z2u)l7dR|Q=ns^Yjy_b(B4$DWKXyUN*%O;?S?}zU1UV$bKQ@s+;(u_6 zGegTKSUAAUQ9u*#gVy`jXyUfe@q{2W@%7ODNFJK_5~%tC1`D^t(EgnW4sjhE;wCu6ebB@+p!3loIK*>sh?n3H z??V%JfX*jQMHAPB&KJ)?6NjB&vlva>5Zazxi6$-r?bmEY6YqtdE4v>}d@FQ6)JZgP z*!|*{(Zp{+=NImwi90~c^LJ?CZP0xv4A6b{uz2Kyo6YqzPlb=8n-vVu)TtyRCg0|}(p^5uI)8TtG@%7O0_CILi zEKq-OLhFB6JidmmV;4gcKMWlQQ$`angPtd7fF}MIYK|?M_-!VYz2Ut8ZL(6S(H1U(r`E+A6 zack)LW6@~hf1veCDw=o&biAn%Oap*j_2(*6&3x^fZeOQWU;$~3&?r7p`py@3aO_-!a?I*m0CVmIHzw!r~_%Y}_J_EE|g!y+lbbpov znz#kDzOY0S7l5h{K@KCDjn?UdHIE*IV1{J@L zCaweBNAMp_+!!jZ0NwWnbH6RLo#2Qjz6rV>I1x=;3|bCUpowck<98;S_#bGv?LrgJ zhn7pX(Zr8I_p|>&6MqZ6|4{@wJ`Hn!GxQvC88q=d(Ds7?nz%Kz-)oLT+#iQ{7!L6~ zH1Va-^^v7G#CvgwPr)I+22Fe+be;KT9O9>Oh+o1X{t8X}J9OR4M;zju&~gqI{xJ0d zIK(y3#5JJnaP)DA``{1{#vxvaCT zb}wEunz#gXJUI_d99GYjqKWH6=jkS)iLZh7cV?oACqwUP+J+_$yI*53n)o*8KC)YA z;;?XjgeLv~+V1_2CVm?_-ogeQr-y~-8R&i%Ni=a-deA}>4}+eEZ-^#t4IOuNK@-n{ zwzs{}#CJl+XR^`6m7wRSl%R>bL+ACX(Zo}s^-~|3I4s@HKoj2q-RF28OVeK?x7BulvXgNFwO&k_4E78Q)LG$%SH1QYE`N)%K;xnN0FBj3o5AKJocY28? z4paXTP232oo)4ODVDa)E+P@P+6W0-dn6HN>4pVQ2CjJ{*E(N2B!}euFqlwRfwy!GC z#9{01TG7N|_cr#TiDy95+bT410cd<}LK9bk&L^Hn6JHFCm+NTa{?Kyu3!1nT)cika z;u_F#a!Kg89W0!!q4SA~XyQkp<8hW~;;?ySCp7U3(0R2$H1Qm0J2(za9F~vL(Zpf- zA|Fj0cArW!nm9~-7n(S1oP80RI4mEnM-zwTqwQ$oy3lp7=h4Jr`RERsI4mDMK@-0S zonQEaCJxINEYNlbEM7K3#}j1G#9``H(8Sk5=h+?6#9{fu6HS~2dQMIvnm9~-CYm@e zbe%~Xnm8;U^`VLTLi}6W;~x$K6E}hvlQEXyRJX@jxc%`UqHf z!txOpn)p=cxxVUX;;?+Ak0ve$J&(u-O&pewLeRt+q3y;TG;vryDn%2A<)aofaUN*7 zxeZMm)}GmmCN2fNFZcqQIIKN$9Zh^9^uCPOXyUN;%m*}aBj|YhPc(5@d*&aSxFK}i z2s?Cq3l=Z1_6!f2cqDZEM-)vQ)}E0<6TkWpQZFc@iNo468ffBL(0+>{nmDXIr$nz$)6z80W~!^+i_XyUMP zawD4f9q4@YQ8aOw`ZH+aQP6!EPte3+;qVbn99FLWL=*o9t=9yh>os8E01Ib1G;vtD zs)i;W2|f4K4ow_ZPP(Cq+d}8R;?Trl>eJA~t)b&o&1mAVamcQcA#A~7Ll`=GOSbnKP6aNRD*O-PT4pTo5P5d0R zKf4=E9F|`Wqlt$@$C+=ViNn-CMiUQ!j+-$+_xHfU8J52|(8SB3`@dAt#9{f%2u&Q8 zzpT*21EAxm;b`Kp{1uNT9t555t3eZo<*ybr@g30oyAVwrmcLe_i9?q^FdRb@hvlzx zXyQ+x_a;0;6Nlxm4`|}B{Pi16+!A{37BjRR4GaGmXnRHgO&n&vB$_zPd_6RA6=;9Q z3{CtBXb~R+1A{%9ILv$xG;x^uv1sDO(0$XDXyPT%@sl}d;$hHzrVG);)u8cv1Wo)u zbbkC4n)n{*Jl#b!@oUia^Uu-5A3*ze@6g2WL+7WyqKRLI?$7#zCVm)Nzc54XhsD<^ z=)R!{H1SYqJf@(Dw?fOi0yOb;(1cinCVm4t{t26(gxOmJUB58}O}!v=9AE*O_&Vr3 z`x-RymC*UJ9cbdJ(De#O(8Oh-0ZgC>3lx_({)P5cS89jJmP9uMtz8=#3lfR0Pspou?&mU|v(;;qp6(-1WA zW@tDhpos@V$6a&K#D7EYN2@>+kAjx}EokDmp!-uMpow!r_ZQ4T6JG?K&s~8g4!t&k zVJn*WQs}zFLule$&~dZ#XyS*V`ws4)i3>r)^Cg=2TW{ z_zr0OvJOprA~gN)MiUo-?&COzCaw+LcYhsCoCTV(AESwXg|@ffqlrVehcfU$>jzkT zSwP2^EYZa0L(`ipns|5?WSpT6O*{(P4%vn#?gbrRg57Hhv$qObuiZpb&jqa)UZROB zLf7eiLKBCX!vkHH2Q&XLwEUDo6NjCjtBNKLGshlH{0ww{&>KyB9duqS98LTP^gPTu zH1YY+^F8LEiSK~=cL@&h?P%f~q33^|MH9abZ5KU36X%2W7k;COGeXB#ouKQ}Vd3@{ zTAxOuiT6P3@lrJLozQeU5l#FOwA|Q)CjJ$=PVX|B_%Y}{&97+UccJ0N2`v|4?lgvu zuZp3G&xh8_8ffAf(DmLPXyV(T;u&b-Wzcp}2b#DRv|TqJOa++&~_$2be$2*zp!)a_0h!Rq3srbH1T|>zp~K8v!UfxE1EbTbbM+Onz#_O zy)hq6{4MmJm$hi(<4~=Z-I_Gd7z1BK>d}8CY}lHcXXkNpNH;4T! z0eap-7@GJU=sJfaH1YG$^1K2~+#TA#D}%ZV<{nq*xN#Gj_%Y}>-efd!Y3Ta@b!g(o z(DuMdG;s;&`2+XS#7{x@FEc{VKLZT|LYK&ZD`q>WILw{TpzBm!(8Qgg>C6jF{2R3Y z9)KqPA6l-4p^39Y_f5p0iEoCMhe>GSZ=vn03^Z{W=r~m#nz$x(Jy;2v_z7seP=zMG z7@T1}$%Apox1!&taa2CjJcC9$11Vo&!zK ztI))MLE~!!n)oqj18y6d_&wub_$B zL(7d@XyR$mcHjdvab9RU^BJ1B8nj*U22Ff6)SORf;?>Y`gdb?)I?!_FADZ|o=r|q= zblnXsUj)F`N1};Of{uF&pow3AuGbPn6Tbr;=afMc&xP(gP(l-zgRbM!KogIIrgJ?s z@jPgLG(i*J1&v=TH1QSCekE*u7RIz0_eD61e*9A zXnQ6OOG;uFz zd!qwQ{4=zl(uXE~8hT&Y6g2TO(DXkGO?(=(y}bZUoCg}e%h1FRLDxmBK@(pB-50P4 zO?)zRoz)IBaW-hZwhvAG3A7$Of+oHldj8lcH1RxWJK+MF_;%>{?KL#BW5t!*HR$-sA~f;2(DAnwXyV$?d$`u2iLZzDm$#sa|ADqkccF<#LF>~4 zXyV(T<7~&!#O0v&ov(UVi7P<+kN42TPe9vOu=9gq>ERHxK6-_w z{x!55`+z2H2pzBZh9dH1R#qb^;%o_&n%*t_Yg= z1L!!U6q@*F==l!{XyUcd@mMu9@p|Yz3p!}xeb8}cBQ)_W=(=bNG;t>A`Zqf?@mtXH z&;?C=F|;bho;XwH1T}s zIV2@$;+4?x>MAtx5a@VC1Dd!MbY7_qP5ciufAye=+d$hzlhDMMKV%m5)NqMsnB?FLlfTut(Se!#P>tXfgm(- zUFiHy1e*94XgfR(O}q};Ur0d{zXNS2XQ7G9K+i2NKoegI9e*f86F&o;_pd<{KLt$( zO=#k<{M>;iZVwI5J~VM|X!$b*O`HKbzc~v{ycIg0zW`1A6Lh?88Jc(oG(D_A6VHa; zkF^O+{5Z5;hOK{rrROcs^EdXPsdtB_!y{LKBaJ&Lh7-6E}y}r|;0j=R(`I(8RN$`)h8ai8Ddl z)sN7`S)k#@1RbY`x$`QteanL;9t-X73!{k(K-)92XyQH4bt776;;PW_G(;1xg3gC} zpo!0gs`p0|-wGY)Oh*%+18qO#p^0yYuD>Zp6HkTCBUGS?&w%bLY)2D^sqaA(&x6+Q z3(&-2>X)L4_d)wvyU@f#p!3-W(Zo+d``4eL<9wiM4!X4f+^{Zy?*D_uqXl%FsuoRr z8nmC-g(hwat(Rw@iNnf;rD) zOBgy&&5tGyGe-hV+zQ%{Q$rJ930;3{i6$NnJtwvtO?)nNA8repILzK2)uG~sNaE10 zI9SFBDh@Iq)Lu%1j?4L=iMv4i;}K}$=FVVa7;4bOVdsB#qlqttj?->L6Njn)hb9g? z-oflYzrXJ?6?P%glq3c>Nqlv@(`x=KhGc=xI_QKT5 zp^2Y_p66zTCJs}dg+sg*O&n$pY+WAAURe0-MpF+9pA%@}u<*HxCJqaqM`+@(b)+BA z#QmW4BQJEE73Ln8zf^IEJD`b&LCgO{G;!EIjx03sAFy=}XyPz?*P)3!>q7F~Ni=bo z`Y&kWuyeNmqKU)8nG-tx1oJN}oHfzJVdh8T5TAi24$JTB(8OW+XgiuXEFT>}6Nlxa zlW5{F_g_O3hq?bTnm8<-d_WV2r4s|_JQXY)VEzq26Tbyr_Z5pK{sLNl?nV=b`RfJ_ z@rP*QFn_&86NmYW13Dg$?oLY_;;`|1n0nayKz}s#u=^}C(Zv0r^HybO;=0iGUNf4w zIkdgF98EkNnr=^{iLZyAzjp&oJQsR?%X>6&So-;aCJqZX7HB;W^Divi($K_V@tcn( z4hx?eH1So?{$MAXxGJ?40~XXyPz?ci|8}j3%B4ogcY~CjJS!zU2j)I1{wqH(UuRw_yH-x!(>=9Oiy+ zG;vt|jX)EJ<=+xCahShm;t=13CJt+doJ13cm1ED)#9{gRJ(@VoU%%1BVg7Q5wnt#$ z0CQ(3ns^(uy;p`N4pYAphxi#ZaoE0#7ii)zb3USp!_KAphbI0Rx{ux#IzElzel+o8 z&~dOhG;x@{>1g6s(Diu5XyS>`{#Of{_%BOHdYXVHUJ7lW%)=qR2u-{b+JHWVCJr;_ zJeqh9^j!2iXyPz`eMS>!h4zRNW-Uhv|Ru;Pd0OnsJC7y~yU*eVnz#Y9ll=uv9Ohq1=(;&rxWUAg z(8OW;CT!8fVd~w`#9{Fsf+qd~+WF2#6YqicTYJ#NVdhUo6Ni~U4^14FuGXN5`$Oa9 z5}G*7{M%^aF!Nuci3>sZD=|RV%fP~I19Y595ltLcpBkWv!|b(06R&};YYIaXht*%n zXyOgfd7J_?@ypP9rxs28GjtxU3r*YtYVUM3@dMEICc zL;M$-_*ZDTAPya8g@sQIwB6-|CJwVV3Wqps-95~lC}=*dL{t9)I$tvdO&n(aTr_c5 z{eBEh9H#y}nmDZ7yMZPSD_7s4iNo3h4A6O0nEUrb&!1646NlAb`e@>?`pW`M9CnVD zBbqp@Jn=&lhm|K;XyUMTcrltdEF5ak#9{654m5FCJA5XZIIJDM6ipn~e%_2jd^?)> zHt4x4_tC^*<~%_YUkdFPd_)t6`HKU({t*^0uy!~vnz#b={9-9IahN$8XyUMRVuU6R zYll0di64Wm&qzQMpA5aHpa4xA)(&5aCJuAYIyCWA=)CF?G;vsZJBua`OK;cE#9{5F zPiW#Wd&QvZ6ky>A6Su-49*HInvo{G%95(LSjV2B=e;Jy1D72q=22C8M{wkU{EWYlc ziNo^s8#M74=zJ(MbX_*gzo((&rz&XTFnc|5h$rF@uf!qVgeDGi{{%GgdC+stH=>Ed z+_MW!9A?f5G;vnwKA@Lq;xKbQp^3xHVSvtC!oo)uTHh(6iNnm%M-!h1-RI(sCJsxt zA!y>T^b?CF4l5_q(8OWoWHFjJtek8>6NlB~bI`2Q7JlF85||LKBBB z3uSOe5(k+h2kjpwAc=#_fo_9fNI?^aZi{5dL=p#?^9ovSRG^86L)!yQNa7&#q06xu z+R((I+Y=eOk;Fmf?}n}$p9d8O&HsX?j?|&^4lAJIpzs8RTM9JX_9BUc?1e7RVK|5; z4n0Pi;S`!UG}W;6Uo6aNMkXMv74 zfXo4@X9rotz`($PCe8{K7lev~xX9rnjYHf5Dh@MW5~PuVfx!k%TpTLy3Ka)&kNG3$iTp`6-hlv{3}#^7gQX?1(|OMHUBc2xCvDJE>s+3 zKFHo{PW7emDj(Zpv##ZA$~r$NQ-(8RYu#huW^H$cUGpyDw1 zZ-AbY7KTGSA1V&=7s&l*pym{#iJyXs*Pw~thKe_!iQj~Z_dvyA?g@d4PlJks>;;8q zK2&@ek~qjcub|?q(8OWu1U93I|AeaFjwb#cDt-Vej_#gQIK-br#X;@_xrZAXp0Clw zIiccT(8Q&n;y=*DC7|L=(DkY?_e4V7$paM!*$WDvMyR+fk~qjcI#6>I(Zsc&;@VJg zbn{JdhzCQ(LH2^ow}YA!jwWsc6;FbS!_1F`x-$odcn4G*W_}RVoE|js0I2vhs5s30 z8&L5DIK=lr#bM^BLDe5X6HkGPpF|Ufohx`2O}q@M{u-Ki2UPqPns^&j{4rD<-TiN& z;vjc|;&(DM+8Ork1SLiWDc@> zw2;I><{yUItA{4O7bJPXF@fT2WO*HW*P;nzPaoBmbW@zF}(D7$`G;tlMxHFo#5>(s=Dvs{o zFdX8=P;r=lgQ4b>qlpJX#T%jGF!L**E_e_NP>kCvIWG~3S zm!aY;&~ZnQILJNoq2_R)iO+?K3!;hdfr^WwiLZl-%b|&LLC?KWLKFW3Rj&;dM|Zy| zR2<|^WcNEEiG$o91vTFdO*{fB?vEy34iyhZ6VHT-$DoNHg^I(@=L5M1WbbyUcqW>9 zMUVmp28LWTabc)<8B`qIzYS1vkTQ^e8KL#aG^jYb`UOyNboHB|;^^x4Ld9X~VeQy+ zNa7%Wm4Xy7Ffd#~6VHc=-+_vwoBs?d4pIhkzdqFce~`pM=C1`Q098fM^Q%BykoaN{ zgMop86HWXPRGb%0{0>xH3@VQ99tEg4NEygI-ca`#B8h|S<%8~LF+~&SfQs8e#nH|8 zfQqA=ABiLmGT#YmPArpy{n<(Fnbq4&EJD04l;i~)SLro;ya<@r=a5K=3jw|!_40aHUBA+ILQ3Z zP;*|QiNA%4e?k-2g${6kLlakrivLFwkA{jfL-#L&+yk;V6e`XO6-Rf!I8+>@9+a*w zK;5r_Bn~pC8)}XYns_Hv+!RfG0aV-)O?(zq+zCzm98}y5P5cB@JOC<=?*1sKIL!Ue zq3+K?5(l~eAJm)zH1R)B@k%stY3TarS~PK9sCXNicnVa!3r#!>D&CJI4hm(s)Dvs_RFQ_=Wd%}^#LGC#TH76QP{5VuR1x@@u zR6GMs{5n*;5KWvPx{kCIO`H`fUI!J2xqm%0{d7RZVeXHIhUZKqagh6Mpytd)6Ssnj zFGCaehKjF36ZeFQZ-I)#+ylEWZy!_~=AJ^Rdrl*XgWMAZHRn8_ZrmR?`YyzpyG_s zbLL>?cSG&vhKhsC0l8-rR9qTK9Ay3*s5$az;xC}$8ffA?(0vLzXyP1DaZ@yL4XC&! znz#y7+zBcUbN>{mJAI(yF!!HpILJLKq2^3P6Q2(ipM@rV3n~sfFA!ut$ee3X@#RqU=cb zsQ5=T@mEmsUr=#$_pm_E{ernC0_q-7Byo^?OriVMCDFu|(bob=o5buPF zgWL&n&mO2by=daQpyJb@;^^itz#+aDDh@OMG}N4fXyPZK;%A}aF!Qg03UvkshU-vq zkU606tbm5+3nX!n`)@(bd4nc?11kOvDh@OMBGi0_Gmv;k7gxq1u8Tw53n~tBC&)c- zp!WKqiNAu1M?l44_QL#|ghRX@Dh@OMAJm*?H1R)B@m{Dny7|+g;vjQC;n@KV&y`5x zAooi__v@`i6X%19Z$lF=gNpA$6VHN*A4U`31{FV!CcXkHeg;V#*_~IB#6j--3srv; zP5dKN{5ez{77h=f@%|Ai4hx5s&~RXcuEz(7gUmM;g`^KwG;w{XI3JpL090HEP22}6 zE&~-ucaIuW9Aq!Zzq_ICF+&muxu+azjuo1CF;v_IDvoZxA5{#B^?aY*7I^QS@0 zNkS8!02R+h6F&hJ&qotK1QoA96MqjCuR#-k3KegKile)~A1aRS{y9kEAonXk@2OdU zCN2dPUx_B}3>9CCCT6)FyMza!NBN0G!q?pKB0Pj?bcTpB8V2~9i}cYPq2dBiadh`cLB&Dl zfZ`VxJ_bnQAoGty%`rg}-wPGDgo?w=w}ys)Aey)uH2f3M#G9ewMM&bHBn}(LXhaeR zjT<;Z&F_Ya!`vSRHD@-GILQ6qpzfTHCjJE~z5-306}r!T4VpMJRD2s$9Ohq`dk)|b zzX25oxfA3b5vVzL(8OW;>z|^DD?`=4L=#tpihqNO!`uTa9~hwfaY6Qi;x`Q%K7vT% zAon;y%@IWtH-L)Ep^2Y`iYuXs?}m!2BZ(v1Yk(vUvR7LQQoov@iAzGoZK2}m{&I(k z!~E3)^;ZOvILQ1~s5voc;*C)8R5bC8Q1MJO@wHI#A~f-{Q1LP}@sm*TdNlEuQ1NCo z@uyJn9;i6Ff2ZLP-wYK8g#*aHjL`Egwxfyvhnl|^Dh@M09vW`vki(LGF=&y5|R)I3HA;5qeHD$Q+RRAgDMinz#p4oDWTW z0aRQFO&oUKtT>W5vO5)!#6k96g_@&+CVmK{io^VS0oopm zf{Mf3DFb3KFfe2ziG$qZ4K*hpP23qOUV$cF3Kg$G6VHc=x1x#9hKhHhiBE=#PlAfW z+z*=%ngbOFIU5wt79a)#1H&35agh6OLe1HLCVm+zz7tLSKU91#n)q+1_%WzBx_d4_ z#X-(McF$cTagckYq32FNL=zW!IQI3rYC3o4FojtLI&K&Uv(d?Bbg zp=ja)Q1LjZIJ)^6IK&&F;xO|Sq2{!riOWO9CqTtv=4(U4XBL_`Y#+g9s5s1g1E@LM z(Zuzj;s?;g9iZYz(8TSa;%A}a=!w&p{Kngo-bNio^U>0%9;QFl z2l?wM)coCO;*X)?N6^H-K*dj>iGPBMUxJFm-01*y&mE{Z$Qht?(gI>IFfhDD5(l}5 z8ALEJFnmN4XM~FXLK7E)ivL3s7l4X$+Y#Knw;3h7crikP${8f`Ne{0!>^GDxQcY?gJH1MH6>} ziszw;XF|n`(8N=r;?+=bnEMYy-QS8sd=XR}?-uR{_C8v&AJU|`sUCjJjB$-uA|Dh@Lr z76-?1h(CaegX{$v!4Eb637R-BRQxTPxI9$+BbvA@RQwlI9Nj%E(0gA&_JWi?1~C{I z7zB~TLGIB5Nir}nh@y$>K*ik zAf+((`y+{i+@AoFWME(jMiY;NipQXdmq5i6(8PAl&{|IVMIGXqasCWWY9NqjZ9OCUzahUmEpyqU=iGPBMPl1Y~ zn?DbSIP4rUnE7l<;A(+kKU6(ToCPX=0xFJf{v{mZ@1f!_b0nbVd`1%&gNpx!io?tg zfrdXj^xj=`aRsP2%zQ1VIVx!48c=b4s5s1=NT~UiIK+dX;xO}Vpyq_3iCaO%`-wvs5s31>Cp6SjYHfOhj<)R9Of?xsQF1~;$l$oY^XT8y`?zB zd!gbm^R=MnOhglh-Df=)Dvoacavb7^q2e&}ZJ_2KM-#V#ieG?=qnm#Vhxm7>ILv%M zs5!sU#C@RREYN$~(9P$=A+8M-hnb%MHAf#!JPs;u0To9#-wB6!JX9QJei781WHj*t zsCX_^9AEs2P%FaDh@Lrb{_Ie9O6vS`%7Wwe}J09h9>?FD$b84&Hz1+ zS{P0IA5^^zR2IZByo^`MWE)JqlpVZ#U0SZ^`YV}XyUq1abGlX zJE(Xdnz#*AJPIm~?*0_0IJ)}_k;Fmn4}zLgiYD#{6|X}R&xMLNp^3xJ{q9B+uYs!X zM-#7tiqC+Gqq~0*R2<#?n~=mo?(c(|vkgrgcAxuxH1S1H^@q{K=Rw6`_XL9M1)0AW zDt-Y?{cfoEHK;hu{m|>#8D8TM|B6GL?-3-U!R$Q)HD3r#{1jAN8Y+%%uPP34Tc|k9 z{CiMy9MQz@K*fEb;xO}}%Uv15q2eHOK>4B^nlI9k#6jWq0cuV*n)o}YcnMS--TXSJ zIL!QsQ1knd#6jjWsX@YPGMYF8RD2Fp9Nqk7P;r>~tD)v^M-m5_F9J1ZH=4K*RQw23 z9NqkLP;r>~N1^85M-m5_uLd>eF`BpvRQxSe9A-Xrxd+2{9O43xA>jeC7i7K#)Ep5s zaWkm6JX9QJKD0Z?pov4=2`UaV-wSGv8=ANWRNNm;JPIlvj3yod6_0_6qq`>!Dh{$2 zl-}+`!?PGk9OU0Ts5#|m;#pAf1~lbH1U8KZA<@M-%@86=!~enr?qU#d*-g#nmC|1kl7qq2gjtahUsI?M7`J z;-)yn{h;C?|APFb1~oqjOK4scr8>MX1)c~oJKTpGpKkkR2*i04kQ>D zrbER+=793WduYB`gCq`ezYo-$4QS#XQ1P8;;#E-by=dYkQ1N3>adh`wfQrN1!wNm; z>KT$a$USqR=Db1^pA8lNj3&MYD*hc!d=*rj;VC3Q(A~p@LtGsy4ss{RJ^P^MXrqbm zfr^_z#nH{T!yz6G6^EIB0cuV>n)o@Wcs7zaC>|xC;Z}hp4sz!csQMZ-@dr@xR;W0- zJNu#HAoqaG*M^$E6iFP}{FP|pF!MK|i3?~z!hIW>I1f~OKbp85RQxcSxCK=F1d=$i zJ1-)MgWQ=6Reu#tJRU0k7%Gk)4sW62uyC-0hQnVZagh0qP;(fcLHq|&4-&71igTff zFNBKop^49hii@L(?}ds>qlxc?imO1y(cP~H6$iNo6h1KbTOo;q-1!h{jvbo#U8uM_ znmEkA-e}@5|As)t(cKdV6-ReZHj+5VJ^!Kh=A()KhKg69iOWJ4T-Kn8OG3q4q2lQ7 z>4%D=yJsnqILJM=P;*wIiCaR&*FnW$<`+Ve0mCUA;#Z*JFnj%=>FNoRILO{esQE9@ z#KWQDAJN1!pyFTA#M7YS|DobAcS5hvV&HrZaWKq1aZvY2B8h|CQw23g7EQbYDz1hm zJ_#zWg(f}$DsGG>z6vUCjwZeWD((OkM|Zy$R2<#?;Yi{j_wR(76OAUm9V(uJCVmPk zo`EKQ0xDjJCjJO2UWz9E04iPw6-Re}2UHy0{Zo;|LGJ$uHD@N8_G>a29Oj-zsC)QcKpYGb2e~H{YK{<^cra948cjS6DlU&E zo&puufQrN1vlL<-gAr65WG|>3o(Of12a-6*J*7}{e9**;q2ggsahUlq|0duNuY`(& z>;;+M1vRG@O}qmt-i9VV8!Fy~CO#7?J{2mC?w3&D$el|5}`2jVeM)m9OBwgahUlJ zq2}nLiQk8cTS3Lq&3C~e9t#zRng0`NP9mE4cc^#{R2<#>G92R5afmO(A$|Z&d=(_P z7*633e+CtYxu07bqTv;qI44y6GgKVrewg`xafnO3f|v(0UlwYP9GbW^R9qb@j&8mo z4sk!IILv%~s5wDs;<`}rXs9^4`KdU>o1o$_^Btk)w4sUHL&YaR#bM?{uT5r{g+qKZ zR2*i0Fw~swXySoT@k3B?nEBA_i5bq|5Pu34hnb%WHRmOocrsM{6PkD_RQwy7crjG` zKU5suJ)Ex*@eV3)7edQhF(h$NdDsaxM+!~66)LWbCcXqJu8tUB%WrXi8DgQ7omxZL&cY&i3>x;*Q1FWLB%(ti5o!0 zcS6Ns?mq-^4#PPd;x}-Je}syI{0s7zBh>t_XyW!z@qbWpbbC48KpcQBt^gH>nI8-_ zM+Hqh5Grl}6-PJ63Ws3kzJpRPg@2Zd)j)SPu_;-ygW?ND)a^AAGBVdfu%ntusN9Athc)SPQ*;_XoJ z`%rOo^It;6Vdh_in*R$)9Ay4%s5$@8#AiaqIo_hiJ1l&JaENO|#XO$gU4VpMNRD3H`9Nqo< zq2lQ7KZ7I=a=#+foC|2;vQY7xXyP_d@w;f^R#5S0XyV>b@mFZ#o>1}6P;qqk|AmU9 zyPx+RBs@UkAos^Y%@ITskA{j%p@|nl#pTe%bD`quXyQFkacwm5E~vO6R2=61&k*M^ zxZw~Fz#*Oq6^Hq2Hq`uFH1U~G@iM45y1flJ#AiUoVdk%enllGYd^J>j1ymf}{7pE- zFCdA7)`1IvHXk!EFg!&P2MIxsV`2D%Bo0y^4Bgkv`5qF0Fna?aTn0rn@p!1X1)4al z9UhJ*4y!Nn(Zqj4&1pvyX9hWdfq`K!R2&p;pru`~d$%v6i3>r`D|mn={xuL{!5=hn zm^nfpAo4KtVdiKfiG#|YkI?eR97!D6J@!cApnP!^8jsFs;(MXu325S8dJuP{pox1x z#WRt_LH5G#4X;2GzYHCSX-5;k4ZR0w8k#tJ6~x{JNa7&(7enn`f+ijg6<-S#2SpPo z{jh)n5VT(sDh}d;!i@uZ@5UJ_7P$~NF3yzI;c5ZXyP?cabYy^UZ}V@ns_%Wafr_J>ABRJ{8Y&Jme*)raZtQGg{nV?CVm+zejO?fb0-hT0SpWb524~9F39|NsQI6e#6jkl zKqq>?p@|nk#eYM^Vde{h3}j$n5cvd2KQM6-sJI+d9K;3Ln-8_u07)EVFU(&iXyPz` z*`kT}L*3(uCf*1Y_d*lD4i)!96F(0X4@MG4c4rKdILMu{h7f-ypoz0X#q*%zuyBwA zd7OcPp#mxn;)2ZYgN8!~k~qlxQm8pSXyS!X@u_IyGoa!#(Zr`f#TP@x(cQBaDh_kc z0;qfTB8h|Cvma{CK{WB*Q1R1Hadh*qLd9X`?}D2D6iFOp{yV5SFVV#BLB&6ziB}mx z!v7nZcn(zjKbrVas5mpUAp~*{$lje$aUQ5Ry8FeT;vn^)_=34#8A%*u4yQ51J?d!U z-=XFkpozyq)tjJ+`$NTT(Zp9k#U0Va=Rn21pyDw1Yk(XK+9wVb2XR5}e*g{tR3veb z`yW8f$wU*s1r;ws6K6Dm__qvA{4Z2}J({>QRDCm=xHwe27b*^OzX7yeF&&5a2Bks5poV3QtDp{Y}r2#6j)} zgqrgjP23+U{sm1u0V@6jO*{@N&iDlq-stY(#v!f&6$iN!GN?Gr zd=04i9Z2FJ^Or)+=|K};3>BXa6^EJc3Nny^fngyI@x4%SkTQ_@JE7(rL=)c*6+aCX zhnepIP0v?xh<}8N!^}SmHRmgu_-Uy4KQ!_CP;sWOkaPkw=Pp#78%_K@RGc48{4G>m z0xFK~ekG_l$b3-zT0p~J4@n#pKJ3s1?nY?hj8JiFG;x@J?a{vDvs`+ zcqDO~fzb4G2#5F?s5s1C4`{sHK@tbqTL(4&0h)LXRQx5HcrR4^Et+^YRQx+s9Oh2g z{gsU05a|$bkxlnN_H1YLNaXB>cwNP;#s5s0$u>O}B4)Jgt z;)yuK8_>jIQo%V^@> zW{_~djwWsi6@LH~hlLN!J+GkRF!xM>y5~2NILJMRq2~NY6WA7l1d7vt5d#B* zGgKVJ1*IQ(=>3BMNa7&()I#kIK@%^9ipQdfuY`&xqKPkrif5sT--U|jp^0CGiWeh^ zBfGN(NgU)(QRs%W1~hSAsCXw-92Rb^AdfRJFieJugSa5`t)bzt1W6oZzAe<86=>p? zQ1OjWadh){L&ag{2SCj~fg}zxKN@Pz88q=osQ6W=IJ)`wq2e&}6QJgQKoSR;p9?kT z3z~Q~RQw-Q9Nm15pOEy4F0Kd_2iXfUzaDCiDw=pLRNN3M4l`#3NFxISgEdqf#07b6I6UPn)nB(_!cyAW@|`1?LZS}go^Klio@K$ z59BZg28MfR;tJ66;iT{GC&w+}g$72}|@ySqeSbWJt&7Y1YE(;Z302N0! ze-#e#!%%UU`G!z)j-!d|L&YyZ#nH{bg+u%^R2*i$Gt`{#XyT4gappge@IyDB7b*@i z2Nb`zq3K)>NgNcvkx+A#(8PnG;@W89%}{ZDH1T?*GAGE&yk0yQqDlYIB;%|^Spnd^#n*xJ8k~pYeZ~B2Z;WGt?_(rHW$X_7$KY^OF6;1pRRD2(r_*ba-AvE!i zQ1R1f;=J~dcs-9M&J7j60u_h3|1H%0U(v(^py}j44snTp5PM+$l7X5pgC;Ho6<0+Q z*M*8}qKRul#Z92%Fn6*-=a1~5;vjoL<)jWYo%kb(gTmPrYECekxFb|N22DI3DxQEQ z9t{=GL=&%viszz4yp7NUtSgo>|16W;_C zUxy~X0V=*7P5dZSd^ei-L8$lvs5s31s!(^nK@*3K!+*me&i@}Zojih?FN`Ms04gqn zCjJ>Ju7D=~5h|_?6^FS~AL>q19O6MxaacGrIY8VOh9=Gc6_1CC!_0SvnxBa#ZUPl= zf{Me;7lE47h9)iq74JtASB8pDMiW;u27CkZGX$3zi;~pyD9&k;7jP zNgQPFdZ;-@XyR+3;?`*5hoR#3XyW^!;vQ(?x1r)bXyP}a;(<_cnEQR8={6lrJOCQBe0Rhl<18lL&Rs z79??ydw8J(ojcIPxuN0*(Zpq-;z!ZMrJ&+hq2e(2oCP_6fq~&ZR2;+w#d{&tJ#Uc2 zLGCevn)3loTn8%t6HPo0D*hKuJOV1t#t3o=16UT64q@&Qz#*;+6$iN!3`uS65S3Kic36-Rgf9vtFVpyD8Zf!zNRYR(Nb z@#j$ShiKxzq2f=`#D7A?-$BLE-SY#7xBwGKC89j!b%NA`B52~=P;pr_ae1h?BAU1? zR9qJ-4zdN5e(r!g&cMK64iyJ+LGe2q8owS$;-K&`gqq`nCaw<^4~2@On;#DqM>jtQ zNgQOpGt`^{G;v3$cr{cUX8u!rio+`RPz|Zlj5(LdBn;iI+jeU!aMXK*c{n#bNGw1+s{Nf#DBS9K;31*J@~d@j@4b zgTz7p?SPsih$h|!6_-L2p8*w@Lld6{71w}@!`#yVE&q+6;vjoL?%54>k28`u$UUo| z=D4GYuYigNLd9X`{{b1uz`ziVL%aei4pIg(e-G508Z_};Q1LdXIJ)^0pyD8NK<+;a zb^k&nagh1vpyn(^6F&nLUxy}sA1b~HP5drYd=FF{<{l2{`9jBVh(CskgWL&n&qt^^ z&(Xx+L&ZNr#nH|GjYC|51*8&D{xCa3${!gtaYm@PDw?6320xExC z{z}LP22=3o{c7M1QjoZio@K~3Qf=TP;rpGp!9GTnjU(P z#6jWj12ty?nz##8d?uQB5mbCGns^>md>NW}7gT%|ns^&jd_7bg=KkMM_g_F0hlTSk zs5s1DZ=wErg(MF0*9xfl@6g2OLB+qLiNAn~|3(wP2Nh>w1-THBu1s7Y>52nQTmvdD z2o(qELQW^rP;r?1WdtGS=pc!M++PSa#{f+{A1ZDN6^EHG0L^!PXyW=%@d&6m%wAKd zy?IFDAbXpj<`sEiNAx2 zbFqO;Mx-AGS4h0`p^5*4suzZegLHw?&qio?8ls68K=X?=R2<|UP=1evhI1g2ILMv+ zPsjSs5rWNHsKII2Nj38Ck$%NB{cC6sQ4YIIJ)`IaELRpgH$5oJr8OQ8=80y zRGc48ybdZZj3!H1Qs&cnVY;WGu-1N)Q9IZUId^04m-N6^Gf|0=0K8k~qlTxlr>L zqKVIjiZ6$XgNy}*!xX50_oIo!^7TC=agaN`K^hqt7(OG3gUo@|JAZMAOL9Oog4_>s z=NhPcWYNS|LB-Xe;vikf<{RJ;_l1hX%-;t!ClF114^%uFDvoY`Dh}~Fs5s303s7^K z(8SL{#k-;6=;lwwA-)zW4m1A|)SQiI;t!zWd!gbm^I_@sI1cg0P;r>~U!dkZM-%@9 z75@MgM>qc$4smf#kV-`UWpjg++tO&_EKqS3s5nR$D1Kq?*TW(14HbvEUjk~5Kbp80 zR6GJIj&6Pu4)J=ZILv%4s5#AO;u=u#UZ^0G#!Wd2Bg1aThPR^B)SPE%;yzIE_h{mAQ1Q=b;xSP1KTvUW_pot+L?H1FDi3Eu z%OznXaZr9Qf|?_aCY}csS3nc*g^H`7iFZTAb?BDn1`goWUKEe;1>P|ADGsgC;HwRlfmEToNk24Jr@^)Eq@LaVw~} zE>s+38Yo@C%rVCy9t;(SnePWRCmc=O2P&Qb6-PHe3x{|+R2*i00@R#tH1Rm7_!Ou( zy7}{Pi0_7q!^|&&nzJ8GyZ|bG0xFJf{v{mZ@1f!_^IM?id`1&*f{Oozio?u*0Zmuz zJRlK7{KCW)pyDv|r$Nn8K@*<>71xJ~gG>X(?^~$(mN>+NpyDv|S3u1PLla*H6^};~ z-vJd*Mibu#70-c+qr0aJDh{$2RF18Lmcz|R;-LI;25L?_n)nH*_yjcZ=TPw}XyQ+y z;&ai&zd^+pqKSWjim!r-qq~0#R2<#?2a&`c84N09s7pysfliMv3>`O(CqpyI-4;$cv6 z88q=ysJH@}crjF54JrT=R(Cn=7ahv${+><1H*EtILI7OzSs%P7u%7LqFazB$7 zB)|Md6K8;mvj~7phP3NI?uVJr2Nj2zZv-`89!VTzz6jJDWi)XisJISP9Apc!`DRdY znECEd^WBleLFTJL&GAMPSAmL$K*iC`kAsTC%#VSZpN}LCGT#DfPBEIe8C1L$Dh@Lr zT759I;}Bl}6$jZ1GT#eo&Jr|n52*Nhs5s1gArOOsfng^O@k>x~nE5eKbFQI@M?uB! zqlxE0#UG=IXFQ_>AbUaStq>ZX%z_}5h;pm}Y7RS^cnwrs08M;0 zR9pm2d?r*}7EOE=R9q2Fd<9fo3n~tB6|(zHpyKH6cSI5g#n(QlIj(5pyP)EJXyP}a z;z4NQ*P-IkXyPxR;_+zW&!FNNP;qqk7eU3*-QR>H4s!o5s5xzD;y<9`{b=HR-jMQP zGMYFSRD2GaxF%G50h+ivRD2m!9OiylyKy%T@uN7z??J^u{ssBV0&4yvG;uSi_-m** zy1id&@c^hey7^H! z#LJ=LF!S@E=2WAJ=Rn04Qh@Xn)nu|xIdcsF{pSjn)nf@cnnk=}X%8iL=;!IHSSx|9w_b-8pqq~12k~qly z5>RutqKS(@#rL6!8$-npp@|zp#ZRM&J3+}QT0W|SOsJIwZ9Ap|O{Y(Tg7#J9|afqAZ z5ch+MgZvBf*CeR zIzyB(7(>ND{sNt+3Of(h4Nd$(1H|GSG;x^vHZ*Y!=tY=o(8OWtx1x!EgHqiddY&3D0JC~q|Ctihw!zMIw*nRMq(Zpfq zJVX;e(FHMwNgTVs1kl9Op%=GkK*d42K=C^PTCUnd#bM#ozaL`0Cz3cQUu=V>PhT|g zEl}|=s5s30l~D5&pyD9&LFIY52*msXs5nf$r!Yjk3Mvj$-v?FSg(MDg&rztoeQ4r` zq2kk_;^^itgo>k^zZOXxWd0SXIUCW$FG0n3LB-L{KLQm;H~%7%ILQ3RP;;)Li9dvj z--C*yoBskTj&A-}Byo`WpP=UaL=*o26=#wFnT*Kqu<+-Bio?ub2n~N3Byo`WjJ}Zg zQa}^`4>ey4Dh{#*l-^+Go8S=lfr^9d1(`1ZH9r7NoDV7<2^B{-KN*L3HB=mCzC6^N zdNgrasCXAt9A>^1G<_~Y6W;+%=WC$iAoD@#d6@QE-9t{VrF zpyDv|UqRiUh9nL$e+$%{EHv>AQ1N1@IJ)_@P;qqgyO6{|=3j)G(}yO07AiguDh@OM z0Mz{}pyDv||3KZp14$fY{uih@d(gz+LB)@viR<}6^6yDBaSf>WWvDpJJtv^P7n7y;1 z<{w5Ap9vK|0~Lqa3p4*34)M=WahUn5pyqr>6JG%pXOsq+jEFCo`P?|fHK5`!^LIkc z(Lod64iz^=6F&hJw?q>^1{HTg6Tbl!cS94u1{Dv0ii3OsN)IsiN8u1JhKj@7{{m`G zIhy!0sCWZZ9Nqjbs5rPs%hTagckw zpytd%6Ze3MuSF6EnQsKWM`k;cILMq>sQTS#;^9#7gGl0_atW6HPa%ne%wGl_|G$DH z4l=(MYR(Nb@k*%pL#Q|?ReP~+oage=-pymgoiSL4n z$DoP7fQl!ei9dmgXF|nc?u4C(Sqv42xyJ_To)#o=kb9V*>7fHn{2$c(UZ^eH&nz%buTpCT>6)LU*6$jY@Nl3)ZZz>ysCYk`crjFbDpVZio(<6OUxFr{22DSQ z(ZpfrVV=by{t_wP?{HAa{bwNgrswb3qaZrT;Zhdp*#^S3$)C(Zu&a#Y54=cR|IY zpyD9cg50wL>i%Lh@m)~yTBtb8oiR{%_9BUc+<6*m{zNqKlTh(lXyQ+y;`7kNA40_! zL&ah4+z)lnE+lbKIQKxq`5cls$X_t^H=yD$_vb*}{{l%I`_$O`H=d{tqe+bN?Br`^6POB9L?fa_2p$xFS>>=FS?ZI}MSYg|xaZorDXQ1LM(8Nzc#n(c`VeXHIy5|UzI6DIa1N2%jhMP#@ApgSDKgJ>c zA1V%W|81zf%+Q4;F!7sEaUL}BS5R>QH1QWuaY?8+y8D%(;vn-u>0u2tJ(wVggTnJC z)Eo;m@$XP^Tc|k9{B&se1fhw;+SP?<;ya+~t8s`=hl+#T333ldFeIVRMiXa)iZ4ME zSAdGIKoggPim!!=!`y!c>YgJ=;-LHmz2=eO29h`^ey>B-Kf)pY4=N6GzdqDnCKZs4 zh<2bZRGb@4+zu+vk0x#d6&HbugG>Xt=RVXunrPyA&~nTXO}r8+9*HInEB6Y~#ATu8 zccO`#K*blKiNo^mAtZ57cxFSQk>L!IILQ6IP;;K3iC=+=|3wp*hPt0!6%+!H@C2pj z<2gM6WJ#4FoC4HdV8ildwF0To9#KLkk} zWPS|PoCq}WD5!WMR2<#>Y^XT8`4vdwAoH`K=G35xXF|nWq2lP~_d~_e&7XrL4l=(A zYR&>Q@d~K;N~k!x`J18QF!Rqt3n+aCK*PZkOAM16^EJs0$Toj$007P4pIpze?aDcftn+ZCjJR3u7D=a69Op^RnWw_pyHZPagZ&b zbn*x49tR|GP&*_7Vhlqlk~p&Zc&IomeD*-={SqW`ko)DK_Ew;YOG3pPq2lQ7>4u7< zn?D^%9Av%|)STI9;x=*Na7%S-$KpTLKA-p6*oo`=M04;AagWvR;aiGR2=3W4yZf5aEK>E z#X;@_xknLdPCA;nJXE{@P23PFUVKB-L0jN00UQjvD2c7p6PR2*i0C)E6S z9O5-lage+Nm;vj#WhPqz>P5dNOTnZ`<(giaA1l0X1 zP;rnsAoJ6q<{Ki3gUr7JHOCZ9{03Cq3MvjW{{hteKs0eDXuBd4O*|i(U&@fgLE$zJ zWFP|rLm!&>GN|}Ls5r>|pm`bCI>xI|agZ{Qe-)S^<;)wXI86OK=)L6Mkip}8S3BvNa7%SVe?I#+8`Sd^>QrK99}f>aHzNtk~qkm*H0ksltB^)xu*@PUI9(K z3M#IOBn~nMHb140Bn~p?1XR5-n)oiLxCN3p$Q;-_qZ5)i$Q;>lh&$cT#JQp3{!npH zXn?}s4I2KDIK)e#;-Gi|nV$(YrxHy(9V*_0CSC;q2e%e9zxY~>VQNb=@t|YVo-5OBymtUT!6Yq7ESyd zR9p=z4l)g7CCq#Ss5s0$F!ODY#6jlYhnnMnCVm$x?gq2e&}b)ezD8c7^vJ`c3P zy&g@R3o5=7DvoacVI1POq2eHWLFP+C&AE>zE(sNX0To9#{}T>zF6c&hnE6^zbNJB2 zHK5{>P;r>~XQAO>h$h|#6}N_pgUkn|TPLWvH(=NQzS325R+pyD&p#BV{x=c0+eeoPkoC_-c2`UbA&r@i4{(*{v z>;=Vd98{cF52O-OUV*|>9%_ytnz$rXTnbG*0xB+tChi3lS4R`y0~Oas6JG}vH$W0c zcBdthILMt}pz3YW#6LmB-O$AKq9Ebsg(j{86^}p@w}pzwpov>U#Z%G5!=U1sXyQRo z@gg+wGN^bNns^peydEkJiXBk-4~xf6s5mShtDx~X3rQRlKKr5O%tI633Kd_DCjJ2` zz8X#Z6;ymHk~k<{VD|1q5(n9<6%7gJLuld}Q1R1HaddxOg^I)c1uF;MK*iD3e}js{ z)bD_X1G_#*B_ciBK<(v56Sshhi$TRfxHP;rp^LGD}*HGeLe_)@6&GN?GZ`5U0(Aag+Ofwfx>A&G;`-v%}37@GJNsQ7uP zIJ)^aq2lP~KSdG;nST^&&Pz1$!%*>0XyR9(;@{B3FG0l_3_vbH^!GWT;VFwI&JPt= z$06IcShq+%GYR)7yaY?B7Y&3CwsQ7#|ab2kRDyTTjJtENX+yWH`*$YZnAED{? zD3UlRJYAvYoJ13Mgo4ULyns5s1>e$aUAMH82Uicg1%!`#me6<>iQ4s!ohsJ&~@#4kd{x1x!E zf{O1%6MqL4KLZtqxfAA|Yfy1?_dG@t2f0T!7Lvc7qlrsG#Xq2lTS3LYpoyD7#o3KO zEZK%C1P;r<$!=U1QIK($X z#X;@|x$_&;{HU!daqpyKG}pTHsh8Y&JmpEVAWPTr%5GegCHK*iC`XEFwfAkqWO zUs6zUnE4`5bL7y(g`ncPP;roHpm>afhL0DTIIKMrf~Mo@DWqKO+o#WzF6Vdlfy$$O#VAag+J#2V_~Q%K^Vcz1@Ha}G`1 z9x8qvDvoacL#Q~q`R|a#LFOkw&H02T9s?Es4;6=*ZwDK@0{4hBs*9$DrchpyDup^+CniOd$*q2{K0$L@+Qg2tdVQ>eqr4 zFfcGEAc=#*K?&*}6*O@LsJJdv9Hbp&G|YT+s5rX$&Pd`Q^9`ZqxTA^dL&XE2;^^i_ zLB-L{Pe&35nePBKCmT)N4k}&(6-PI}4l0grem9ah$b5gOIsItjzEJTQP;qqg7eU2g z<{t(rU|?X_gd`3!KMrcnHZ<`VsQ3Y>I7mBk_@BZd{s<}#vKM52F4UZ7XyVyW@%K=1 zbn}1W5EnE9sYJAgYoO+cqKQ{Q#TB69AYCB$i-HIS1_lc>@!KE;3=9lTP;rp^LHYM4 zR6Gbt9OSQlsQF=N;+;_Ocr@`dQ1N6m@m)~y9H=DKLdADM#X-(ScK;C^;&-9qF!y^w z&3T9>?g15lg(e;c6@P~&9s?Es2^ELAM;GKM1_lOZbC3um{ea^4D}>7+f+P+K&qAm< z5@_PtP;o^x@l{Z9RW$KAP;ospalRx-d>NsMGeE`7k;IYR>3}2-a;Fk?LdA2?#8*JY3(&-uK*cN3#7{uQYth8_K*igj;-F{( zMIkI6CqTtP=?4@(f*?sy{fi_H3Ln8_NH{M=6K98tuR{}ef{JfK6Sski??Dnrw)ZHK zILO`_sQQy=;#E-bOHgrif8BwK!~A6o_19;pIJ)}3P;r=gf2evs3y?}kItRI@4{EOv zns^sfTox)0(giX?5ZXS}LlQ?Gx3ohN2dV!EA{ZDLJfPw*_oP9^Bay^G?%4pfHx^BN z9aKCGP5c#9JPS?y1ynpANgNa}FncSY;xK=CLfzAZChiCoUjP*cxgX@tpHTCcpoxEn zim!!=qnp1SDh@IS>F;^^kTK@ta5 z1Dd!fRQxBJxEfUaFPgXtRGi%suac`(N$o(L9nnBI?M-w-J zibtS{dqKrx(8N8U;;CrjaZvG0H1Qayco9?__)RqN z^-%GHkx9 z6IX&Ml^95sCXAt9Nqm>aEPykio@Km3pHmWnz%Mpd>5LyBUF4Jnz%hw{3KKy=AO9_ z?=oD5ii7M0#cvx_{0WjcC_F=;=Da`?_k)UmL=*3Yiho5DuZN2NLlgf96=!k)xe!v0 zf$V(@6=z2hM|P(Gk~m1cCNzPHpoyzP#bwdNlcC~@XyS=baeXxLBB;1Ans@LJ5>FVDXp$6^F&+B4|7oB8h{-=L^)FQZ(^b zQ1Lo6aaHKX^(HiNd8l{~k~k<{VD?T$5(n8E4^=-CO*|GVz6dIg?yogaahSi3K>c+X zDvqxHEL0q({sC0|JtT3EdkUfUK0*`Eg^It0io?ur05KRC82%xNBaajEIYJbGNKm{a zfEWx63=&Xrn0vlM-J^*l4sy?AsJ*&q;uE3bW@zGPq2g9(;-{hF_DJHOc!AmL0Tl;1 z59H3BQ1=9(iEo687eK{9?gzQ^4%GY-H1S(d@mi=jy7}!;agaG6_du^pW|)a24l@5W z)SS6!;xD1%%b?=u=5K(Cqnp16NgQPUFQ_>O(8Pa0#ZRJ%bLKz-;w+jtJ5>BSR2=4> zgAnBmU(m#lL&g8$5SMlWnSdzwB%$WZqlt?{#Wm2xb)n)qXyV#XaZ@yLN2s_Znz%hw z+zBcUauq0@z})YHLp&8K4hnxzI0rz@$wU+PgNhfSiKjrt%h1G=pyG{CahQ8fL&LKh zDh{$2l&+x1FEh+R5(l}b3Tn;*H1RU1_)0YKNl@{%XyScP@dHqCboZQsile*dI+8fZ zJ*%MR+(r{$1{HsTCVmJi{sK*WA5{D|R22E3&UUo6^FT#4a8tzU`Rm|hh87SkOviqxgWahhoK%x9OQnk zTu6dwMiXa)iua(2t3$;npouF(#TP@xLCyoEf0%pLLdDVDvkOTaxtich6TOagcjvLCyJzCO!=+&g23z8BzXhhl;bIiEoCA z%Rt3Jx{$+14Jr#bNeF zK+X3+6Ay!m2SUX`wu9mYW_~md@e-&w%=~nyITdK)sZjAQs5s1gSUY(NR2*auD4isO z6oBT_k;FmqUI8^{DVlf*RD2y&9HbrOewg_?pyKG}A4L)enLib3&Pg=!iBR!tP;r>~ zQjp}&@DC~uG9NVl2HS7W?gml`$-f|R*!?>)XyOqsAO@+TiKkdY#P!g`mqOQd*rJIa z5{Ia-Kof_#X95oK6*$Cqqlr)33o-u)n)n6ic->hv@m*6P>TjWmhwDPbzoCi4+{xmO z8g2+^B4pX0mCT<2DSZqTRhpF#J6Nkm)Tr~0j(0iZvp^3xH zIgTa{Gv_Lrc-S_G`@f-y!_4`QCJq~a=Jr4hH`sbt88q=I=zys^nmEk-05ox!`7vnX zu=5Ra(Zp+@_hHRI6Nj0<5KSCr{w6eW*u8r<(8OWpd_WWb@DdVkVxFks08?*`LwpGi z@$G2ho+=RYkD!VBLB;>0iAP<7sORxQb32^|1^jVAud8)D7}G;!7w5b-Z);!@CatDwgf!S}6SfCh#ZL>pKf zblwP*%U};>fWi$_zX(7F8=%(1)kBXDXMk=u1&f2!?_+})Pzs^o;_6UyHscWgi9;NA zk2K6ZFms^Sr(l>5-HwkT9sn|c0ny$tfx71hnz#;B9JbyKBn|QxOg(J<7rOXrkRmMR zb3xa6!PMJ9&6h+Ie+>;cT{Ll+dJCvHDBXgRpfa?cg6%(mnGZ9^6NmZ`s5neL%=~0D zahN%+XyP#S>dH= zdxOx#Vdf;FiNnmPM-zvYn+I@+pGOlv1|;qwJe9A^H1s5mH?K=s#3XnTbf zy3hg^J}~nIpyKH2#h~Ia^)P!Cq2lQ3^`PP~^)UBXqlv@p^*|GcnID5D4l^ekO&n%U z6`DBAoE|iBnEHii;xO~qp^3xP??w}cnSUNl9A?fvG;x?YZ_&hI=KMz!hpCt0g_H;A z;hBmG;!C0B!wocXnEK~v;+vuA?Jt@*%p4Bry~MEeu;3`f-F#4SnEPSo zOG3rb)yqT0Vd`P_YC*-()tf`bVd`P-aYGY_*&B)`4l_R&O&n&#35ddL%bJ<_u`wg#UXwMhxlzY@oUih{uWLAB2@f8 znmA0oH1zyeSh&H&VfUz`i*LuF{vQr;6X?C2FmoP2-Q$2J?h4J1foS3|^)XO!Sh~7< z2Atd&lAz)+^I_)XLdDV5S3t#K>S5-$pozoGnT{q7Q-2bN_y-)~ieeD=qTB0&Lp&RY z_$)N>SJ3d>fFT1&8<(9O56L;xO|sK-1x09O9f3ka$N|FN#B44JrzP;prJ!0OEy z9O4-`#7l69H{cNO!67~ahxig4;;W$IpzuMizqUff(fxG}Dh^T)ss~}=zzdyl1c@V? zqk|-ltiA+E99exEk~p&Z$w=a$tl|iXR))nm#5W;{Bb##$hxjWT;!M&Ii$MNDHb)Xo zToT&94#pv#02N0M&m0`$6*$COaEMR9A-)hQ4s$=uo!8LB6`<~CmO=F|Ok47=;0Fv6^FSWW=M>0&JPW@NjSvkLd9X>04wKL zK*eG1gqd>~hxlb2;`gB9=;ptKildv)0-dLYiOWLWFN{N635U2Lnz%O997i1D0XW1{ zaEKS<5O2aEJ`IQXQXJx2aEKqqA$}c)_%k$dOK3QJ#UaiDT9kt{UhM!?FN{N62~B(# zRJ}2pIBfjg7l(Kj4)F#w@xxH_C*lxajzfGKnm7}5y#6Q-@heE;P%FV1_c0FfPdLOG zL5r)P;fZXH0Gc>VP63CwJ`Qnb9O6MZ#1nCdm*Nm_!67~whxj5K;@fbDA4L;~cGDQH z;1GX|Bo1n~_(SWXuQ&i9O8*M#EWr=x1x#X zK;vaPns^~pd^ryB-8jUr;Shg{L;NQWaS`ZxC0IIyxknj?xG4^C*m@{*b5d}qFGdru zhlWEd4)N(o;-E4KcE9aP9OAoih@ZtFejiQT6kMt@FnmN4w}Of@szMkb|AO2D6BorH zZh%AF9*1}^4)Hu3;|!hWj|gKcb04hYJ{(q3bJQ;RX{I z#UZYaL);Qg9NMg9@J17d79$MNIK=aDhMrJed1=pyCtI#9``h;1HLC?w5j@15;myCN2jxzZFe98oC~C zCYm@*{Sv4+NIPh#HRTf|UROcIVfMnz*$Nd$SAPI14pR>^|2&#F%$)aV;xP5q(0wQ9 z<{ZNz&Sea7FS`0T9O5f+h(AOV*8q8tfq{X^1l4?)xC{<)6EtykX!twh5D!8VH-Xxl zh(o*>hjCBc0_aKW4A&DcK zqk}`-1BZAT4)HoP@nUGWt->LG4~MuIbl?k?Uts$L>~M(3;1JKlA>M#PdZCF-FsR@VH%1db47Jw@hj<8@_z9@` zG&FITIi)zn+tI{f<}5@Lp8zeF&fySewn3y@Q2K<5I>4T{1Q|gmfqGw{reM# zI6w4YNp$sQIK+K$h!>-YUx3=%jzfGg4)J3+#Gj&x--4R|4Tm@%bi*yoUoiEuXyUN_ z19~{b-O$8Yq5C2daELeH5MP2Ot^hS>GY;`%IK&^Li5o-9jW0OFnH?bM2o?_dP4dI4GRsK^|dXV3>y{4m2zw?z}b05#tqP5dfUJRXO5F%I!Q z9O83vh;PIpeg=p5Z5-lnafmazqlO#IUotqvwb8^ML&L!qhqylu@kAWr#W=)UafnYx z6Mq49&q_4$w@~q&IK3IK+SB5a)*;zy$IR zC_G{Q(!wEbi6#!qFWxxBW6{JbK^8GEFy!M9Z^R)!8He~%H1Rs9`P zA^r`AII9n8{)L$@i9_53hqyBi@lYJ%nK;B-aEMPv6Q2kThov~gwVde|s5LdtMx;*!_+@O6Njn)iY9&lYCeM>B%DFrH_$lS z2MI`mV1tT-c%bnA097vt6-QSu4i$%~huNzH6-QUE4;6>0hq=cJDh^Zs8tNVgs5neL z%st*vadh>8P;r=gn0sQN;^^vAq2e(0C!qc8*ymjB~W|o(8S%L;?vN?OQGg0L=p$hm%-K(u0s+Bxd*2HFq$~b{FgYynFCSN z2~52tn)pnpdo*!~TcC+Ag{t?!As&uHJPn6<84mF_H1T$5cuqtT2ZdV`#G4HBki14)JF=#J{46KY@lD1N34wP`rTB1MJ=| zULQ^9%BdgzqBo0#F2~~dv zO?)v_{4SdK38*+*7-~2uK+m6z!y(>|CLRM-e-cf+6Dlqjj%t1%RNMeb9J)jrtS}2n z9ON%IsQPLg;*-(DGok8N;Sk@AL;NC|_(P~U4{(UT$07a?hd3`ZgMgwNZ(2q2lP~Sl|$M!66p>gCYHVd}Ne#9`{K(Zpfu{m{f=>eJA~Vd{&}#9`{2(Zpfur=f|%)Neo&hpB&v zL;O3Mco;O?*y2#b2PQ6xLtF(-9G1U~afrL1iNng705tJdsCyF8#9`|5(ZpfuC!mQ> z03~b&28Itf#C_sX{d)|mej%FpZK(KWByr^O{4J6=C_iq4s{eySoHqg0UYL4iG;vLk zVGIlmMmWSBafk=t5Rb%9$J!NIA-)BN_*tkpNH-`5 zVCLUP5=RbyN$CAWF!e7%4A8n+s5rWNbfMxPWgzom>TPg{d*cufgNmb@9}g8rH@^r? z9CojLJyaasoGu*V({PBdhKj@Ng_(a9NgO%c_>)l6AxynHn)pXhATcm7G~y7SfJ1yG zns_+WoRc`jg_5zm#~Fus0FpRzdm{mdcmWRaS|o9h6Jg=dk3)P8R2&vx+sr{B&cLt& zhxkUQI7k)9d{}tC#v%R-P23ZtiGhKEGX*t#VB!)u#MN<#o1=-t;>8In4)Yf*|9V5k zVeW^ikH;aNheNy)DvoY`6I2}C{26HCG0fJ6KQ4)F&##DCxr7f3}7XPCVjXyR#5 z_n4rG&x4A)qKU)QN1%zr)EA(M!_?QHiNneSk@o8w{u>8IVP5dg-ix zG9WI1**g=$We~+7u7X3{7>BqM4)H)7;t4p!i_yek;m`mThm{+iwjiG{Fm&S(pN>O( z15_NO8x(FZ^A913BZu=JByo^>=x_uBJM_MKboU5A#bM^d)XU=#*TW%h2^B{--w7&? zZhk15IP9LvB&ayLIk`B*D{+YTLB(PA!pz@+B#ss_QK4OLKBC@iz-wc<}X$Q!XX}rLp%m5j&6P`R2<#>YBX`!J>!#ch_A*Wei(=NZ5-mCafow6??Z;U z6Lt@^IGQ-@9&HUYahQ5*G;x^vU^H=<`gk;PnEC=VahUpMG;x^v*=XW0^~=%3Vd{6F ziNn;NMiYmre~Km!Q!fU+M;ATZbkM|M>lLkWhk3{12+d2o)6K~!^D4}iEo7Rxj+UZoev2UN52OXR&J=EslNa< z2Ri%#cMmMx!r~L84di~9cnC-U$zGUv3Ys{~{bgw4>!AF8C=H@O=I;hE7#J8}@*plq zTognwFfbee2_V@E6TgKf4jYI0h9)ivHAe_agQP)Bn79dugJeFe{TzTpJRMEk5z4QG z(lGO3;+<&Xu>RU)H1R|ze=(GXnFH&mY{nse7>D>}G;x@}o}!5-Lg$-)qlxE1#l@jC z%spqJeDwQCVdBnEd6;_GJY77R_(dqc8cM^|!^G#JiNnTMcj6GgfF}ME%6|l%3`LO$WBazf2my_uCt4cu| zgMCQqK~V}5pNA$c4^@90hxm0gaoD}Lf6>HY_rUT)&4algCa#G?+#gLGc28>onmFtp z)h0A?*uAJz(8O;*E21T6;;?%{x8M*zf+n5~g$~3ea$LLKBDI^$oficQPuTqwp=j!1_dcYeiNo$wC`A*8-7f$; zp9W?=OnfSudf2@HOVPxeq5fQtBo0j);B>wVNgR~UVd{?{i6g5&k0g$){w9(*vic`z z;xM@{Na7%KVCSN>i6g7GLlOtM2WGwp zk~p&ZU?g#5^|46e$m%oD#G%LaFjOFkgUp!>^;Z*;ILI7uWHB%>OhOVzRzC+x99jJu zBynW*+mOVO)gMC=M^+Epmkf#*Wc3e_)Puxf=Q)2s6NmN3*r4a8z|4V(OQMNGr?VM! zaEROE5cfwDhpo4d$01&XCJyT-Hlc~b`iGNnh%Z7Dhn*L?2~GS4G$Ie-5Wj>&{1KWs z?EK76NaCRQf}I=r7fBoxFR*=@oX`$7DEvX{uRznAHV$z+G;!EDlLn)nH5x~f7F2e}7!t_bX2W0<`cpz8b4)WgmjnS~?{azE_+idAUhuyYu8p@|=W zntudI9ONF@KJN2K;vn;3>S6a9gWQR%{s|8C?~ufi)&E2iM>d}sy8i&(d_FXB*f|Mu zNa7%KZb1E|fg}#H7gp~WBZ(ucw?z_1R_}o%j;uZiNgP>yERr~~`gA05Wc5X8;;?=9 zO=#kptFPeA&ln>j_3JQOadYJfQs60$u z9cs>JG;wXHI5TwLCrrIDR9q5=xHg)2093s#4sl;Jao9e)STyk!P;+w8#9`%iEt>cl zsCxAKreXWq=Ax;G?K@kGCJx*Gg?`^OY#-1SH1)7@>NO7Wzi8sH{X6_<_d&z<-6$f7 zBc}&LBymvurb6?f2a-6l`UoU(kb2nunhZ2?Sh-VyCcYAyKKjwbt)Tu{ghPBQnmBA9 z{c#-PH*tu+MiYnam;Z|<4%>$=1ii2fmTqDDvQ^QwOJyU8BbyKF-+-!1&{a#&<3<@^^HDHy=&~gS*jfdcICQxJ1N2yT z@NfgjoHnqn3=Gg?yy4x zx~+i$dR!A++zqN8Ha`Y4zZ@zK-L?)_KNTtt-ChY7Uj!A0E|Z6gZ-$CPmy5#14?xAC z%bMWg7og&>`8$|2p#Fx5KZlB!qKSWjio^DC!qhWD6H7gsdI6|-3!1nBR2()R z2s1|qD&B{t-Ucc@8BN?9Dn0{EJPaxhn}36up9&RUgr*)gU$q=fycw!~4Vw5Qs5orC z5oZ1ZsQ5NC^&6q$yV1lCK*bNBiJyUr!{$k0=3jw|pF&fA2P%FZP5e1j9G2c;=D^n7 z-9%IW3#$Genm99b9_TTeI5$-M1)8`hRQxTPxExd*di**(eQH6)zoV(Qfr|e@6L*4& zGeXlN%wJwmaoBnUn0O#moEuGjEL2os8h)qtu`MN@AH70*HwcZ7=Pqlx=M#Y@n{ zqoLxk^PFJzW9aoD;Gm^uAW@!x3bVe^Iz&~g{19yTw_iY9&-Y7Q5g_$8<~Kbkmf z{!0W+{3TR9Y~2UU-j7gmIW+YQ(D@x@G;u+wxCWZI3{)Jp&H`q>3RK((O}!3O+#F5Z z8Y&K}|6%61K*eF}N?_u!dv)E=%!z=ihqV`A>Jy>ju=Oo4@l>dI6x1A0v_X?TxF)JW z5{ELu;yP&UbJ%!tE3^>|G6$p{*8iQ1cK`JRXuo44bfGv%J#u>+`Myi2kzjja1V}yf zDh#j?Y+V`1PGt8(uR{SRJCGb$F#`hwtQ`ds17X;{JXrk;5(8n_`2*P?3qkkTFfcGc zuiOC})qo@pQV(0d(TOAu9U=s)zk(!=>|a>^1(^X-4_o*414%td4i?U^b|^>;q#m}e z+Xo~7btlMt*tkk4k~l~`?7W%+BykWE7GJP-B1jCRehS$23=Bs=0!Ze=#xc$!iG$R` z+IcUK#6e70ysJR#TaXw^{OT1~=9VNTG3XVS6hY_=7^^5XCsD5?wW5SUFD0=gkwGu1 zxR?PfpcfzI=N(*Pnp{#@km{N2YLSv3U!Iwgn&+C#pjVU+QVlZCP|pyRYr&ugH&m}Q zFDElQHK&q6FFiRqKD8n_wV))vBrz!`6 z;*w$%!Nj7(y!2F5v7)?mOocg_d8shNi%W`NOptIqm=E?eI8=&KbM$iZlM{3FT*CE= zQq%O}7EMzA_-|2ld5a`d~CJ{m|pK7(i(rWVS?jg8UCs2lEf?9%9hA1IT`8wu5M5 zU|`sYW-m+vq!z{o(V*-4KxX37kFFk_4+;~I7#k?VgA9b?15o?X&4o@EKvgj?fW`|z z`eEZ9Fp0xZ{jh#6OdO;Z#D>wJ@dFSWT|aD`tP-Rc34{C!;)3*mXwdioh>ae9kD&D+ zto;a53&LpLWB}y=P`seW-wEhK@D8X3Q2c?WC}8%(;tw>g0J0yd3}giu&kzGs46yaR z5FP^q$SxQgM9+qZ~+1P zVeSE~*9L_@*btZ?0|Nt0zc+MW7EB6eKa76|hx;Eu-9Nz=;xLf=K}i~>ALf40_yRWj zKR^efVC_nneK7qnK4`%=HvJ0F0mVm>aFt*Nx_;0#KiJ~Gzz-6m2}NLS;P?k6Ntk|^ z`$6Li*zD(k9wY}FABC6#i7OZzM1z6}oBbCKK7r#sYRyeL;VjDL&jI2`jN#zY?yu!8-&+0GBALa z2%e%e$ucllK!O3nK?;AEz#$yzCjuINC!h`ng&(N> z1hXF&ejsUdyFq3dap`f4uVM9nW6BDqEiIIu98CWQR ztKQYejR`gY3$91)Fx&^Ssv;jzh(PKo2L^oxJ+NAk|3P60>UV>(Du@m86Q~;uVuQjA z)J6lD6B_K%D+^+HG{52C-v%D3XgN?K;L&`9!=v*?bnM|Yet8!L1`o*P#4yF3@4Ffj1TGdPAjhB<~hhIn><2@UpWej@?V)*ayB(H&vo(Rs~7^Pb1S zf6N}1m-$;j8!SCLj~SkPtpqc|$MOMx%XS6^29M^0j2_L0IXo;s@;A?8U|{g+*7odn z74Wn?Qhdut^TB>l>h$P53O3)fJ5<1;o0ft;A!dR!QXNlWKU<>56{jr2hVOd4Nq$~ zgOV_xP7ROd100^6ZW0-Y@)Uo|Y(@qKAIk?jKqH0{63mLJvvW8to+2^0=oFZ$MOfNm7v-m zY~=*d@W*Y#w?3UIybM0QDZCsWttacnd|UsQ=6iPLS@?FQIe2!)dAvOI@Be?F&VL}2 zp~=OwyUfE!^Pf-We{jIRzTnwiX5gdw%%}6YN2iYp2Uygj+ed}trTc%7=4YUg=zNcm z1Ze;(@X>ts`UKRx*XulXz`WvNdB}s`{enlY40xNGN9TQnX0S$&&Z8cThhN(L|NkGK zE{IbgYUls^|KDTx4~P}@uU8|nuX^-?GZ$F-1Vk19Wm~Wq|278+P%b%)nmqc+_{L9}2%8ovoe?7Zn z89bVw{_yN&(f91mL9qbJSjEu=w|lp76;`4pY8$K#qSYGn!3{l}I z=JT|?=+o(=BEjDVO3)sbM@#rTIuE}-nFjY?w~LB^r{(byQIPXM&hl(N&H-{&YZfS` zn~zu^W!AI_4HgXitrh?O|M%<;wL9u07if~@lB zc2UuAJjTWdGFQT(kfV$8!Qz=}dL-=`8hl>HPoye?B zl9oL>4|{Yocyv3w@aSH{`~ehxt#A2TW-u`@G}Kx!@V5jpGBEJ(D|Lp|iXNTE!G`*F zmpgcN=Ue!6s;KyMe(=zI;nDnqqbv@*d-t^zG~I(_nh!IAWDove_OLu$Z0p$_qVmJ1 zJLfKgN4JxJ2eT80r==@L(N&Lb78S>1t_+NxmPhzoK#LiDJ9Sh%n~!k3-ie5hZWk2} z&+d2+-_CRg&rWv>kS@jxQk zjGe*P@>z)tRJQc>K2Tc$Bm?o7<+IW!9-u(z2ZcuS5e-o5sPlcahvqwYy$&uj`Q;gW zI^XRFwd}w;!RGkD>a^w~93X49`gZH6I5yNWFqB*Zd5_`sQ&4__ssa_<;PuHK-3|sG z)}SQMz~3?foN?d(zrerm!^`G>$my~9hz3$-nc%Sto)bEcf(j8156z<avAz(#v?p7-c{D0hN#(AZ-$0B_5jpz^XvCt^`==>-k9Du)N^G?|#UqR|Vue2A|I75XGGb{d!px zUPk@@53TW#>Q~P_@O*L}95F-?(E2Vk*rW3^s8aUm4s!r!o6d_Kng=}^e=?ZzFqC_E zSRN`d1yz#Kv0y{NQ4DcWcd*54L67c=AK=or)7inJ^?&Jok8WoN56eTP&mfv$?LV-V zmIEax!SdG57A5z=<(x-%23S8h5qW?N>3j!P>(TnQR0yWH^v3HAkop;HzXvq&yuLpH z)Lw85^?|hZ9Ya7xI5b~(gS!d4KphH?UQB6V;9V}n(0u7OY znnw^#V8?iNm#7Hf(%{i~AG|^tY71BcNI%RY@B+rCdkMIJ@ojxl67JYgqhi5OqVCAQ zuS5k=xHKQ(i1z3_4r)F_0vukBK+=I{H;W2-eknQV)A<~nS6*)i+m6(vg4b`Lkdg4{ zcIWWvR`;=dP@?S7`P&B+_?<^RdL4dvbUJhRw!ST4hvZZVAIk@&5725Ret8E5P!4AF zuyz*UZ+Qr6|8(a5@aW9u@U(nWa?z)|^oM8XTaR9dm~ZR15;jo1U&7^M`Ly)m>kXj( z&oMSe59@3J{uVDL1_s~G(jPvZ*&M!>Z%QWlc7r%?eS32uVsP!;z98){^ZtYCYfuvb ztiOqgfx)M<6l}eZ5pMKl13k}jSkER z8$B)G@VDFnHROq~5wws6;nk=7EsOtwIvW@^LPCqj*YZv2!k5u{kJh&(T%ZD)zXe=rbRGq{;O@)6fB*kSbiX`1 zkE8X#zO!NJf&FHO_Q0O8GB6mPbT$0u->GBg-J4?v>4AZ&M{p198rVO^zMWq{3CN?< zTj1rkzwmY%s2+qQGkX>W2G34NngC@%t-t^O`*de>_;f43)P*!vK>dAqHxX14Yd-Sm zya1^JPVl#Y)&uxhKHUlJDW33PJi*^24tD1O{#MYgcEh)>hW~v#O~ieBbHq77y}AAb zP%3GC!r$r)PG{D>oqs?n)uS_8;H59Zorr?lxAQ$Xe11Uey};jcot1&X*YYX2fPq&! zKiNRxbAZ1!9vVJx{X0u+8N7RQpj}iCMg|6O0GWaVNZYsb4LpEE{(`GQ0{#V=jNxC< zrd@Dlw~>W`0gHdxVb-1kr*ahkUi$-&7oSd0*Av{BL-b3F1weHf2lfuD1SlQDhd}U! z*K$xowS0pbUN=~w;S~dN_eobn)bOe=1cw#qhz*}kl(35W1M4XJAa|5Ky79WU8$*Z8VUNF)w=%5sE+6ApR!Qw^Gf^D!DK`RJ-I#JRt7m9_Lg&1fN62>r+E7*&d z_*+3slwCnKe)C2t#WpfPGbw1Ts!yjeD2MuhiiRkVb&#lj`5u-6v8Sa1veMETm@e#w z{sXm~q4vvy%5Ny!3YOe{`E-54!}5d&zxzRtUL9~t*8`MGL*QdwAu1f8(LctcFH?Sz zqe~7H5s1zKq*aY%7dQ+&L5&|CjhB@mD~MHG12P$@^^M_uAE@`?J)zEHo{UFd?g9lW zv6ig-Lyo7J$kMeQq-!s{3vt~8&VHE=N=^uFA1W6#7Kx-d6_h#E5d5aW}ZWdM0)CqXN$nXHaCTLjgxQhyCDvQCx@?Wu|N9S+P z&M$^1LH){ZZHI41*-QE1jhYf4P`lNm`89{9<(;DYpw5_pN9+F*ZV%Al?m2Ke0CgNS zQarRF7V)=&cIbJa4vj(E;UJX~;KqsNi4r9b$jCRyWfC5}H7Wv7(|lAEUiX6gH$L4p zDgvIJ=a5QS&^Yf0cq0L{Nx;+cJZhyk71Z%=Jy04CE_)7mcj_2;_vRRI__lt73@GbB zdXk+vDiS`OIVuXT8+|&D`+&x3{((B0ur81fC=(s<(fsMt`5&Z%!=n@8VNkb|7d9Vw5_pTqW z*?Dv`qmA>Fc!0)uN~BQ6cc5J`NcRh7B(`yik~1EikTHtahrj_aAq_E}2htV&WdL=(HGDeXduo@cD0p-Sya3IP`7plfc9Lj*u(kOF zQ>PPj4h^ZFy@eU%SKroe{4GgL3=ED9b)bSPC~lP!pKGGy%0 z7c}e!nh$pbB~1R7S_TFNN0ihFcXE!31IWo1o|bn@WRb!j&E0oP-@wMp4ui+*Aho|| zHye6<^0$D-$$dJ%gX8q&bx^x~0&-MfY5)z>`atu*%ScfF92T3Pt*Fp&K{f)E6ur9P zNs+(hFarYvI60<)k|RthEXTg=1Xl~7{thHJ!xVs02AWwV)nIe{kj;sXg^r~-#(@)b z+5}J!5?uCRrf2?^T2KWBP17$6Kz&Pm>Pu$A(|AjogMgF96@gCL`lMsBBR&=;tqHM#^w&N_rUHz89WDVoB^fZ zl0cNCi(JNlqXV2CA!QyYLNU{qJ!nV=mcEQY=?giq(AAerg_p$qMEY+UbUId~=wln?Nf$IIa9aSl8^26ui2vpXUrq7P34GpU(G?Mo;HGur0el ztL(tN>f8m;m;#G~g`i`?o%f(xAZZy?{t1B00WDO-&;v0R)WnC(?|63aVFhIskJkVE zEg(lV)Prh;Uksr6opNVb(E^KSP-(9Ls(lndEmDu;uHa?+o}EYeHC;D&YJTN!0UNdh z)^7H(e8Jx|7g8gD9S+tDngsw&ZF+Pb^3eR0=E0wL(3A0O8h_3KpU&I^Afr4ikCh06 zXAnYXfc1HFht2@4LSVe;(doOxwe>%Ls~RH%LwD#J(831L=EZK;6`*Mgu>IY&8$hjD z9*^$Q1BjUg*AqysSfH+bF0F3{p0Xw<;v-yz1&u?H%Zba)2q(7t>M%8K2k3p{##H+Xd3f{TOJTfoW#a0nv^4``Eh z0!-d96r2vhQ~!U_nyo(Fpp{7QDH%|f1(hFu-D?y;Q2`o0uK*XnC7$3q8_G z1GK)#NAn%11?6dZmA_>_188XVnBjrfaxnjUSia zx(JpEJiF0X7lFnMJUa7GR~H39r_>Rviypw*Gmi0xC%76udHsT4o&jt-bfz7}2K04B z8+^M#tA0?{6}<xx_r-+FfD@G^Mz<{&RD^6kvC@a)Wk zEG#+>9vcEJEJ6wbYzvFtfeTf{04``@ksCNSy#oaWXe0(EiL|ij9eE3jKqWAV3ybD~ zaxxJMi_#{%{C)rbf28$3;Q2uK8oNKBURVaUip>MQvWUMGv=7XuyI8=p^DVf`0BIjO zYj|`Q!^(cp+AaouP1gp{Vg=3b{4Ga7Sp=!<|H0pM5xh7KJ}jpID#N>-HBd_a^N^Ci zb^^#OP{}U|F8QZ|R@^{xQ#Y6m(#v?!r}G`SPygJb)3?K;*S7(pr1Ku4WI-^yYa3t{ z!33-oL8*mD^N|dsN&r-T8(uOz`7$2dx&W8gNagKI(E1p#jbH*+R3i26LGyXgum;T| z|MqBp6M+=iE-D_-W(2Gs@7Q^y-TSs7L2LSUU=o za9R(P_<)v9se{%ndUS`Vc%*n}i-5<2_*+2-hkG<1i9jk4JUWko7leSF{QA@ckIsAG z?Z^;*+XQgY1?G5khcbW$Cc*0=*%&++4|y=&@a&8e@azoZ02f%@t{NWJt_G0xmOh;Z z(3L$JAouWlcDr%B%m(!lAmcop-}ZwBCcs9&euUH?gG@t%_Dw;nL8LASsQU2eULygj zKENw3Rxv`Bos`I&|)F*coSsBkWVKIWFe7HH;c;a%^uyQ2B4KgPcep3 zQI;yg%>%6$0xwhqPpW`=E-}!RdHX>V_u%mN=nYYkM}#&k^&urK&?umSN3V;DfrsUB zesEI=G_q&l(OUpnG6e3QKn#PILobU!{X@vW4Oj|H!14u*29+KN-1z}iH6ZxG9-Y5E zy6qu4yQ?jrS+>{%k!7nDK!Rc(-Ngpc9-9BaE`g_~=)+~H$tC$kR#x%8@kObLIXU^s zply_?MI{U#sfh&&i76>XR-6o64DQYfx$)qgi18))1y-CO0SGrKzoaBT*NT(DH?b%? zHN{GSfh!oab5kKPr3lQ)tV*>~U{G-4VsOqV&C6CuECHDq3=-z#WZ-i2@$q+d3~_Z) zaP|oG^A1)}X7KY@fQowh`vr3`aJdD!qRAtRFu1rng}N&^`}_E~I)`w%`8c`xB6u{w?Us|G&pQezTnwwu#$-uA=G+YTv9ULB= z&~yq~VFhc#d34ICcy#8da6s1e_^5Dz5_Rjz(lf8`fOH9f)&nVcX#N95AuA-7;XSt6 z4bVn9rsM>0;`Qi_T>#P38`^+Kzn+~(AfiYGe|PNyk6zae9+t;Tcs;sZH^39FN4F>_ zwRv=dm%P9$3XuBF!`QXJ6~SEEdHD5f4^Vy5T?(p7FrABP38E~jQGsWw5C;Yz(=q>)9AeSy!H0S1hgiwGB6xt)$IqV=VAcMNw9)xe&rMf zhI@?Cx0o1?G6{f%c;#7p7#Xx!;~Antzye~5uUHrumb0>Uu`z67Wo=?(_`wP_MG&z= zGAXe*Ga0mDI5RKZN+CHvuehYBG`S=*KTjd8C_h&ruQVq|A+uN^FTX^gEHNh&dUYWK zXsuGd0CaAH!>3c__EA<(a;ST;PMWt8nIU; zn+4PnMDQ!-+}X=ML*(c;yE|8HrK`=(ym|MAM{=6#;YriZOe#LdG0D;4WZ(n^M@H3- z1q*Z>4JRyaU{OtXWn@k|m*m9Lu;|m=;#I46RWU8P{=0tP{khL)uKTd>c?e%@Y^?2t zrP+Z}-B%xMZ+f_OgV@9ElX~SY$9wA^JhM;PbgfF2VSHb;=?u>oAFgU!OEg%eCzV)0HD|f|RE~ym!b!X?hb(8jb^`BVQ@?`yt3sSztHr5bOzHH6Q7Ha=N**3QZ3`Z7m6PwF+gu?UtAnWh!^z@R|-qrivqc2T~&# zLrPf$L?TyCYvop0cOazrS#!p{{C7&99Y43<%s6K#{Ct7sbsf)VHk6xD|Ey!q8G6RvlXl+8@q4EASh}u?as{zc-n= z|EHYV=eB&?nfrh5tGJ6F+xoUpe*0xPLbPgqs&*ywk)#bIi0oQ-1PI zW}Nco=`-!-&kjBDCbw+UnT;vm4CObUkxlt#dVkBA_zOBQ*Y9j$I9r*v(h}QGDg(4`MwvrWfR*m&~qYl3B@eXQse`iJ3~4Rcea^ z4c#th9ll>Gaip}#Tky{9UN`H8T^u)@ehC!u|LB{-(d*&*EAW4l*E5Dq3>Sqv#FRx; z7nHZWj?z3nabe3Img~YsTI+9p;Apzv{Cc|3Kg+N~$sGF_ufK?3obUW{5sSa_kK7Ll ztc?1iuQ?iv_ndtUyrLVj|1%54Ieai_c;=NEvclH6*=u6z$xZfk zd>qnAuFuXq`XM&Y6*?3CGb(SLvfD!P z@m>3KkBS=qIUmc=EWiDMN8M*}*eQ*^WV^MFe`c#6VNI72d&%hMH2-i@iX*p0i(UND zm5Z_zPFuWW|KQmW^2)x2`$^^O5JRQR-M+7sJVj*EI$Uq%KfkY`@;50xzB)`|@+-%B zKf6;WUu-nGC;4`A*}b>oRXaAN-)wkTo~gP1)~1+8YuP$&ztG=@9Wv76f*o@k&enY%|mM4FAcTtUBj3C(l|Pqs?rYEZet&k@{o{*P z&s4t?_PZy~J2G72&e4bOZ_U<@$}3@a%4*6_ZhYZh?0R3|Z1sGh3H58l9~@R?&;6zP z#!y>eW0>O_%^vN!{z3f=sZ&K9WL1vtKK-Kjh-1I_!~aH~{1SJVG%gqVnvpkg#tP48 zS{kq9UK~E$aZ2^){DY6pr_?&DX=bS^b{^nYiRk#pc!-&!?pXJ+I_nAUl@1C1t*x)}^YlY!m*E!8cA{7+9>>kc~9y)Q|lQaLGy)4n@Ha@O? zBXWji>yz`%f2>zL*6z7etTNAXZeEYXZ^i~`rYrj=Up)Urwkk;JPP+=%k5|n?bu%6m zF+8TfoICJx@(Yeu_wtfMrUeG?B&IdE9=NZKINTdLPWi8aeqts!T+kAMGvRvKHUD`Q=CA}iMIO2)4ZIYPxSa!$Qn&8d}nCq zptRlKOnJAuW$4^Z4|g$`@->~mQJ~+z#&Ym^P6d~Paq|OimgH@lo-(ZEYr4PrVJ(9! zSCjpwhvkgFEI9rJl`VKxa;PRm>o7!B8vt094go}d-jRM-48d#Px>tI?x{t!@E?0G zv8(+`hdC>C4uxKM!0D`!Ab5#UM~Tz^)<@lwZ+Op$`xc`uMvSzc$rEG^C8lEOf1(yU` zzZeVTwRvCUXch5jl$s-?wu6&Plbz#i&>Qat^PASXsXNQGa zck)KG%OtKkqb~Za`oOM792QF!OxG?E&a3>itnGsCvtTY`>4@GSW!GB+*RD5ut&yw|x|i}K zZ|>!)We7Olc1ibHUF%MU2<^*CuHQNi-Qis`Sx~v!DY1@g&Fk%bZ?w7YzHVN3UR-n2 z`qh8sH$?qXa{cDpS}DHa*iR+bZ%v14SR&51wXM5!KlsJ(#$QoKPSmY3&}V#oy<_5E zuf$~sY!sAjgHrYf&e+;`)$Z@KiF?;vXlE!5(wKXHRm#7t@BKSp^7%4zmcNXf#Z?qO zWnLRs($l>@;wHX(o_|Vs^rFmcT}1q5TfJ)0*Xee9WX>`^3r@M0nx|g8pmNd~$7k*- zd}iw>R&JlUf$41ZnMEmlhSC!)uk7hQGx1r8k^9W-6Eey3REpR9G@bd_r&x8?_gStd z<|Krv7kAz4I3t-RZj?UD`DD$3Ilj+yK6@Ia&yGG>bE9VVnaXF&Q}hh#V>9nA+&yjM zT*lX7$G-A-ANV-E=+alI^C$1t`Tl15S9MEkM-2OH*SLd11!iv@C;ZMyH|c%$=>6?S zOPN;f==1YVQuaO|Eg2}PvZZjQzM|Z*;2yOT zcRt#9A7Fak=d2?Zyuj9f^6xKVYwjJ)dHrp{gzb}en%|CE*8f$`BZuF3cG`($TQ%Mn zMv3fab3DrMK&$hjE7$(159eGya*})B(z$cIBrKyOKkpOkx4V_o#rRK(TWkO8ho8;g zfBEEo%;9SLynC(w-FxzP9cNl^ljM0zX4;#*0-Hr_*aUyhoszY>1k6+$>q}Kk_YI>EKg6#9X5?60*<(WL~%;pcyT>I2Bq~?UP_)8vp zc%EY(&xIV$;HsB)*Q+}do~&p3VYy^Wyz0gGs=tgB+*_Em*QcfI@2fnza=(zM=JW^k zky={rE4r^ohudlN)bwQ(*z`SiWjtN<=ql&;fQOG&mUA9h`-$_djBmQqEM^8tZP7cD zB3^NFr<@%sTqfvf9G+#@{C!%1V9w!>iyQX7Jn%E7C;h~e9{tY`OXMZ@u$6vQ?-AYj z#$n?d=BBi|7s8*qISRIDFD!3#_jK6w$vXIk_p%L~3TvBE-YbhF8#7GU=rrwk|FT9K zLH?+h?1#M6Po@?1_Ivd1Zm6)ClJjxesiL0(7V+M4D;MdV{%yj4MMvRXOooM$?3@ja z!lztR-aKguo0Ra}T7Ay5mc&U8W_u!7jW;JoYOo!a%&WH0kThRtD|ZfRMG-Z&v*jKK`2N+S&z+ zU!4pJz8d@d%R`5`QeMx?=f^eov%WD*&=J;I%bIxdifu02ecPaa%$2WSpH1)F$M<0O zxgSMNk=+HX2VOX7HM%=roSGc?nQ^U?#44f3+r+kVUijs*VAZPM(SJT3n5+HMXmiLb zuI^tZ7tFj~aag-n>l{jCIPcBG*RpEXU$NIh26d&!0up66MtHWGu1!cZHJCc}_=7b$ z30FjQ?CuCYIQyVwocwTS+>aGZ;PjL?z72Dr7pH^Ji zH90-?{pOSN3yg|xsP2g2^SZjdYts%M30b2#D|f9rF`Y$6`>^Kvoo_>TP9> z3|CwEJ^at9X%;6`C!F|oIJIJ#^1I$&Js0=n?{2xo{&4?=m6Ijz?`)Z5`r-b&D+if> z1#`X#-7)8U$ueWRQ+>b63w~-|j%2S1+*adc=NJ(6VqAO1Q{-`Y1PKJQ7FX5U>r!H(_F_J@y5A{AZ5 z+cO6rr7m%R2|!)vyT!tEm`EmHKn1mzSH2bXL0Kk<`zEHyqWoT zMSle>@Y562yx*pAM)g3|E|(cKvlmVH#`tim(8N!=;fZyOYqV7lU72FO_-*0Ymf44# zR9QQh%|B>moSaj|yTGjclIYQ|NpCLvX3qBUbhnx6v)?)K9Q(Cd0cjq~`a)9p82{%k z_bE7Mx8TBhhN)Az7Dk^D>m4~V@)&m%$)Mjr%ZHDo&M7|FQks&n)qpITV(yq z3rn<*UUOb(&Xo0^jRDK5_!U9e|+)obwO!J-<^ ziJsbvGnbxfNm(@OPcheC#enLzh3v~8O;Re>|M1*(!p0ZoqQ5>n*h;j?&FPXV+;(R7 zf&Z#KJ+-SdME5974iS6z<+Phem(ccaT|UeYzH=xi-+xy$b6(e(iU;~U%E|Y?6wR!D zd}+yI9*ZMg#?%!C=ddlXV(ell$4yUJj9lvGz&fM=n!VN!#H^RSkY}D=@ zyU+AyuYyhM<1NgOwG#GEFW&aQM&@{^(zDZ-w$w!W{oM4itZEg*HKzxs-maeXCkos~ z@!Iu9)ManL4DN=lMj;!I$}BV}XMVjT4q%Lpwlywv0SP!)pXr5Xg z6%#Hc`shxQRolVS8p6%tyGi!o#mjTAly_W~U%+|uT3N8m)WS)6U#j@z|Efj3?&ogU zZ*<#n>DS{Ij_*lX*xn$wrsdkb1CJt~ZPU6oXLrR^8xx63&Z{1o?ny70cVJ?U{adLg z9%rYlXXsqILj3%~+9taTfjs}#t(4&1@-qJBrO=&mwjD6bREck*4u4{b}HGSRp@&$L& z?_AjV@R6I2`J|nJ9nvv5+_AGKPw&3Fwovtp+?=w{&(5yo|LDGa-gkvfULx~*Y&8~1 zs4Wt_`sL8+Pg%3J&D$?Ot!94SrgIPKX50yW`SIZQ1wYe&?4FhsR`jIKDXDR0&{?M+ zlgjeFZtyg9Glv8o_;p!hZ{w25>90b}=d$wO^*qjRgjW)qc7aO1MUU~0C z=$@((1v^=rL z^I3xNTTN~MwCfwPVpdv(EcLQ))s=d-DXnyM?8EGWb!&Pb>~(r~J@jO1V}$R7jZce> z_R5Pny<}uM=w_ONm#pSZ;d##v%y9`KsI*|quR44 zOM5rpxv28m_l(7*xfWBEg5I-K#IXE(9<=Ktr(oS9tJ$B`9~7E81<&7c@|g(Zo}Atb zF6#f1ilvzEt#iwW5^ldSXE&p~wqlttIskgavg56&F~Lt zzu{-g>uUb-)x8P&%}SjwPhO08@vFMvXOM^HTnp*M8!0slUaWhma55uP?uxUm_shyw z!`bG+8JSx%tt;XLZXdFp#lB(L_BWTyw}hoB*q(jC6Pu#1@FHX51izMy2ZoG-XWecI z6bW)A2r6Z4oFLXx!zw2&`16$8EP+pk6*BHmlBHMro~ZorLt^4*v!GsqJ74RWCx&yp zw6B;GmY}WpBPn@al-QxffBVu8*?eCRb!}aDOKS;t$9tb|D^gR#-~PTT?r`y_zN3Cv zR$*%POwo^LyEbh-D`QlA#_PwksGGZ&OqOKe2NgpH|F2$g*txw$>MSuV;GH5Ev|#&$qCMvuwx^ZoP% zKA9X9(kqpo)V9S5z0xf_yLr#Hz5UrKvZ?aolVpDHSl0MQ?Z@ljfIkd3-qgmdINGf6 zopXCX_tE;2j@S0LtPZ_>tQF$EA#hsziyOyV?Mx?{B+nJw($D?)Qlyhj&+-VSX{zNi zNgE|H@2&acre5yF{Bno!#)#PL;E5NF_nF+#b=NOCQskar^r6iKc8jM^IIQ0n(~=M;=>R4E7tHI6y`jqyzu$8z?Hr$lfSmRZQt=uIQ59U z#~-E{XAKh1PB_#&!`bQ=lM%<)HQSlv9Zslxn5!yK+s&)5SRv_f-m{{e_qos>_63WD z?j^hb)oi+7;t+GEtLpleox+8`<72ZuPiwe_7TE_(dgYkTSASjbNwGtw(`N-s-`?$HG_RWEvLR@=!TmKm!FjsxLN7luCozm8Q%S6}cf3P*XH}&yU#_Wjr zso{?^_x`V77ht;{etBVAO78LbOf8m8N2;ecw)Cg141Ik{NW%Z(v8er$C#qkyd;Ses z_rdgl-4qM2f*`p#MN7~BtP)Yo?P50{Us7<>z0!PlQt7=TD&=R{9+`BUyz=_Sp1zFF z(&smGoIfO`1`o_e0g)zd69iS-_>cXy*pMmcy^V*iCEgJ=`3#?m>05 z<7E%7OHZR09`iS=4Pmj`zt=!$B|CXHo_A|8vyo(U3Tu2{)%aq*!kNq8xlTL3 z<#W^vn8R|e>36bbgIVY+k<-mb&#rb(eZA~9Yx$H$H@=Db%}&+_E^RETm~gDsI_l8Z z1Iw3+{JZ9N)1k{Rzv11)4^vAw>D@~{>CarS&^c~@*7nJTbH2(5e6!jT@T6j9;j`K~ zKdm;{@gMft9(}Mz`-!xJv9$Gy@V7r~Q#W!kFK$XP%~bx>x>>K|Z~TD_{fJX0ivL7+ z&EDB~xuu#x{`!rH!74d_PE8efDX5@R>~cy;RnjbzU4YNxQHtyFTlGipF@5Mhrl^{= z@mBPj`;CH^k1TAP{w*-9`ml>&LH#*5C2jWUr<@Kc$)_92`w2ZsoYNz7O;)dV!kULN zGs>(aze_n?XZhhjb(MwHU4cX15BA5L`qbdJ>67m5j)rHS8YUd>JMc6lV2$5~H)WIl zSg0$v$2OieT{-jdYLV1=%PvToiJr39=QnXZL&Vi(em`ZsR^4X2rpj@D{R3r2Y5A7< zAz$=aay$j<;tpKmBpUxi>lq`RotnwSR~nSm!w>yhDBs*Tf4vR-e+cwr=DI zyymv3h~b$@cgXrRZzI+y8|*SIPD^B+F57C@;G6TTC&@R}`cl$?c~dOT9(ybuV10{a z-|o4BPmb2k2$j*u&XHfo-T6j&M~$%GBaYQpQC>X{g*;O3J)1Rc|4z|evp9n-JlC@% z^i6JVaXUV`sIVz`VS7XO1&_`Fv+ATd~tv zK0fftedafl6@GGe{dwQ;Qg_a$_+4*)&#Gw<&3riJ|Fp-O1=q7i{1rR5>dWp>_FYZ& z_KK^+Cb48MKgYt5?&UOPt>R@R8_ow>l2-41r17~pRE_@MfHRFnQ(X*h|NYM!0xjws1Blhlc+Rwd0S+=BmidgPsIkrPa z%l(o*DZ}LCnf|$%-TIpR>FX`|{P{ z#;sF z*_!osMz)|;+@f+tsr>67ZrU)^3jH`g>EeNz3q#ME-|mcJ{qgHsmRi)D={e^F58N*( zu$buIGw<2LSf)ekCzYsXeB07FS!m%l@r=g`OReAWWh|U@U-pJM%lFwc6TXLJF1G7m zz#VT@v&|!(F|vK5Y_a{tV@{vv`W^UezT>ZG)ZYi+!i6UpoPOdIHh)-|>Z9x@!; z+9IR6rge?^f$z?ZFGR0rpKH~LnUs8;u|HSaBI9>=>zYXpEA?1cacLfR606$MTrd8_ zG*aJa-Rr0``aTiuk4tI!~R%+-9*?OrF2he3h+OrFz_x(u>RWe_UD2bwJt4a(nt_HJ0EKp_oNn zw|sK-g0EVK?r&M8o?Ea=ZTsFGX6rX^+F`c1dG8K0Y5CKgM@>sk95pSm5W8-4V6n=d zSYrb>nTOrkTMuqu>F}k}?2P#JcPtqTTI5|LVq>KB7pj(oEP8(T+qXxz+D@K&6!pGu z)-@jE-I75S0yTxX_Ae~Ds*2to`1$CT^@HCt9lkuznW4Wf_I<ZZAlB`nJ|%I{W3t>-M~5xF_==y1}VBVB)S%ZH4u6 z6M8%3CTfNW9z4FoExUge#)|0J9YbK zhaXoa@|mh+KYeQ@&~r{qGvjG)A^X{#pW1vEsZ7u==bK!W{dBElLb->G>Y=rJc-fD+ zEEltMxzHswZN;;Lbs_8aynT_geve|#=O?FbKd)VT)WkpibWmgjPvXH-uG1zS+9a=I zYp~+N)a?%9x|dExKh?VxzivLJuyd z@OuKk&6w_P{IsmJ_2O=AKBJBm+WD0S%!3tvP5)+fL|cb{t2N8jsoTXKywhX7u*@q` zJ74Zgx!(S>4D*-z?aXg(vN>>RV_U_vGTyj4YX-aJOFxKOSJwP|>)fz!+K13;KCNl@ zw^%ROzTbK3_52&XN2BUavpDryhvr+b#=ipDekz;j#L(`(cd9 z-6?lpXn#7o^G_L%L^`W>$xq+g4Zr_0{69J|==mqbB?|K@c;6VrF#1pZdh;ab6_`jq}&D1uzz0r7d$n8vVpB2^V(g> z)xtWzSE)pw&Oec;{J_XB>)8)2*PF@(l`&e6e^|NJamSRgoqQh<^w%mOpY`Ey(Ld}5 z*0DWQ7yWy(-09W(l1I-)_t+$aHWg(5m2rd?wG^LYME|29L-NzZ_3 z_YJO?Kls1UI3V>Wuk+3>#jhnVAT>~&g2=m<;2J2KDQx|6a1FGZ`I@@Nzb2)6`Gm_& zPu4y)-z6Q*b|cvF)3s01a$M)WF_mptzFDjD>Gtgh{|hUw4inn=r);nKxj(FmC$A|? zyU)ZRCc<+3lXR);Rfa6BryDar22_}=eQKWcjrE#_y75WB4k^^MJO6~qNtmj7Z~pA7vwth|hHeEG z-Tl0*|4;5!-WtF0&o&MT?W*=N=Axf(SsD60n0&Y7nilqnJXahZt9ZNj+@o9f9A>wOtbdl9{U%}y_|b+vH71^ z?Ttq+EEC_jbam0*SLa@4Hk=b;>YIC6<9OJ?r>vGlpgq4$UX z2X{U?m$^@*eQ(!ZkDK)u8mbll>dpGA6U937vV8PIt(IT>FP5u{Z&}DCG)a5r;ose& zrzdm%SlCjqde)8k-Jxf#%~o9U|H`j#7&CFklL;2`j!f}ygoLtXg#wumc_#!52^Aao zZs`%9ac~oR#P{SzR-J?O`wMhZIAfPZeV=dPxYbF+{G_dSOF$mi(dKQQ(`LJ}2Fh=6 z{BXTLd5J}~mh2nXt_gYh7E2|5Y&*VA*zm(%f!T-bqZqf&oOUE-!G7(=q@XJf<&59# z*nX{($~dF*G?!)5krNJQr>=P%`{=Ud`5W`kttgs)X^K+aq{IJ`*p&C4Qnw7-#QX5e zx&69(qb&ALz7Q5EY_{kE=ljT-&2OU1JL@L>zNUUZf2sak!#JZ0vu;n-_l%8{*%AEk z{i?p-4Z9!jE6&RGEUs|xs$O%NDUQ?f{GK(DzE&$!MQ?TcE?Lri$A#}T+jPdJGv;E! z6`rR%jTslrJon*HPW!inH7gUew@mtd=sa)84$h|4m%kNPrLu7Dxu9+4b6Cp%rwjMG zDc@E#o8)TWU;54X#N_?P8ae ze9}v%WW|1YYwn@Pa65bd9-K~lO=jDgxSOy1J>G0)(OI}lg^lfh z^Ms_?t`nKQ%PQ8(+MScT z8gCf#-b(f5(h7gVb>a8vgQuS5$Q_)}qhGlF*0F!Tq%D^yEadWkIQg<^?u)x#$J9CQ z7p!!tH(mMn%@Vuf@44z1a!x7t%YKM1*WPQG^0h#(Z5_wb`E}>*J=ST|e#xxxFDP31 zCDY=8?6-Ll#TOYS2I^M2ExfX)`cP>50*0%9R_0B=6lNMCxB1wM5__*H*F&#r*-S}D z_9$4qr>?)IB+1^iFvP(p;IN|N%%jG;c(=be*S(o((fI|6UOzSFv^46?+|ujZWE>LJ z^s0ZZy=#T8n(VVY-|Ao$f%^#;FShH=nSQswLjK{I)D=emH1!`{Tybc=d+nLz_?i_` z?e~mQ=B>@`yj+ptvF`JA<*?I7e5F?1J@#5KCTq!*TV>Hfdv>JV+F6^q;%Y};q{l(q zvW1BUrz+=0%sAzkCTZrGrD zs4{THJ@tzh2%0G`-W=%o$kCT>!0T8XB`h8u2x&B@NtG7``4#V;V%~Cg`PEI%YSqD z@G^rHoga?GKAEblQmCEs=*3)pxtY3UDPFxDGLn9B8I!GhIG$;wW?VIy^VH77>1P1@ z)h#O%*1H?$*Qv2Ydg@flp1t{@_uy8COBbEQxu3m{*n0cS7GaKZw(h=sk*ETD&U#6{ zcdiCi275M#PtX(6R1pw;r|{6qZ-yM}Pd*iiMTaK2@A9557bUvSB(&AP(e}mmxoY7r z*UtEPg83TzwN)vz3R(ST{Bh0|_xabj&ENN5ht)mu^06smtQ(VV zd{-4)y8id~i(z-Y9-ij+b#VF5yZ>;pu>IP@OMizi_g7N9CS>1f;<)W`;bI-N<=c)}iPa;v`=#P`p17GG=T$o#o$Me+B$j_(#az7uqO zckz<%&Sxv9^&U^F-qtTDcXji}FS&W^C+^izcw@SGz4!k)Z<|VihLZa!>!NQFu*Fyg2lZ@=0AwNy|4fF?t?G z$JZ)L-9NOv+@7f{)~)ApdBL2%$6xy{Z~61s<;$DHzRA^^UaOcEezRCUsj+L4Uc*=3 zWuKXLu50X7vy)qTgPQKL%()w+>sfHALiNq(2Y(xbb=7@?Ok(BR zcS|42n6)h96n~4*)@hRPMGxXWw z2U^Yt>v-nmFO8a15F*KCEyZ=z_~628fvFzBnF=8@1>7#1xCTcnl<+SM!)G<8_hioeu`g@$M$2<~lIAPxI1)dES6$8fY5wJC zc>T*y@vo8NK| z^r6_z=eCtFeyL%o57#=^c6Hkqd@K$ILO8vvbXhS_9>_{i_>%+qRX| z&t9;tMdlixUaZQ^i_?q>-qx!mJbo`MSiD75Cw-g1hM30oOz$Nr>H^SQRB~_V zKddRaO64`1z#{cX!>bq5wl6izZMr4I8ZBmVRgH72%EJtAk+SL!?;eJ{&hTE6X;b0P zzdUo+B2Do<^ZA#b%<_&Xd!tYxFRl{jxxs7#>-LOnxhqR^_O-D!e|Nl5AeVpqtlqTB zLq>)7b2iT@JIB_l&G=Nk+d5#Y?H?#QwzEHnT5hdvH5SVat~+^A-CJ zHVX^gjM#CfUC3FsIr#a5gPfLcGIy+*nBv}i$U35oV}r0!QXgCE(=&FAZ>%NvUSMhH*8mJDhd`QEN4jX3-K1}V{=Vh&-UKe zZ)+c$>ny*9?>`G>Ez_K}kNN%UhbED{T&Mdg7xFzY*56vtwPV%uFZ|m-tgH;!xW>NU zcl)dJA13@VmI&c<-+H;}^?9BTbM*!OCc6KPl!>XIaH8x$s=k-aqZRg>n_u%6-B2(1 z=`~6A>vK<^^>)0)o-Sts>kAHch%&BObKvk5`JhWI9BZ3E37Cf^C&WV4d1}g8)t4goPUlQR~oo-~?vn;b~*(Qe-X0|WWv3T=~u9{w((o*An9I3p?jDe`SUoPiWY>#m35Ie#af2YfC(H zKRETZ@`t}}3iVel6(?4vJN#|m|N3=wx!;Mz(g&A3Cdp2Hoqnb#u7P)kqSCV!F+VI? zd|BTpHny*fS@J|uVGVbXQ9xi3%ZBTRz^P40pia#2>cz6|bDd3RxqrsyEDP`!>O19{ zc%9X$dnVu3zEiHV*ccLBEPOAE`0_J8+*mN{%DGHqfijLsvAuB*-pf`52-c@;zNT9K z?vI`E8|K|vzt?oD22Qkpaxg0PUE_Y`#=jZw*$;i~3)xut_TIs!#iic6!dfpLKehV9 z-kqU80#C@rOxgS=U5VCZ_!WLVbZBe>K z=W8xhy<8Uc)?(H2$?m)otDa7{dvt5aYT>KQ5r-$QHl3m#R5;PCbG^sJV=4VxU1qu1 z9&(L3ebis?lG@WfBAMQ0ikI|WeQ2)8_@LAA;VOG-SyjQ(c8ROTm$%s|yg7PFe&V-B zm2p$P3H_YrQGGJx*Mv&ll?$e36nYn=YUlrC>)V}OwV`rb_Mb@F`8gx8 zq$)Et{N2`-f|C!m>`mKao@h30|A!S{cg$tp`nSw0oBhp|tLKuJuPBT2V*PIx-6y%b zc3Wtl<;lD&IhL0$eL8!rNv1K-lIPmQ8G6n3b!)?JdsNk$%`4%Wt{I{9BW#YI{;coS zJKm-J?63(aS5{5qTTpRvPu`AqiC6Zm=DqmxsZ+|7DLq0jLe&p^*s;~B_{e6yb?@?y zO}JxuqS_*PMyc~s^Oq}TpJEc2s#<*I#mgHNKUjm8y-nS*B0hJ+#17x*t(IZ`&skTl ztKB!R<7lCk#)ax0l^m=1McZp3u6Oz$T=T2^T+QaGb{ct? z6+K)xNp$fQhQ$nJUOzdgE*@5sSvo6F{9IGMF~ zZTOe9D%<^8<}2sVH8M$8oX{f9jB9_vN_J6rIueB;x4 zPVqYHXuI4-u%^CQIwADQP8<3B1#L7heuooj&

mG#xu?EMaudH?);`BO7pElI zHd)V_n9NgdVy=JiM!kOdmQRmV-qgLznA@^>+siu_)wbDY%swdlcG9n=WV7-+6F+ck zRJ2&{TF%dyqFH`NQi8oN^v=cRMVs5KtBxi9%zM}u_wj~Z+>^e0BHNkoTr~e?H^K5y z_mW5+QBKo?&q^f@cbSweT%2n5-^<_W{mvJ?;%9fqcezN)$;55f6?v>v%5vmU%j%dP zXPmMR1R9#lPuv%$(Wb+ieKOtdVt>@VtQM;R9p@yCJH6YdJ>xE|Ve*>1sLhc@ueS5} ziroxrH}3tJ`tH2vS;@nHs$T?d-G1@n%1U$3Fi$tx%YE+7X_9kJMb50b^nq(roFZ@a zlD2O#hfP;D=6EH9AN_Ink5vEs`oI};{xl~?GHu>d{h=poyGMrl(X2e(t;N|_lmdCO z@|H?1skCd#2y~V`a5X<}N!sQtC@# zFZgv zRL*OStqkn1i4ifqIb~WqQ_NMyB)u9NA4i`Qlc)DJ47X&)@k|t6W;E;hyh5QJ_qs)n zzMmVYGUs$&O3D5STU?G_=_`<4EZz1gk;A4XQsnbCZ>3Zxt^Cw)YKGeF`&uhQ1-kZ%q zzp8d@h@X7vrGE?OZ*$Gq&zz$O3hL6YAMc0D{@nvj)h zbK*tc`=tgg%_fJc3g=#_RubFAv**cz%l>s23lmniOy5=T@lxxY;KvV}sxSVLb$fW+ z^rO=`%f)LgQ@!`^)w*hwu-;|sndJ3$ThC;#x7e!nR$lXMDpT>2y*UpwGxf!9=)M(Y zn!I#x(!AqK_6E)Cy%cA8J}`6r!^x+M)@Cg|adlPLR?+Idr2I$Iz02255#11WRPGzRlB`*Hb}+UsVB=`i*4Lta!md9+UQA(Wy`myxmUl- z@b2Tgb8()G?9Ro?mR5!Cv}>eHk1L=&XV z?`B2xwW#cQyy@D6+bU8Q9jtwN*Jr*wvhoUtw2pi0fkjU}_dH$j)bo#-;tk961zUP! z@&x6@j)<(=lk2X3>|pc1xIGgWn{M0|muy|}VrRj_nb*psOCPH*)h`vx4gPuM|6+xF z`S1J0mOSSEl>vMf&TqE<`HrTDJaz zQ<(m(b=NXIVmCW+N7{s#94X{gmz4@RbF zOe{4v8EL$WS-0!UvR^m#x=)s#-sak?r)^qVyYy|)BuS|!zg6b5tSNcI6kZrtAH;T` zcGjk~Mysyu{qSPT6XVY9vNJYCxophd-Cxw*{!2^r+| z_51Z--wz+H7TbP%8cP!2HuY6|e8VHBntOh}^nLn;!@JF;bADv%*w_6y-7g>ZrM^j= zrD($Qu$l_DHpoULT+~VZCNh!^h(`K_N8yXOa1ww zI74|&l&^31WBHQC_?Y95-pQvejHWww!r9?Wf_)(7URh`KINvMyq#QPmVlnJLOE&yTi&mD;KMoPoGfV_nXz| z^)CO(HxK+(oymKb?dbZ6yH#fT-Z^_R=hZx~wBqkJM$tRMC*8cXcmA2Mcl;-F-tO~E zi#A_3{dj54^L4Dx0n~eYbZ}{m(5|8;?~Ay^Q5}_u<*g4PiaKg_`@G z@pmHD!!*ZHSegh=e-mr{#sbanhb*ZkhH^-|1=V8!C2#$m6lQlGe9 zowhjR-m@a93!0bPKR&tK;CEExZe5h|`;bXWdnKNP9lGE8Tdp+Z{PZi&tZ0d0RGU6(%AaOj zkth&zvz=|(gs%)M;sxgT_D?i4$`Nw7tZLJJ?4n<&hqc)jRiQ^WU%!{hxBI&$^v~S8 zQ`-I>ui#ZM_tU(i`6|bIcG;C(enEUzSJi#x^gkH>v?D)oc$#L1-?#m|o zilu!|Gdqe_g{^p&!PzBK7rRbM!BWW9t?+%!qzAuG2D0hzoiECI!uF-$(VR%C+Uo$=93WG&gQtbGqtjM9$qBuhronAJ1d6TY7c% zq{ULXxmQ*PFYgVJtMI+`>Vp8wpA*IBGOj8;k^FF1N5D3@S%YtHnT^zp@Z*ej>Y7v5 z$2jw4{$N_5?Z+##&bi>q=Ls#(4<9Jy)Z+>$u42Y#dejD zBNcNVwd55V$r(3pINW+*tcCsF|@|9RDXw%<(u=fmf*e^#DYtn%Po;eUoL4`;L0l~jGa zki|c*@$GTuoqJ1kRNpN)$=Uc{ z?OrZh{ozRTf4L`$4~|cE*?Z$>)rT6D`lIVAo_CAe7@M*){tw*{`2UToJ^wt@sm2|DFCfxce4*{S}v;$y3}{=V7I-Dk`5ANu&{ngjnk`!A2|g81Lbe_0%V?fjPi z4woO9A7a=pDF5J4{!gtPDY07?_WLdgZOis~@c5j$3s8 zE9jNT9QYo(@KVOgFP;y7O5Ao&&5UtW)qZnUUG=L=Rn1<{FYkIaS8ZN&@x%=kro}so zGOQf0vZlPfx^mg}33fJL?_TT`KimC!mJQbzj&P>*AM1Qyhu<-Ze7Bw9*dy0J7W!!u z&&4ILJNx72?dvzU`dZkE^62a^ejt3*>g8h7w`;D*9JRV-p4lyNSoy+v!Bcw{X!>d_ z+Z}&(A#2tBR`tUCu(+8DO+R@)Cmt5<3tF{UtBh&tiH#GN-ZKb1FChEn%}tqi8zlA2 zI#qeYWqyXZb1u2K<>H(}S&#HSEW2C%RchJH;F;w=)4rTPID_?rhy3GP&mL@+vAd_^ zcYh(*!*?_LejWR!bM*Yfi%b;>{TDM%uRVX{;l!U!KijqYe69vI`jvBp|F=cUIl8r$!~ zpKO<})8O6J^CmY;{_>%`+HJv=hfB;`uj|p*SGIbU`Xkd z=dI1`iju##X{y%yolfqp_!m-` z>QPy6Ws7WR?8_74eVg{WvU;p|zbMiDb8P$TD{m{zewAsz*L!^DV*7ew9moI6TmC

1G{y)?FLXWc zfBdIHxZ(aA1vMX@XTLe-{JbGvy~F>Yf_jVrqYc}s86TaV6un!ne#`Z?|M}HcUBSnG zf5=wjc5L1EidD7s53^e23hDajgLm3LIxqXE@{8@m4~@sm#Sh7{9c|7ym9a=s#Rc z)pffsOz(2pma?haUWZ0cXZNqlJ{21qE4pG@rd`d_N8Pd&r#|tyn;yQN`j185Hg|c@ z*#+KmJ?qa+S!ABNDS)m1XhU$KdfAQ@nrZ6Gn9grDy7fNf(rM!*R_|At$k*jAHRtLT zRxA+{HOs2D^3`Oj*f90u4?k7y9~NITxUNrRvzq59d%Vm_+xF_cRj=RP@|Iux(YN)) zp2k0`oBsE$cpJ$6_Lf|!LGz*SrR@8%#Xo$0Q}k)7#iNztZbxI2KAgJH{WP-m-_eKn zj!Ep*zH`udN=HlU(F>P1J-_kI{qqN@=Hq3Ough8cZ}z_xdafV1=dSbRj5BgkH-7Et zRWQNG(ka?WPMcy^s zR-W;X^+Sx&;%j+Nzo?x`_}m?Gh4tIM1bwe`OV$syiHjfSEp5BtUd&WzajgHA>_3e) z4xujLZ}`@ky$k&*S{-_i@55>r>4vO1H{a?Mt-8KRwxde+hn4+4!Hw-nSK>e0on7&+ zIoZU@>)|J@RAGx%k1tE=Hl(kR6#b@gTrhxV({It>H@$BjUt(&1xb9TOu68H6rBi2z zcJxW{K8Q3tcEnamUvIP0kAP19uX>wxY-YELUr3$S%)Tju(I)j+#7=ijSMR3jN)v0Q z8=K@R7xctdui<&o)O#UZhHc5>2TS*FbeCNBWpPP)OU$2IzGwUzJwA_lezASfu~>ZI z-UF)_zaq}xuipDsQU$_hmF_(v-(*v+GgX|LBe+|C)1!$qw{4oZ zHTU<5hP4$v^RI77ZTRIdJuqYb)Jw-R_Wa=bb9!OD>BIjDzkYwTvn|L{o0p`YB#`!N z&$UqTr#q78uD06i`uyAQ1`-D zw`zVE)dwBaTex;XNye={Qm@A?DFI9WnF@GI>xp%rUsUhyVw?7(t zFJ6E6#|LSvx(Q~R;`lVDe*B}YH;aG&#{g+hUlz@IhmJXO@Y*O`uw2Gl7ul0}@cY6V zpU;nPc`}?=GWoD0rgD>l$miIops+-%gbUs2->L+@KlI%D+u%pC(vPhbD)|ikswQKf!1tf3c#d-Xnjv#{Q)9YU|$T#Q8=yFU%`$c~z|< zUsCqs|F#eLTfJDO9Q+ix{oUy%jrzVN_Mt-ebos9B`5VEtam&j!q8i?{23kKE&Xw|M zgmihoT4Pgw>)WT8ulX0gUbAgD&%|f(+|Pt};pGFH0!06@HCb|%E^fHUQ_H-zkYQ%= z0Xc^k4R09cZA{FuNXY#3W&OSCy{7l7ewjbpYgiYO%db`S-oYc^X5$H=i_0a0Yj)JE zV*N11^D&p(RXZo6hWo3Gx#U9B?(dOX@}lxh)r3XYpH5}vUtr=Ux96$mSh0Yx!XK(zkW6=p50`5y8G;; z^98duYkdjapcB%t|NMbJlBSDxd{m0-Qxf@*7&g1zCG7i3U(3gb^;207Tt8uv(poa< z&&Om&(F^-KKm2zwS@lErWy!Ps{QjF?w9HX#GWIHqc^uoi@-f!~>6^!1IZtfw?g}h@ z^Kem6h^bx7gYx`si{9;Rm#O8G`58S_2c4d;Hr3&VHp+Omzna6y(4f@NZ-^*T8x|i&9Eb&h2v5zeej;rlE*7C%5 zQHsoZtG`KH58Rb9vN-y5-W30+sR-y1f4rFW!;Ij?Cnru=`CdiJ)0b`bs4Y#Dv0!p}d{_CD1w+>Fhly{# zY})kfaPSR%#h1$zo_2_STJp5cs>-(E_&)C7E7_U)UU_*R<3DA}9Ju&! z;L_AAyFYBP@?Yv7tk`_C@4)(JPmlK>`Dirbl-H-gt)6B)zcn^KoMB|b^7W`V_en#g zuSu%2CO-bje&y-XeeaK*n^|`6$g(=o?LuGnD2gB6&wSPJ!Q)>aHSElry8l_n{COi$ zSInPtYxWV}zio%k)$_=Ikl(Cy;h)6RuNe;A5B}-B)jjujUfjq0wmWuO*FP`z_*%Gg zqQX~p{m!&Roe$=sXWIK7da1^BEqs4_%_LSm*ZpZv9(3-0w8-Pvq=XH(njhRu_Ime0 zdX`1l1b+YK#2bGEJon3RpL2SjUTOKVi4;5S%)hirFPiJ` zgII=tY?HP)To2q4Qg*1z>r~603W=4e>pj>f|B7G1SD3>%Me|4PguH}@@?0NfSrPx;&z`h3rtqbC&WOxdhCS8QhO55~pj z6F#5iT-vYaV%)sx;>s^2_rk?Q{&p={GTF~ndCQS_t_zxsb~fIc_6OXaPF8$;!z5eg z^F#I}uas9l^;9)EyPa>>*}Ml!`)wqJy8Ei^etnA*JM|#nYR2aPPA`eS7p}M8FNrUMepP%xXle>;klAH$Jye8 z)z>e}o7^vn7OCu=abM0;f12a};}Yu(QufEMKfus)MX4i7Js{zW)zcG`+-yy9HGZA9 zd3r|Z#lK%WK3z1QUh^Yyr~AYy)n1az7qET3vZeGz{f7{bx_|FZEzr06spfG1r__U8 zb+>M6_FUT|{8j1NBzO6el;p<`wU^$@tTOW5y!E(b*75j_muLOa-R3i``f2HoePyTG zZm?ecxbxAD19dFd_byQTt-e8ptNxFHr^xFR`w1;9`)XqXoxbDx!@=Yr)6kXjIQJB(k(&ArN>9&@psNCs({?+P@wqooN%az`j*j}vQ z+;cNbv^uQxiB_LT*ImV<>e9#0`4|S=w3ld&+Q)V2s7TAx@XVR2=Wp`OySUPRX|LnL zRnJ4@?zwf%_x>Pf&%Eaz*CDGFeaE_##lo47>UXWX_dU|+ci_jg`K$Z5yOjT(KikLt zLF2ED_v@aA;(^|3zNJUnw0n+)CHfqD{x(1*aE+{8+x11W^EmmK>Q5@|NRPC7y)-NT z{gd>(0OOhKR$iafwui0nu+}E`!WrqJ?XhQLm3$`8%nSK2b=3pst$!X}{j_=2Ynvj=LDx3(O-JmqKiqzt*NSL*X>XZUQtwO%so`V4!2kLw(jhqYGh zQw?GKQ@OtBlBUJdPOENdi%h9Yd}(Z&4@|t~@y=YuquHh0Aa-EAriAP{w|$m37foL@ zdon|v>%kdiW-SH*`t2-IvknCI>wkU_UMHRqGS6-`Pti9PD{j+=`PMUb8%{dWrkSj+ zu;7lX;`aNR+iy?$&2~mxqkPVjdpWB!%>&O>`&BMka3Xf&6C;M>Vu^QDcHT5td?YO4 ziuLmuuf%kCE|+|`^m|_Lv3S>b+tn|7*ov979JZOw4L$tbo=?TDXOs3h&C7AFWlgHP zCC|uebmyE6=PvqYaB8pWlLAh!iMJC^)^a{8*C?Oy#IEV)d)_JCR_jk>M&6Gsk*|2( zyuVRJw_!f3LDih?r}SB?Tx@Q|Tbz1O&XA$T+$XbV;^WiVnt?jH&Gxd#^~EJFpNpP+ zW=ibOK$djB1GnZLlE3*N-K6L4^XB~%H~!l5!>ujC^5|CA7)w?Ex3X=w8x8ZK|N ze8{V9%X*|w(xEG@gFVi${PmWL>whQcK9igKt+4pNVwKLlS4GD|=6)-TPg#3kAa3zj z3u*bq#~+^Qw?4M2ukcRd*|kZ_UVCa>ZTM8uoO-ZSDD&c$Z9AUsoG7>b4X^LNecN~C zPK*9!bY_EV)e-*dNsdc&aw9g^l`IJmw$*cfXnMrE?t($yhHE|h!=E**tIa>T^})*G z7g;NhUzFOfW$;#*`^|#g&P?xD9AEAA==t0&vNbthLj32zt3 z-k9|-P4!p?bPM#OH)chJVxCbSdrDLCK>ZC4J@gs2ouJC7pVqhf~nt`KzNn zm-Lx-GQ`;w7}f{5ox2gh*&p{|BKLu{TbP$GwVqPKD&lVPZh_GL9Ra!@t27^%FW7LJ ztG{-U#Uk&Vt+F2%O6hH8a#LThVHsEd)exC?`?{RZG2XIB>z|xlnKRX-UCeIT%^xz$ z#l#;7tre?$F}L?7&$GmcdlOGvZkfk2-B>ef?Wy(-hskSyov^Mrz3|eJWV=5{TTZ=c ziMkWN@ItTy$Ewbv#UkQ5t&XBQ8XZf6GWtZ0wx8nRxSt@i^EsdRl=(&H58NqknJD1I zcXI2GuGvlA`pXvIOS|GbTrQNSFC{5@(US(%D-MaZr6GE zYaP>@UkavGA9s3{eOi#T>xHYA^ZxVOR+s;NedTsUj1>Rh&UJ?q0$KeM{>TMn` zvBqN2$HrAIPFr>^`f5_P-b-?gg@TcJ-rdY&E=xnJ-iOKNX0W-x%1Hh=v(vb4#k{Sd zdm>A(2F4YBkbZZrtAF?WR}u@Y)K>Skha49=D)@iiqYZobHXZqWzkR{}u*VBEf9C!v zxzXiQ##C|qd`S09W40qprnAVh>G@`+-P^EquG$seF3sEg%xf051@g&m+HWnei|0ws z`-M-%>RYbvw~vVhi^kKdx=sHa+@JVA!)4>9Tez;_zb%(me?D;}KE?G`4a>Uwp)WSw`d!b&_ifoD z;oH6^!{xXiTb({UFSz>==h4J7M=#A-HSL(~DU*iuqC)}UiQ7EqYS}C;5_{~EH0{yh z=+|*a)epU}H7$B%pW>Qi_wV!(=@~!jr)4k;|2;319nsnQcEK8kPm}u6tF)xouamyF z*6J6FzLML2iEYf{k2e}NFO}H$_Xg`~ZL9s-P8YSOgj(%>#L2r(K4Mp)fJRRHt}WXg z3sY?5HdQRn>ad!4a9*I~?v1f|AvGy4k45QU_1S7@Trxpr=`_j9q55WDrZJ~^FsJz* z=HI*bYm)l@U+m87Jq-Ewn%eITZ8qO<&|RXab=rQ@CvBZPJ)Ql|Dm*ep`H$zh&9$>^ zi*R1mZF5BGDgXbc7iRT3zpgi1lJ|qB>5$@Ad7h=ocEZk?U*h?fCbnI?Ev21ocl_t8 zmA9pouk!R8nC<&jdErLJgBvGiSHGCiv0ubd^@AN$wyD>ep9|0R>n5g7G>|GL1v9VM$x zTMSHp=H+{p`|y!sS(E%F(xvQm@_NzUA7!`JiX-%EhzmlV&Uy zJ+b5UnnjA`3(|7Mi{@}JPPVwlv&wOb(utOHm)z`XV)~?+K27K0G$~AJy2w%UxV-Jo zQI))_-Pc>H5*}Pj`L?R*_<5e0eyXxbKc~ktUKe7WWcrTTMpUKj?6L=a(o0Tl`n&48 z-%-K6YAIJ`>m{444|R0v=QH={V$V4VS#p~{yGIAu6eaAecge}P`lV@$^p#(MlUF^gF_F2l z=%daG9@}LP{LPZr)v&$YC8?$mH0xzZR@=P~tM<=GsyfEPaq#BO8M02Ro&A~<8h^JH{AYZM4w(O8eJS(*gr>*46phbcnu;@UAix&EC1v3``&4fJ@S7@Zi+b5-1cJM zujlsC0?m2MA0%#8*e<)_JNx6>J-j<69ZHlYX{+r2P z_poLB*S~k;^z&T;R}6SwndQA{J#&B8#_gZi_N2Z`4cqth=k?FJ{qxqV{jQ&!FL0&! z&Hfqr^`*CGE=d2=@bLfI+vim7-VICNetCu3{cpMHlj7dA9Q?Q5$Mm;T$ba)?vplOl zYr7S&a+qIbNm3QxJ$I#=T>-awoZ8D=yY8g_uX3NqT=>2{-+KS?lt16auXJ&~d&|Eh zc~Qmbxk4rr{C-9=zmz;PWxwHsOXnK)&vID$@?G1-|69(w&v01!()C_<;{S^*S!$>L zPv*QLe(}wIlg3}{PwiCN{$73Z-R#ugh%@)K%c~6X+VspVg z>Yv_+4zb)nkN&-{^{IY?SW*0;cs_PPvEFa0ETWs&N_c{Lbj`mhuk53mRtNj1}TfeJ3 z2o#C@KAY2cvSiBy4+RG%6%~mSMfU?m933s0JMtnNpY(7kP5jN#zMx5?qexOTMB&aU z#pCO^S8(rmQ`NN2-6dgatP5kT>x1KezW$o^YTc`O^XB=iTezQJE%fiIUAul=T^;`Z z&%C=Dv3&R>38^~yeL-;RrK zg+7RcCX{ij*vq}s*c~mmFfZpU>s+n)V;b8Jr#lobdB&*Gr#;QRkjGDM@v7F3PXvWd z{@ge#cG6{&Yg3+-eC1XyQE`9KT)BB&Q+3gr`T%b z?@4jHaCRxIKKpfH-zMGpLLvt{W?pA^dm+sTFDx<9YkHXRP0^C#nTg|t(b z>Q(QSkQ)=esUKObeak~L%|UC^V_(msJ1VBKz4SafeS*gNiWBeWFbT<8FrVD3Vf8_j zN8Xsncw^~~#zhjRk8HQ#E|j=+XlF&}yc1JWR0Wr%-1#7Qh;_x9g{nV$c3k<(edUbG z14T=z+*OQV;y+;$^0M?zzF|YHQ@Z7=-2He?;1A7_%>ZwM75)zI}T? z9z6Q~_3y~0nR!Yn@%PQMCcZnpeEs@IuM!_TUNY=i zQNK&A6Kd)nYVH!4^j_b_UA*a2?<9T$ja$b~AJEn^-l*i;6`*5xSnk^CQ%&{y-&@~#F9k6!lY^9nCH>E_eGT(VWsZHZp0hQ+~-z8`ERVF%=PIV88w zFZ_BUQaW~jo>^+(u_kF7k?%8$8XxX4{ZPEx;iCI3EB)?-j*zdxB_2=j9xmyXFAOzm zTx`Fj|KEg=;#7_&i_3hr{RxbH^Zkf-=!fY4+w{KOzGTb#ac=O9_deg3EN41)|Msir zVKJ-M)a8lJ`+G;sS2PB#6Y`(CknuGgow6LO&%XS@!axnMBy z!F-X5_r)G=57W0dR&W%GH=UPve7_?^pyg>p=lb#kPMQG?2E@5YZkdTF2UdBLKdD6ywv$p{z0Ih&z{HMqaVD!eqi0U_h!y7S3I(MQzu?C zyXi%|&7E!|yL$=z&Hf%+t#4TW_%!YCg&onWR6AFjI4D~lOFR*?On&ytkjwv9u@$dy z`A{s+c;EH*`nyxVoZn|=t8l5l>iZUjWenFD{ofa}+~P17S>%*)d-@(=8uf1)_EMK8(Mpz44zZ|)6_it2#)h-n-CF$-NYQ>^7(`n31v7X97l zuNdF3JaF+Le_*Me(e z0(E5#KbWy9sk!^iJY32Z=I$lYHdUl$M!krBZ)xlFpWOGKKP+*(xNlaKbpT_022W6) z+zsFR_q{~-Xs-~TdUNJGfw`ACmb9dA=-V~l(Vyixvu@Y>rnd!p3H+?9W^zwku2!s= z7T0>z`o*gw$F>~stYq5q-d$ht{NgJ=o|wOP>?`Dc@#<#C!N;k6&(5(<5bXKkv@4*7 z(fx(-!i5sfX$uYSmGZ^rYMh&}GtIb=?aeZ-SC`y39(&vyI(6-?koz(V4^_=yVz<9# z#yNYdSO0EEcuLlG_X#Q9w6c(Y=HB+f?$8>?H=BalUK*WW;r+AwoZ*X2dRNaaFS{wq zd7|0Gh<_2+Ih~+_GR6Ou28D}?Jdaslx8+*7ValqqbH{mljQ_3aP>NePJ7*zRr>;iK zw4Ri8w}VC9E_5qOe_r@a>A&i|Ge=bS=XvHz_^W5lG zwic_U9XY4^ztW(4XOXA6$Cu^ppF>RNEaILY#Crbd+J8=_D@~6HWq6xsxQGj_Y}&$= zv{G-$43Q*(#@Q>gG91N&RyLWOwp}4L_kghkS@%74R^)V8`s)oT3)aO6u*ae0^KF-n6Q>JNo8wiT+tWJpeAV^1uqUK;vg(w^f{HzG>rZ{euCsH$=IrTAP{#tUcHuH$U@pvB5KVSef%4(;Dj znqglmjI!2k%?(!Ey3s(fdAsPYXB6nKg~4t2}O9J~nBKV)#!3Hxd7-6LJ{houYR?-qUJ- zj`u=ALUi}zC+F|6Wo&k|*Xovc{(PuzooDSs-v^(!ZT@{|E>m}lnd7MiWsWr}%Im-Q zUbu93VTG&H?pwD7I90dkuMV@&-#-0CPv`lyjiTqw-}*FkU4Aa_O7puO_tKeo&1OwYtF%xH z^%q*FGGz*9cplHyIj1&#WV?TCrMcsFqon65(xNgATHi~zBtBmaJvE1dEC)SSS%w^Pn#7>4kw`mv>d zj^{CLE7O$QwdUdMh^0byum0+#)d;sU8qE-&di&`6FS+6ZlF#z~z0%A+aUg#(3v=$0 z%cA-#c3kl~tx(8j$9jqFZrUk@k2&X-JAQS4XR_Jy`UllbliD8mewlmlqiSnI4`<7{ zi5G6KS`v3C*K}QW!LlQhEOa?y=PdE&auQe1>|gWx(Tp6Gw@=v1pKkJf)h#eB)h&GU z(t{_zr5)L{VYX%71N-u=dm5{6@Y*bpX54GNF{4+yBGA0rdTRH*l@_P3JzMv5QMvB7 z?v@SBJ74TfnEHQ5cDoJ#oQz*b4f%5x?H73FxV^ZrWB1E*see;ePhIVKNc(%qip?+m z=4E(_dN0WEtj9)uR&eb}XJ1n<+ zR>``&@Zp4cN3{dH-(@;4`j*fyG;zgEjx7ZX-5vIuakGWpt-i&voukt^99Fyq3^F=3T3~y&>=xTG~+L$<`T8Q zVv^4f zc%#DZ?S8T^T}qdP@xDxy<&wC%xc$9LKwQb+&O6LgU1Jw%HHMXRHa#rAd*%9>ZTIcB z>;8U~^Ly`_Eb-^xUBWoNi5PWF&or0)Sfh0{;=%>1KxgR)5tBwEmCT)!c_PSmc*C{C8wIKkeZ23HQ|nYo>76?d(_3asF_X>j#72A5X~|>7RFd zADnji(3@hwF8IfpwPq{FzGyak$GX6WZ(S4~X8)+rjr87ouvT*FgB7pEZZEKM{}lCt z*EF#IvTsqy3-*gE+9!H5J9rk}PZxZ-OmWBNU%vx0m#^CGrfM1QeMLY>LO0N=Vx8ah ztEP`$)JO45Tq@%$@}BeMr+2bTkLQ$Y7yO^i!^?M>b9cq^57LS|4<8V)-5l_IdP_ss1|SCEqsF%PFsSA1qsTay>iC!xOQe-)+z^6?^!jTVL?$ z-0v@z=>Bt=lE!yibz)6X+ox+ak;m3mGwBIQ8}Tq7J?vfI@@a00k$;f-9=-SX*w$T< z-OL-md5`)G6aVQtYBRP>Rg3g7leDniG}h{z=l~hlO}t7Dq6ZNvYu)3lgTm@mrZ>#S?1#Pr(T}*KPS)pGG%IZ zq?g^vXA_RFOyqsn>Tps$(s7cV@!W1dyO-11H80D%D0$U~d4|UCUVCq1_1P!>S7)eA z`(#>Va`^TmYo4Y_J}y6RDQp&hyjkO$P~b7%ZGV#9++3WawrEbRe8?S_DU(_g@+AFS zR`N-PwyluKS}QT{lT-LI=VNyi6Rb;?wol!=+xP+htgVM%pYu4jk16RI=ON4QM-~57 zKfe+zB{zFU@GTcXwTWe7_Ij*$t)~BEXVdEr)9cRK%q?|0W#cRLZyMX1Y^qeB*l5Lc zE$gpS`jP58mE+%Sj|uN$uey8^T3z@3(zlwV(23Ixe+xSVA3uHPO>2~``>fn~adqz= zz7eb_Fi`rvGAAs-sbM>x>Ehs7{yLKKFAI&Q`eyr-2}mqc-ZE?665rz-kwKYR>Vo=C z56gJe`>zC9^7}qjnRRqwPTZ_bo?AG=3#LD`%6jIKwQOOM+^jCoE$s_q{FcN>b*aiW zW^7Uw)NTv0oEVbnF{Px>#cJs*t_gNadDwM(9|f;padfw+;OzFL2~n$_Cax5lA51ITlbhO;$vfRTXZFzY)6CiKFMjyUTfdSq|7EK1 zY-M}R9uwugo7~q3zDyOK(fvo}uyNL}H8~$n-;5uK7RAC z^gHl+(bI`9S}uvd4L3Qadt6l`L$&b*6IX}tQMVSmjk|9wwJPu1w7*mJQiNu$`}e0- z$0RgYTlai3=ylz-i)Hue-G$zc9r_MG^(8laejGUEPk4vC$E*DZe;IrIwb=M?yUnJ> z344{>*ZJ@0&k;EHZHb=^=a#z~@|+i%VnswMuesm-bo#beqH{>K4#)iiEK^po zo^}(jUeIQ|xZ5`1@Xz-3tXUJ*bxE#xXm8xadu4*fwYmjuJq(RfT(Z%}S>=}}UXPI0 zd%Vuw%f`>SzwoK8pYyXFn`DaF7PiubA09hzGsH(FSHhiG&WzEymIH0GjX};yb%tIZ~Lt} zFzND*zo8Fgb?Z_u=vwgU%~vs>?-J*5*{gZ+zd+Srw|(X>Ivn_3g6+P5ezyO`hfAj) z^UmZG6kqLk?cpNxxsqm&;vcF6|4H^=Dk}efPw*+re|rsG`|G84PKa{2*sT_JdVTN| z39cX=E={|=5-Xqn;mN%){q^!o3wAb{CHQb3-mTHSD|wYrs+;g1*H%rH<;O1?ozbmJ zy!Sa+Q*yJKPTh4XMS)c9K-)}KRuT94|$mZ$N%NG@o96xi(#w~>X zYqVNce~V>kX2!>`$*G@SJaaXkwdi={(Mwl;8vQtQ>P++eZJ$Q&@DXM*7&p5}DcM&!&XPNONZ% zoMn^d*1Gn%tcHH(!DZ)6xu++e?b>tjj>4J~>}PqqMSqqTAC{6z|G(!!&5x%iHMt)a z6g}PKXd&aetVQgFtvtV}OrO^4P3cqXo(rel`!a3q9vg#y zUjLhO%j5FjNxfSy_U`|<&ZoLMup=&Vt=JUC^=s0_ZhSuVX+vD3n9W9}oHa)u^lg2n z`TJeO;`u>lLE#U2r)=(wx~19Ldh}I(X~DvU`=?$_C{%q|EqX-n#^09@rnzo>TbDae z^SNE5@RJ#bHJnWDzqT{2yZY(f^rb29jXs{<^yaU`)+}0cJY3~$bk@z!UCBP>JA-a3cb{$HkU7{as>qZr-|p06c7E1e zb&Do;?RnvL+ipJfGL5e?Tku>|yY>RNkWJ0y>h61CIWOeiZ>xGceTHmn@(i_UER+5n zu${6!^x!0+uiLt6*DX<5yLsN~f=SmtpO2rsrR%(oZ2syVhJ`DhFO`kTlFBetb+9;n z{BpN*kCIAJljYgWgdna?T5NXxnSZTu$+uTAvoG4+Jr~tge)UIS zXXwp1x6`IR!aj4=8)UC3C+;j|%+XTMICg?9Q@_2!>UUD*ilo5kdg9_#46hDH~kOu`SS&=c1G9g zHIt4m=DHlS&1vOFr&5j=i|)P)=q1#vNBwu zZa-tWaC4;;%SW3XU0aST%nNHOzqdiF=b-i9@Ghoo+luGYLXQgWxxD$7+lO-wZu^-h zrLX6^`oesw=`Yp4V*9erUNHCl=h}Sgc-+>s7pr}^rNaHHj?P-R{+60p)}4P|H+X7A zHM1&>x16apWpO?|*Q)&99+>W*t??8K+EAOBm~JF|9O&T;R6jMv#| z-*#@2)pwlza(ydr?v$(1_b#Lzp7kkt{%N_VoO-EiQ{NnBzVU_6W8Ud48xt;fKU9t+t{iv!r|oo zG;G%&?w@l{KKU-TKQKFxBk@n@l?!{%uNAcZbKk1oMCYN|R_7e`Q)-ubeA`U_8s+^v z%kofUj>_KM*;Nk|7^ly9lpXqa21CH|V?Vr?)J(ZkK1XkX((JB!nL|JHy^mh2_<8O3 z^iykJ1r(bJ&#{SmuwV4R#ETb?SY{@F@Jlzoe!IZxcS3EawNcpphWr&$s~`0X z3z<&*@?yr;nM#39mt`cc&r{uh`lP)&6X(bD_hKzuIsW}hv*IYd{M6_N%+o_Y?6-R4wpI9wla|<#TBEf6%52NDciY>c5Dmb?SJqoeD!;=)k~+9n@@CjrFi1KmWMsp zlKDJEbH#l-;-;r77V@0iV9D(K;{ zqVenEtMk~L4smW>-gx1SHOsH<9UR|tR`%Pk;4ifEm$KN9Y_w+M6F>Dp?@9dT_D%o4 zEB^PNw|KI$#%{YO^)6ETIXWy0u6J(`s{hSBIb1yB;r)Pz{CVt(&h^o|+D`9pIbYH2 zu=JUMbi?kjtDUzC!EPxz4PQ_odLIB#!I;F}gGpm{T-QP^8;KV#3U<<;kTew~es zW;Wt>-u61}pzC?2<5wK)mG!FJEdKHSx_NTJ{aMMAHz=&*r00_lfxRT8BC-$2#Xq-Sj8lkoSAV_vugQF?b&N)7+-pL@#gFpujzAoeCH^nF@;Q7noo&LgOOU%D2znH1J zeU;6Gthh>%P>v~!cMD94ySLPthudN0)V(%q*gcniPjWVyR{O@TE-Xw}=Tt9MWDyjf7*+g;ss;ja08X|cP1 z=j~0rdUyYy=MB4lf12<%+D|1{^>+EOc&Dq6qhqJCRsC6(9~xl$kLPsT{pHO5j;>c9 zT@RNFU$*5(8rx%Lk-B4@bGZA{m1MjZ*FJn0vFRK8`Hge#hHtc(R{2}ENN2q)*Tm$P zWea!;b#C*!h#fC_^!9?~w6FQo8{S9smmfMcY02K`ytACm3C`R0N1w_$@o@jlw+D~y z+|_(*&j^i{SCT{awdMC)b{5V&cv(ags?9ZGUYyNlZ)cZ#lOiMP8G! z?dhwD8;o?8{}bdi61gRw^v2%%rnu7gzg$|*GxH+bF8yfcNDlq8BI8|5d|s+XvK!{nUkKj3dMPJ8AC)mH`#D+UxQYDijxc2qvv^~AN-YGpI?$;_7iD`bViK!7% zb+Va8Q)J_(Z{kV4{;^~FLYqInM>c7RhO}*Z>rxRh>AXMN`AIfao02xFg!)CMcp9B+ zIWeiGVinIum6`whbf&31zkMNc(zE;17`%(V+}^NBC3;^si=@}HmqF7Oe))OcRI=;R z`&8Z!UmeppP zB&J2#x1HNC=g&eGiD^6S+omQ~eu!CeGN8^n{FKoY?dQsIZJYi&L7e&Nwg1CJPoe+f zHr|_lKkqs^>C4~wuG3Q9OcjWn^txWtS;zC9{=}n`a{if?OiTH*UiHAFD|;luraf8S zJyF5=%U?ox9OteUinBl*(fq9aCXf@;o@<*GJ3r+@z!w>doNbN$o#iGfTZ ziiaQV$(oqBvUg*yQ)0xwvaLLZI%n(pb=pz`0$=cWM+I^k=)4zgotk*lYu5?}qbV*@#WLSF z0=t#Cl5`f{;Qn^6TKtXDx44bvU)~oyn|gP9^>lf?-JhTN{(V-Rf3Z2TZdIXkyt2co z=1u$)(gYpa?l&nlgtvuUKBd-BsB3XLzD4@?9;-PsVs+T|GBQrcJ$x@|*9FyGdnZX~ zPWj7sF<9o?M4u;zc>nf>)y|fguu7v-El47M;ep#OqV_uLITuBIemg<0U`y-I9ZdR5 z+c|j`EK<0vv;ON8CiQ^pt3J)LU~D<_akBn~`8heW%gaiFa=yylaEVyEkoWn|!~a5_ z?wKgF>a6e9Yd#aNe|=T=qvm9@|b3Eg`;KS?8Kko!r1l}x`;xKey!p*QbUF*iipMKfC7T3J|8jM!oUVQkK zmnzrgxo28iZF!g*_TEysnbKfcD>ifQREZ0I&-!|mc0N45_x9D0FE=d>8Q%%F6mQn= z=Un}6`I)D47R=rEe*PPI?&mXqJW*5F_~no-!)Ml`@p)>`=L#|Kc}%pQCO>0EPmsKk zpID3F5r@420r8bn_=8qVT2X%e!>xmkJPz$2Hq5%m_nT+YPT$j0Cpz!dij5E9Drc5i zCh(Y1M($h3o)v0eKiBjnO?3a#Atrh@X{PLy=*!HL9vCdh%rbhq{l;1S^^fI4cvOn- z7S*m(c^%?umBRJFV^Oq)R>#?&7ncfjFdU!3WR%nID|Yyw`IFxzZQ#41Yys#+r6N827`yL75k1Kyhy!Sgj;k%{N z37?z&O%}1GsWJy7r}8juIKq*7YsqW2O(rt(`cm^JKH=-LUutZ9+1+}Ua#qzjCmrqJ zbnh$|>!US(44+^8jk$a2?1i)3bIw%0Tay+3eEl-RH1_jsWVh83~#la_VLT+ z>)j>`cN)aaThlamZuevEjTmAi4< z3dZ&3cT<+0Ht_RHd*>eLyFloc^VcGg6P6!7i)N@#d6Rng%(^2pU%g2U+N)I(ll+-Q z;_#{i$r5YKyp>xQtWeF~AQ(FT3L zA4HV|E=#?>@ZHu$uBzE``&*t|Uu>r{>63KN_5)wuxP3lXyh_zvG5$P5o?GuqpY1VI z6}eb;ur}W~nqYe?_=4`cwG#GUPF%^AC|r7mPk3qM)7x|9R3pCdZP6%WtX4n9@3^T> zd}`}DUnAZE^HsOiIo~Tv_~`#ovQ51-<=-)@HB0w?SDM)OP~uyGyxW{TY%49kCm-qX z`oLghms`vzcZ6rJzOGOy$7vY`{?J9PE|)(QT=8y~mh*h`Q1*4e3*G)jiSDxO-ExO{ zcEv@0vv|g$#S7&#wpDMmqW!XpU&)>%9@lI++Dn}T5R#; ziPx*IUa@a~S9x;Mb74z;foolI_rzCSN%2_AwCBZ?meP19I}XOUbsc@Sdz+pyO=Z5( z5POdOklPY(>zmc0(JvipcwfK#URvTWU;S;5;AWXgcVjbX@-^oZox+k3He%GLW1 zzt8dJpS>a4^`G7~?Pqs;c+Z`EV4HF+on`;~8EJd@g>+6-)hk>dIYMDCxrH_!kbR+lwcyj*=h}Z=Ue@*2 zF!UBZ-DenWBDU}98{u!iceA|R^yatA4rj$l+f>5V{Ar)Ck)h6I-|LNE)T<|~m@VU7 zx6Jh4|L&;H7q7xg_D|ta{oB@f^4a$pif=#hm+W75W}1Dndw9x!efPMsC-utrS?=~f zsh9D6o00AMdCQ;pE9Fsj|ISaFoj?79{Xt${CrGux0IL^1zlR9G_!V>B)^g67a&&6N z^^c|XwLbpm8JYwibI5)E?l57$w35oAG}G)uT*ek3B_#f?oqf3X-$BJSyN#F^acD3p zYb{!B+{w`*98SJ_GIP)G^PaN*e=5{*TdtkTKg&hIq|--Pz_>TYIpT81 zHH}yEQZ(LIa;<#6T;Xd#|1P-|=>i=y8Lu$qsLLLz_B-@Lajo3J2@MGz**#B+W!0A- zyl*f=&H2g$1JjDAo=-KMjFFu4#FDdgf|Hd`MGDFbOAEffcuITKf$JUnoU2$j#MLrK z+<(k`~>2sLsHApyB>09 z)F*wK#^)6mD*IzqKhLYDPc}E*N??<{;(m4Fhv!c=F9>qk5|#17tHYpYevOgH*C)mc z(k+#=mOkcf+w#!=>%;(Q_4z$p8Evvz%e1UKj~_eb5wuFFohPjMYgT}xUU2g1D>p>U zrpX+6#@{THG*!VwF7%dTSMTxJP5;u&mbH9mexk&h`94f_j=CVvr>T>Yls&ZlQxpH3 z{MTSQDQv&^mgYq&XKpW_aGW*6sdUZ-t%MD6@>1XR4s1K!-Y4Oh{BwSj;gs^7EbZ64 zPo(9CJehrRz6QfT7uHk@AFq(m8&~Hkq*%l|$CaKakPv_P+(Ijie?`>2$L@<-?0>l{ z{5-z7rJnbu+lAy$Ya8rtem0X?C9lR`@wY2eV$aU|Jk!7b+4$VfCrs$!=BaDN?3&Gf znRA^xp2Jn5_RlE(uxtP1dZD8i1KzAZ$sO@a{Ke}lnO(6GuMgTUn9qJs{bu)>@B2=u zIkrFf{#iA~Bxgpe*0nq9O{ZODoEp2N?Cs*VX1nRD&m3k6Y-M?H);lTdy_iPJD~&6G z!IKULSI`4E5jc12>|jOv446%+bDCp*)^CM2>%bsf~ zu2UUm9XiU=%HH|M>JrB$_nw~6Z!+S4Jl@oduX z69>4HYxxh>*KSzc-}_al(6;M&(vw*x4q@+cTHj3sFl zzw>`)sO-z?S?X=`CDt6da&F~$-=LCz%!}rTsVxpOIu@B|l&1RF;)8a4)v8L%ZwZF( z@^w3my{2S^OlC35KG^un@{hz1<5efaJQv9`HWj#;z6=()vQFqqb*xtjhwi-B3}T)M zZ?~@5$tBFG79ZKer?z_G`L^O4t4q=>%GW17ZuXq)|J2;$v&Ge4k)hi1Rm(g)eyy1C z^l`GmLm_Uiz(AdudlgQc^!rp`ak|d+Jx6i1eYDV~$*+9QY_ZzB=@Q$%rC(H|gjy%c z)#Q1C)8snqS1j%mN`kz2EuemV5!UDniFrmrj z%*FKB;gn4~&CkqA>e$Xt**SKWmc5^gHh*%q=xz}9 z?BcR+VpZ$i_`AZpl(T4sMBCgJv-d|z9h82i<;NRDwt%$=pG;Ouxm}` zo>YMo3TIb}D|X5;t1OROqLurWlNfIXs-yaLa$n)2kD_t_0|3t*~OB>C@6z z;-#3Xw&cuDsSNcxf6d-db7RTbYI3NG3GJ~-#A^4C9xpEMP}E-Q<1zp(4xzJv2l z)J#}fv;SOD{F~O#C)xJDZnN~BC2Q8cqI}}jBbQQ(FQgiJy`AcwJ@;G2=F36Lcuadw z?YOjJo&Bl(?SGffzZHL}*IIK?br{dPBcApE>B;={M_fkmV=)oq?x2lFx}LDXYgMob}Lk zS#j#A@|GT%g?VjXbqrWbj<&dMnOPdVJ~>VBv$=8Z{6MjNsU3ma-&bYNe6`lCxYRdl z-E+eqC%3XMuKM|uC+bmAndoP=XRB{m#B}r)FRNN?JO5Qq$s6OX5}&pQo_H-@qRsx? z``@f&ZFQe3H@yr4y@MV|)Mm*o_CK3^W#vu5h8;{RwteySSQ{K}y7gX;kG<{Ix~iV9uZWoj#H?j=d1RIpfuj8D(llcO+vRmD$xe56(F8XX47%dmhTi)C?zX zz2Ls`BO~ASz@si^opv5;g>M!Js;+QStKH(ipc&JTo`t>JXB=*+ePZ>V z?Y2Rqv-pt}$zjvmMyzOo;j=;GUQak5~ zygG9E#H6I98&98X(#Ygl98!4t&5>m$)A-BuE_5D!^Luq+mEPiI_h)r0|0+0pG)vy} zDZ|;I)Pe_7EoE6Z-wd4p^Y!WTCsMc`o-EM{71!lD7%)F!g};G`LV&o-*AFwJOLn%t zTxzwZ;bzB5$EAm+?(EtexGre!PL8jsmbqn5Hv}(OdL-oSimNl0owc;wGhgbhi^}Q4 zx2{(onz;Ya{{6cT?E1B~wWFghFjn}Y{;KRNIWAAJJ%X4#zEPby1x`8_GAyI?=z@?o{k zqf-w)EjhP&$KGjgpLEH!N9VE2woiE6SM2^n;Bd;3)nAvNxE-|BJ@>d`SR><0iCf1H zJNnjEv#D;AyJmJRDd^MO{Ib20d!=l*pZpQE`)8_|!X5>e+bLUa%{}Vcy}H6J>(aBG zy+N|G_6CJ~-Ttjhq-5Kw#fR6eIC3Syhu40WefG|}HIjE3Y;?`kvx?eEJLk{Ij9R0b zZtVRs-_Sd7vN2D-Xsk)Z4pL*3NP7w_Ika_U+X!LYD?eV74!0Py*la9r(Negx1N!H9ev`-Miqrcs}FfH zzyHjA(M0RcYtGub#JA6relLyTd02V!?k!hmpR9x;=0i#uOGAn#K3*KmaVTM07{e2j zp9dzKH&x8$*>LXPgR3)n*blWhYMj1kv~bhDVE^wDkJ_C)LY$HWjF_F2BLa2#UC)>b z`Gwohuk=_N_+&}G_JWM9Q!g#!k;=PNF!h*Wmc{}_EndTn8H@|n#8)kiaoHP@)g{u@ z5vR^Pr8zvv|2?bi-s?-}@I0UXsq;?s8~-Q9k5ei%zUS>zhjc&wpR+ z?^Zuw|Jc!&N$F`Z44-1IBxgx2wpcUgk;dK6={MR}{QfuL{gIxn_p5^D zI^B825#HAWuNl?q#JlIa>;BQ%*XrFq_Z$D!cR~+i?nKY^-|vtv9If;%Z0XV^I?7Z2<5*7)PK$uk}q^oC|!ub903 z+n$~{Z|46Mb(Y`%s-4#P>wYuq7wioPE`Q9#-l6?7(w-M{t zfZ!K@FI<{@?9|pz$)}69F%@Xntx5iLVOoIGT#taC=hiQ-Uv%iROm%bRY%R5A=FW<% zo;%-3$eOy(apS{DR~QOqCtP4$$2Y+@kwxMETYBqtu3zdshEo(s#LE zON^M!?O7jK?eKXzF|_$(( zXi~m`zt0A#_PLBrPbCjWp6&><`;)cFyJ)Vors_5E8(L?+$62}ET%a*UD|>$IH8nAA z&W{=sI@x7Ja0l#ls z_qTpDtv2wJ`eYMmJJIj7jArlKNB;L4B`3VRYjv3S-$zE~$<66IzCNnAD-iQM>>${d zKJm9lBtye`R)_BsORX|wBmGaYX7t>aVz@q;*Xkad(afv`C%;(DS|i*L#S!P8e%XZO z_@jwoEN7NUujFRX-!d`po3pdxmYH=fvOG_JxPQ@pHAiia^^2Nm%V(T7Gg#^(eZx$% zO8WPdpE~=}!aoZLpT8Ya#VaCSlog{Y@VE&w1MybnflBEj!#yb?*si<}dJK^zJ+O*3Vm}DME!O>7HVT=TbYqt(0qaMf{t-^>3|o#}nizeVqRFM8Bj z&X3nSuRs0y^wXbDKmGai(B!95+ttp*ayx(LvTI-5{pE#T`=>@}py)7-Ll#~-MA z?y&c5%6~~mzJK@IJ{UZ6D~hbRQpl!r=_@y@iP&-DKYsr!JuC`7DyDN>C^2eoaTb{G z7$(Gc&*NC|mzv9OB#zv?w2e`H(reF5k?WJqj0#HDyjT3Oo}b6&W1wu|%L4%?yrc!) z+}gG%CcQe#&FQ9NbtW2tk+7D~@{Id1O#R@PTNw`;;I zDG&X1MX$3nyJwU&`^Hz^miU-b7;yY(qiErl+{dRj9I}i^VJ{t_8tCF#+H3L@sd;74Bss?WzSt+KT&t#f31iwFLdW_ znH!~Rv14{P{~?_;!4FS_5AVIo%Vfr-y6ex{(7T6yA`R6>2p%&KkwV@T=B{0@4O>IoG&No8%3;)e%d_QFR}c1XAB>^=;TWU zL1J^Zv`yajV9HkJ!%`5@lR>=jRIQJJ%wPg~6_ zxjBbZ+dLspNB!cf)m6p8yQk$Z+`i!8N1JrJRlM^`;~byIrq346GAi%Aw#oLLw)y>K z(#@ZP|MZ{B?OXH8i&g*jb^o&IhOhZ- z?^$+wRD4x=u;Nr<{`J_XbGvuUxi0qoQs;8Hhwj=3S%kJL6v}$uDp_a3ASP*@-puKA zTXjv?j3`NV_Q`Keg!~SDtGrUw+?HezwtW5hHEV>^#H@DrDlFstxV1REJmkUqstNUL zubLDIa|YJ1ol@G`S8nZbC$QG|U5QH9iPnkjC3gHTbL{wU{yn6t!n#-HlFohqyWXd` zS(h5A3!dq0wcLE5r?>x`(3KR2=uE5D%WbS`4^_|DZfnuotETj8-j17UE0fiqCf(e) zl67`;g3heNdS43c7iYa^n#O)Ued6-7bslY>c7s3t54SCU-(!S_{4Gg z!mwT0<;y=Rg_M=%i#%Lr*0%24F2Nq938{g|#GynpYUXS*Ak9^DQ8#X8d=_xg&r(YI>j_y6tBFX_CsZ^Nnox@)?7 zQvdDyr@%h(+rno#mkz8~{_m@zTjz7!lfiEhQ|q6u+L((6R&-i_VQKmEYK_ekD+y1> zwjG=|SP$(#;%d3+W4Y13yVZ7E7wy=+-EArVoMYYb(Dl>z zrk(a#CcCHKV|sXZt;^XU|HbO7))|3QYXVODPG3Cz_#^Qu;TsK%b+gpxYBl=4oxxlw zU!e5I@@2@0?IsgcT%Kwh=be zGcWh4hWh#2tX9`cEMQy#YBQPgiN6-r%$Y3DDxNxbO+VhPaJwGH=Y+m~JaR992|Ox{&+Y61nTGy{m$9 z+HDwGt)^>OGF@GDU8?Em9E)I%Rnb?MU6j&VmbRbk$+T5xdF=BiIy<+lX`1x7nVI(w z=O?|yeIE%+iR6f*xGkFLqD`T9=J|L+#yS*N_# zrRBZaWLw75S9d?yzj+tKMm>i$o9$~G_)TQ~W*f<Ryq z%qj=J{#bIj%4nifhSJ{YzgER0b6#xiJHg1Cdyes@vrIqJIxBdw->g*_V?LGKD?#NGP z53MG@{=k=)HkPo=m0Nsi<@4uVcMe|Ea^9VAb`6i%^skTInpa$$SXm&{RTOyE*+#Ix z&u2+WbB?ajOfNV0Wv8BSdn6X+bY<=~sf^gTJLG7d(Momct2LSFf?IbLOjYmOva3Lp z^I(q7*X1)f=N{wVD=J>H{nBom=)gMhT4{z;D}vASXMD`}%2X_$ydv1k>Fa;VTV}CL z%0d?0FPI8Goz8yhDBfA1ysp@MlCR5+xp_+Q2^Cg*TfL6Yey8>?mQCtylnlpzw`~iI zC*E_|Iyv^(pAu6+@j9i}4?au60}Br>Vx7Fb=E|FeRdz>2?M^RU;K?g+osm=a!7B#O zD8cQMZmsgNV>7<7pZBNlr+xL(M*pS6)?Vtp#r5)KoT9+(&x)JEWxhV>)>u$o#qJw2D_`pqeanx04QxtFi5Q!&r=bk;G6B_d(0=QndWF@MUvTE6mmfXS>y=N4vcjk#he zvbITfaZ|TdyHMcvO^vSwuHGx{IP;MGRbmQ{S9M}V$jqZt5`0YO9-XgKdqL3fobjtv zm(*>&zH;({-QQK#&e{EFs0L}huU+YA)~rK{XKk{`U7x&7L{_Fuiy3MVQJbGWuN##=Cd>Ww~h zem>*G_R!Cd&Atjf5*|I8p{z4wkt2-AyFrHHSW6k19 z+c$c)&M!Z|nvkwh8^>0&-QHQU&S9yov*e_y-*{3zzU@CBaO}&Swrv6F>v*1T*#4rv zwfMVqPEv(UFEe>7=Cy5`l~K``G7nRkwXQ|3-iJPsvl4R+sYI zIR9j-JpPL(b+34Ees$X=@Pvq%Cun*^@O;2M?(7fmzZp+S-lO;}%xJpD!P0F{!{wI9um)EMz?cM!k zbLQ;-v%;jKyN?%N+qC@8YOnc^-alB~@%{t9Wz>fUYZt~H@vF1E)g1F~&)faGznbma z9eUc_Dq7~qokwpDJm7nt^>)^L;oH?y1jRG=|5VnxWw+Qm@Zz@xpC<|1{^y)^IdMbA z4u*d*1%@p8aq9Oos}?2cCOn+LG)ctn=k4d}4}PC?_`qu?T$3Kxed?I|3ss&u{5O2| zWIhRco_5^)%cUJMZf&0z*Rj>lQ!SRXxcozAo!#~+2kx?4MyzJjjk;LN{PS61k+;Tc zpC|Q~^lnekyl}#A0XP36uFboZT#PMW-1OO|zgkl}bV;C<*{t`H+E+I>7yWttD&RxS zlzpi?(+-EsW}`Bh}u)VJ=KgbDA}XNOz#Z5(nmO4@qM z=3UwS)l~S){{ZVtA}6M?SHIVtGpl`0aoh{@uPQfK>X)v6I$Obu$#u!3FDhy8S8w{V zZ||asU)hAWvYlO8e^PS&1*-;eCJ|Ljb5@~^TP9tZw5j`&Z&;v}Dpx@1nza{$FRWhG z$6GyDDERQ|I-dHv8lCK)D{fwy=HbJ;w&VPje>F`^>lN1m0sY|9lVt8%TQC|HELfki(o&m$ z>&u9&9|z(O%%8RS$U$D;!%b_AKj{3mzK|nysVe^IE4!Si{~DL-inUoT`IJxi$I>%N zyYTR%#L^$%?Y2#b%zv^@I8adERn|h|(b5&n>??PhKeJwcjPpTRkNgMsr6GKbl5f{+ zRuMiq<80i)F4dV{7O$@Dzr1c`OY`inelxX7N;av!WwCzf7xbn@{q&W&zl^pnwYuq} zy2fV3speHSJETnZRe%ck9@qFSZKjjvulmNnMx>-8=IF7uef*u8WzJ%UIkIEZm3frC z*1XGUNp$HnooC9Uyh*T4(DiDyV4L77!BZxOLy~5_wba{q3vYEn`7 zI?(>pG*^2oIi}LTC{`Bdbg4k& zvZ%p^%koy?FSu@8fBEwZgGo~$<7=yaKlX?+zs-j(S?%_hnYB>;$G4S24Xc=I8;aKV zrT_HdVz_WED4*T<;uH_%P)U`jo3RYL-pi{<`Dt;5ZrZp#zGR+OvHQ`Q`bbx{lZSSk zdMA|h{qIzd*rJ2!Qd-}|*Tz-p@p8F)-6;HQSz?@}_GDesKG%mGDRVX{NET~o8A%?_ zS)E|CreKTZB+;4NXJ2(cng7u?R!~mGcHyUEo-A|R4$S4)kz=ZVxRS*tFt1%*`N2w# zid|>;&bu5qt@MM%ekJP>>z&Ul7QeLI-+th|_+%z4m5--#^UoWsEobK0$NRjZu~@A7 zyuA10dm4uCGHst3=&!V6R#?e+dC3xyRDa#~#=g}jZ*7e&?d{)KVkhvAXRcZqYs{p8 zcJ0~^MItxvxjg9m^iRTvb8VEtvmLkQuJ>}-|M7t9wwebD^#a$Dc6O|_@~~)b`w`q4 z=J8SNrT*Tk-%n#>TMnr3o{l|{c`9P%KNY*XiLIqS^dI;T*C zCf^133H+^jes%8B^l~0G$(Useh2BfqG0wd6WM7}pwDfoQQ{U&&1Vic+EuU`Z@3^AqJOB$YiqaOu`(}XRxz&9*I&f;&9|DV&#nFV z-<3%r5B8gGR@zfl6qi?6kvrjN->N7L*46$`dMgBftett>XdeH`7JVh|0R0(O7BdVi zW~klsVl7#ipzh7TbY+9t^5dyqizTMdoN`jTSL*JM8GSp#x62h7X(sQ!zyG3WU`64K zeNSJ!W;3*U6%wLvG)F)Ak?&^Rld_&a*BD%U^7P@H@I_S{itM*r2Jq`8XCJ*=pMBG9 zTD#J61C<#kx(?Pn&M-G!xh%9HsO!{)wEg?S&Gv50k9lpn_gCF6tKUnnhOU#-d3Ehh znzQeTt1fTEpP9M8*?#?#`_0*Bu85^9l<%DJFwJMLc=F9o{+*JBisq-~_MSf*wAjvE zS?x*M&As1uN=B_a%ygLlo9XAhvnSo292UE9S=q%eEoYb6t-HBS{mNDIRec)-^cjx4ke3O@Kl8wza1@@9B4mzGnIwIw38`TmK z9KIz&`RV6F3tTqOeSSFTzvW&#*&p#|)}4OU)U$Mtdgo~?zhCP9JwKOAE%&^$?A!A% zpSE;F&a2aWdvq_$nZGy0H|M9hzL`CtL+jg#$Ro9NCuA*V7#0}#mt`(r!u`cyE@#%FcJs@0RcV)(1t-(= zGty3*=tu?r{Bk;E=Ha4C8yhC>h}|G~Hf&dd@FdBd|0d)=H#@lOV0Y$($wd-1H`KEB zwr5Q(srlySb7J1BH@b`Z&)*ArZda|WmU6!2n^@$D^n9PIv47vcFWuMo`yT(#=Qck? zxKBGxnju(|^|sU2Y*LwujCAMGJBIpaYz~JPY3`U>e~5dgwcX+Ck3QPFbPJ`ic&%+; z^!4Ab8Q%;AOv9`_&v4aPzV+1k`E|>j{ql_+hR1iR@}2wqjwM3i)A7yP0S0w?-&MQh zv#n}hbnBH>iNx)aVXTju3(E5E#Puw?H=Ul)8StCuxqfL?dig1XGR?H6&Bk-iKi`q< z-0K_tZCyZeae7{;#zmc1UzWHoGE9+5;pQuHNo1SR*j#hKQS4}k+2N$6U1o>Ne3Ol} zH16cS>Ak@A_Slm*57tH1Wmmasyf|~-ZW*VQ(DL9L23IaGFlm-M;_C0R>BkF+B^_Qm z9z0u3Ch*xsv!%!?Y~M5e);z7=r0Q3bzW5(rS{3YmQujS$boZn-p3g~bt}8PP%)DHS zMFRFaMqel>Z2dj$cAsx}L6yRm2UX2=9)jN#|292actSJ(%|cEi=1;ndIgOZ89N7ZD ztx?#Ve(SE$%C2i~EqHw|w#8&AEuB%AxGwzS_m#dAB%d9Pc;~R@d(xVs?(=6mICn-K z5t%=GsatKHo6m`}N>hK_Q8G1I{bGuP^XH!5t9Els&3dG}lPf!;Yx^UuH48OQHhGI> znO)$$a{a=etF@AzB{s;U%=FBg`mb(xl?kNFPw<}fApla#;P@iVGCD$;_!QT z_-E+NNR3r{Lh4w%wDd#Pt#qk8?pLdzWaY2?mHFLi4_iBH(UtRc{_m1WU4Cl1*8Wn* z=Y`J~R;)NuFuk?u-0{@->8*!+f4V(WZk4CTi#u=ixU`d_i}F?+zcooRd>NP3HLs2fFLJ#7d^=~XTqzwCcZYZ7PEGqV z?`NlbI{pd?X>ORyK{Eg0#n7MpL57rk!`4neP2`hhJ;zyyuVo6~5N*)K~hNo;qFW>+z?# z9)I(mZp)8<7AX`jVK=jI>TZ)c&+cpgR+&=yFYKO>R(agYn(Y!Z*>5&A%M?y!2UT$o z6uRF}DOzr*acA?BOCOS2t%bg~ixy`WxvqFIbLLLl#iwk9mOIWXQr~H#Y11LS_D<%J z5vr(0hH?|L!FXyVCMqKVARLhzLIJq4&CRZR}3vB&Dg=64FcW zSjwz8K9T)H!7J&HydM|wy(vAty71UU$wx*Vl1rv~XvseiS$W4&@4nG2mf|@&2Nh1u zo0{;=XLod3@Wox#Q;XQI^NRbcE@Nmue$U`gz}qDY>XTa(*FK4i?0Z_drl+Gpv^y!) zg$2Z#YIt1kQGJZ~ec?MN_iFts`}2FvrI~)qet$3ckp5`>vD=dqmrcG|q07F=?W6%H zn1A}MDp@k$rG|$?@%#?{$M>%G&UBS5h|`M>XFI38bG6oipQ|37I+gKy_Td(_7jaAG z&HHH_WFNYXYvuftz3#7cMIZ00{rD{I`?P{*`&2HANnQQ7^i5~Lo=S`Fg&Ozv#BN-= zh~p#M%}31K2LxqO*!Vs8QTkG%C&`c6{RC;?uEjjL@i{vIw zzGnhw;~Up8vn&qnl4~;l_)y$`WgtwzY;@F)0TvZQj@#VikNNhV7iu zKP7$NrN*siMV_7XkX(7mQtiGHEAJ%6)bm^})ywwgRvX`#RXx`$U1)aVR`eEH)|H;B+JeYbi0ijtadM?u6yt+}3WvYu7TKRy4JH_iIuqYENtsv8{l z&DVeUw$nNIhRzm8w<{Wj9t*BiY3vSP8ocYKpZx?MJ@2}%pwp@|Sv9ua2`sbs(v3cq z@3!>JUr}%ETc)=yh5qG~+dHVuU-sTf&3x+JPM>?a^BaBMt%->ExVGDF^<8nNi_d#Y zyfuFH=+Bnwvh$x_FZV9ZckPaq5*NXV`=Ddm0|ohl2}jGlHW$|g?2!GkFW}40spq-* zV{^Oi3uIM3+u0o(`emZUTn!Pc*^hKNA3EO2ILjAj(Wbe`i(QDB{qn(=LMN;o8X_g? zjpC$^PW~wR@$Q0~ksLX1XUPf*ue^EihEtk#_X~HCIi)$m+E;VZ1#83JxY>HgPd-yN zA$UpJ^BFa#MMP2CjyPEhB0-Ag&?c7Ge#`Y&(%e&c)O@y$JY+}~EtOJ2YETg$A} zFS>V@J6+LO=mrYZ`<}A?7D1WP5#Lq*w=7?@?GcOJocwb&edo5^>6){tcF=n!WZji?oP_cXK4XD^X z0xovXil;cW-0bbp^mA7ZSi7n3{JlksKi(8yy!hkI=vQ~r^Dkcf@unL@D3_YVPdLrA zdG`4i7TdyKXOvBvdvMy--zD0){&Q}6u5&453tW6evN7oO!Z&%FXJ_d4M*Y6!f9j*7 z!H>A^^~zU2exJ<$KzAbll4;9j3Qx?dpK@>Fx4qrQr;Yc0?|gIo$B6^hJJ(wNPi*42 zH?^TubY}CO>#FbF?v*c}#Osl z|M{K;1;Q`qE?lssYaQp`)jvfa=3N*6c(Uz+%EwRdFaMmWF0l64?t88LC%N84&Sn4F zw6a@RBKyKYlfoQktJyXoakoS@%Rjm9G3j#s6L|09_m@)^JFwLF&h_6pp+(_T(R{z1 z`#Fxj$f%z8utqboe|>VCZ~l^{_m*#-vPR&WjrNJvD*Uc~tnV*>lwLj|qeVkjN9wJt z?|O5kQ*JlDRNt+&>OQ$ytXs}xkBH&5-z6?Rp(3AlM!viJac888{QTLjpFV=S5ZwzN z7aK48==}G5j$x$ujBh?mjbG}msQtHpr+>O+q}U11$1k3gJzbKTqB`rFLe`R7?15Rf zQ|@Z2|K;CTVE2Fl3}E|A8o)dT_&$`1Ija*B5)zUa82Q*zHh8eNo}O^B<5araQzMIo zAD1uqcvW%(Gs9DDru}I8CTTzfVCGiLIT}@25_(kf{Fy)Zc7NZud(ZEC-W+NF(Qx9ao3uoTj<#xu5n`8g@RNWA^iT?f(2{=eD0WFV3&JKSRR5M^5K^L zsj7go&U=4$3jgw!5xkaaPb z$5qvm`{>3g|H3I9lbLQtaO`Oe?U4B@QuklW*>v`ijZNzxu6S5#GwHwfpJ$?NUenG5 zp1S|AV*Y!DKZ-XFecL##lBvw5G+A(U(v1^#2@?xsggUD9?yR2hO}^vRtQ-BicBT8D zdT+nP)QT^;zRi7`am|tETyF%08#7NRtNm2gGhTUCbzeln&Inzl%JUDIw4YlX=VqDK zIkjolBboUkyzbG7*8gWbmiRwK!n<8AD>9XNb_DZcuj`wl+>Yy{zLwzI;H-P#l#$CU zzZcgwn^v(o%S8+JHMF{Da~Bp)3O?|J%X_M6s>!*e%7>kmEti>_>pEF=JTD~3nTT*l zDmok9J``}?F6qRRn=(6V)Q>aPwZuPvkrZ}D#d>-$x7~jm*_D|;{uWn!JnC_!<>jNL zC2b{Uy<58ln>lk1)i(xY?z5EbSbXcq@yDI&E5hf@f5@NN^)geo^KkO=sZY+Osy-B& zaV0D6^bDhq(<@z;N?+I;t|HqVA==e=!C>;)loM$?yKHUjzDO7LTDI#d`S4fqO`Y@e zR8J%G%LNndI~L8}^g1{H@_E6Mkm+(eo?1(spA@GZ`?}B8>^$JLQS3$oo5s2K ztwwh43min4RErqa27L>z*f#NGmHAZdp1>7Jr59z`H%|>J*t$%xG;e47t@q0euXHbV zzx;Etd-5F%n=d7s-2qK>akp1L4#mcKgR;dXbY&K)&ZrTbd4p@shqWIcnr6>#jr4154k|YdOzn6wwU$?(&F+ym`{T8l zMQcp2FRH4oW&SwthUyFD?H#&JeK&RWwl$-dkY$iw@dJ~Y!VeO=^eQo|D z&u@!7?ypzAuUQuG;$2Cg;Ht0~1AmYCe&(NepUjf>ono|w%gK9#Pd?{yvIS6x!d}5s~X=N>n)MCEZfyA z^SrB>`Cp{oz2fsbcD%{se6;w%YQ>cHX)PbZGMqcOT#w#67O1PoA@f=0L(;x!3l|5S zH{5W}W250!ze0nnmai9_oBu9pY4sJ?#nGCV6@C3j@dfp zNTZ)JNAn|Xygvq+#b04Fny(xk!ae8XyUQD#?AIxuUa_^{z^bicB1Ar4w8C#bL%zSda3b)0lI`vT2L6*X=Ou?odIWp@ z7U0zHZChOXsdb)KyJV!>Z=vJO_RF<)*KfM?$V-0X(OiYBdormv&KtA7`npqWT10W~ znhoW*EHeB#cPHgDh%;|)j*zJ_zA=mWo8g;B!mQg~6>UDfdD+c~to&_(`TiWY>#7;j znIs+0aPN~_BKF_i!aaW5C*3t$R_ClKvM(<*C}?~0@%&@vk1HKkrMIz9{<_u5tM@9~ z)*mUgc_uQsAN{wa$O?be{8gHAkY(b!H|I2!TyJ(S?|5T2A(f~5r(WO6V~WBruPJg* zUlSvp`mIb_{@3(f77xT&HkfTNZSZHFK6To1cm7?`U*c3APt1QfBjt_R#H6>|KFl<| z>$Y+4MYpZ>jont}>U&Z{SPN7xNG#CHxUgO7MzY`52`Q(ecAnJ#{_Tr{p5#|1z4r5J z>lcbxygYj`VAc9-E4lru)>kZkkRcvY{k>}A{pusP@7-NAWqtT6Ki2gDS!dY(1xj~F zecgZ9aoW+3>kQ8y34dn8ogY;ywr|T4#!G*~zu#aJZ*BbKknQ;2;#H)U`%J^bN5r4; zaIcS+kN9zCQnb^i{a5-k^VYtpWjZa=eBMayXF&Qqpr~ul(fBk{&y>-zdF+EBmT))FAtfnonw?QE7{=`cK$!ISpD8u{?i#%HL-T%tiAu8>z}N6ZZJ{2=*^SgJ8UxczdGoezbY$z zj+4lmTQ~c;a@uSRuPoa8Fy`RB@U9=6?`!GIVLq<* zbYIZCwZaAuM4XjpyGpE?zr=;oEe##1KzE%Ho??pX#p6c^d;l1w;)h4feH|5)+ z+uuV!YQ9a;Qhdd-;3+{}K5$&uKySe2*#%t{-K6-9NgX)aoodz1CAs!CyPwRn*XM z=6=UdA9i~rruNMG;$JLr_1{dLr%spO{;ChMk5^;9TBD^Mu6I{`V`|T@J@?N_e95($ zyOO8ohw7?l{{Po>WCZK}RXp;2pPVk^SsweP)#a;Fr{4=Xt+n%Rq8yiq`t<3^IwVV}wmNBuUs2h4T9*SK5$pz{6$B6iak zyX6GmyYka{?Zr*sz8!D4UGV$wj(VMApMCmF7X@uGS>l?ewCk(GN)6#FtG~D?nm=)Q zwS!M~!iQY0z+FfCnP$Z^Z+Wv#qJX!t@5Pn*WxaYwXT8ZcW1QUnM$NMb&t!Yj(i3wpxW_qsWbDx7&e^IOFe(V^Sre{`GutU9d-SeIg^iVahv_3Q2JQU z;luXJ^M2p!|1i05i_N`S``Qcq@0RUioASG0g+RirDc827&6dx3cgwrOOY`CMe~~=y zH!IsbZF+y?O1RzW+bws-9EF zb6)7bBmBOU-;T>~)+BvfceikcY;wqc>HH-nOqRtl+9#C@p2vEHhAlMXGJfcjs_M1j zRf_ZV1*KsbYfXQ>`m=27rdj6i->+WRa=y`d9b3MGsx_TB`623E z*E*%*nJNxH`iIiib-RL-86 zJG1)zo#!@tKCZT#|0Qyt+u`TJPBQCOF4KQ_SSb9=s*kcy?VZmUWm(r$spwo{PpKEJ znZlU#OgvRn;9r1iRgcKup9j+FvNy7AKA~~6Zfc`NeZ-eQNBOB=40V48PK^(r`FF*+ zZy%n1*Z3AV(cZze?(T^_%4>U6QtaJc@x1&VDsgYi2XF5aT@7DWzufdN$9X}=jJB4T zj`LiZY^p1Eg+Uap|yxY2S&(Vz1 zbYA`f=S}`wvJU;dbV7AcqzA`?7nf7tmMy90{l{}6YJOr@`I4n;>Yv}c+-l<;cs*)| zQmgQc4Tr^_K5DbOt-D-c6W6oIZGUF3IQFM>gHb`eOksO$p>IjUhPn;@i*q$}l;#tCd2dSM7n~m_>E67)~&I#6GO#~ES0qj zw)A)@8PxcnNW0DaoO4#9sng6?n(OX9zP@$&!Bc*#<{sX<-Xk&U!tm@uq;=V0W^UaKDHr)3<-M+DycUsA<#LZ0W+~56tD6lSrHPO}8 z`(W&}1E206yx?@(F+-&Nu-zPinVV1b-)Wj_7hZDDl*Q(j^A4GBtK@pp1A{l5RevCu zmZ;kMDRB9-Gi7f7A3Dw8s^r_VZ$iS~4IvgLx58eEG|zEcY};S-GryK;7i&$kSf22@ z)0$jbEjhDhD>PXD;>fgL6RaFza&YU3*!^=al+-#af7#~xN!DcId^{?30b=x*+Y4ApucReZNs-Bx6#ym|=WYeW6m%F=#&m6llWrJX7 ziw}>@9rs<)oSk}xOKn_Knl>EXRC&-$XG^S@tD8lOjcSWshpP?G8Lugu=DUd!6&G_NB{$VhRlRJpSz|vq&>hedY1EVwVpacdU&*QFZk~e;cRi7b_Dz z%heAuls8EDMwwpQ*Piw+dKLqB-phqv_F+~w@BFK{8g{%szx(DJ)s3f5Zt&o+T>^|Ypf_xgMM)n7mDP33%=@SN?2v^evw$CC~{)Oz}I!@}dT z-wsz?F?lGvMMU|YZTx1fiuavW2@kxqo%j|`m2r}u^`mUtX}8%;=8wWOUTfzaT$cUBCx^-X@8Un~ ze+0J(o^dO#Q=cXF$&kBv)z!^6*Hwkw4VC)5@i6xr6KOq_!b+Ev7!Q{vOXnu)%B_pN zHZgiHuc%aRty`*2banqfz3V))So2cbZ-3bTtYby-;ouC0ES6mco&VM`x~rQDhxoop zz89X@@=NK@g6=ti(GFoo2b?M=3HeP@n&3A@cTJ?-!gVVd*S}^E3RZsI;_jhkoN2`~ zLsdv|rAUm})PF}EZNFr-Wj8sx9Pi&ZJ?FcWX{%m<^xMo&A{II_n+`^u*zO$oVv^b( z&x0lpdy@B0_PAy8W2^t|_o20!Q`lNl6_+b^p6K)wS&&w0uC&27DdX~)i9x?P(pTJG zq&M60%cAoKk8OK=dZFTzfLk-2#CUs-Dn04*JZPes-DUEgd&!TU-){a4C;w|(+&H?3 z%Uo;qyc?}D7A=Rf*S?vsb=HIBwhvwYvE}fY@|REivR-AKR>V3Bj?9MZJGRZ8828Gp zcPrPo649Q=$5y*r%y~0`k&FN8&kRrPMY23U!ulw8^CToas&dK+WRB@22xFEA3>h$LWFNNyt z1wYB`e_NHNetdu0v4Ra8$3)}}Hi=9=9lC*Q#Ui%2zSh$!_L52LwYyKHL`WAGpHG=G z>Ab^)>0f+Tir;Ivy_+?;GTY`!!BM-EvzhyyQ)3%eJ9@3YykYfUroJOwiyed$ctzGJ z6=hrq*I_Zto?!U9X4b0hk2Br=cL=7jT-qyzG1s_+lelP?}`Gw4fBXLl?uvUWMSDf6kWujJD!=gYcvUaWrSG@q-yIJa6s z;6cGDmF|zZbKl7)Oi;LUWTJ<4c}@7!C7mZ9WhO-#|8cu6ald!kiHru>Kt}G&)eEgO z(#sMY+COraO};9A>ex?Ctt#!US3bxbR<$`${BzM2`SV)?UmW>Xmh2$nrywcr`BQpT zq(VUT@|z|%nl|Jt3h0)$ZrY=JfhD$Y%`f$=WAazlu%^#`n8*B*cfr)OuqAH!462{a z8$4X|48OQt2+z&G-@aO0GBNhxTNu6iSWsdJO>sRW;6J5`0m&rZn0Ky3*&~;D2=0& zYO~V?r~3K}&s$m6bu)c+DbH`40Fz+t#05+KYx8CQJUfpymuLF6vz(P|ds>b>)9AJN zc{*odyc2h>dc}&>$E8o1-kPHPQL2uA^XfgOORjz2BpG$%QWBtJCEz$X6Y@*b1ZK39$e!1Q+wkJBbViY|3uki-WF|(6_I0) zt)8NhSgU;JzUO194VT~Fh!k-*c_}q#>1|EB;;W~RT#WzOcGpL6>N2@`DPfWu4CSWk za_@M>>6m@l>6b{-`tasWTRkV7F<0%lAYFYkS>Xkva&LqASG7YeC*^tD3b*(=uRmZb zf7y0zf#3DIciLXx?#hTWzT30W<9XvInW>XsuUL1|O3U}{#Ct5Wd$M``*rX0c-MaTi zb;|6Ae$1wgzGwF?nzGV!;|cv&no1{DHii{&i~|`d*1GfD$}OcO*Kz1q>C_b%*xMuXUn{t7KnTzsQ|dqGQZue;M~_AvkC|3|{IP1KlHR``)ord8Pknfo zZ(?tH`N>VUld2%7E`V6kAHU{>BE`M8=yb#{y zk=&->e7t)}Wbur7QMo(6&ro0U&?2nttf|9Hor9D2teqXz4(v6Al^IG1` zs9*l*MSil+Tid>*9n)_2>({5Gcpr9=EYX=bx9He1Cr$OIJP-dbRNUJsy3tAE4Ewoh z$66&hU&Y!buzg*$MmS5Nc%H)iq<*peO<{_Wx6 z8Rap`uJ3kSGP{47Ek5&wnVq+7Q^xTXjC>`Q5o?1dzb+0IUj8DmVp8A#`%As&*nBLp z5b;l~u)n0UW!62$4Z-giKg@WSV6?2*>G}S*pT3mo_i;xqbm4RkdJ=Ka)I8qv ziODZmFJ38qNBVJ9bM@+sQnif-_eyV4H(f7PIX!OP`-{`#uFYW1TebPD_3kfvJFXZ{ z*%Y)V(}{b__2VJ@&p-4(c;N0fW9Gl(an_cab-R{xl`n|7dikWrfh7d|Oq=M_bNtbhhSQIqWXS!O+7$jI`kKYf+wA8Xs`v2oA7P1=jybI( zb4ABx*`>hro-=WiJ&(U>K9wf-?oH8-n*B=iv?AV4E47}QySZ=1m-!j%QUscVfIGbb>$!CnSb)htY7y<@P%iG$ilx$@fU1fMsM22yE|UT|5DM# zL(Mi5Q$H;>%oU9Lu#xBB`CoH%&dGGb#pJsB^`Da9@8=p^4tF)V3 zk+-GANpY=)b*~4f>&tTgf9BIemNqVN%Q|6OdS~ux0axFb1)P(Lzu2^=NH)FinldkW zzqNaPA48A%(HYC0$X=hK;;M0d%A3w^f!mX+S*%tR=A8VYL>$2B&A<_dpsaDr?f>;lWG~iTp8Cx+@|(@`TWvdk1s!7bn-(4~bKaol zQ{+_TL%;gYm&*9CKG>jtUUuK(U5BGJ)=Idy1hyX+d>FF-+JVFC*yfdQ@tRkx_&_7P zidFf;&y&#&|BO23El7*cubOpNEBf3scLw7X*JWCFc01?)TeE+{v7;r?Z%VhFEK%Iq zy6@xb(-E_N%PxCoSNprE^PcQ>r!y^EmF8UNxg{%pnmsf^H|@dvUE!umy9)XB1=*^# zEzRcii*l~HE_mOFclOE7AIEn3e)5{b-^LLv_i)|feG)IFa9#N6IL_4(QDoZ_tI$784T|M=lkJfZl))_LOhkHq~c)C&{NmU}I>fw3~W z(Ibe<+mm6*XZ=L&zhcjWm<$rP>CV1oys6MJt%~0<$u%mMLtDy; zZ_~FsoGS(2?rhz1{M3$LhdJ|YbKaL;$}@O*`B`eKm{DZ%*|R-IY_1fYUokB<@ARuc z-Ths=*Ry{3-qUeUKCu443y=C_Nlr`QYu}=rqx$PFs(;~qBD&!7t!&<+JR06t`!O_q6}tzU|-r z^6lG5%lv%yDln&^6~AHD{G?vFywW~-?w|d&m~IHzP85tpQXpa$I&hR zF{TdFjLdrUY|kj_wr!en{@mBNTmKxw7Dk%#Z_0bSq`#iPcQ)krgq#?+Iqg?J8eB6ww7_E*zfAb?lhcEz?7LBWe$%v5 zJt8vG7rf7z!r1durtihHt_u!kd5a}_nAd)-J#4k7>g@8vtN9Od_V?-DThz>FZkww1X_M%kv%Qu z?w(_)ebP^5KcD#HDLXg4%l=bUAvZN3sC`T8%~#y%y>sK|UDENbTKsgz*DF6-d=4vx zJX+0S!K9ntVB8mVQ0n9KEf4e;Z(cNcka9S?aLMSJCTY~wkFTXd=J96^ojCqgG z@8Vgjuk~Po;MAMNZ)z?-6L~#dBlTg-8@FiFO#zw4fmvd^Z|Gd)Jb#F(AS)oFsnj_{e+PEubNBT zMNuw=ML&OQ{dGN)*1=F~C0C)lUC3RcYv-m#I#;#NPOY4!-7ziD-70+k|LN!W9(L_% z_i37Kc>b5oA5F1E*Vlb8wVh-vq;&PL)?~hn`JJkVb|gtpSjedJ&tM+M=JkrZZ(ca? z&n%}%?K98cTD_|}t3^XxB{D-;qP`?5KJd2cUZV2G`bFIo?Fs9Tvc@?1qj8x#R$i*(}gj+64DXlnouY>*R8BYZn)wOvAJ8bWFCEZ_OBWkxiUp?mB zo7t`h#fv@*&DMVZ_V9<^K&cCcH&^ZoH}yQ2k>v9!ZR(;%Il)aw@_YDiL{u``Xu5P{ z&l6R8^}>FIT2Xky#v@iqGB#J7w@b6+n6G8I8qgZp8vBp`-Hg1mppjJA`j+1u5Eg`F zV5pdLwl+KevBxCc`YwCjvgNzkr|ImM3S|x1eWP}3EdSw8@8ZrJb!}RtF*|t42_?;y zdm^sn?-!iNpY};nEx71$(z5hjr;J?Hj2{<1I@0O?UjAQ7_y13StMlcj{oM59mFPu1 zty3LGLqk|X!}cV;$=sa!@caAy|4!Xd)4rszvi`^MyX*J=D}4Tbk?+^-`~TL2g{_XS zzw4U#+5M5a z?0b9v|2uYz?SHG^^fT#HO?}a6yN%0NB=uVc-+%o6h0yj_l4{r2rq8%ZB|EI6JPEmK1_?cPtKYd2kj|s0hKTb01FR%Q*=Wfm0${o9B{{Qei=~#}~>+=^L z3f9>B|2dM(6Q||9Xu+CwX=@&xPW)bWwf&Ka|AV^nILXi*Y@RLCTeH_bR=Jf@aMsmy z?h)1IyCGqWHSt@xC*=mXY9If)zpapq&L;g;s^$Jex3`zLyjc48ZI9g2#}yytAKz>|+R(mM$;PfQ?2-Ks zcd^{CKMS8`o0~Pq+>!iqO)J^eWwzF*_Yc>LPycbB{f^oPg%9@@EoU-oin;pp)8nE? zzvtcP_#yNn{_=y}+xb3zx>qH?UdjJXCwsTY{^*>;uXyzuDpr+$IX0>2-bMrd59Q)D zybrZpMV5U2F!5(W{082mO7c}3xGQRIXzqAf6y|0by>Ek2`{FAWrpASzKdpZF{p;zU z6<*7pZ}6y``1GK#Ue30}r*F%Zc!Ml!$iT!hv z`Mluc*MIGjwQcKnN1Qd6jazi@al-d+4?oQ2{(E8mfoH6jLv6)x&RcquPq&;a{!>WG zZJE5-hGKRsIeM2R?CjAUUvF)_?G+S@pg4z-pk$m-7o)8NN+vgzF_MW8SiTAzn>5@Phea2{Pmg} z>_@#Mt-@IS|2^0Kc3kYA*t;k5tOa+KZae6Iv2Bj^t`(9yS4i&Cu=!$l=XmwEigRvk znm^`Ts_J_B<7;@W@+!kJj_w_fa$&i zSsL*lyUYCetU3#)Wfk@2aq>6?hE+_9*!E5FSH$$dFINqDcEz~)e{8$$^L0gy=ee1) zSI%sxZ~8lH|Ac70zrQC~>%A9l**5P^%Z@#dWwh89x^BI*ZY}ePX2EM+N$!<`d!C6V zS4OICzxZ9_PFUf#neWsldl&F-xVWh0X{1oQ{-u3yCHJev?^+i>H*R(O-MmvTZkyd| zx#$)5EG*9Lx1^O@Y0vAw>+Wp26PG?aT zImeo~c-33=#0)>q4|Du@?$x|}g=dMWf9_ArZdfnb>RP(fZ`;%2=bdjj+T||F{OZ;| zez{omaGi$MC$EH^;eoQ}EL}ECnd>08lk;+n%*UJmyP9N@H9dqZSea*?j z=Un$In+>()F5Q&j)3Hb@xc*_OV<7K)Mx%D)W8nro3VXU&i{EfsU9tCAMoES7j#QJE zGR9K-d^YqIin4R&G&QLfM$Y`WIPd$G>dcrQOhKI&KR(gT`8Db7<5xHHkGZMWT)EP} zw(n4=;{1}{%89-|ESrVTlq+g01b$}s*L$WWAygx%epmBYrN852V-*cnmelVLHRpUf zcep|PQD(QVH{&a@Gt*A(Ofks0k?~{qQ!~F+6^Acr9Ci3+djI3OW_^uo75t7LS^m2; zx<4#T?Ka|R(D)*|ydu^3^VFS^cV<4$XXoDk`9!ZZ zb6NbC=Gp4MEP5eoZ^&emvA=Tmi|Xrkue&S?vjaO?q&ryiuQ>*}+0W-?s@`_+()si# zhF^Vq$`5FK7dl^99G}8*UL<_No0OwnG6!8w*ZjS5DlF!((3(Z18+^6eGWB$1*tk6d z!X^mWY&1IX{BUk|cIA(*DXD+9DC%G8E}e7QB>#ZuLiM>^=~wP3zI|KJWE}cFmE*$o zOW!Q!aNKGtxi9+Tp2ioBrq<~7M#n$!H*Qw(d(72n+`;|8=Y{o0-X$|O@c#UN>6up3 zSuO8KfwsU%DbHut{c&u<->=k8S$CwnhT*nA)zdOg^NiNI-W%+~`}p51`aW+%bk&c2 zy<+dCeb7|)Q~L47l577am0LEU=hvMK5`M9AQ!R)5ttnqv3yM~8teYfyFgQe=;Y(hW z`R}xushst-?+@s)oHTp1LZixYTbpsE;oFkdwUbv|_-Os(*YY(L2W2Iuub%Y3tZcOt zOTmBZp61Q&;iv7N9%nQA?J@m6%Yvipn_d6Cs(Dg%hhx8q%nYt=4)qSrz;2wEBImT@ta znIlJW!@qYACtj+WnZ5Jw*`-C@R={K4A^nv>p%`3~8 ze!sopa?9|CtFrW*GoP4rkJxGNdt`TP%eJ_8te3Cxy?>a(zv-}W=rid}{(UbueGmw# zZIHS1JCWf;^1?-P=O3HkyeuMY!3U0WZX0}*@;CcV4-Dk9?s7@Y+_I&-WB2Ff?W?`2 zHw0by^x@pP>{#b+y~`Vp^1eRx(B7xwVQUS;nruNk@gM0n`z2T#Yz-D)>g4gZR`NIA zBh&69vWJajeRlW#-CfgetH0h5a=YLC{fsMbxh`31*}qL`Rey1h)y&DTc%NA6%m9}O z>o_KL9R6*jBzmOv()Q0=r(3^gTYXc)?1J?v?VqfF;*Dh|{rS1(-{JG=TcQnazBnI~ za>{fDyG5wIp>n`F=c`*a|K4BK%NJQaW4}e%MT6qoE7z}hoK_fc6pLlM6=E`+vl?8{y?=Vm1e%$}0a;meO<`pKOp zKQ1gkbmZWNc!QpU|Nrp3PxPDWxL^8*zz>Fdu41>CcP=V8(=Y6=81a*7xq@fJ%#?&T ztE<*a+|O$3VX28xU0rcpWn#t`ZI0{*WmE4s?_z0Zn5_PI~4<G_VuNJQYs=>C>M)aH?Xrt5dN#sVOmaj^GQf{WXfGPOE-CRV(uJm4v|Oj`TpCIPR8<9UQ@84}GVm z>^W$^-ejMz@T}vlAKyEFe-OKQ>q?b1ysZ}DbEH+A#eaDDB}W}vd+FYin1&Zgb3SAh zIL7XgarY7wT{yXkQ#Y?kBU(RslR{%)-KND>XaAh*s(+kZdQjjY!zn4h{=3{~!qQG& z)?`rzx8)f)wHZ0;_*R7DU`iJJR zSng`2Uu@!;K_a3uS2J(;7~~ekh5xGcDSFpgllAxab!`s2?l-OWSNhg{II)MNS@-m$ zin+xWk|wT;MAC}`V{P2;%bSQCS{x;KcUib?`fZ~F9gAF|4{k~c-OT-q`_ttY(rGr^ zTuzDY$V=3?o3-_bnwCypVjYWG3P(r z|0^`%zL{mWvh?5Nvv)VJPTKJ5)I%Sa6_tWw=Q5_bOZz9!KBe$5M78*!(aPTN*~VRw z6W+gAsCV6U+scq%ck6#-KU-H{xb`^TY^@ISf@7AP{zmQ-Zx_3?F}F=>UgKi_h2?lZ zlSAh}dC$}*V*a8cq5B$dp4qH?hOJ!oU+Te)KKC9>GQaJcn;X6*M4i!c!a40jSNU@a zkMA+NQ+vnT;q~3nU-@qJ+hy6$$gjJ4d+W3kMZEupTWwPpO}X~cME6Pmz1Zn|84%O`*o`-&o>2V zE7U668XsivUdCNhH2vsmv&X+Bq`r#k-$-uZHY|~}oHp;wH@-OQcdf1=;u8;CQc-{V z;?4X!yM1-8IOazyT|c0vw&}*9)hk?=mDDYeowj_%*Nv>=b4!#tjJ6n6GS9r&t9AVf zLra+6>~j~-&CG5M+{3?|jql>4S%R7~R>nw_IqX~ets?kW^R2RsYqc{Ywl|-ySi9Wr zhHK%oE*8IaCvp{zpZ+5CaGS;=-yergO)r_*%llkSe3tp6xx4~J&(@h+E-X33woyhe zh9k&**4iw-bN^S=|6UlqE9a+w&tazI^L;n>uNRK%E|HkDDItH|aNL$@-6Ur)53 zO*ncs^|?ZfhW3Qte)WH?H<>goFS;1Xnl-sQ<<7gJh}5Vzn^bQ}pLy$~6s)&MHKt#F znXqe|+_y7Fq$^EVC%io5Fvq1>bqS;DX+_OWg~#6%xN2{0kj+_gDrxs?&J&!|BD*#2 zN_C5FxRF?*Ud%Fi*2Zp=ozp!!0-k?4E8V^0T5nTU{$mTbhV^N(_1|6B?f11g#Q%El zm1ytPllMu9se9BICF;a}l6!p0`(^vNtvaVtT>i5iXSNM>R;o9h6~4Ii_3mIPl{c?9 zX)oV;IjFsN?TX1>3xe*r-ZN998~yINf`iq$CMTR)Y%>t=xp<9d~dw@tnlF=w}*C=OmE{;2tIvP#GE zfU7zl3TuDtJ@Mi0+KW9GuJKIP&`@BM>z3!VJ7jf|sXJ*$%soGqP&c8+=4t-|-`7}_ zFsJD2oY}rgCvawO#PW_{-X%waW8E3^I;;L|D~L*Bx!(5vo!R|q=X+KJx_@Czv}a7y zERAk`bXn8u_*S<#(^Z?!rj=gQS!4ae*?)of)3$lvc6B_6c%yWW#mS~%edQJY@8`BN zE=r6QKmLt>Ut#~_Jy)_+zOkPP3Hu-=Bh-1YqF2c3=A=lECl0y-1?S(E2*>XBkNeSh zTd4lA=%QB@yLwJ&Z7qAldw9|RgX@-kJbytau8;3xc9Gv&?MrjnO687EbKcFv8ahQ> zK5Sa!M6JJ`0qgY~bPse67m0XQ>D{Vo(oQ0@ZavhUi*3F%MZsY z?z;BJsb$u$yE3bm2(O(GG3n0>VSBl1?|;^}J&a_RFS);^TPq>^VoSl?MQpo!Z&zHk zNHE#(=v!nkXKaen&g6VHw zZ{=Ow@>?eCw$h8IJ#Jjg|C1Dz_2R$EOW$F6qo}n#v&2B+g2eGZ0=6y_Lf2S`24@~R z*!y9F(=P6;1ua)+=YPsIHMdW@@<;QCz>j$4RWElfzwqSyo%X8jvyUC!pcLtgCuHcg&>iFs=|KCMIuCHD^ z7X14#RzGy9+2OPY9Gm!dG_LrtZt|@2_YWP^v8*`0LiV4)+0w9w>Xy%npRHZ3G12FG z=QAIUcZcf_D8zm>|8PKBbpPdsPw(UmJT5h< za#Ph`Mz`e?Jml_9tjfH8FFL<;k7LD3%ccKTui$#L5oscEo8;py!X~Ue*V|) zzs06kOaEN#S6g7-uw(Z@jc;2#_ildTbZPDK=RKtxzMpV%_E4xRlUe${%S$%A=~DU9 zjIjO2DpfB-wks#g^H?~o?0Cp__u5`D=4D%F9?bdOEA@^(F!M)#50ighV%b3q7*r;=TNNT)UpgL1dUT*%Wvvzmx zzPCH}+|GruGUi!g(cZ2@DdH+DXS)m@I{#z+?8R&NLhy@~!ilO6(>x!ET7HRqw^rri z9wUWyTZL-n_3kfx?zVu(wv&CIZEwiga+%n5vGKesKk#j{6})jb;uCwNd7bDgC&Rdc zne`86wYqR-omv*jqp@PKw^U%kU75fI#ix&53zwdAZROpP34(Gn`<7@P^k3zu(vb6T z4!_B}PLJM@E30x|I!g2k_CB^?c24{;vf|3jWis;%KbHTP+*izRY3I3M z-OS_Z`BiV1O|rfttjv`p%a#80g3der;EBHuwyzAWv)y%Mx#)Ybt6z>?Fwp3F(CQUt zlX-`;ELHb#!EHqrx5~qoiw`6g#d%*2`u6m%fr)_5)f}rdZJh`6uAM7Y{iw#;dQ;8s zmZw|Uql=Z-9cHx6xwj@crrEIOY~PcVO?VdHbi{G-iHgn z2Zc4Y$X~m%;K>Z`t1TBcFdsh}U)d{YaBp>x=1fbqr}J*V_cwZVVM)X7tpDP~w@hPme!Z%5qUYq5oRjr< zGap=D#9*d4WpVnHApMAVYuV+t6X$$8eD&z$rweA>I>g=N?SAgawX*9jx6+sKo!|XZ zX11|f{OY-%3YsH%JLfowb?(>}vtZesWtjncD&`vUS!ow6UvWV=U&Zph-zr0%qNJU= zzr+P)3#UC+57acQn&h$L@6A>0$8-N5zdx04innAdcga`N4O=x+Yn`25r+X($C)~8Z z;bgz_2v=ka@2ZJ!3M2lweVul}$j0DAm+PM|F_rcz)io>m88;o;$p1d^YP)j6jJA#} z@6Gqas!Bv#4cGO}dS-QI;jCAi6t_JO{b~L3vB_PgIPcw|=hODZ_;Kxi)R;A6>xuR5 zVMkJ0gTHQ&TDz7zXljFq-_)98&le~C=U11qX>gb!yuDZC!-Fkf?aN~WTdsX>&o??) z`)9pV)Q9_fURmnx4ftj_C(X*|PgR=RA-~rKCr@phu)s~%A*R`)D*EV4%Lwl5`UO}2 zsHAI`2K_V;F=p?X%g}s!^+mnFt?m(`5$ufox{5r_LD$&Trt|t4>I>ianRqi{`O2lG zygP!AcrO2zV5rF2{K}?Cw`|r0EyYytxUejhD6O-Tf zMYCNxTH7yK+3;8DE&L^v7bv22bD3_@-;_2xi<9#dKKh3Re!Q(}D^%mT`FNA0P6TJd zS{HMt;=T>syj-5^7L|CaT)#5&;L8BU*gF?iuToz+k4-l>_)$*MVz*1>v#j`+v9=U0 zIsNJD1=qX(`A=p`R0(hug&sDxIv}3xq*=H4oy5UOOPTMkld6sM5-xF$NxadRpLy1g zUHYQblPtabFzt)|&L8+HGIX6D9%(D(>kh5dvi|%@M_uLE?}Zi>9e=Kc=*>Qselc9H zJ1OSS3gPR9iBl&pvYvaa_}U{c9)>MCooI zMhb>o;&D^` zH9PnHdAIOE+Tsb@9p}bwt4U1lOV-{deM3+2Wmog^i0(79xa^vCw^^Q>c4S`4!IfT- zS&Y87hca=?qzIP z74HzQ9RA>g1>OEjS}P_+M5*qRH=WeXm$5eR=e6n}ap{R)Vgs^WlxIX;Rx=Y8PqL^u z7I5mL%0B-y0y06VvIqOP<|`_O&Aj8FUZBo%l_p!a_@roqt zw@FJkKS)`%i8nDai)-G2*h3rZBU$x-lvz4^39G)y{Vh3d=jNl+s#`ABOZad}pI@xK zjc2df?LHn?kG)Sbp7#1QYc5zIvaqrIjQs8i89guhFQh(`!cY~p#p2=QdSr5Yn56rTk>sZUn2MJ?|zy2)9v0&Js%k; z*_?l@jh|Q2y6^HVp$zvs>Z?5SBDj0yi<{GO``+a%yL_2CW#8yv%2_iTBUv1(bj z#uG8AH$e3Sg6cK<5L(=FvqqMfJHnaVaibk9(^WNM!o`6_W=tHiJ8rJKK~ zH@hEH`rddWw&+WJ@}l2o4<=qc8gYXw-u!0WVTrwOpO&o^%yd5=I{QU&gmqHo&*13S zb$%RE-ZWS==1&M%e<7^dw&EglXWuuM*hzcyByKKU7w#UVcjb>_i_6|9^POk6Rkk~t zo=QKgZvI%TTCIzvBVXu%+1DR^%N!g4PHXWZlS`7PdTiNehd%lxax6nIOY!9_@pCJy4?jL+TK`|GQR!%B;%xJ4%daL} zb5LiAD?D<=&~RE`UCS+B{``=WD+O~`uF2S?5LNp5;)K8~;~AMYOTX}i+N_9}bWy~L zrE8+lpTiQ#o|`WpTg?(xs>`Dp)f9Ps*{7;mImZsTOn9Ail)b5>Ncbf~r<$hDmKB-D zb?5TtPyHBY6)N`QdcCs2e7BoDxjj#EQm5HWmt&j8%~<>QXlNqGQ32QQW$vnxA^9fW z>h0;*C3a;l(|eW@ARa8;k~aGyAMflXntcx{R|td#bn0F|yqxv+qb+L!jw-1q9(0(p zX4R(S!G@is1|k}oTHCMfs5so+HJ7&|<>T%d_y4A>VD!50a@lBgtn87tAYa$-d9%{$ zbT2)Ab$gM?@;t>j=WQz*Uq1Ty_;KU8In7=N^V-kk{+qDqWP-*2-_7=6?t99!u4T-a z=)QoFw?y`i>YN`ZSJf`_T$T{fe`RLW^Rt&zwfH)>MVF{uRowKgQQA^t%IC1tUVg77 zG*nOQz2?ib#X_A=;6?Abch}lp?Ko<7OJQNMWYnT7?>8P-x_7YhzyFkCcfnngR(bX= zJoT(=YT(vy(Pu?u#M*z%iZQ#sbH&Om@B)GD$DbYcIw0&}8hO>LT*@hTQtrGBtB$*$ zk6H3DZC=w{#&p}%X{RLm&Ng;t^%c!Y^*a9JlgqiT>Bahi(fyAE?r|#q%YVDFA#a6h zr``Y14B6f9N_?NSyInu59hG`JwP@1^rp?w|iz}z7cdZONvUzry^=hU0TW9XyWIJ};Q3XLYu3iODWed0F|59CP+Awm!jOxpU## zdcJ9%_3P(JaD9zRzH)Tevy)+3mu2(1a(UwK1YhQQ-@Zco|MAxe=R;;6+;NIoyxo4{ z^|g<4zWR_6{~5V@un*KTVTjmwc(@_1i5p%kJwFzux7E+pOnD zZ?XQ|nSMBU#nvZFI#_Wtr*!ep#{q$*Pu5{b`;hnWtm}y%u>*xaMxQ zFLd?(`Ahw*LsCqy+8Xq)x+CZ4rzd;Z#Nb8Xhu3#w!!&kIO7)!Z2<$(!f*_(#g*g9XJKOW#J%66q-G zUcO1LY)QXW5$h!@@7;>qf?19V>sM>v-4>MT9KGfBHU1k5bWf~Pzy5)}$Mb}$Ui8ev ziIbzeH`r@vPJI}@L~v!Vl_h^*YGLOg_U*qO8%{kQn6~S&O{iw|xottMcYG3FevEan zovmBDW9sw0>&h(V@NykuD-5_`So1>Y=fUWw9c$jWJ6*6Zba^h-dx)K3f^;pz!=1c` zg81uf*Zs+NG=BA3eygq22{w*ZyM!ma&f(qv@87OFAHQ_}tG&8Zf8{s!oQ{-$%&c>_ zABd?GEU?8ZUTi$Su)+DgHzaqkaawXyM=!7i8?&~je=qs1PFKmC1`XJRM6h%uWS zB>Oy>dzM+B3=5x2;#AA|mtFf0DC?GFu_?`B7FCTDsJnfvmG{}(b$50zzO?J4PfW7#9fi8^75gV_pb^uYkyD)U1Bm} zf_N&cp8WFLr4}WYRW+T4mGgGZetk~6+qP!^=UrB5_a(e8BxnEUSfw~QPGG7|%~Z4Y zTbX@V7nt2Ym*=W7spI*q$;Dp&Cw*@9@U7gc)VHEqj>py~B*!ItI>R&l2O(x%2a0Af z8wz_K@nIDFAilrYX?j-7g7yDoi{kzmm{sq{jrmZRw9diVcme-h8C9tQWmo2ZKYl#j z{#{-&<%G9c`uPbP{@b1@&Z-YRJD*u_VnWso9YxWh^2fYbu z(OkRjM^(qvx1Fjd5@PB;?>gj~J~!(@Z@5$W+0I|3cWW-r3aonf*#4WbS8r`O|H~CJ z=HKUi%xq#0wl(}0BW>Byq?PqfLHL|?gx01lTN@U>5`N|tqG5Uj*T%=n7<08_SU&qti@YbUIjKK-qp8vx5vL1(Pcd9y`~I=kR<^Sn z{383V&)=x}ZGZaT=#L?fi`vh#KYxD8PHw;4gQBBLzN`zG^YT`{h>U*e!Z^ki2W{^x zKIr9^mk^w!(IUWlc7wW_;3>1Vr)7V;E=I&zF2DQu)^4n7~`z0cp#Rc!)kPtmIX^NbzRhnPg z0?U1}zFei(`?J38(^_Pp9rpI*zV$y}pEPJJsT= zc`qbax-~m2`rw${*SDqf*NqF|&JHR2_y3cc%^SOY6*EWW=Do?h`ZqGPwy!wxv1-nQ z)vrCyFHJWpomy@dk{$cWFYw1E0Fo9VqH(yqH(tZmktw#_{h< z?yGm0|3tI66>(bKq+sys@>FJ|4(>F!!ZGF0! z`_HC*^Y06Om8s>8&R^ql>8)7B^5d>El-FLDalg3q-|UvVg}o2T2!@d4*#Vc zd_uqc@9SLU@oQhRlI8iluAJH2Hx-tjl#*Hc`*|7jM(w#XS+AvPZHd=?ne@Joedng` z>X2uSCEKcfY@7lg-tG1~F8?gSn!7$aSZYI|-vWs($t&)8tDM|wHqm3>mzgsBucNr0 z2JZPk;Zn$g2|wgMe-e%|f1=Tsl=S`FwO^}eKi1@{Ja1!~k-dhmy#0s`=Yi(KvFQ(F z1gz`4v@NbSap}J7Q9C=M_ipg1Gl52tuB%FyIrpx-C~UAq>aD%eCw&j=ww}z{*-pB8 zg(v#FcUt*`znA)?{(`ltf0o(B&{Z=|EjykK|wkfdxcOd>itYq%2Vx-t)Kj$z)$L^<d^Z;CM~%}1)VrMg99lV9AFx@_}iS*c96d!)s||1--b&bVL6{w2_V@~ykR&u6T8 zU$dxg{$@+pB^)n}Bff7*InCj8`NU~o!Q;ZbQGplUFH$;mTk{5^iig*MwU?Bye*2}% zR;hSi#P*wYk#fxAmuxcHm6LK89qbhI7XBc!Lg|I@N%kK}za*08Za;UPdE1$*uOil~ zayl_D>OaxS&qy5{L(nbfoI43Am&jfY#KJMplcgvsmTji$sntwZWmrB{`1w1r;z-zZ4TYj5C zSuM|>6UTGh-*MYbob+UN@~Dlbkc)@>Wv?o+^)EcRoNH~|SC8c{)bkg8pZqyW<6>XKvcP2)jr)reu4|ii zZfW`Dw?N0GkXODkEY&F>uO*=^#&2i9yQ9mZRrymdE3Yu%o4X^eQL60R4B;n}cT0W0 zRu|f5>f*!CF1Bk{d$#lL-xdFPr$4yVu-r=Kh~E)?QPbRrhq*@c+8tO!C(XEh%Iw;? zjckjhT%!{IYft?4!`UYyy!7S`kv*HTqBG_NE}W^slJq6bOSP_c)hau&-)>#%zx$Z| zbA;LCJhCtD?&X!4+k3-d@00o|hR?3#`(`ek79DxT+2OG6xd!R=4;GzO%vRnjbTxF& z;ax|nyFBk%pVwHh;@`gQ`TX-l1*a?MJhfdKRg|9kr7hEJ?<>BfxvxI0`@3-OTJFvQ z&$^U9vS-Upd|w{8HX}o7Td&3*TfY--OAbt4|E)Pg$I|N5vI!?eB63n3*IzTAb$xHb z`cxrV+p2$oYBQVH{|GzXdu6rVoTR_WQ}4V_@pNiP49RIWQ1VM|o})5F^q2M9*Ou?9 z-uGOWa#+Q5oV!nF%54)~t|R`}k{DW!9*#TZ!m)>IG3OSELpi-d(VMs3WUFIdU72)O zq+Xl%q-l*k?~=lv&=#Go8l2Y-fAYH&`}IWPW&fy$O|NAu3QxBFYD@O;tymvA<-t{5 zyM&OJOK-V2-Zg#EH*@l<-G`sgxREfS*Q;W0py}O0F-GxQ=9j!r*2Hi>Tg-N*BDQ2( zb8Ulr-yDS*%B!Yaifq5vIrG4QLm^;xVNKI~*#Pb)X zRguSTMP!*-E=btFB28nC(Jsdgda0eCruLlscicl2%={$S$NdE-T;jD;KL*43srY@KT| z?G}6W%$bL09!}g~ae}qv#%zI>m_J-bFSj;KJwM~Ad9K(7JFnGuW4`zt&3N+p`+tWh znHC*QuaaZa1efgGJ^4HT@AkiYWek?rFTW*`ckylx^YWU_WxxKckh6c=bThK#>6Y2C zFE{1oNF-_$ufBBgNzR#e8QH%RpKQNUZ~nOF%zDOqPcOgD4OL9lKKDIi??tgIOL(7b ziH}NL$h7bZqtCaAn{EmDJzcS}DQiXa$%BEh$J5i)4)APzem3Zicj~(}H)nKREc@2% z=ODq?TdsLLsi?o(xm|MW(fbBL=YmDQXk~Cqwa)u`VgDJwj+qz(7Wh`0R06 zo|aHfNL50v+GDOJskk$%M#jvat1X0T->$l1wPa24<$}FouU!bGiBG|aPr`{$z=@B;gB$FZ3sAF!K(q^=fG-~hg9-x!!wV3f zfq}slM1$Ss%**E5%pAwX!_MK!9m2!T0rsx|G@vv=>Rk8)g1GoNytrNXI2afhKyEdF z%D)HEV7I!$-RcT*t0Ty*E)cgCFx}zevv9<4t1~y)tQwFR3=9lgK{VJbG=C$T6~I)6 z)hu^zu)9IdWvmMD0mmZyY!Fu(7MB?e4B#*T30g8UFo4nnB%HnAZU=`m*gj}DCouan za`9QX^BK6H2Q*U&R+l(&L(|>_kVOm(4Au-#yZ92C+1uE9SbJIenERO+Oc)p#DnN0~ zz`(E{q!t_>;B?~7r;xzKC*cTAC$8LiaJC0G1A_(w1H%TWK2cDZf%Q4_vN`oK`}MFi zvof6k#ikF)9iX_n168|*3rD&__HRHjR!_NdGcfotFfgQm>|%FJ-EU7a|_fwd3YEVpo9^~uXCUo?=3ux+(3EBk57SVAtYd2_&8i4Y3T%1Eg#5S zu-mYuC1~6_Fs+5S4I^q9K>1e$oIn^D-hjf-iBF&plplLR`LTz^kx!!ylpmYfn5!7M z_%s}mvY-n$(|d@JD=b&KgW|%1fq@|dYGx1A%wCY0JP zmSA9DSOV3{3k`>6CU0g- z*=PU_D_L0B^RNjtv$rwzu=TR`vGg;8+$#YpKp7Yq_JZtm;uGj)a_5tPy4QtIqnXu@ z&wwch;#)_UbDbb@5dziw4&*kRaRDtO0+=pfEzg{|!Da9Qs98{o0pzwVP|g&%+uY!8 za|F4~h0mY@&1o*&4B+xv2O5@1uyhOyFAq?7fr87UnVnf29A2Qb52{NNpnBHf2rp3n zXo0E`g2e+)e}mJYJKqFG9L0zuH^|N_Q1hH&cJfVNM9v_fx@Zp@C;%83)Ik)uE{X!D z3lJ9<)@1_a-;e*X$uom%O-vbP22kmbO&nH>qRKHdfC?N`F;KQ-WZ(ejeUJ<&pMhvO z2GE)62=fsv1_ovZ9*`0gYzyXLii7H7CI(gpSX_bYC$L(OIpCZF` zZ$%OVF{`2CM?oAU+z1u_jwA+RwnN1Q!8Aw&f_uSy9)@=iE}WbU6$ixwT#$i*VJ1}k zHnJcC1H*i1yhK68L1iq6c?POp6HJ3d5SSTU(joXT7Bhn&j0vYNf%Su0r*I)SgPB1X z&W15=K-~k27f=}nlKTuc2UGn|s5q!@0jY!G|6p+*24^r06J=mvWrCzbHK;hKyn@Lx zgIlC99)y+ytB19^p=B2X1A`e8q#P)KD1-MeL0o1AP%Q{zp<-r?+y#+mW{`$3&`4$m zSS~@8U}jK66@c=X8I++cREininnZ}Zg6cX3Fo6(cU|eU-;}E}$!<@%V3=Bd@l?)8VAaPV7FwX&pcnCAZod>|GpnW3-28J>m>T7U_x8M+81T!BR@ZkOu0|Ub$ zsQ3e@IJm#Wz`$@7hdKYC>J6avHMrlzz`y`%Lt+b0Jr;<+(CevW7VP0X9jZP6TGxa7 zN(>AP>!9N3_0d@t1_nhYRcNR&z-#W8IL!ZyL!6HlyL+T?h-=^w_rxI%YTsZBpF|w$ z3s@oH7658c!}?7O3=C~haRF$P0NgKPU|;~X8?l-H4yqo#K9ysGnEyZ=5_F(`4v1yL zhCLj7q3SnCf>bdufcq#63=D-h)OX~uFi?WojAn9aEK@25HIJ1xN`!uzyS3dK<@0up?)h4 z@v}I@8RDa&{EXb4O*~Q)3ye!LQeDejEi&_pOA_;vQyJo;+{5rl>-jhvFvKGinB*oF zWxEFC26*QN1(%qWr6!l;7kLKw1;?8@XO!k;y9OtE2AjpZy6WZRCnx44=42)oBkMOb zN-IiDjn6MjEy_tOa19DJh}TQb&q*Pq2FWx%A7^6*Js)Qy5Mcr$Org3hL5_K%Fm52%Fiz;hWHWUHa#C_bC5k2Ai@$v7#e^{Lof+;h#}ZbhNfT< zu&WHsz-+KiBd|&%uu3C{UWhpsP^W_<$2>VdCnq(z#MLi2-q6??!tpOC$;{7lg}cNE zY`783&!`&95X!)|8-bl{WQlBxX<|-JezI#WL}|RckH3?nPkelFX;Qprd`4ImzXA(R2HOqCc9ds zyeHJ%|pKBYK6J|i(NB_|cCJFz6S0_64h%>>8wU0;&gW zk!f*xYAU2KKo-VQRxr4P>lLM@>BYyVS5(9oq!tzD=OyN3mQ==ZIA-*&;E-K9{$;?fKIL6t~HOSkKbhm&D z%HR?-(_A2xONb|i4AfQN@*K(rM+J)OV37%{aX~INa(53f`q{QM> z6VJTN5@(2GFvP)*L~3t?y4;{HD`;F8)Q*JpePH5${zHH^ND@4z2pSh;8XB44h@oq@|S`3v3g@Zei_$4H9MPA&Dc$;~%IvdVDcL=Qlv+BgdB^ zk~p$CHc)X;eh)(m2VbZ-$eeH_@j4{&2qf_~B=JZj@pw>Tg2pehzh)wdBZtp2BynW* zXOP4}WAm`|^8hLiazCi-fr&4K4#9%lj~p+@k;IYB|AHir96qej@hXrx(MbN{fr_Jt zzaUf`q#il^+mOVO?cIqaj+~yKB8el14<~e-3}imCIg(Iukb6M0Vz6*fg^GjJBj*bp zs5mIxkmKC~Dh@ISR0qM#afXV6%t=5B2R|fn8N=e;txIviY}>#F5kaA0%<)bSMBFumgoBaynFm zii7M$PCxx1&qMPCa{63>B#s=vwjj@7Q6GjRj;uZ#NgUbyDkO1a^^=gqk=3t85=T~l z1c&$)BynVOwnL|kK;eKaehf(*+5CG*;>ha1BZ(uc=MlwTu1X_`Bdd2q5=S;a6iFOe z{YE5lG`k|2b3~WIia! zVdj5=ildwJ4@n%k{NaMmCxFZWMFq?pQK&e&If_W)X-MwTg^GjB0Ywqa91Ey8x;b%3 z;>hJ*36eN+xz_;|2ZbAQxi=Fk4l*CP+&c&r2dPI6=hIMekUK#^0(0jBs5rh9F4iyK5 z19G@6MiNI3pH)zCkiE#^xd%xcxqiP26$hD*Y|cZdILKchCMpdB%g zy~yF?i6oBf-#{dB>d{+apd?4hl+#36FI(0pyD9&k=1uV#nII-MiNJkm-SF_P&j~?uyEK8 z;$R7fM@Ztx{(Xfcj_lvxP;rp?ps7cg`OF{=7W1``#F5Q+K@vyyZ#YyO-M=MJarE$M zhl-=Cp8*vIsYg!dtC7T!)A?bjILI92@H`I{2l*G2v|;|e4iyKPkDSh#pi4_Y;>hXB z6iFO89Bh%qk;6F(Dh{$2lq6yH#zVzH<|EtNg(Qw_?{*|{WP7h5i6e*q3#d3K9FWr| z3v|E)WG}LM38*-_dSfJU{dGv<$l*2vDh@Iq z6h$!e7eK|)&A);qj_j`&P;qpBu_z+iW60{oq2lQ3HK5`kdy&(j36eN+I?P5A&qAty z3y{Q-)we*!LG~ht^8~0kC>%gh3JZtXP;roZki+>HR2-xpxt_WP6-QV95-JW-4+<)n z`R}0O=<0tWi6hsuoJxrBM0SrXR2*bJNGr^IC8#*M`MOBr$mYi(i6f_^^)ev$Aji8TR2<|UWd9l=i6iItJ|uDE^mz? zU&!Lx;KkygHQ)>k$l_K=;>hVa0Ec)kk~p$CtB}Nz-FX{_I4gAE9Tbnq{ZlTeI4FFO z`(-Xj;>h9SgCveT4z?Ic9N9g0ki?PQ{~t*lIo)zW*Xe-VgPhJqk;IYng%*-Ha(Jd8 zi6iH)LL_nId{KrZj-38CA&Dc0!!9Io@1s`T_0f zfTgQWkfBgL3m@J%E@naUBo`NgUJ`2ZgX9nmDxhWiUe%hnZuI zL)-y}IB4$=$R2ce)S6QIAaP{(6oU+bhCi};&^{uN6i7XCe(wbdLem2%NMP=n z0Tl~jIlqJVhWll6WmQ&DXBiMXc*$L7QTbBY-53=_FG^2plV1VRd;+aqb zKy5Z;@tJHOA2Kk2+6KttWl#r#;u=}}-2xDgfdQ1KKrEQ~^PvURN{}E@IM_oAjBRM* zF!vln6PE=It}`$&oJ1410}TQ(Ffcqo6NkCyIhy#LP>6s8#Czay1BK6HP@@L44<1c? z8mQ3<+JA*6t_lqpdo=MGry%Bgpou?9f{2HpiEn}yY_NO>3%3O5Ml@KygNYY@f|!$w zW=^*YM7#`5{5Z6rtw$5T1te3zThdu{8BV=erWn!f+j8k%|PqW#9a?V%-Mk^ z-UrQ(htR~;py757O?(}+;cyL2{QFgi`K+Kq94TI4?%_uhhq*@*O&sPPWoX3!OAphb z<&QR+__N0ldw)XL5y8|?gdPOK3SIvL6JH745iW!#?#T#AX!2;{F!gF^;)>9XxOQmb z>p`7S(D@^1;@!}KFak|H1-jra9!>lpwBb{PCSD2U!)Tbl@}T{+2~c^MIL!Ui(Zpw7 zfP@=pzY~asu6`q$`dFy@Pojy#%m?j{LN>=6TH(LIq5eIZcn@e$kb!}L9a;gy+;bgT z8NxRF!^Dq4H*9O;P;Z1LZULTWG&%Dw?H1T=sA>v=r#BV^$ zc_wJT6&9YGq4|ghP29U3VvYowcnGL51v&=?O?)S4GM|Bg!30e_As%9mFPgY0bfbF? znz#hizb$CuRc|2X^q`5qgx1R|(Zubb8`n3YiQ9u3*PwG=(8RyBLd=J)ql1M{9<-tN z5>35hCq(^6G;sy!K>&Op1CYwY=kp=z#n8k#q50PsO&k`^)@b4Z(8H7>(8P_PCZ4kh;?7<)ab9RXU4SN@22Hms(8PB_+qWmt#2-W3Etk;5?V;|! zg(f};G}y+#!0;ALTm{;$dk-D207-+|ffms6hY{M5fQhR^^DiHo_}ym^|B9lCzlL@M zHPFOi>h;mY#s5IeaYqw(g4SEGb$~GUEP4o0Ux22b7rMZ_7EPQV+7W3%6W<3K#ARS$ zScoRR7+UYIKojqPriXKA;uC8i?sY1P&ADDmtLdS8W z(8OWoJZv2xO#LHhhsG97{RwDC(FIMs1vHq-z`ziLCJqb#WHfPoP$!asfuR9S92U;) zXyV&@AmOkKP22|BQQM3r4vWVFXySDnAm$uL6QBJJB7Pf99H#yen)qyJJM9meI7~e= zG`+yWQ*sl;d}%asn0h5N@hoWj)*ek97GG{?;>)4!`6M)PQ|LfTKAJeJpV){deh=D? z?LZSxgyxs!XyQSjO&bgh4ExZ;OF)Cu3=9lM(Zu^elLHJ440qAQtL8z%=Lwp)Ewmr> z2Tk1TAVfVUbYKn^&Y{qQV+7E|lR<+h3=9k!XyR4S4!u5__!ek?!5vL}B52bI0|SE} znt1GWh`dl>eztD1^6-~SwG$;$&caJ9i3N+XQI;#s!99GY+MiV!Mw%-n; ziEo0A3!g$04_gj#|06W4g(ZpfxA8j;oUdX{v3_)n(u=Ti6XyUHWafTW+aajAX1x-8~dH~ZxG;x^vm1yGg zpzWdyXyP#SH_*ggp!;Mvq3gO~;R91Ih$fy6?LX?FiNn;Jp@|!(L&7r_O&q2^6-_)6 zx?yZ0ns^iwB)!c<6MqLC=-q}U4pYAmO}zdr#67ps#9`_mqlwEv+tsk6n_%I?1)b>N zfVQt;;`2e1p9~BPs%YXc^}1-{Q=sL77n(RseGr=XFKBs~k0uUl|CghQM?l-9GttCh z>KCGkTS3F~Fq$|_{b@Au$VKh$OF`=)8R$BHSh!sQE!F^yf1-)M22BDp zFfh2GiNn^#9`_y(8TSagWvPf#9``}qlrsF>${U^;%_-1>GL9*cr(@iWl&m@H`VI#Rs=Q?H699y|$>o_)~7Vd_KB#Pgx!y=7?P$Drf7b!g&$ zpzdFQCJs}-0!`fIBg8$Y(8OWtFQJLMLfhv*(Zpfu8KLzFES=nix?dSh{M|i>z1nEv zJE0qAebK~W>O;}Rq5WalehrwtF!l9l>g}MDEz8ivVd~eRiSK|MkjQWWO?)nBQ6U2Z z!wocXZD_pwLKBCnXM)a$z})#9mXFZHVd{0z#8*S>mtZt;nEGfm@ri#S;arO*?hkFZ zw4#X{LE~#Kn)owlep!ts{sEePcA|;H`pbvV!~>z@ffv!lw?fA;)^t|4(orNM-!KYjtf0U6E}fwX#R;N4(m^`LC4i#?tz)lhbI0NI{u)ICLRS1 zXA3lOSijE!O*~~SB)%fi#9{5&L^Sc#eGv5}XyTV%Ld0v(#04fo#QV|2Vf~{yXyUN; z;Yu`dCusj@2b%bFX#e~uns^Sh|8faUTo|-iiGhLP2@dhsXyPT%`kn*Yu7|}7%p86+ z@k-DlRt5$J9W?P2=schmn)prVxS1WAxC?YVDi}>1mJajL#2-V`Lj#)lDQJ792Tj}w z+Wv>_(}DR5mJXMpsZZ>O#3L+Sz|A)MYgBerP)rwyy_f z{;P`+bN-^Khl#U57l^>rmqPnxGHBv5(0;cTns_<%07Y{&@h$lfd%e-brRPG#gV4m! zLhGq4H1Y3iAnFUz#2-M%LpssKVdhUj6Mq36_g;=Bz82bkT8AcX13d`gD4IAde_cWo zhnaH|P5ks6i2FaFiOWIzO+V1YH$%t41fc017BAPK?Q;n<@i6E(m;stNA9Q@)98G*D z^q@XJG;s@PdJaVsKLPE3m7$62LKoE3p^HP)*+ew)JD|mVpmSr<#E(Jq`$jZz5$Jf! zPBiiR?;+uN4NV+YFT6k#_kqsqeL)l72OU@cjVA5_9sd!6&MU&gAEsUsP5fUo#61RR z;u6q>59Vm%C!zEBerV#GK#NmA=cS^F&xOWs8JhSiXnkCVCN2-{UoSutkA;TAax`%b zXuIbGn)oK@c=dTS@!8OJ;A=GT70`CzXEgEnFOcxzfsR+f!t*0&5fJE{P&Dz2(0X4N zP2A=;#2iyJ@lNP?iyxZ!Y^Z<3(8NQapl)@)|U8m^m$I;u>cl?wN}w4ja#0 zg(eO&XA_z@Y#!w_nmA1TWi;^>(EjopG;vt_@C%xF+%qy zb9KENfrrr-a{`?C~ z9A-WfbUh2qoR6SQd!YGZG;v1I;$qNvIGT6{lhsXV zQ=sKoH<~z1{bV$8Dd;%W1~hS)`WhGe7!^Xvap^2Y_);mnlb}lR& z%An)PQfT6^c@x+^GMM^e=z2vf9O|9W#4SM@85kH6(ZuapAmcOjXySR${`fRBad+sr z*&+-FJd?mCWEdX6G3i3W^ z9vP-y0!^F^8lDDd;;{K93pDYU&~@qoXyUN>rU*3g{m}XD0yJ^hyiWz1_y%Y_I{{4` zHtz%5e+Tnd({xC=y#Y-W?kYwTzX%<7 ztws~Kfgb2T8BJVwH6)y8qlq&?#{;*ZiNn-IJ91d?c;-q!{*Tx(bUg}_IK>i#C5ko%=bnUhnW+MCO&xu zM12{W_y*_#{26HC3qM2DZ$T4>&C~5c6F&>NMvdVLnmA1T9W?PN&9mQ=fGU)X+9n15mG!5*WjkA}`y!YsQpFiNn;lp^5*3_RnGaSYhsjsb7tzJ{?+roJA9dslSRQ{&W{4JU^j{ zheFGxUufdXq2qXp(0Uc-9+-MfH1V(-5c9p!#9``#(Zo+f`!A(v;xP5KXyVGCO;HRC z3@g#ZVd^)ciK{`=#|<=bnED53;)2lmVkXeW8l?F$n0hWWaZ%`ag&~?aOg(I0EiBy3 z&OyQ_8cqE~=z6UTG;t>AI*I}`@!imIr%7nyF!i(0#C3l`?A?wg4pR@?p9^#6KIpoa zhiK};>)4wlNCDt1T%j>w4TsG6NjlcK@1g5+&~aDTzFl=%9)FLFWg3(Zpfvf659>qnZw;C_ zY~4`{n)prVJjGlzaVKc|c`2HBDRi89FPb=Poz+n^aZ~7e^}A@|F!fK-#Py)_!hg}k zVfP!cLj4B|w@c7^L>5gPwhlxUO*{m;{@Djj9Hu@5O}resPp1q`9HzbwO*{#@UU~tV zI86NtH1UhjafwrC;;?lfm(avDq4Sbo(8OWt|DcIagw87|L)W{(!VRWg8%_Mqc1Zg1 zMH7dq4@DDy3!Qf>M;C{V57eWH$3WW;3(>@3>qb_hiT6PFwOv3HhpE4TCVm^*FZ+ci z4pYwr?Z?2vK@~a|Hw~J`vuyr6e(Zo|;L*n;0nm9~7GjyB}7CxTP{jgeS;xP3_XyOy0 z`%Oa7#9``V(8Pa3$L;IT#9`||+R(%^q3I1auL5%?O#KEl^|{b>P1n)HVe0RriPuBd zSusNEVRZ93(Zr3Q>(I2(#9`|&jnTx1g7e&~^1&(8OWt_n?V8Lf1dvL=%UtlYEFKo(%1W z|3edpsb@2Vb23tU7+swKoie~?w9dL6MqYxua7|!-!={6jw&?q zGrkbthh zCJtL?@(oQKw(g4=x*r-A{#&8z+_=!h`JwYH>S*Gyc}x>DahN&QXyUcd@jyQ`aoD(V zD4O^Z=)6)cnmBBpq6AI+HFVwYWHj+x(D>ScCcXo@zi}^`xDRwa{~eQ5tw2TdHh{GY)XO)BSKiC==wmu*55KMU#6kDUf?_fgO?(a1zvXD+lc3`DXyRVbd53Fg z;ya-E>pq(JI_Nt2XK3Q8(DBS4XyWeB`jH2^ULKYXOQ7pggwe$JLFbiJ(ZpfqSfYsw zLGz;nn)pKKI@%yKahN%2XyR9({j6Lx@owmOFFk1D)zI<(6=>qHecxNr#GRn)jSr!T z2SfKIokSD&fbN@nh9(YE{}xSrCbZt?f|gsbaE7TDL=!KB&KK*UiNn;JqKW^9mh(Yq z;xP4*XyV1ta<~jl9M;~bM-zv&H#*V8e?Y@$5}J4+bic_gH1Q7T{;#!Y;;?wxjVAsS zx{v!Xnz#^j{O1Ll_&ex12_MkJe}fKfVqjq4g|=s5;Sck#44U|4==vf}H1S{1{ig^%~jTM?WA9Os#7hN1$9;Ty-n?S`I(Zqj4$9ZO>iN`?q(QHK%PlV2woktVD0X6?6 znz$BJoEd5!EPP6#^FGpO;y%#*Vj5`T>!Iy2eKhe}(BXv)3=B4C;w{i}#uZH*c3w>! znz$;oJiLe|9spfWdk;@eEk_z}ET8p^39V z=ldMc#9{4cUo>&pI{y$f@nz8Zs1QvYwvWC7P5d=<-Q7GiaUJOT(v4{1uzm5c{VOnk z6+*|CPUBF22~C_6+E0IlCJw7NKcb0;K=TVPbo>csFKi#Z2%2~r^gJCMG;vt?8>5NW zL&t3b(8OWk9F8Xb1bX3p8Jc)Jw4Kw0CJtNA-;X8^bI){iacKHqk0uUVKYS2P9F|Vb zp^3xHzlJ8>2|B!xfq~&OnmBA<2?Mm8hJ`aM95~R#pLT&-Ees5bXyUMSGMZ@O0?>8c zHfZ9oeI+hv;@r^jpl~#C*uIh!G;!Geks>tlKhX7x^=RTs&~|kXn)rEWzkVi~_(JHs z`7$)|Lg>8SW;Ah_`Mc1>=RwcgIg2I^Q-1|bd>QoMx;JRzEYNw+&uHSepyM6f&~gP9 zkH*k(MjRZvo-J$y>=c0+j)GtL7Uj&_(+>0g-Q-2gqyc*iReS{_sQ~v@@yc@b7jRAVD1}vOm z>N(KFFF?;lQ9u)isnEb43$}srN+_p9wuLEDKFM4BC$?LKAm^uFvd36X%7N z+cVI_qwYe=;rVFdZ=w5}cB6^&LC?!Nj3)jDy3gwYnm9MK|Mdb*{J|cGyyT_aXsib(nB=yi_mdS4(R?HSa`z987VYz zm^n&l;t!$gwLHn)nQ8Jgz|# zhm~Xd(8OWp97PkK3w8e^G;vt_=RKM@%$)CN;=iHex>C^nOt5f*XzN;4W?cMOp%t2V47A)1MiYni3!>1(eWB|) z%F)DO>g&?-#tJRhn;`-15F&ZuYmzNjsmmS z20Gp%i6#zHuZSl81v;N=k0uV=2jPw;t_fX#6OASg+Xn$V&kW|C2hjBr)oAKr`wp7X z#9u?}quFTUuze7V(8SH4`@D9ciNp3697hv}?JqcwCSC*Wx4uCWhn*Yt6HOdu4kL8D z6XsuY==t7qXyO;3^Nea};vb;QTg#%3eYc%y&pyd)XbR8K?J#4)kH=20qen|UD z8BH9fUK>q(KXlyC8BH9vuHG9>+yff#DQMy_^*LzbGrmIH(~2ezTMyieCO#XwzkVT_ zIBZ??3N&#==>CXPXyP#Sm(avv`QZziI86N?H1P${@RWo0|6t({Q?G_5{sTGz?29H2 zTQ41oCO!u`FHnRg4pU!+CN2&=zitkiIBY%V5;XA#&~+4h(Zpfkw{oT;SwW0Gh zerV#X&~em4H1Ra(KKDvA@own3SCi1h+oAo1S!m)9py!8dLKAm|rkh=8;_=Y-z#TMk z59mDm6EyK((D?;6==s*L^fnP1?|f+DjnMMK08RWSG(ODG#6LjOn;)9^d+7e15H#`I zQ1_*yiJL(8f99i!--d>B2bwr+pL;)=_+{vNn>A?SF!h_!#NR>tgICeSMWN#ochSVB zLe~%cLKBCnXM&z{01M}v(Da~zCJq}*jhn^SYfhHaY-EZ!TCJybkG6bQCAA|D4 zp)|}r&d~L%$!Oy5q4RVZXyWUj?Xglc@#)ZZR3n-=Y>O&r!9n1v?p30*(498DZH z548?W9CknAK{Rog`V(m4TF~_W08Jb=kMJB#ycxP)ofCAa7}9zPSbtm$O&m6lAd4nm z2Tg}oXyUMWD@Qc(UC?#l>1g81pzZT2G;!FxRU?}CPUv{c6f|*|`q^mWN1@|so6*E! z{l{Hs;)YQ3uc3*<=B@6ciTgm$LHdd&4h#Q3XyV+^b08(5@dit`uy9sD6OV!J%eF@o z-wo~Od!vcN(q{ykILti>XyU)2#5sRL+EJ{~@PmajY~G3&P5c3Len$aK95%kBizW`6 zx3WSLKL+hbIiZQ~gN_S@poyP{jz<-viPuBh?bT@Fe9-m1GttCvLG#fXXpK8KLI`RH2E()Hk7t%Ru*E%t8}~sb7R9eik}D zupdnvrv5mZ_*&@t#wTdvuz9*SXyT8c&Ve@oJXyTKg>%d#k#9{5~$!Ov)pzHY;pozog>DHi$!{+I>p^5WB z=jr~ViNogI*rDg@!NRQu+E0)|6Njl+LKAO;u5&O&6Nk;y*`kR@K+AtOG;vsY8;m9n zn_r7Y6MqU_=iG!Q4l8G-pozoGnS&6OV!R zN7$kIVBri?&xa;n32i^9p^3xFF$*+tm^t=n;-1j`4l!uru=ZXanmEjyGBj~LXg_Wy znmDW-wHi$vX3l0badYT6(it>ynEK0T;yKWM7HmHUdboW?Q!fLZ2N#6yzeiUui6$-s zU0-UACJu9tGn%*wbX+JEO&q2^7fpOI^qe2qxIVgjCZnnU0iCDYh$ar3r`w4p{u^5F zUqTay^@DDriEo7Vqrahv!_@yn6JHD+_mGCx^Dy_r)GMQjuZ8Z*c0dz{&AWM^i5Ef7 zLr6mthpEp)6R(8M)5Gq2gt-ScPd5ckJ#2n$4x0E5=(?aSXyUMWx`SxqFmq0#i7PCw(X#ZLqx?T?!FR*z!c{K4Y(0%>pXyUN^Y>y^h1YMsUjwTN4&&H#P z|A($iFGmxH&AZj3iNA)<2hBhehpAtHCawf+pX@^uht1O+LlZB8jx*mv6Nk;yJwg+& zgtjYwp^3xh>6oDX09ZI@LeGnkLKBD0(oxa~jaZZ$tM3&P5Z4&C@MK6L*2GD>#BCt_Pj3e1;}&0zEf_2|BI`3pd!j z8yA{*26TU%5}G(ny%w5yB6R(s6Ph?|-pvb5TpH^BBs6iD`YbeYKIpj(O=#kYL(e6cizW_JzZ6Zp z8G2s&88mU&yxSEtaRF%l{fH(GQ~wi9JOw(>E)8903JXuzJe@L{cp7w`&IU~!Hc#h* zCN2eS|3sjP!{+G{(8RAn?~krS6Nk;ywV{b~K-)|6(Zpf%bj#7i|3T}oqiEu=dAhS` z;{MQmqaV=3Ve@o9(8O(^{R%3l z!_+sTiN`_r8_Yu!{|>Fkm!XL-gwD5aK@*3K8{a__hmA|TMiYn4_x(W={|g-#;)Jee zgoPWdeJ+M34m++pA=iNpML1Wg>~uhVGa6QKKy?xBgp{PhY=9OkdjXyPz`{Y4Wmf`%t2^qhNGymvv@ zdkdn8XG6!q&C$d~p!=H~(ZpS$`+U98#QUJ@@j}tWZ$ZnwL^N@jdot0)XF==tel&5I zduF1E!`!nNO&sQ)wP@nsq3LrIn)p2E`BB@^#P31ZFYQ4SPlCqdK{W9+=)E~7(8MP~ z&kwndCjJ^a-gOU6{10^8^(~sXKlJ?JZ)oDM_U&IZab@T@l_>Q74On{E3C+JUXyWD2 zjcO)n;;?=Cj%ebrefOSd;wzy0Bht{sPeRArbJ4`ppz9}F(Zpf<^!w1nVdoOeMH6p_ zuG?RNCTE0{514jj+bcS2GIGA&uHQf z&~;hA(8SZB>wBf3>oQ>R2s1|!Oug7`iSZ6ipn~uFFRguY~sN z%hAM_L&tMk(8OW+cLSPu0d&9H4m9zb(EHqvqKU)mottRlbb?# zo6*EyKo`Juqlp(l)6EPtahQLPpowpQuD3jcCjJ;YE_xG99OmB_XyU5S^<*E=#H*m| zO#Y&Y!`!0@y(beC?4Wh6r=jc54bjBapyx!}p^3xJk#I*7hn*u4fF=$L&pb47C+K>x zGBj}s=(@P2XyUEVdET{X;-S!Uz;>aDD?!H(ucL|ELiZ2eM-!KU_RHR&iNnH80@^=- zh1&t>ehLLN@hQ-An|0B|Vex2&CJsxtu4v*9p!qroP27SNa?o=Wnm8MDJ#8PF_1J&P{0IyP)G9JJG~zq2YBAP23$iPIUuKd;)ZQ`xTlvtlVRP*7LA% zZikk`JZR!#(0fcI(Zpf#<%%YL6uLjo7ft*PbYDOenm8;RGSS2rLeFg|L=#Vg=A$|^ zaaew7M-zwT7g+lg=3iKTS%;=x6nYN-Ry1)V==lcM(8RYw$EEM0i3>y5f4)K!{|zlK zn4$CDF!wY-&jaB`6K{r|+aQ7_4jX^aKojqR_9OJs#1BKqSKZOXUqa^*{LsV?LC^7w zMiYmHa|)U`ESzi6#GgRd*R`OD-+-Q9F%eB1X8tTRahUm=(Zu7S_1|tZ@vYEvYhR&> zKZdqjKB9@AhK?7oL(d0-#S1LID58naht5xFpoz0U_ivh_iR(i5ZMmR{e}&eA-e}?? z(Drr+nm8;RGSI}YLeEXjM-$%(9cQjV6NiQK1T=9T==!edXyTio>$ujViJyk<-`S2P zE&|QJN6^G!_MSx(hxzLZn)prV`AEOf#5)Ti;|VO#`VAIeu>8e~CawY9@1TYzo&_D3 z*F_U=hsL87nz%o-J>!Wc?gOo-0?@?Gq3x?eH1Vm>{!AsBct7;siZ(QHSbM%7O&r#q zpNA&?6qNBC^v8&L;uS3`CZbTEegx)WC5>0#+G~6zriEo0gvweXk zz8dPD_h{nWQ1>uF^BKDPInl(ILi@RjXyV4u`dR}`oDZ5G9ni!jq3ZxW(8Mo8&*uq5 z6W<6uk1-NWd>`~a_f$0T>(Kfr2Ti;g+OIE16VHQ=TehHyJ3`l8pGFfefcDG&qKWT> z?jz=co__!f&sWg>_F`z_uyn3~ChiSu_o9iz)&-fMiCaSFAw1B;VdEb0XyS~}{m8Xw z;=7>b)l@Wb*ty(u(8Sk3&%xe_CJwvL?f{y&HgvxEGMYH-9)w$H;vb;rDSby1cZ7~( z{6iC84Qyaz-wf?9Y(W!;tvfx6CJr0VzlbIdyNCTQnmBBp@gQ`9V~uV zL(fU%Lla*GUH7koCJyV@=%I;UhqnK$(Zoxj?RFP5@rBU&Rv$F+Q0Tcy325Rl_33Eh zPSEkgdNgrZIP{>2FND^2Q_#fYpylcsG;vtG>_iiv1kI-h(Zsc(^~y~&aZPCZa%ke0q4Nc5XyTip>(%Yh#9`{)(8SL}%b8>}aoD=D zY&3CgXgcda6Nk;;O+^=nuB)7jChiMOZ@bXMS3~3L5Sq9Lw7-8JO}rf%FVE4$pFr0$ zvq0NTu<+apHJ=AfJQ{jVmnNEc5A=KkLp1S8(0!DiXyUN(lOQy4*mzeWn)rI?y5c-E zaacYoM-zwTi+VKif6#X0WHfP@`dMh=`Ox)go6y8z`Dj0yI4mE*)+xZklL@*{`97L@ zSU!4#CJxI-U(m#_L+4F+py3KLAC@mf(8Nze?|aoj6NjlcK@%5*j@JdEiNo?mB$~J| z^nBVvG;x^vN;L7a(Dez^(8OW+XdasQJm~oVyV1m9`RD|?I5Zz!Kog%2y(j4{nm8;U zeMJ)&fVSI(DpAWBSU!?M6Q2fMM{SNK4$DXOXyRv~=P1RXiNo?y3Yxelv>jN3CJxI- zt!Uz~d^813{4#WX>M=BNSbOFynz$D9-rfgj;;{D2b2M=u=seMHG;vsah6&n!fu&m$ z=(r*`nmDXIBZMYC3p&3pjV2Cj&nTgZuZNybtBocOYtI;=i7$q(Td+nGhqY&%(8TMZ z>qWiM#9{537&LKMe$PM?hm|KKXyUN;Ndua=IdmUcFPb>4eX1s#IHl={VUMKVd@*u#JQp6&s;QdSUI^AOpCLRMlceEKz99FJ&qlx=K`)@1I#9`&?1~hSK@@F`KCJrlC zFQSRV%GC#G;{4EkR!`By*Fo!3ap?RcESzEGtsI(o4D_BjLo{(%d24|to(J70>w_i^ zD{q6*#Jiy9QOBT(!^+!aH1QPZ{*)XvaaegXyU7(=T_W96NiT>*99Dk9_BF!PYeM&v8sJcGjwXH>GA+#Dk0uTahZr<*Sb3X* zCawYN87XyUN)HWghQ z8a}yb;2K+CVm~d zkDvfe9Hzb;O#uiB3$4$EJ2(8OW+YYCco5j36eK@*4Nuajuvu>5rqO?(ry{rwV6 z9F|``qKOMY*L`t9>l0Xf!PE<)iLZywAL*fq!}5z6n)njvy;pu{;xP4LXyUh_^BToy z;;{TxjV8VoI)5|+O&pfLmZFP8^VeE5aoGNuQ)uF_{B;RU{0-Ec_h{m<{Pi78+zz@w zP6XO-fQ2(Gf61VUyM2SS11-_SVfo7uOeh9i=IuT9$HT1r}d^B;`d~q|H zI4nQ*pozos<7_nX;!_a!uRs%r<;RU^;;{U+6HWXPbbahuG;x^vD`?{8(D|%4XyUN^ z_!CVWmLD0R^K!6wc>!I&Cy6Ew%a3Yk;;{UvhbG=I$rSvO`HQ-KEFm2FNUs<{evd{6xyF< zhVDCrrIQQLeY;#};z7{yH!(Ev2hi~=Sv2w4&~XVBG;wa|K3q*S@%_+w3VSs1Y0!3N z5SsWw=(^BIH1T}s`MODH;@;44-E1^**#7EPG;w+8Ibc)K#2-S>y_tt54l`#5n)rU` zJopJT@eR=Vpo?hYFmqm`iO+=QYi8(tGAzCpLC??UMHBx8oi~(36OVz;+rq{bVCFbN z)fqx*nD|3z|H~Fld_A-t_d^rE2o;Y)6K96bqotvVPlvj{2u=JG^c=l9H1Q44c2^gg zxI6S*muYC?-=XPz5t_IPbe-xtH1Vm>_}zsjo)4WzIEE%J4&7IE2~AuNIzDp`P5eHz zfAtDY{0wv)^&6Ua8nhl{g091Y#fufRzTiU>-vs5$LTQ-#Wl(<^qlvpg!`~iFTnRdE z8Gt7K725ufK@)F;rq>KK@%7OAj7reN0a_l4;}F+E6W4_919CtU?}zq-!qLR9LB;dX z#3w_?2ezV#UxLodoIw+Bg6?a3fhNubUH{DjT@MTMR|s_do)(&T9W*?>(ZugS^K~wo z_!elmHKK{1hORg3Lldurrtbx4;*QXI?Esp1JyiSwnmBBJjsd#980N1mXnGSz6HkMV z6WOAPH$lfeBGJVCp!>2*(ZuDT^;Zv?_+;p~;uok44SwH)L+lh#B-qLFhTtR z^H)1`9WOtcxDT}dFOMeP4V}-`K@;zVu9q-G6K934AGSghSA(vTw?`Ad3{6)aXyOx~ z^Ao;k;(ws)-DA+iXF>b>nP}oLcjlpqn~6i(Y2|3*Fn89ViB~|!Ia|@hVeafg6K{c* zt25EW&qMdcEJG8AxpOs|_-3fRThPQ|?%atcz8Jb*@DQ3f%$>*4#HUS#gu^v7@n)#_ zV>EG?J71uQGeXau{D>wFbLTfSacgM*@jse4%$+RI_Ae~mo`at2VSpyC4qfkShbGPp zU00BVCVmMzo|%b5ybXtVFAnilXyQE3`G})v;@_a_HtwK_S3vXc4>WNd=)92xbbmZ7 z9Ckv_50u9tZjM9T4u^Ocnm8MDA6Xm@@iH9ZbvVSQp^2wM>+5+q#JAxP--ko|8k+bM zXuWw4hxj)f;{R}ni$mAxz{1}Gx}QQBP5cqG9iWRQJ{2l%jwUVuZ5KJBiJykv%ix11 z{u|nEk3kc+g!V)8(ZtQ5_pDc=iGP8vujoJ%kAUtUnTjU<7rNeNF`D><<&bh?J(_qa z^!)P!XyRX?{mL_F;+fET=O&u?B?hCE2 zOVPxWq3zoyH1Yq?b*lYn;-{hgjyY)J*P-#X5>0$Dw4B+7CLRMVmky(e^Fa5TUqBO= zg4SPm(Zn60=byhq6Ay*XFMmf9Z-TZDS)lteVe#7yZ4U^diC06@tsI)TBD7tqjV3+^ zdTxdVns`3+oNZS$@fXl>^2ouhcpr3J z>pYrxF*F^%MiY;P&cCxyf|v&jw>i*uxC)xMEp)%R4w|?pbRNwWO?)kM93U1=d>wS1 zVHTQrC$wER0ZklsZqzn3@tM%}`Xw~+-OzINFPgX+G`~wi+ZQnZzJu0l2590=&~z4r zCVmw<4jhFh9t&N!Q;a6g4qb2Gk0ve;ZQpK16aNG)&-bE<|AOw5y@e(o1sykIfYLC3 zIY7r_IncykK->SSXyON;Sm==ltWXyRVb{honn;*X%^c?OzzF*KcbqKW%K z$GcXci8nyY=hJB7xzO>?H)!IMpy`kWy3Y^heg|lN zbuY|cN1*M01vGJg=s1rKns_C2Kf48*xE!<`c0m)bgob|rnz$x(UOom*JR4eHWT1(c zK*!li(8ZzSmJMj)2ch*>51ROG=>D}CXyQ%K^@mH)#5Y67OE;j2FM{@8_MnOPLfiQ# z(8SL|-FXE~Toih)$OAO-SZFxBK@$&!)(bz-#M7boFR(!CNm%?IfVO)D(8P~H=am%E z#Pgy3bX_#@aA>(?i6#ymzF=@e6HkEdFA7Eze-0fNO+XW$1l^~fiza>sdJbL{n)n`Q zKeruC{1wzeQ_#dMpy_rYn)n-NJ9ZtKIBXnqH=1}Pbbr|iH1S2ybbb|0{0ekk`y({* zdT9K3kGQ7=FoP&Et>c< zXg|UWP23rJ-gr2gcn7qfo`NQR4!S?9lTIVd209 zZAXcqiB~|=vm%w=HPmpP}XXDKzmY=zXjY(Zp{-?*;pTCVu5Vq<_c<-G2=8mkx9u zNEJ=|C$!vfLlfT%T|l3XCT;|6XEvjW&w=Kbm1yD)&~^T&(8P^F4r5?oc#S5$2zstH z541fFQU>aBr$WmOWi;_M&~v}7(8QCV_d&R!iStAE=SHB3?}6@z%|jDE0!^=-XyW3~ zbJ%91iLZp#o14(Y-$Tz|x`8HM58b!*1WmjFdj8cfH1RZO`LGrmZ?N#$20iaB+?yhRglhTgyY4^6xdy1$79x_$wq9hAd8z8<?QIv>Hj6yk4~d*(ySD=su~ zN9ek1MKp0EX#J~!CY}Kuhj%~|cY(Hx+|k4KoC-e?Z$~)6m3oq3zPSXyPK!b5|CliO+$~<8MI|zYPj-1_p**XyU!l z_SgY5aY!sNFdRb@Uk2r$fzlvjLFMfQc8HG4XyRee^Kc&E5Pyy)J{wvd{z4N!1MP1z zLh}dA-hCX<(n~@cpY@!!2wOY6}q0;7ft*&R6GhzocR|d9MaLm z+oA1~JT&on(0ZgCP5c6My?Py*I6ri~_e3=D!_fRS15I2H+Rxp9Cf)#zukC2!f1u-~ zm(j#mL(lWMg(iLzx_;mjnm9MK9rY7UyaBpjUJyE83X8`&=z1*)H1RCxIagNb;?Q=f zBbxXl==?_{n)q~ReosIX&xDT0R-lP{Lfeb=XyW$Ja&jS>xF@t9u>wteIkeq=1Wo)u z^qi2>XyR&6b6%r~AAqi}`-UdY2|aJ^FPivPXgh})n!jP;3@cB#(8OW&mH?XgYiN5* z98G*CbUs=eP23wgZf1lgeiK>_d!vcN%7-8{@rBUxJO@o2b`N7Qn)noG`k8H8k-q=y;1Yn)nQ8Khzmbd_A=O%|#OrhMwP5i6(v? z+76$BCY}VnKWjajcoDR}bP7$}0$NT!KodU#Ezf_WiQ7ZZH5G)e8-j(K05m++(Zp?_ z=Y#}8_aDI2w?Nx<|IozUq4hF1Z2t`d0|ThOvw@B?NTP{1L(`QSnmA0oKbp7}^!%|n zG;tZ|{>oG|aag)`=R?Io{snExu!r^+wnN2X=0Jz37%rfR zL%aJ7cag-A#|Pd)#X;tS(&tL({*fPO;=Q_HXELxt>lv8(-_ZFKSp5SNUjXf=7^A5_ z0!=>-XyQwt>vDb3#9u-8o0Ox8!_03%6Ni~U5ltLs{ya2s*g3S9(ZpfrwLU@<_lCAh znV|d5Vg7}ke=dh64s)kAnmEjz7HHxycSfR#!`w3!O&qr0YB8F)8+85fZZvV2JFlaO z!`%4U8cqBdbX?j7O&sPPPc(6ud&1DfVeUyr z6NjarUNmu-`Loc(VdgJK6Nj0<1x*~5e%_*q!_Jfch9({iZ67j2&-HH{cLIjV4|N9S3`kCJr-S99rJP!VM;FgeDF%Ck9O% z7CxD1;;`^3LlcLE&m=T)n7vEU#Pgu@p2yL|VfT#OL=%sKj-x(96NiCG7k1Bu2%0#|d<8UdnEC6_#9`(i z!y$eXO&qr0>^GV??3^wZXg?3;&c)Dnjv$(ND0I9}7fl@Io-j0VSUWryO&pf4%Fx7N z@luZ_4hx@dG;vt?Oh*%krJu!U;wsQ_gY{_Q8=>o0kD-af+<6{N9Olj&XyPz;K0ya{2|adYTAX*!y?2(;X8 zMiYm*X9W)NLulgm&~dycXyP#Q`Jn5OVg7}Mr!<;4EIeWN3c}RG!qWv!JLKBCD!!tB-SU4C%*YTnID+Enk0y=(`h$b!z z6|Y1ShvnZUG;x@F`q0E-?pcW@4)gCp9O9?Y#9N^A;Lp&+Vde-z_o<`%R|-wM2|A9f zh9-U)dajlunmEk-Xf*Ld&;h31XyP#S7tq9=q311VLC48p?u3P>F`76m-d)keVc{Hv zCJqbdcrT8*95x=p3f<=c3kTS_XG&<| zuyVr?O&n&g6`D9Ke8SPhS3>u64$JReXyP#U zB;gRBf+oHVnjYq&iNnlUh9+JIo%h*j~tpf%wMKx;+D{PFB>#*L+E}bFEnwOIT2{$>!Ir&lhDMa zpzE}Y(Zt=M?ZXLZ;!C0D^({aXSA(we*o`I*bI$`D;xEy}Cqvf-u^flYZ@|J6W)3f! zIIP~(L=%UphwU>)HzyT``dS>~Q*nsTLlcL!S9YU`AB0W_Jwp?Rx$_?maUSSA70mr2 z(EU8H`74aT-n;;{Ph6q-29oTq5wuc6`m2~8YkjsUdZ z3G*+keIZj6-}i4)F^(#J`}4!^%$%==l&Z_wRwOixz;2gXTS< zQ=#C9)rN|L)Ps(UfhuRvM-zumk2Ao|pMa@{9=pO|gQgz3tck%DO&q$-j=>X699o<( z#6rbk?wkU4B?Chqk~p;K43?=y5=ZtI?A}q3J3;fmTcGPJWgs-Tw)PI2ZIBIG8)3)5{EeXyVXizYMT*<6!F9K^8GE zFi4}RhaQi_paK;KDFek9EIjpah`T|>Vdjg0G%_$Sc%g}lK*fX6#8si<;b`K@Q1N6W zaZo&7fyQGFk~k>7?4ark(8P_P;+0Tw5EtYxXz|R@j3y3UropfPDh~5k2S_6W1H%$D z@fN7~N~k!93o;*i3?9QFG;vtoI0F?2nGf>UQ>ef0A&Gx|Id$%P~ia;F|tJs+C598_EeDh_f6D14yH zE*R9H;xO~SLc_rfNgQN;D%2b+H1R~JxHFn~6I9$CO}q{&9tagjcTY4_9OfQYXhdcs ziG$p;5^7F9n)p(vcqLRE-TY>#ILv%esQHtT#6jktf|@fOP5cm4d;yv`6KL@ZD1D-d z|ADGsizcoNRlgBUTpB9A3o4H8e%QJ*boXC`st1XK-0uxF=PH`GBUJnzns_Nx{1KXX zK2-cQn)o!R_80j6FLD$b53 zt^*Ypgo?x51HC?)K^iI!G6xhse$epIK@tark1f<312l1KsJInW9Nl~u9O6k(ageLB$K9;xO}}$73+S&QC%YpAJqis5s1=1W@8(U|?7e z6$hCE3ZFP=`0Pg#2f4olYR+La@gk`B88q=`sQ3jm@kXflO*HYzQ1QEH;uE3b&!FPy z?*9N4hq*rw>i$1S;vo00hML0w-7gMO4-#Jr73V|~hxwNmO&sQ5F{n7YdlaDJAoD@t z33HDwk~qlTb5MH?(Zo+c#jVi9-$KRh(8OOu#oeLe=lk{_#G%KZFieArgUknoLnAa^mLZ9Q?3IVwy9!NQ7An3OOR zXyX3Rb98^9iL*n`Ib?_KON03fw%<((O?)?W-;g?*xbHtm_?w`K&xWo`cSIA1o!=UO zCjJzLd8Ml7^rKZ0Nr0O2PzKpFDyKlAc=#@ zu{db?vjR;#3M#%9NgPxzbwlTccOZ#_%xQqC--9Mz1{FVuBn~nM7LR9;#6jk4gQ~xP zCcXhGeica^R9|d@?vH+sBn~p?4pjYXH1SJN@efGiAakxl&H0HW4ss_fzF4k8!W$Hx zAoKa4`I-YwoC7M(izE&*M*&)XNg#=X%rStfmq8QPf{H65iG$qv8tP6hByo`WmQfJ* znIegU%!l3kV2LIk0yWf?9lnL+i2pfQ1K^Fadh{*!yzsVz4sVh zy)0B5=6(;T`*o4TLGG7^+G~g=E(sO4f{LS??*bJ^H$MaV@BLDpVY1 z{(fls$;Tny4HXC33o_phYED0zxD8Z%22>o~{6#p#cSFTt=KDj<*^egf3l%>P6-PJ! zCJynhP;r>~iBNNXqKU^t#hIY@*uc~mLdDt8#Pgxz{7`Xp_ekOpx5FXsfkQkWhj=9p z@r5|VSK|;r3l)d?w;k%Qi)iA_Q1M%6;tQeT_t3=WLdBm$#nHp(BMxzX=!62yJ-eai z2&0K_hl&qouNhl-a##bNG01=N+23J5>BT zR2Sg5_BXyVaO@i?eB%wCxJ892lnq2e&}^PuLm zqKW4~#iv5W(aoQaLwpZZ9AKz`(!|j3)jYYJLowxD!-;0-CrLR6G++yb3CwizZ$K z6)!>(2f1?#)ScBx;vjdfhN`be6JH7y??4kzgdQ;6gC-se6`zVGUJVtWi6&kS6<>rV zJ`*aw3{8A0RD3;}_-?59W;F5bQ1Lxz;L&ZVC0t(M7 z(C~bMBn}Es5$FP-7ii)FQ1Opw;zm&MuV~_WQ1Smr;>h;$LeJencc(a19OljsPjtfDh@MW9cq3)k~qlxN~k%- zXyWBi@fxT&y7_HTadh)x=Td{jLFRWs&6$Rz9wgoY6`zkLJ{u~&7)^X8RD3N|9Oj;N z(C|EkCjJMSp0D5#{|FU_xpOtt{I6)@E1}~5(8Tvc#hIYzX~E3d3l--^6Tb`<=SLI2 z2o;xrio^T`bH5S}acihJ%-$zZbL`Q?A3?=E(8Pa0#eLAkzd^;rq2e(2FhavQ5h@O{ z7nE+Tpy{dzNgNcve9(QhWoY7DQ1N;+aV@BLGn%*>RD2?uxD!--Dw?<*RD2#(9NqmZ zpyKH6hnk4J^1K*LTnZ{)gC=eZ6>mTjw}y&OhKj@733Ja}s5rWNRw0Rl+!G2lXC0b&AXI!i zns^CRd^ehS5mfvfR20-hj=(t9A@tskaG;u4a zIOAhTxsL80ZXDt&P;r=hyrJf3pox1z#SPKKEF?=smE{(ZqG3;$P9ky`kbi(Zt=M;!MzUSV7?fa!)Q) zoDEGp6DrP+Cf*Mf7e*6rhKkET#bNOdJD*AoDh{$26h8N%;bVg&4sy>8s5uU3;#Z*J zUP$7|=0rfn(d|uwio@*v2DP^mDh^Yh22G#MIK<~b#X;tP+{px8x3d6EoB=An5h@Nd zzZz=(ZXDuwafm<1A(Khb15NxqR6H9^9Hzb$Dh_j}EYzJnP;qqgr$NQh)h|a92l=ZF>i*Se;w@0| ztx$28`S+pjyo4s+0gbOaIK+QK#X;@?**gtt{$DilDNu1X=)EE^^{b%bTxjAepyCox zahN+{?oq-aZVeTOnZFNejy;UTF9vLd8M$g3^gD zG#<;5#6jWn0%}e*n)nl_cqf`T6ZAaQUNrH4Q1#QG;^^*K02N1f&n6^skb7jH=5Iq2 zmw<{NK@&HFil0CeH-d^^go>lP=QdOv-92xS#6j)}fSU6WP22}6{vS;|3o6bG-AD*B zA7oA%RGb4z9276+(0CC<5(lYofvOip6K{ZuOF_k9{wjp#7bi6F+0gXh0~H6k2V}1& z)ZQc{age>spysEci7$eRS3<>M_QK3>hKi$`KNU$FWd22{IWy73&qBr5K*iC`-v$*& zH~$2ZILQ1zP;<_piT{9#KZ1&*oBswX4l_R*8a_Xf#6jk3ibC3Rf6>I1q2g>WAo3t{ zKOI8+?n z{6wfY$Q+P+TA=PJMiK}4YbMm3ay0R&Q1Mo%IJ)`$P;qqgmm-OS%-;w#XC<2WTB!Is zs5s305NJ4@Llc*PrvDo_#J@ttLGA(BdmL*1Pc-qPP;qwX#$lMfF!Kd*h-*Q`Vdme4 znxls%eiJHg2^B{--x(?nG6xhdQ=st@f+P-d|9hx85oqFXq2h^X;*8LHmQ&Hh|3lU1 zLB-MCQ-MQ#DpVZgPLO+qpytm+6BmGrFM^7ro4*E!_)(}h%zS02IVaJ?6`|rcq2lP~ zKgJ=>06pgbX1)p392PWjBd9npR2~u26GK(8Qgg;x15ebo2dih-X8^ zVdjTH&B;d-4}pr;LdDU|Z^t3N28Z}Is5r=8Q2JZ~O`nI6#6jsH4QlUkH1QOu_ysia z3aI!MH1RU1_+6+ty8EBw5NC#-w*+!0$UU7D((&yM>jtZhj=bj9A^F+s5ymb;;W$IRcPXSpyG9C;=7>Y?ND);dt{*H=R_Rh z+t9=nq3RFd5WfQzhq?a()ZPbZ;^&~^FQMWv_rT2mj6<9UdXE{*{D)9;1kl9qL&X)K z;^^jU;ShI&io?wR3^m6KP5dKNJQz)!8G7$kIGQ*kR6GGHj_#f;9OC^r#Ao6VKY&C0 z6b|uEIK=AmPZ#2}LbTsiusCWUIcrH}D1Wh~>Dqf2w-VPOSL=$g@ig!W9(cM1{5YEUX{h*VH1Xq5@hfQJPod&B(8M1?#qUDJ zVgA*DmM8ykh;u;i?Lk+sjYHfNhj=hl92Rce&;xzK(Zo5S;t5c3bbGUKh)+QiuZE6G z&%+_U9V!lUk37`g-Du*nQ1K&BahQ8x=AXkM{v0X}Gv5Ge&TBMrJ*fB}s5s1gGpPI7 zp!b`B%mLN=N1^+YgptHS^{g}09C0*pd#Jb^R219fL7R2=3`*gmo; zNa7&#_d(5>fhN8SDn1uU9OO>eKEb6(;vjRbL)EWD6Tb`jtghj<%Q9A>^c)SNCfaaE}JG^jYt{QJ;! zwH{3zmM?Zf#X;tS@?#h@Kb}Go2gQp8)ckX3;$~3s8&GkWz1>iI-y?~G*6(S86fiI_ zFn>giFPM5>s5s0$IZ*egK*d4YLF@fs>h+-F=<4mE;xP5Iq3-d7io?{`Ld}my5(oJ= z2A^6$iN! z$J2_$ilIdiNb;d>cL9Aplo6h!aGDFXw zfSLalYCbOxaaE`|$Q)4kEP}dI6HR;pRNM$Ej&8mU4)IW^IL!QwP;(;D#MeW`lhDKu zLB-S1#1BBl^U=gFLB)&F#4kX_YtY0WLd6@<#P37JJE7v}{+$dJ2l)#W{_~*WzXVAf z6rLZU=Bz*ye-9Pkh$hYiy|-d3nm7Ygd>>RC-90Cu;^^+Vf+P-dk1*7n8))K!Q1ORo z;wn(_r)c6zQ1K5?adh|mf{Mf3vkn?Q?9lsfLE<3ym_W_pMiV!Jii@C$yFkSy(8Qgf z;)+mlboXdO#Xx$UW6ib4t;~E1}}`P;qqgJE7t*^PfP?pM@k2GQS6E&O9{nE~xkl zs5s1gHmLg#qKR`t#ZN=UVfKE3+WQbm9AxhbsQFLP#1}!u-$BJ;_QK5n0To9#p9Okw zD@Yt<{z<4g9BAT)q2hv2ahUlMQ1?qi#X;tP(g`>8e0v=vagg~hpyn8$i9dmgTcU~c zK*PZnO`HQN?gkY{cTWIR9OfP+sCyET#6j*+gPN0yCawY%&w`4>%-4aob867U6`|qK z1{H_dYXY@*GLksRUUR7V)6v9@q2deB#Dk&YOVGsqq2gnR2=3WN2vJ`XyTSo@gg*FnED#1ILKa5I(LJ{Z!eNKC_HCF?VX4w zJ{>AP8!8TSPYBfBrBHF0`4Ld_w;_px%-;nyXBV3I4ygDMs5s30WT^SKk;FmmCFt@0 z46l&HLG2}&`Y%v%n0s=e?%{_X1PwF47HYmE4sk=MILI83`!7M=X^JL(0V-|>6-PJU z1BZAbR2*jhL#R2aXyW&w;(2J|pP=GJXyPBB;?-#4Owe$sM-yj&ig%!i3qr+v(8T$n z;!~mG=>DA#6$kkXl-?Sk>Ng;XgThl0D!v6xTplXE7fsv-(o z7e^CMf{H7kiI+gdRnWwXpyIkvadh{XL&ah4SpZe|5-HgiBR$DP;r>O*P!OSMG^^PD(;9TZV454MH4rLiu*yu(cKe)L%b9!4ss{RJwZ@&D$&FPpyJI?ahUllq5kcK zii6Anm194k{+)#+4l+L(YR)_~@p!2Cay0Q;sQ79$@k*%p7N|JPJq*zC#(g-%uS3N_ z?gY7KGSr;gXyOy0;!n`T7emEgpouSpiob=5!`#CGbq_1_{%V-GGE`g{O?(MdTo)=1 zawjM}IiTiyK*eF^z|;pp#nII#L&ah04@2WC7b*@@uL?E44oMsoKCp45CN%L4Q1v}f zahUmApzfar6^EG*OP_0y#6jjChMKbhO?*F8d?!>K-TcEi#2-M#LH2^ohm8w8K@-0T zHUAw{9A^GbsQZ6F#X;tP!rv9Dp7jr++yI&X1}e^pCjJ5{E`%ly>nDn#i8DdtMII^+ za}NWwKcb04+zBcUawo_=GEj5e(8Q&n;{IsjI#BUoG;uAccmz}&<{l2HdkWCRVdoZh zpo#B>nllwm{47*_1)8`4H2gQ=5I+wUhxykUYR+XeaacS5E>s-mes8GxUy#H>?c}MD zXl3B|3t^zE7lMj|>;LdDV5n?uFX)q6n2Vd|ry?g@g5!_=ok&Cfs*2gPqF z)W11s;(<`{Qm8n(`Sm!&=Rn0l_JYjMgPOAdO*{uGz6vT1Gd~6D{w+{(kU606serow zAd)!9{CcQ4N72Nqq2lMz#AiXpFQJJ~gNomVio@J<0qUNoIK=-!#X;@_xo0EP946@b zxG?ecP;qWF@qxGE5YLB-!`ulQ2Pj4p zKL>SB1ymg7o+hZhZD`_EQ1Jz5;!~mGt8j=Phl<18b02E&X*BV>Q1Po!ahQ8x_17CD zaZrBT3dx2H-;u;Y{nqu+bS3Z~q5x*j2I%;bI#e9w9?*OWY<@}~NgNdKj8K0Wqltfo zy3+zl9Apk`Udb6r9Au6I)Esv-aSN!pFH{`n&QNH7GYKjVb0=(lMJ|#!$ozDuIfZEA z$x!h!Byo^CVe2dEki&Ms1A1OHy7@vl#Py-#F!MJ; z%`rw3Uk??xfr_J>?}kG>9x4tq{}9xiWHj*uQ1N`IIL!QVXu4`e6X$@n!=d6J^Fi?& z2EFfKDUvuSUSQ`)uS65S2(@<|k~qj5SbE!rBn~p?4OIOuH1StZ@%>2RAah{p?F5=Q zEWKTYio^U1^VfYG;(wsxApe5g^A~C_10%=;1_qe;Z>TsYR2(D=DraEk3*!*ifr`V- z;e)n|4A8`3=S4d}#nH|8!Xcgx6^EHG4>dm#9^n)Y@#j!+n7vL=^IxNhJ3z(1Ld9YBUV@hM|8a=RFo9Ge z;x`y-jslu^AXHonDh|>Giubor^Bs}ILG=-A-Z>OW99exlR2<|lQ2S>YbRM$`Dh@NB z6Piz3aEQ-=ii6AnrQ2+%I~SmdXF|nSLdDU|-;6{23{)IueihW53uxjMQ1P2+;@wd3 zyJ+H_Q1NGI;E#-AotvXn&XcqehVrdfhPVI zDjtI-{u(Nt4i!gtPa#ws=AM(#@To%*2f61j)SMGS9G;waI_zb8x zx_cHu#bNHb33bmpByo^?n5=1tbC~mq6+BKh%6dByo`Wp-^)~(ZqwH;_^^& zkZGXuM+)kG3p8yFjO2A4xsWX5t`oepyKG}S3t$l)ptV0Vd_sq-7^^~ z4pUzYHGd_NILN;>P=BpO6R&`ZZ-a`Xn|}a@_+6+t$X<~7Q=#TOL=&G36@LvChnar` z>i(}#agaHn@M(d%p9y*)GDsX`{xYaJY-r+(pyK>!;s>GP!f4`qq2e-7ahQ7?pyh@d z4sm;^ILtjapyoKEiC=??`=E)xfQkp8i9dsiheE|+?(u-SCl^gT4JzJ=CjJr{o|AEi zZ-9!!-2WYF?-n$1*gd~Hq2e(2yn~v598LTgRQw^Dcnvh4zQ!TW!2vQEkssNh>!o?n z#95%?Vo-6AE>QlO2sK{;Dh~1&DE&-@rXNEjaZvgZhni!GCJwvj*B&YkGk*cp{4gYO zP=1H41Ia=X2e}8Pz62@`bI($!d-|c`F!T37&7X-wd?QpGWDdyv`cU_8MHAPBitmGp zqnm#MhxkLNILv(5J+M#F#BHGFze5xEhl+nf6ZeIR|3(v!hl>A46OV<8b8v!Ojz|xA zP;nkK@f@hQC{!Gz3l#pa@RWy&gZu?b4?CdYZ-68Y3eP&IIVNc0HBfO|H1U3@xFec) zFI3zMDvs`+5U4o1dlHbuLGFR=`$$0(p9eKR7fpO4RJ;&Pd_7dW1}cv3o;IjB%snTd z;WHUY9ORyZP;;iEiSLJsFF+H&2o+y~CVn0&z7{Hu?w;*XahQ8F zFCSEWE|NINUf90QLNsv$sJ&HCahSa@^IM?e=;lvA5(k+d4mD>Ans^{od@fWRWGP+Gyer zq2l^z;&-9q7Ep1Jt3d84fY$F$IK-o&;vjc|-18G^PCT0Ucc^#v4#mfr`W24?EB20-CrO)IC?B;xPBX#eR2=3Wb*Q}>XyU3+aU-ZW$TU!Vu|wO3o=D=Lb_;ACFak*& zS$z^z9Aqyjy}3ZsTP;)^-TZc_IJ){7P;r=g*t)DmP;r?0XsG!+ki|;@VJgknN!ODuBAj6o6<0+P2bt5E2bp&_KoSR;!vHCH>fzsUXb~nP;-8viMK<=nfXB`BkBd1`Mfy9)u7@q^JhTK(LxiS1{Jr0ii2zc zh5r@k__+%X@kFRN%zW5=F{xs5r=cP7^WI^H24Rwz!k~pZou7DH|42DSJ$m*@3;xP9cK;7?yBo4Bd z5qj@Z0GjxJsCy#O#08=1W6{L7j|cLdDIY;vic< z?uVK02o;B!Uj{Wl2uU1dem2ycFf{RWsCYC~9A^GHsQYu##9g7{;R6H3?d;_$-Q3VwTxd&A5!`eknNa7&(Jcioa zh9-U=D&CDG4l)O}es3C*ILI7EO-O+_3r+kt)SSgoahShg?pzBM2e}gzZn9AK??Vy? znXd#j{}7tE0#y7AR2*jh6{tCnk;Fmei8sWV4BwH&LE#Kj&nOHs0a7o3++z$iM+iwA zjgDG0!`clDxQcY zo&pt5MH5eeif2K^Veb3}wYL#T929OL&~TfIBo6WyO#OVQIL!TFP;)jQiG$o<1+{kz zns^0Nd@q`K7gYQpns^6P{1{Xm=6)t&Q2^ELAGY#s_Ur6F0cg}>G{|`-k zI#irp1Y{#5oq*JDhKh5eiLZx>3qZv|x9Ry1)FsCYkA9Oh2gIYthnc?;>V6L-agg~wP;-3H#ND9cp=jb2Q1M7K@e-(b5>y=BJvmTu zn0xj>-BXJs4sy>Vs5y;j;(bu@HmEqv{JBv7&Oj4~wF4JH#bNfIf!ezsNgQPFDyaFJ z(ZrWQ#rL3zAAyP=KodUz6+a0ThqdwnJ#NR;0LGA>(=N8nQ4`|{ypyEH##9u+h z|DuV%fQmDTfn0)Uw^TsgBZVeD87gjuCY}WqcYun6+zF~5??A&d5J?>5{-02LL(#;) zL&c+^;viRn@8A%+}K5^@VWbAoJ;vo0%X+y*pp^39W z#kZh|+d;*5potqm#rGkJgY1o73o-v3k~k=QmO@k}&v4XAh#R2<#?H8{kl zLd9Y3w}F~76HVL-D!vF!JOC=b3{Bh*D!vga4s*{2X#DQRA$|iY4s%aD)SNqL;;~Ti zr%-Wp^WWnT=a2xYM5LcWs5v}n;`vZ<8K^i&7brcz+^+@|2e}iJ{%=Clr!kT^C_S`7 z%`rz4Z-k0Fpoy=7io2kRFM*2tqKRLGiU*>JpM{EtA&GkK zfr{s#i7(QHr1Jta@p(}3N;L6ZQ1Mzc@oiA?HZ<`|Q1LD_@pDk|$!OxApyJcf#NR>1 z7odp?=t11S1WlX`D!vvf4vY7#&~&>UDh`YH|IqL}fg}zJPj{#}XVAo*q2gE3#M7bT zH_^nCq2iCw#3w_=pP`BOL&aYsiG$)D=FXo`addw%OM*lo`2wU~4C-Ggs5nR#l>VKJ3_@l;R6bXwNUrCqKU7DiU&Z&VdhVV*0YI7;-GdcB(@kB3X#M??s)}uPc;tl z8BlSUdk#YFor5O6A1b~SDh_iG%>4B@#7{uQVdh_knsWwC{32BR4pbc7{AW;ckU606 zSA+WNJCZmkJYPc1`Hd$27%I*p1u_{Dk0A9k^&uh0fhIl`D$a`}j%=?OR2*a)D4f%w z@uC0~hq)7WUbhjFILO|uQ1i{u#5Y65?V;l6=6gcLVdgtP!yy_;9Ay4+s5$Xy;zyz4 z8BlR_^NXP3=;qfUiG$3)2{oq)P5e4kyc|gTgZ&YEBZGcr;Wz8%?|xDxQxfUI`ViKog%16|X@Pp9mFiMHAl!74Jk7-vkw( z1Qkd3?;NN&x_?(9iG%!m4rLQ7Q{Iv?I-VjZE1ytM&Dh~1; zC|~G6%by4|aoBnFNlZm4(zn)oBAcng~NJ*apunmDf! zB>hZ86X%4A&q5Q2sh@`?4pYAzDh>+=n144y#nJt{4@n&4UoEJ;htR~;pyH>|#C@US z=h4JHq2f2t#4DiUchJO3pyE%_#9``RqKU)Qe}amm`}Yr29NoX1vLKa+^gk79FE5(- zM5wqJn)nW=xD=ZB7O1!~n)qX=xH_8neWM-m6cFM}~8y+xym|AD$E1x;KZsy+ivTpKE0h$ik16)!~-cZP~rA&G_4AR$LHzD6Dp4Gp2JXa zn0wYj-E$R59ORyUs5v*$#Ji#5kI=-ILdBn^>(QLtsQ70zadD{lcQkQPs5pZ>$R&vQ)qsk#poyzN#rdG(AYGvNf`yL+4sk=M zIL!U#P;*St#7&{%c2IG2^F5&AAag+Z{Qxw6Bay^G@#_gSCl*cI9V(uNCY}ft&q5QA zhl&@Yi5Eb{%hAO1pyD-1;>hl7g^I)cFkPUw|gw02N<} zCO!))z7|b<22^|-n)phn_%1Z@6 z;%p#I3=9l9XyPnTaZ@yLIjFcLnz#&9+#V_p@&zd0g+bFv2oCW$9OC6ragcvOM(ctI z1_p*|G;wXHcnee<-QGSN;>)1oF!Sx9=Bz>!w}pythl+#D=VoAFfL@2fa1bgEG6$58 z9zgwj2}vAeL?DP@U|_h0ChiXvzYi6MnePB8J{ev@#bM?%LhGGhNa7$Pl0gIm1H(Tw z@kFRNyCTSBNV)>K-vesCAP#Xos5r=8kP)RIf`Ng-2u-{gDsGJ?-T@W2M-y*@ihH1m zPlt;8povd~iibkQLB0UF-xuoscpTytP;r?1S3=FHK@(pN6>mio-vbrzL=)cy6`zDA zei|x14Nd$cRD3>E9NqmZafly+io@K07i!KiH1XR|@$+cnAE4rw(Zt_D#qXer|A&e{ zKokE96@Lj8M|b~c9OB$cAeD&vS`d^u7#JA%(ZuC{%nYR2*hLtXx`;L;MU>9A~)lhR7 zl|d#T(nBRwoC{677b?z&Cf*Gd7e^DH2Njn_6Q2VWSAvRzYzNgxu=~jLk;FmiAqtuv z{Gj3>_ao1bXQGMoLC-&GMiK{E*$Leb(uX7tG6%MfaT=01C~Iv6X<}etn1v?38Y(^? zNgQNOaX7@GtB}M&=6r^#Uxz0C94fvUNgQMj?7YN%Na7%KY|J6%A3_s1fQlbS5(k;{ z09qeiLJ|j=Qv+3h4NbfVDt;SD9AwT!=)Dxrki#bNG&olmt9P5c?u-rZ1f zkoll+fSucU21y)bFDoce85kHYpoud>#cx5yVfKE4n*R|=925@FYb+R8RY58d@d8uN z4;6>G2X?-+0+Kk$J+e@HRnWwxq2hW_agZ&baE6_i<%=fH0X=Ug94Zd8_dGN`WFU!y z?A3vqpMxf@1r;wv6L*1%SE7kKLB;E!;xKo@&gq(iCN2bZ=Q14PhoRyi_k-LS3^o5a zns^{o{328wX0IC5{1-^#p!k9=BWL)7Bn}Esn0hufkO_!*go!Id#bNHrhT5x+CY}iu zH-w6VOaqy32z5^Ynz#v6JPIlfG9Q#~??dCO07)Da4h>NAOVGqCpyIVqahSa@^V^}~ z=;lvG5(k;T3Tn=DH1S1H@dZ$EnEB37_pgGA!_5B%b^mT8agh0!pyupH6F&nLKY=FB zVhJf|&Y+3^gQ~v@6-Rf^eW*ChJ-pEKbw419gWRJ5HUA5mxC&JKCsZ6}z8CbI1a5VZ z2qK;MK*K>4Dh{((9%`==k~qj-C#d;qXySHIaeXxL1gN+%ns^jc+y*KRauq1O1whZM zal;`V4;2Tw6Xc#os5!}K;`LDR95nICQ1JpZ@qVayDO4Qho=B*B`q9K;=P9j46HkSP z=XM<8SD@lB_pgT9djm~;B~<(_R2=4>EU5Xf(ZrLW;;b4Vm5BI-spp4^gX{(6Q$uL{ zDjoF`hxjz8ILv${s5!IH#1)|8i=pD^=C8#eeiSMWGv63$&PgcY&Jo6HVL+D$WkQxEbAiK^)?mP;r>~p-^*l(ZqwH;`UH+bn`uN zh^IltVdken&B;O&Pl1Y;K*eF^mq62b9aJ1-4k$f)LeujUBymvssfU^~15LaXD!vd+ z`~*~dDVq2psQ5alIJ$dwK*eG1$%MM+9FjQ5Js+UvTtX9n2Nk~!6-PJ!DGqTqEs#n? zKaL67;p9RShYgSkL&ZV5K=~0Cp0YT^t)Su{e}UXD0yW~u=}1`k;FmfJ3!6pL=!iIicdll z?}Um^LlbX?iqD6Nqq}D%R2=4>HBkR7HO@jp=Y zXOP4};S96)DpVZi&I!s5KVjyR6Ghz`~p-w4o&l(b|Z;{{L5ntNr(H<#JQm2C!pdm_rT1*1Qka&|2~p9 z$b4C-IgioArJ>@Vq2lP~|AmUf%zp=UKc5arC8C_vgPJ3RCawb&mxhXibb-AlR zadh*Iki#K-97zKadh|0K@tbKrx0q+0yOb_sQ7v$aZtGg^Vbd}agaG}Q1yGz#Ot8q zN72M#>QADH!_;4bilh7M4pbc7UoVivLGIZKwf7C0_-3g1f2cUR`JB2S5lDJN_OB?C zILQ1XP;(^F#1BEmb)e!P(~#4l8B`qI{mw|@AoDLn&2dK)zX%nNf{LS?p8^#}H@^@` z9Ay3@s5zx*;t!zWb!g%rq2f(w;_sp2-Du*Bc93$WA5Hu}RQ(L7IJ)~6LB-MCzaB{( z;s?;g<)Gpx(Zmg);%Cvs^`PRHki?PG$!(}Oy1$-6#nJus z2}vB}F9)dk-_XSEpyL10#QmY-%z7XjA?X%mjxSW42TeR4DlUK~9t#y0MG^=3OAvZ* zh#ZnQ$ozb$dL=aRT&TD@R2<|gQ2Kuit*3m@#9`%g7!L7D9OBJ5#OFZ8LE#K?XFJqA z3(&+{q2jBd;xKm#K*tTX;t;05NFc|sYJx%YN$C} zXyPlO;v!ISkSl2Pbob}t5O0Hu!`%NKYEBoL_*WT-g0`E#M-Aag+JToIbi*CC06(hs9O zq#WCXCjK94{%$mJNvQh$XyW2f@e^p`8c^{wXyR&6@ry{}$nLxa6^Hpt5*qJMpyDup z8AAQ_5lI~6FDt0|U(v)ZpyL0~#Dk#XOa>qu5$Q7kD$b22o(L7^M-z{Sic3JnL8gJy zEzJE&P;qqk>m!MS++Pee#~4k#5GrniCf*GdcR&;Ggo=BjiO+(H`=W`@fQpAf#nIiL z02N1fe*uy>$o*@e=9Hj`uY!u#qKWT=iZ`N(?}3VUp^0CEiua+3UxA8Gfr`W2uL?~+ zD{+W##vy(NDh~25$X`#P=3hV)e+(7B2^B}T_c0Ff-%xRw`QM@D{6`c23Ki!u1euJ~ zKZW{B42QTeR2*hLCv;-o98H`ZD((ms2iXEjw@aYrM<9uV=6&8liVcPwByo`X4N&!E zIK(GI#bNGIgxWhDOYQ6-LILJM>q3+Q^5=UM?UANfChiCo ze+3mscmEe0;yflGm5BC9DAXJQH1S}lxFni*I#gU1O*|DUu7)OF1r^sq6R&`Z>qEss zt^%c>d`R>%xZn`?!y%py6^F%3C)E6GH1T$*cnMS--QGGJ;?tnwF!N_a&6$NJJ`*aw z7%C1jA5@RzL)WVuKoc*4il0Rj{{^iVo}h_yL&rIpOhG0?$_s-kUr;^!ffEuA?~uen=Ce3K#6O{lGeO0FqlwEv#s8y;OF_k1%s?(d#BUPRJxXZe z_E2#hs5s1>%pe8>1A{G+ILMvaQ1czp#5JMf-cWIn?VxaQhnk;+Bo1nyK#wD0C_@rQ zR^I>>2RQ>2Zo(i20|UcEByo^?oT2tkMH6>~iqD6N!`u@Dblc3@~XyOx~;uE3bFn3Odx@SEO@trutuR+B@&IY-2A=La^XyWss;!mLB zFngCn?fs1;4vH`6@(l)l3y?}kJc7a#rd|?%C>+i}&2L8&KL!<_02PPX3p0NfR2*b1viZx9 z#6jl2hMKbqP5dcTd^1!WX8sYV`}ab{VdjT{7z_*y=a9rf=5ski%E?P;;w(_{+i2ou zQ1Sa{;zm&M7f^9@_k4nigPZ~KZzhPrz`($42~vq@{{%qIVMi19fr|4$#X-72@uhf0TqY2hXERH3(&-+q2hbc z#Ggame+()PawjM}J3$Nv28QcM;vn~LhuV7^O?)d<{2^2v=AQdd^M9g=e}sy2Sb>ewLZK?g}3)DD5Qi%gKjLGC;Sb&my__z|eMEs{9M99X-^14$fY z&VQ(SA2jigQ1L({agaIwMG$w!Ac=#_ncxBuPe2oQf{N#%iQBqE)EA+Nt3$=hk;Fmv zvP18|Z9)yf5NgQNOdo0A>X-MKAb3Q}W&q5Rb2o;}?Bo2zN6n2O? zE0DxN=I<7Uh;K#`2bs?S-N3dTO`HKLz6VJhWRCAYh&jiR#6jj*K-Hf{6W4)?UqBKE znKRoHV$N+OagaG3Q1$oG#A~49Pmshx=GZ~cdwh>14l?H&RQ+c(@iS2IKTvT{E&!E# zhe4Gm0|Nt_HAn=JFJR)zP;pSc0GZDLb-y~AI2%;l04feL4cUAv9OB_nahUlsP;;Wu z#HFC(DNu2A^Yd_sw?oBY<{LoG=|&URgNo0Fildvq6o>des5s1g7pOUh(8Qgf;uoOe z=;q(TA6^FSe1ZuA~ns^XY+yqTL87gjpCY}ftcY=z8Tm_2X zCs6nJK*d4!g7RYnG(ScniG$Kl71W$qH1Q&+cp94cE~t1Gn)oKDcrjEQ=AO4u_tfGL zp9K{MxfA4`FHm#lp^1NjiZ4eK=kS8$-_>a1Y*6tnXyW2f@f~R5qEPXJP;qqkpT;5n z1S$@5zc$pI7ii*|Q1Opw;`UJSuV~`7P;mxZkV_EhO%`Mk0|NsWR2;+w#qWG*{7NH< zgTgZeYK}abxDQlZ15JE7R9pv5yc;TRiYERTDsG7;ej6%oha`^dPIn}6kUJHi2jY99 ziAzDnL(s&pLB%7`#4ka`6Vb#!K*dwh#NR;0^U%b(d?4wn2u+*~Dqf8yt^*aXM-$h8 zig%!idqKr}(8L{};!~mGpx6iHYgoL`hl<1EeFrq&Hz0|F!m|o$&K5NBGN|}oH1T;* z@q=jMv!LRq(8Nzc#m}LMAA^ctMiK|bJItLAq2lQNdW}Pz&km##k^W6V9%o=+kia2s z3Ka(_1BJsAsCz8Y#2-P$U7+G1TR`C~3L2baU|OjU*0ozY5fx_h{mBQ1KsV;RzY7%yDFeCF18V+5G;uem_$xH=7^wI=H1Q~?_;)n%0;u?JH1RyB zIEw?wM~LzP=6*gL;_6UwnEP9x=4hjdH$lZs(8Omz#Vydpr$NP?q2eG{fzoXf$RY*? z24AQ+hzm+rU!dtK4oMsop6j6IB%z6~f{JIOiC=(<=c9?Afr?k4i9dsi*Pw|%fr_`H ziT{C$ccO{^fQnCoilh5?4pbc7zblc%LH?EShvcKRXyPJJ@oi}0R#5R>XyRs2@xy51 zF#jG$6NmZt0-AUb)SN45;(k!^yHIg-|2~I`qx<&@k~qk}c~EnHpowQe#TgwzCPT_Y zkopNwaaJ_(9;i4UnmEkALTKVJ|4O5YuYj5(k0!nZDz1Vg4obHy(8^F3NgU+PV^H;m zXyON;;$~2BknceGVksz~7#J9$(8Tkg;weyZ5Eo>x2-MzEByo_v-=OAKqKSWkiZ`K& z%LYKwTN|3VBviZ~P23SGJ{e8i7AigmO&q3v0h%~W{Yt1fEF56|-3%2+_wNBDagcxG zp!Oa?6OV$5pG6aIg^FK96K{ly-$D~#2^GJGCcYFZ{v1slrv5dWI86N)s5rWR|3Ssk z{mbnHQi(|a$DsD|qlq7aic6r0zlDm+pozbPimRfD3kE{cgC?3dFI3zJO&q4)3{4!S z-U%uW@&zcJ!{XNmDh~6n3N$@OB8h|IR}X4$ESk6$R6Gq$JP|6Mg(e;g6)#2;uZ4=2 zqls5S#cPnnLHW)K>dscEILu#%K^|dXVCaX6gSa5|E>QIgk;Fm%nh!O9DVq3fsQ5ZG z@$FFYO=#jG#;Ih#6jUR7ix|hn)qy}xIdcsTBvw1n)qs{cm$F-C|+RpCPKy0-I)y)M|Woh zk~qkn2chQIpo#B?inpSPUxbQxqKTh}icf-yqq}DgR2ch5~EagcjBLm}nrT{LlasQ5E9aapMND>QLwsQ70z zab2kRcQkQrsQ4eKIL!T~(DF^f9VCJ%pJC;m5)N^Ds5r>KAb;6H&38rQ1PQsadh{ehl-=S{|=Hk$o+Gm<~%?Xp9K|v zi6*`QD*hHtd>vH$2UHy0Jxm@T5kxwHg|j?V9OO=rd-g-kQAQKr3l-Nv6Tb`YAfhN8VDn18Id<|55DVjJ;{Yo@( znEFjnadiLg!6AMXDh~7SKB&Dn(Zu&a#UG)GUxJE1LleIM6@QN={tznu8BP2?RQwN` zI7~f*7syA5b}URiA5#K z-TZzW;#<+gL!j}vA1V&A7nDxEL(|DsBymuD)kE#Qi6#y^NBR*|9OfRF`EQ`&=;r@G z5(k;T8*2U^H1YLNaaJFY$%uL<8R~w1s5s1gKIr_W0+Kk${Etv`RM5mVhZLZR z=Rm`u3Mvk>*BokZJCZoa-X^H|-Du)fQ1K~f;+vr2Gtk6WLB$tB#bNF|0UeK8jYIqh zR2<|^kbCYx%{hT4ehn&q5lx&a5)v<0(Zv5i)!%}O!`yQL>Yh(%;_sp2e7+!+h;-Eo z4NnOi;-*k>nEMr>?y*D@mxqemLB&C~fYM19)O;T_@g}Hv8k#sveF0P)WG^V6dP3v3 z5lI{ro<>l6ThYYzpyK^dahQ7;py4nRhxj(AILKa*`GHV#cA<&;L&XoHiKjxvkE4kv zL&YyZ#nIh!3y1h;s5s0$Wl(dzqluS5#TooSCL`*FE~q#Qns^6PTnH)-(glhySop|5 z#X{H1Rc1aa%O;RZwwvs5s0$oY43Rgo?x5lLAdY ziAdrg_Z)zllZqz34=SFACVmAfUW6uo2`XL#6^FS;66&5d9OCn!;vjc|-18J_<AN z$58RrXyQMi;_K1GzeB}$L&ah4$$+}&C{!F|FDSlX`T81?ILJNx&4sm;^ILKch_q#&PaYhq&hKdKG ziAO@kL(#;;q2lpSadh`&Ld8M$g2Hn)G`*D}iG$pe1vRG%O*{=M-V7B-H@_Du4l{ov z)cjdU;vn-ULCu+mCf)@VUydez5h}hKP5d-ed<&ZR2dMZCH1Ri3@x4gmpm2b>^B7bd z=C49%I=lcChxzLW)L(az#6kWNi-y!|57ER0pyIF4#9g7{@6f~@q2k}s#G|3&ztO}a zq2eq7AeSTRL74mbpyKH6mqro?xxW}{jy#%pE>v6tO?(klTn9~j9#q^EO?(Gb+!9TE z8&up0Dh~1mC?CPx?*kP_cYg$uILQ5HpytG&iJyXsr=p2Jfr@9MiQj{Y7omv@$3Wt@ z3{9LLDqam0hq=EOntmoDiG!Meu>Ht$q2e%qU5BQtbx7hMe`!L^--ITv4i(=G6$jai zZ2nQGIL!PvQ1h=LiG$3yg_?5atuKGj8xzWT^pyK>!;z>|(2{iFisJIN8crjF55lI}B-(l|5f{KG&1qwGlNc1w8 zK*eGHQib}<4M`m2uWqRMUTEU&Q1M_i@x@T_a5V9SQ1Jw)IJ$eXpyDw1*hAe@gCq`e z&rYa04QS$9q2irr;uoRfy=da+q2kk^;^^*K02N1f&l)6gkb9m&&Dnq^{unC04^8|x zRQwQ{_;;xIai}=VJ<#od4A0QS#i8-|0f#tW5Xb~bISGn)n0g5u;udJ)u>9+ULp&ZT z4hkPoI0!@cMJA((3qr+nq2eG{f!qT#zZ{471gJR7e08WfQ_#d!q2i0s#I2#?%h1Fv zq2gj{#;l2^9y~3tE=~+dumRP5k2`NCa>NgG_+rcVzWSIK-`RhP5kC`i21+K#9``LLQum2wqIBX zO&qp=Rsl^MwjRkEDh@IYR6hnl$9aOF;^^@bg(MD2hknrbjYAXnf{G_2iG$(`=FU7M zagaHAQ1wM<;%QLvawKt(ISLmc;nRd94l-vBRDBzo_!OvkHa}uh4 z7Ml1`sQ7#&aZvf6&kAwR3M6rm`LJ-_j3f>+{|(ff?P%inpyCIh;;?vWgvQG$s5mHI zK=w96?Y)g84l-W{df?i9G;uAc_)Dlb%>1cP^FKqyVdhVUn$HpnQVGd-AoHD|=5U~i z+d;(z(Zo}s;-YBciBNGls5rLB(gFiEn|5FNTW4-18qAK5KD^ zpT{A76NmUe9O4{dAR8g|8Yo_1_9{ZfVg5Z1b*Czt_+hBH9-8}OQ8928Im|C{Yxc4!eTuBdsrhu zB9MFyO1Cigh$D%E+_M#Gjx?J1dZ@T2n)nT9b3^Z|RsCX`tI4B$}q483NBo4CI6RN%nP23eKUJn(A z`Kt*U?~BpI1EJz;q2e(A`a$hIj3f@SHxp|9aWwICsQ4|YILuy{`A?wY=;nVz5(k-I z4>ji(ns_Z#oHq(&GNPP;nJ*3%M>k&+NgQPURH!++XyTKh;?7WUkS(C}05jhgDh@M0 z4jMjDNa7&#*F(*TLla*K6;DSKe*zWHMiajW6)!~+2c?HRsJ(SiahN-Mq4C&(Lwp%j z9OQnGJO4w?UxgKRCqYqCqMl zPKAb#J(~C`Xn1UJ)d!i zOT>dzBJwFLe3WpAd*Toe#vxvfL%bD-_#&t{EPU#r{#u46UJDgpk0w3=D!v&_yay`2 z2Tgn>RQv#%_)@6&NvJp|ltAej7Cx78h`)h~!`y!mYR(5V@%>QopJ?KjpyGeg#Lq#+ z*%Cl5LFC8RP;o9a@#j!+VW>Dr7qa_hafq8i#bNGehF%n5g(l7j6?aAx7lDeqqlpVZ z#RJg9b)n)RXyTes@mMr*cc^$Gnz%DmJPj%i^Y0;OdD4zUd?F6ye@%gk!_1F? zx_=>(ILQ2EP;-`|i7$YPuY-!Co4*4pj&A-@Byo`W*P-T|L=(RV6@Lg7hnb(i0;#Wm zK*d4kgXU#m^Jol7AeD&x%a#UF&w?h-1Qq8*5(k;%20dq07)c!DPIahyaWrvRsJI52 zcr;X82TeQ}DsG4*4zf3TEySJHNa7%S+o9_1(ZuVa;x0(yAah{zaeheRAagcC)d!)8 zuZ4<-BZ-5|fz6{OB8h{{ISo~xiY9&>DxQTT4$2qHnIZnFMG^;@^A4)M5l#FNRJ;vI z9ONEe=>5?Xkiz`b3QhbDRQxkk9F&_tqEssx@MFI0Y3)cjpzTIJ!F@B8h|C*#I^FDVlf< zRQxlV_$;XScQo;7Q1L%V;>hk~O9i8N=e=bxU-Ta+UahQ5o`acX6hpB%7 zb^m1~agclNL+!neCVm?#{s1bDZvHE%IJ)`Yk;Fmf|ACtG8%_KNRGd2vWHKVYVD1-% zio?wR1$Dn7k~qkGS?Gm!s%YYpP;ospaT}<(5t_IKRNNXW4ssPJeqru$g^HuQCmt#e zQxB_8Goj)z^*qpYScN1Ga(^<^-a0h#c&KiBNHL^XDOngUoM$nzIN^yap=1 z2`Y|m{vN0}%zPQB`_CeYgUp``HRmFl_)MtyEvPuU`A?wY=;nV!5(k;T3u?|+H1Tav zan^K@$%ym=3x9s7ILv$-;^^iFLB-M4 z$3Vql>TRIz$wd+exrZeiQoj_Ui8DaO>!IT4=66EH(aoQRBn~oP8*0uhG;wvP_(G^S z%>0#5cOFI)zXBD1fF^DTEm!}diEn`BU-k@;$&mIWsNCKUZMTafiG$o31a*%znz$cS zTm>o)G7S_jF!S}G;;?XlnQx6G4l+LJX8uj6`%{s`LFV^B z&B;U)?|_OILB-L{uYroAo8O5f4l;iw)SO;4@ug7lSx|A9`Hj%yA@K_`XX!aedKN>h6)!~+ z2blxA_plyG9Ar*3RDCm=cpy}~14$fY&ctsJdnX}@gUp!@RX+_)ydNq)2T2@cPPY!k zob^y~P^^LSQ3iAY`c9}gC_R9}c?UF{Pa=tf>^%-O|16sLL8$mOH1Us6@mpx(uc6|P zq2lQ7d5c4wD+{C&lHNe>k;;Ymiw{j)0xB*66$j};_OB8SaeJsZC>%iMYeUU(MibYB ziu*vt(ajITA)W^nhna5!HKzzo+zKjQ4HZW>zZHl0Jg7L#d|#+Ji_pZqq2e2$;^^k@ z!XbVMDh@M04rGN)I*A z^q>e8hnX)5HD3=&927q0P;-pX#Py-#)@b5IP;q-S@f@hQ2UHy0JwZ@$n0qXs?ukbd z2f1ef)SP5A@flF@95nIUQ1JpZ@vBhrQY3LuI6Fb@t%Hig+}Q&Sw+^T{%$+e%^;40= zLGEOQUKBkOO`H)bz6ecR9V)&IO3k(roE=SkDO6kl zP5dZSTm()0AXHouDh{#*lrNS;y1OPe9cNL&ahKErh0r6eMwwf1g6_ z%|H`>3>7bgio@IkGrt-tj&6Pjk~qlxZ%}i3(8Rw$#pgi9(am256^EJM2zCE;;f;*o`L63Kc&B6-PJ!98?_L{M$(4AoC@l=G;dU7lVqwhl-<{{}U<>Gk+q~{akq< zm5B7C2{nfgOp{gqwt&(PEWRwD;^^*iMG^=3*9&TnCz`ki zR6GJn98@mB{FR6#4l*Yesy-D>JRB;Xhb9hFUxX$OQ(p}gNB37NR2LFP|^nsW$Ed=garDpVZZ{QFRGbo1XJiG$2v3^nHi zn)pJfICDP8WW;z2EZ%vc;^^i}A&G;`-vl*B4o!RmR9qcR{2)|Z8%=yaRNMqj{32A` z0!{opRNN6N4)O(Zy7h*Nqq{!>NgU+ zTpudF6HQzfD!va%9OSR%&~ofJk~qkn_E7bw(Zp?`;uoOeuyA+)t*5@CiNn(Ee;ndU z1t1eJ)42`~aaX7~D4ap=42QbM6HPo6DjotA2iXEjhmz2GHV%h)6;vE%ekRnMIyCWg zsCYY69NqkhIK)1oW@zF|pyD=Aagb|4`A!d-egbibN8=DLfr^9T3*@h@Q1dI$#5Y658=>Op z_IBeCUknw8nSUH=&T=&IqfqfJP;rp?pmRJpK@0{4hJ8?RkU5}uxdqJ^=a9rf?!O5& z=MtLub*T7ls5r=2Wb>cm5N9d|sf45lkom8n=CGlOzl4elK*d42K<4v;7z_*yQaHrT zq2eHafz1C4HOCrF{5MqG1x=hEI{xp0Ce8~L4@47JfQpBriOWI7~j!<)Up^4i=#Sf#2hd{-TqlpJW z#V??VCqu=rpou3!#qUDJLCyw+k0gk}z`*bvhd4tCL;=kGrBHKN(8P zsCWvR_-Uwk2AcRusCXe%9NqoZIK(GI#bNHh3pHmtn)q#~_yRQX_fYXAXyR|7;%m{w znMxr2j*V#I3{dfHP;r?1k^pN&Jj87dAl-vw$;JDRu?RD2Rt9A^GIlVhne3GHK!9zyca4y1u70R ze+$(7c{s$kL&ag{FMyh}8%=x;RQw2<_;#rH2{iGoQ1OdUadh|GhKhsi1+{a&LEAYm zkiio%0(i&W0xb6DrOR6$j}8r3YAe zNKv=22gQxG;uwsxC5HFJyhHUP23hL?h6%1cYiok z9NqotNa7&(`$5ggMicjeikF~?Cql(5(8Qym;*DtH%~0`HH1S5LcsEoW=Kh0_;AB{U zLwpqu@xxGYkbgn`nglifIGXqbsQ3k_IJ&*JaEO0`io?ub2sP&$n)rOEI8z14WJGxd z^A`^eaSf62N1IpKIY7h%rkiq2e&}#h~V|K@ta<{|su* z1~l;}Q1P8madh(!L&ag{t3l1bf+P+y{|D5Z8))L+pyH39;^^kT!6D9C2~vqDm$=Fx z;l_z3&H)t{fr^84f#UZ$L^*>T4smm+ILKch_sc=eu|^Y@f{MGKiJL;jJnzaFA(Jn3OK~IaELoY#Xa{ay;(tJfFfcGYK@(?zc$47|nz$NNT)YOt0Fj_@H~?M8s|OVa z#TRIuBy9bs1(G-@9R@+;%LYw604nYX6^EIB5^8=Fn)m^z`wOAsFneL^S1XakLG~s? z&96lhkB5pkA&Gji& zn)pws_*|#X+`%(m(Y0K?Z%OI4B*0 z-2We9JcB)wILQ2OP;;Eo#J@nrebB_&DAoWUXf5r_D1s5s31)*u5J7#O(gAPkT=$o+9p zd->7CW1!*^P;rnhWcMgR#X;tP(htmheI#*^`T0vt6W;_Ce+v~ych7em;xhFhm56o%Ed14Qi2LFY562;1k3+l@ zhxjt6I4pclK>f7}P5c;Cd^4K(O{n;GH1VrY@dIe$pP}MM(8S+E#m_>;L7@an|FH16 zjzjzdR2=4h?kY%m_ytXz6Ds}}Ol&e#C55m8@AK*hPx#Lb}Md}!iEP;qgnILI_) z_bcKMw}Ohp-0uf9#|};02P*E4CLRwJ_eK+shKh%viC03!BhbW4q2h^X;*+7`sc7Q; zQ1L9NILyD$Ww#97IK-#o5Z{4A{16WD2T*ZXxb1|x=LwqlcBuGUs5rVizvB>BXauQ5 zagZ&bbOJL!4u^O-R2*jhJ*YX=XySLE;@wbj zbn~a;5Z?q9hnfE#YR)z^@wZU%{ZMgq^H1Use*_hWna@xS$*0fI#Q#Cf{{|IDH=m&i zB!U?)l2CD&`GQdMWzod>q2k(5agb@q;ctpVJQ__Ldd(R_DpVX~FQ{IIUen1?iX;xI zH#MO4R-%ckLB*TU#Lc1NZD``AQ1N~=aW|;=WHfOXsQ6r{IJ$qA;}Aa#6$kkX7y*6F&(Rw}y&?Tm?!$P-io^;t)@Qii6wktM ziE}{3^U=iRpyI`7;xbV28Z>cTsCWaKxHeS06Dp4G{>eDR*FeQ#?ze-QvjI)q1}eT2 zO*{xHz86hA04jb0Dh_i`EGSSJ7#J?$5PuI9hq)&aYR+dg@p!2CAE-FG`D`s95k$Iz z*((nfhnZglHAfjuyZ|b03>62N268&g99yV3$Q)4mYzHY|U|{e<5(lM+E~q(vXyQ#! z@o+TplTh(!H1UH_@f0+1##%^v%Rm$V300qqBo1=ta;Q7Ykimlp ze*qP5M-zVn6`z16&Qu3+=M*&Ye^B*v(Zm&?>KCGk%Rt3fp@};|#n+*U+d;**qlqU$ z#do8LM?l4oK*d491&a4X5W&E}a1JUCi}&Lo1q=)f_mRXw;W-;>&SNz3=}_@EXyQAe z;vdk&w?f5#A&GlxZM>fq|h5hxl@+ILtlY zq4usu6aNYo-vSkfxd&$cJ{;oLq2e&}IqD(l_BNV08&v!?R2<#>uTXK2IiUFZ3{t?r zz`)i9VSvOz;VBC>hYL+y94ao1CVm+zE{-OC9x5(_B#vyaDpVX~J1B?)pz)#)6$iNo zq@D{T$-uzih$Iej=XOp=Jz6rgUlC%nm-XuoF6Ja3r$=JDn1WQTmdS+0xAx3Pbf4zkD`e$hWhtB z4)Hfoagh5#?lgj${{c;ILKa5y48h>=OT%N z!gDIroI*75iBRz>H1Um4@j5i|wNUXMH1U&A@d;?+N1@^~q2lQ7UknvTcmDn)pws_<1yO(MCwVyNo6-2o=8r6-RgfGpIPa`#&RzgWRtR zHRn5;xF%Gbp#x+xVtmFED$ar??g|wbLK9Dfii@F%$3n%Wk;Fmi#2lJVRFK3$?yQEY z*FY05g^KG!#X+tG8F39nFfcIqqls^Vibq1lVd3Kr70*Hv2idz6YJMJ?_(G_7Ihyzp zsCYG+_#voxA5-++p5LKFWD72k#?{u3&G5-N`F zp36{iboV?!5(l|QxCxRzpP-5JL&e{si5o%1Kca~nK*iZRK`ue`3t-_R2o;C9Cmb4I za!BGJ_xM1~Q9=`UgNkdTi8n&U_0hzuq2d;3;tQbSHfZ9rpyG~5;-K`L4t1v&R2<|x zkkDNa!N9-}f_8L04;4R%CjJ2`eiTjo9aQ`rR2H?XJ zD941L>eGP;rnhP*gny5ey6r+Gyg3q2i`E!~>z?Fn20K%@0KrmxqeSp^2M9 z#gov)jiKThP;r<$%|HwW28ISSaVVFe3(5ew2b4a`q3)lBBo0b%eo*u0p^3Xd#h0Ur zPlbxFMiZY172g6C2RRR90uVgas~#5)kxx?@c#{U=Xx~p&rtCl zXyT?Vko>p@P23nNehf(*WbZbpz2}j{LH2q;)n7&vcY%uEK@;Br6@P#xz6C1&4o&h#9&}x zkcWzc%mIbZC6FWo1A{4&ILQ2Xs5zEs;?YoXXC!fCa{{5_AnQOz!|aWQio@)E36f-B zU?_r$!_@OZ#cObgPlbwu%mKNx6Y8FsXyWZq@l{Z9nEA?3^S9s-zlKBn0S;(AEp$mW^g(Zmg*;>>*@mmunKeW;<-#`Qd1A_vZ_&cb$9aJ3TevtVb9gy_ngeJ}c6%T-l zqnjTE6$hCEa!)zbJvm6?AoCTV<`kfb%Rt5JpyKG}cR^YYR)1waTBQc za;P}W{NK=UIF2TM0HlC{f#D(!@wZTMkb6M(`a#YAh$ij>75@(v2N?^p5@tT~E1~8b zKoegM6~6!#M>qc#4)O0$ahUnLpyvEW6W;+9XPE>t88hDbaEPlz#bM^3hMJ>|CVmns zZVeR&*@B!NTycmeLB(O_-+`Kwh9-UsDqaE=M>oF?hxlR~;%lMeAbUaSb2>DA?m`j= zrH9W@d-tJiK^VOi{=%I1g8Lq2k$S z;-8`7C1~P;U6Asv0!^G3D&7bcM|XcW4)G;WahUrxq2{bW6IX|dZ$uNff{JfN6E}m3 z??V$0fr=kO6AyrjpGFhUgNmO=6VHN*UxA9l{Cfq&U|?YQibMQA4soSv5RD)b6z?!| zba04!LB(O=HU;V)KQ!@4Q1Ni6IJ)_XIK;cr#HBzQ85kI*;t<~m6^FTJ1=QZHXyVJD z;``9Vw?oAbp^0yWil2dsgPZ{hA6XECfq~%~4)J$TahQ8fK+XAtCVmVm{u?R|G8Wl< z*6AP-M12agR}Lx;Gyf*k93?dI>rioHs5rK1nz$QO{3wz*$ef8+Am*G$5(k+x532q$n)o!R_#LP?EM8)un_{0q#bNOh z1C5t&Na7?)fOg(iLgD$YCuWHO@ux(F3#M-x8}6&FAge*hI1K@-0R6_jCkBUj zB~%>bPLO-Npyt$~iF-iB+t9@0pyFL<;xSP1$!OxaQ1R(#;@ME~1yFHx_pibsei$ka zbAKJwoa1QXHBj*jXyTKg;#bhbCqTvTL&ah4G0=vD|4SU=Y%@VB5$SCq)Eq7}@%d13 zVW>Dr7byL}%$LO>ZUz;H`F9i494j>O4N!3}s5rX$Ay9FUIiPa26Pi8~k;Fmi;W*Ts zR5bB}Q1Lu8@jp=UA~f+&Q1NOsaSP~u#Pw+6Mo{qP7=2;+<5$XIP zRGb}6{4P{n5J?;qk1%`Xq2eIZK)e?sR~P!_9z#bM_6LhpxaM-oR~=R6%r9OV8?sCyRT5Z?zChq*@{YVRR5aapMN zX{b2NJuvgH;t+oa6^EH`05#_mnz$ZRoM|@5WJLQ7Wng17Rej}1N$b40(Ijv~o%24q>s5rX$Goa$=<}X1K2bpgM zHD?8yxCvBzBbvB7RD3I%xGPkAKU5s%p8wGByn`lQ02P0RL!5aI$OJ?=5Dqn;9ZftG zDlUK~o(&ZjK@-n}ip!#j*F(h>(Zp+^;#yE~kgGuH1m=Dd9OAxEaZvb!!g&JJoIo`3 zKB#yUn)ni^cpRGeBB*#KR2=4>QfPPV_-Cj%y8Hh^#nIi*H5a53k)Bha=J273CqTu;(Zm~| z;?ij1HBfO)H1Szbaa}a=DNu1EBymtWk%FcZYb0?{IB$olw?`A-3Ke&Oii3Oy$`|XQ z=`asXydElE0TqXZj~3M4P9$-Vy=S22_o9iPfQnB;6MqX8pM@s=5-PqHDh_ie%stzo z;^^)(5h$e0c6~BrmZVDBD0ToAg&nKujx_ka3iG$pe0yT$u z9>@elx=MhG^Pq{hLd6Bp#2caFYEW^IX`pz7g^vML9OfP?XnffsiG$p;32Kfbn)n*1 zxEGrEQ>eHfn)rRFcsQCk(-cVfN27`VgQ`zJ5(lMcFQ_{+q2e%q9fPLBVl?snQ1OXS zagcvO{*r;(I~7e_3MxJiOl&_ z(ZsEw;#bhby`kba(8N8V;t!$X=Vcso=aX1+Vr{S%?$ zAag+ZVjDDlE<_RsrH2rxIZM&R{h;FOpyKG}@4z8`6)Fz07i4}F)SR1W;w4b=M^JHe z^WWeQ=UfC*3CZsu^XEX#;YAal1r-;Aii324!XFks3OK}Vq2e(2uZEiAh$g-gD((#x zhnepK4gXLa;(1VUnEAV)<`kic?|_QeLd9X`M?uYR$05D|Dh@OMG}N3WXyV7A;%m{w zA3?=8qKQ9%itmDoqr2w_R2*b4D7~GArnieo;-L8Y3N_~{n)rLD_&qdn@oA9q>Jgf_ zC{+A4nz$NN{5_hu3RL_DR2<#?Op8GxkaUIYetslzkozs6<_M#S8$-oq(8Qym;tFWu zkx+3>H1RB`xGtJ_22|V(Dh_fjC_Tf{g9B6?J^TZZ#6j+_gqjnACSDE|k3|#jfr=-h ziMK(;v(UuXLB;dX#MeN@OQ7N~_h&%Ua~G00=-gM>xvYz!;vj#4+`kuU&T=&I-B9rj zP;rp?$mZ25{O2SdXV@{s5mE793%^JKg@h#s5nSH$ovmb^Hq?O)hO`IPp z-UJngnePZ~K2Y(GP;qqk{Dz8y>;dsQ3q{ILJCsyu9US5wP;r?1 zBcbN_poxb=#lxWDF!N#VPrxBw0~LpvpA9vq0Zlv;D&7Va2bmA5$G1VxQJ;(^z7HzC z08RW2RD2(rxGuC`a~ndVfEuNG;!E@diT)8GokkWL=p$t zYrq1@cLFOQ3PAA)TF(Pprz8Uv2g!oeTSC=qqKVr<#m&&fBcbA6XyOl`>&X+L;^_8f zBZ-6ZT_ZI8dqc$y(8N8V;+AOQQBZMPH1P;L79`^Tqlq&?#aUN_T#m>WiV)=t zQaHp_aERMN#XgA9agh71q2|m+6E}v6FM*1qo4*c+_-Uv($X<~7nNV}iqlu?O z#cx8zVdg`xLu7c2L!4m^NF}1atAd)tf+k)873W10?}myCqKS7x#ih{1XG6v1(8Om# z#WkSfAXkCn7v_E=s5mGbK;dr#O>g!{;-K)^05!)MO?(AZ+y^R-Zhjb49A>@`)cj;5 zagh1Xpys5biQj>W7odq-&4w6Mf+lVT6|Y4T4}*#~qKW%K#oLg?LE!*%XFpUN<}YZo znqekX9OkbWh;ta0A&GPznoeTS#9{563aB{9U!eXAtR3ElCVoT~V$gClahUq8XyUEV{^m6_ahUoi zXyTh0K`v%s;9Lix(cL42CJyTtD4>Z;K-a@KqKU)o^+FSe?N13q6L*8Ie@;geFNEHQ zH3>}|X8v{@;y2L5iya~1`43GTW)Ay$)NtUDhNu@o6K{d8H&a9tw}f77#<>C29BycW z7DE#kfQkpBiEnrXu{Qxtd@EEuA5B~any|{y#D$^#wPk4HLcbv9uY!t$Tnp_|f+em& z#bN2;z+JE~!!4*dNIj^34H0Ev_=+a(1eN%YLtJ_z$OK6H2V@RRy(&~3WG|?E&Via^ ziX;xo?>nLS&Js<0J5<~WDh{#*WInWdVeo;9!_0>s>&p;>Bn~qFBGjA&H1YFL@l2>V zy7|RWadh(=kil^uR2<#>B}n2R^BJM>z5-4BKh*q|(nE8oNbJEbn632f*ilLIK)Gt;xO}X zLd}Up6Tc1>PlAfW%!jozE6~K}L(8{LByk6*7>JsSBo1;X?4Hd{XySGt#S9D#r=j8? zcY@j#H`zcgU|={86$kM^<^+HSWf>S4UO~k{>OuMLJJkK}(8S+E#lNG8tIdO0{2NVN z1}e_71!N;49%1(KLB&D#g39?gPKY`3Na7&(1VPPFMiUQ!it9qfLAHSWwFBxebEr7X z{5+`n9!TOK^V6Z`_@Id=Ld8ST#Ji#5k!a%WQ1K)rage`Y_GTlAgX~=dRiBS0z5ps- zi6jm(rylD5HY9P7Ia{IXyU@hfL&YaU#bMzy0UADYq2jRcnGQ979g;Z6{L4^tHlc~1 zhl=lpildu<6ev3rYe?cC^S?mNxrHYF0V@6&DvoacTc|j?`M;3FLFS7>GuS^g zaY3j!-&T;xi1Y~y9|@>9%>3<8_p2g_gUq*pnxly(ZUPlIhl+!20i{ov`HoO=bn~O3 z;xP47pz)Oo6^E%m4s}l%k~qjc;ZS?4(8PnG;tf!7nE72$^QWVUzl4f!K@;bNwlgoG zi7$kzzXKJAx$_p(oo|uELGCPty5}RBcs^A8J5(Iz&b?6c*|&j25b@Oj71w}@gX{&B zd+U`U<%ted9Ha{r{sz1dad)UVNIl3sv!M2Rqlr&}iibeO(anj2ii6An<p)s5rX$_i%{+hKj??&xe}xA5Az}zo{LtGmw4l}62N14^HJK@0{4 zhA&9sp!BcnrGoj)!P;qqkr{NHiG$L^QK&hJXyUt} z;#z3pf{P&GqlYHW2^BX-6Ze3MTce5FLB$=A#F5?Ui6jnkXC+jC*LB+e!#5Y34`_ROf zLdB;;#X+$TDhFWkz7Q%7if&MN@~iBNOap^3*s#rHwQ(ak>r6$hCEiZ3f@_}@el2Zd(|)SSC$;(1W< zXK3P@OCcfm3Qb%UD*hfx9NFFO&EQ1P#5;;W(JzmUX1=_DJPPMG(Ce1u51r=jZE(Zr8J#d)COAYGtz zI9U)9?^R2|&ile({2UHy0Jx7tmLGI~* znsX9Oyag(L2~B({RQwv6_(G`o8>l$Cd%i)%VeaXN#uxKGkV-^4xdb(b9ZmcUR9pZ} zoO1;vors``GegB?(ZqG2;)-bEYEW@CBymuBhK+;iL&ZU^1*OmB(DZ4ECO#i39u5@; z`4<$nUj9SPu|N_Bne!B?-UdzlHdNddOj7$i3>o*gP`Id-+|KY9H_ryaEMnz z#XIznsJIQ9_)Ms{1Dbe0RNNCP4)Qf9AHmXXFjO2C@7d6J zPeBp~h36HhIT>i;7og&WXyWgn;-zTfub|@fNaCP)gxT8*6-RgHbf`GYolQ`8u7irh z)LTIF;|?6+7op-Hb3p!*SPO~wt7zh4Q1NF_ahUnOQ1d_F5a&G%Qi(`cI#6>2(Zsc& z;!;p?kS{A#Mv5hq>PxYK|kCxFu9P5Gsytel%1ZWDY3&CqctA2T2?hK7LSh z3edzopyHKi;!Nux;aQ6&{tv3Y2}vB;-fpNk%$<**<55$g;xKovgt~J%k~qknQc!zW zqlrsE#kWAk(aqln6^EI>6KehiByo`Wnox7DpoyzP#qUDJ(anDj6-PJ!Gm<#Sd<&>K z-_gX)pyCYBi(NqGfYiG~#aYnAU7_N9P;r=hoR2=3nnERV?h|htF!`$BoHD>{ucn?&3 zC7SpmsQ6km@dZ%v9Z+$Yd*Y$tc?c>FvKN%j&p^}FWh8M>Jnn#+a~(~53sn38n)oHC z_!Bhob5QZOXyUJ+;vdn(UqHowp^5*6ivL3s{|OamKML|Gq8|tIuOL($-M?~3;voNu zuZNTmN@(K3P;qTEaYLxMKAN~LRNMkh+!HEpgC_0{6?a7wkAaGNqKQX9#e<;YAYX&Z zXPAFupyKHM%|sFh`L_&ePA-~w5mdYkO?(1Wyb4Xc2P)o-CcXkH-i{`|3@SbWO?)?0 zdy#`IUi;%=Y{<;oTzYIJ*M12pj#K-97zKahQ94LE~!)aehn(V7ESyDRD2tn z_)n<#E;RAaQ1Sgp;-K^_2<`u#fQrNXbpV<^FX0gX02K%M7vwLAjgWNs1x;KGD*hKu zTpcRTcpPLSqJ5|e73YGAgJePR4s(wP4sj!>ILtj}P;<=C#7&^$_Gsd+P;qB8ac8Kw z4^$l8Jz+S+^Pu7|_k=*rDMAwuf{Hhwi6=wFThPQ4q2irTahQ8fK;vsAR2*b4D1Mcp z@w*)=4pV;(Dt-_u4pSco6~BZe4vOCrsJ++F#0#L}50Jz`_U1v&d5I(rGG``K{aZBg zUa0stH1V5I@n2}-r=jA^CqO~icoWs(8T4T;@MDfbn{Dbi1$IoVdfh^&6$KIt_Kxg1Qka&e+>@t zqfl{}`HoO?PNIq1L&dK{#nH`wh(nwmdI2I#{e5VB3E~jfgNno469~1}2u<7{DsBT6 zhndg92Z>)ds5r22>p6PLO+kLCu+iCjJ8|z7$QIZ!^TdE78PxpyHd*#ATu4+t9?Nq2l|Y;^^)_ zi9`GmR2=4h9jH0a(8RT%;_uPK9iZZ$(Zubb;{TxHF!xM=wwE|gfkY7H08CsJDh_jx zKhzveG;v?3xDiwwWEv>H!_2Y4Asz}9hnXJ-H762HJO(PB2^B{-zZfbGG6$4CFG161 z1Clr>J(NSuX+aaug^Ks0i64ZDPec>n4Hch-CjJg8J`YX&2~>PBk~p$E*C2_5+$p~W zk`6bZiAzGoccO`3hKlb+6F(0XKZYj$7Ak%UP5dQP{4$z2`&Nj1uA_-FL&YDUiEBf} zpP-4WLdD;riHAVNKcb0yK*fJS#nI!Ph zH1X|FaWypY%}{XzBynVW?V#cyS0Sf=52!dSeR4s|v3RIBO#KFEe$2!n-UJl~nFI3I zL#TV&(8TXU#iv8XVdfu&n!gZ-_&%sO%>1uVa}J@2e};;mhKi$`e-(%LJE%C!e3osH zboB{MoCzwY;xPC4LBs6@n)qdCdj5n%oc}Dy1W5S+a;E~+d|@!IQxdqL^S5t^ z;#;BOo6*EKLdEw$#nIh=3@VQ9{>w<>Aorh#nsXgZ{4`Yj0h;(rsQ42!@uyJnPiW%I z&-6Ds-7?L>1{jyN=rO?DBq2kJD;^t6sbu@8fsJJPb zcpy~V5>4C}DsG1)4sxeAG@ZC3iG$pk3svupCY}xz4}gk;d=1JMj?n&i1)BIXX!>k| zio@bJ7HaQgByo_vv!LcrM-!h06<>fRz8xyQ1WkN1RD3&B9Oh1#dk#Xy(cNP{|^0*Xgi_*g;3VeZL?#+N&iILJLEP;Oq2du} z;!C08iD=^IpyH`$;wPZuSxDlb^xOz_XE9V9=C4p_`m9A0_l1hjhKhsy3-Z@{sQL5J z#9u?jSD=Zr?t;Y28Z>ccsQ6Z>IJ$fGL&ZV%g4{nD>i&yJ;vn~kLCv{}CN2aOzlSES z0~LRSCawh)e+?B!ch6U-IJ$cnFMw1c(xElf99A@OOQ^Uonz#>CTpUf@11c^96$jY@ zN{3O^Tu2bt3eRo{RnUJDiPL=!&_74Jn8-whR?1{H_-OCIX}1vtd_Ld8M;1-a)p)SQE8 z;y@@rO`x3pDZXP;nbH@vl&ES2S_9 zJ&^S2i6+hh6%T@ngM0x>KQQ;l;1Dl`io@J53N@z^OmP6C0Fp@YZJtRQQ5l0gbgNiGliEn|5tDuQ5fr{&*i3{$9qz6MZadxP< z8Im}%JMEFgLGE;ds&_^cw}FcLpoxEjiU**He}alfqKOObgSaymO`HcRo`xoF1QpLh z6W4=^7o&-XLB-3_!~>w>4QS%EQ1KQt@nWcWFH{^9%bi9dsiA4C&>1QkDqB#vzFd8jzdof6RTsGCr6m^-gQ-T4|x9OTY_Q1joTiT{C$ z|A304o6mF=BmzkfAoo0jnlFMR4lN z;vn;7pypVkiAzDnUC_j}q2eBB;+jzLAgDOZJ+jd7%tsUVhNkCA9OBcU;vn~f+-VIp ze-@g!B~*Mdnz%nyd^wu9FI0R3ns_o)d<&X*B2;`YR2=3nnEQ|85Ptv_hq=E9YR(fh z@dBv$TQu=DsQ5=T@fN7~AE-FYJ^s+}WV;3uL8Pmn&~zn^Bn}GCIZ$(?(Zpv!#Z}P6 zw?V}<(8M=E#SPKK&q2ja(ZtU{#qH3^=Ah9nO1*KVl#S7_o}q2lkM;;?YbhmH>jUI&RF`XjN> z{2~n%hlQso)LtDVage<)pynH(i9dmgTcU|GAA+PGTQqS-sCWQW9ONocdWN|t3M!87 zo^&K}kb9(|=47LZi$ldr(8SH4;uUD(CQ$Kis5rWNrb5Nh-LnWu9ONE9s5#5f#J!;6 z>(RtBq2im-#M7bTC!yl#?zs#Vhq*@`8eb2P#6j+9hMMyPO}rK={uWJq7gYQsn)nu| z_%Af^yHN3eXyVtQ;>iwbP9;`P(B8c<=TR$U)Bo2z-2&lbMXyPGIaTO$Ski83__Ua;ugUqRgsy9Rv zFNBI)p^5K?irb-yuZN1eL&ZV90HxaqsJ{Yni047YLE!^(&wHpjMQGx0q2kq0adh)r zafmO1io?wR2Q_CIn)n~6_1znlm3w+!`vr0!@4|RD2DZ_;jfFR;W14Jq=Lz z?8hN~2PzJ7C&)e5q2@e56Tb=-e~Bjk8Y=!4P5dQP{2QA1FR1u0H1Qu$apv0~mm}II zF!%G~5LbhW!`#n#6p}u*(8SrH;>Kv=vQTkzG;wLDxD!+yoF#hxkmWILv%&s5x`d#4VxXYoX%k=5L3JgUkV?Pj0Bcjv$GH z(nAQ;oD*o`UQqFiXyWsr;#bkcXF$d8p^2Y{ia$aVKL{0njwFuk&JRf9Ab0+Os{eu} z{tYVr7fpP_F-SULyaNguMESD@D$a!_ehMnihbDduDlU#D{sby6jVAs8Dz1Vi&T$;# z9t|{cCaAa}nz$iU+!Re*6)J8A6$kkaIo*0d#bNQT1C94cBymu9Rzb~)MH4TBil?E8 zPl1YOp@~m`ikBdXgW?fpZxd7;-JLy9ahN-uq3&D^6^E&R02N=0L;M(29Apm2U;Ci$ zIfW*^2P%FWDh@OME7bg_IK-Lmf>a{X&n2iiY-r*apyK>cagZ)hyui$t#36136^FV1 zA=Df*H1YdTaW|+qy7>W6agaHn@DGOiD-lT?6h2>|=A@#Dzk`bBp^2|J0ZF$-XyQwt z;^j!<$o4is#bNF&hK`SQp^0Zh#aBSZLGA~+^8nQRHE81dpyFGh;^^k@hl+#D0l6m& z8V(nc#6jkthnjO0P5dlW{2o*s-TW6&adh*)Ac=#_zXvtv2b%aDs5s+2kjaR2^%g45 ziYERVD$WlT2k8Q(t7>St>7a=-L)-0UIK+dY;vn~f-1!%3emI)=Z>V?znz-OeNP0*? z6X%DD=c0+LLd6Tw#Fe4qRZwx5zhLff!67~uDh_kM3Dlg0XyQgt@l|Nz9#HXhXyR^A z@tsg{n0q*&;dvM;4zd@NuBxEv>I#xLC_Lk!=G;INkAjLnL=!KEia$jYFNTVLMiZX^ z75|PV-UAh9xDRqUqJ0H(KNnOS-TmT7;vo00gqkCbCcYFZu7W0h2r90DCcY0UZiXg) z8!B#vCVm|%?hF+N`2v*AVea>Zile(f3P~K~{x48-;?TrDK*iJ1#CcCa(sMSNI44xR z5=~qUDqf2wt^^ftLJ|k1lNM+?=|&O;WY0z}I2TfcEDt-(q z4hx^DPgGMe}~sJIza9ArBv{lMJg02N0MA73PKkbC|@%?U&k z{|Ob3LKBxd4M{(7XyRf}@e-&wx_j!N;xPBX&iCs^5(l}*9coTLnz$oWdI!7Q1Lft;y0k;AJD|FLB)SU#nIiv{17C9NQbAP?iWQ82f61Z)Er4P@uyI6B{cE> zP;oUh@xM@UeW*Cdc2GKmg^wjv925?q@PxU?6-gZA9=bmfUA&I1(>M-!Kaibtb~ zOGCvIpyDw1tcS)+15_O5p4-sy>4S>H)OSF~8D>DmVd@2;=Bz{#2f5!IYVTS!abu|X zb|i67I4DBRIe;V%GA9PA{s@|Q095=en)ocJ_(e4FKB)LDs5s1D6QTZkfd=69`X8vEOISbIle?!IBLB-L{-+@E?9-8=6XneiE zAGim&xh^JSspAb)|LH1P;!6!`juD!; z6ja!io@Kq6Y8EI9OC&ADH>VIK*|J;xO~2pyn8$ ziAzAm9iZaq=6gZKLFRzcXD!rU;Yi}3^k57%CmKy$6Dpp9Cf*Je&p;C|hl&@Xi9dmg zm!gT^f{Irmi6gtS8A%-EPSNv_aBfEv=ZA_A16JH7y|BEKR5Gv086yy>}`Uk}$%wAEbI7k*b{mVneVeZ@t zb*C9r9HyR87!uA7IK(5N;vjQC{yGnJPb`}FS*Um(R2*i$7}Wd<9O6@<;xO|cL(Q3q zCjJmAz6dIgZvGk^;zyz4F!Mh_%{hrC{sAg}6Dp2w{$r>($Q)4kABBeJ7bI~|_^@7t zgy#=5@&8cs8J~enhQuRC{Z6QQRy6UgP;o9Kab$aiq2eIZK=IBi4zX7jDh_k!9jH6? zk;FmvUWA%&j3#~_DsBT6M>pRMDh@OM4b=PyByo`W51{76po!muil;)w(aq0?ilduf zjU)~-|2@>4dNlF3Q1K2l@qbY99yIYkQ1NL{ahQ9Apy9b0ODAv6-W2) zG9+=3f6qb9S%oHk3M#%CP5cE^d^?)>6R7wBG;xN@ko0*3P5d8J{aG||VW|3xXyW`( z@mo-FbpJkqilh7YBa%4Czq(L!zM_e1LdE}~iMvC^nO=ZwM3k$}P;qWF@pz~>Kbm+f zR9pg0ya*~TgC?E_6<0(O2c=t1XnNK{5(oLK52{`dO}qmtZVVL%`2v(Lc8fsbB@|8E z3~GKnR2&wb(opdNByo_vyP@WnpowpXir1ovUxSJ_qKRLDicf)x!`umT&pfC&x_ee5 ziG$qp4rum???9V&hvDvs`+n^19d_dG)q2f0TPYR)S(aapMN zXEbpesQ7m@aVw}e?@N$N5alf_e8i#RF!$&}<4Xle9ORxbs5u&F;sH=`Lp1STsJJPb zcso?w4o!RmRNM(od=*sO9Z4LNp6#LT41kJ*d*3WsIgvky)DHB|gKn)n~6_-QopUr_NY zP;qqk+`}RM4JrTsOdR6dpyDw1a9o4rqg`m? zY*6tdP;r=hzCg`C2NegI14^H_py~5Ik~kG7j3zD$6@P;!UJDiffF@oD75@np zhq>n;)IH2^Kq82G1SYNk6$iN!nPfzsouF`A12xABO?(wpJQymDZhkBd z@iM45%>3O@bE?q9cS6OxpyKG}Pl1Yq%mIbJ2Q)mFB8h|Ce-3KSN;L5kQ1MM@;!U?8 z>2MpGcpX%HHn7O zJxBzS9zgDihlYbFk~qlxl~8je(ZrWS#g(AqAk#qU1m=Dns5r=-$mUxhiG$4F0X4@4 zO?(?v+!amyI8@vdP5dZSJQyktbI${4xD}v@PlcxEDjed|q2eI-gWP!?YW{3A@vBhr zC1~QWq2eph#9uFEhl+1S6aNbp-v-0ue!2Zb9b-NM`-jU*0oe;d@Ccr@`QsCWjN z_yVYS4x0EJsCX5c_%5h;9h&$ysCYY69NqmBq2lQ7pNAw4a{m>mIg8N5FF?gtqlv$R zimyi#e+3oaizd!-2a?_nqKUIW#g8G0gTlEInoiCmiG$p!0#$z*O*dPd8M(G?F;T-ax4N@@V3|P;m`3@jR%w4w`rtRNNja4ssPJ zy}{h$2^B|oPZ*Lo$UQTm=0u^1Plbvnqls^Wil?KAZ-R6ne6VHT-%R$9Kwt&(J zKh$3uIK*9{;voNm+_L~`jwhP7#!l2P;r>~>!IekO_d>>ER93ocUANeCcY9X{s~QdDOCJ7n)q3$_A$$2B{ucoS57B~%>U{LN5t zbo2KkiG$3a3^nI4n)pPh_!%_uMNshzXyOZ?;s5s31FQMk-pou?+ikG5^|AmTIqKW^8inl<;Vea9EhG!pC9Aqyjoxg;ptNBRc zpzsua0?99n(ZuXa$BcS4^(8NQa;+LV~ z=>EM66-W2)D8FCr;zj$j3&+q6^}s^7lVo?pot4X#Z!^QLFx80G~MPQiG%!Q1XW*zCawb&FNcc5 z!c72b&P+6MNoamq3>AlkCo6P5VhfTu$liFU`8&|WqoLvl(Zs8u;z!ZME1=>xpyDuh z!rb!+Dvs`+_ekO(_e_GC^BGON4=Vl#O?)j>oZ%P9Mnt+@4HXxLii2c9=?&%{S*SR= zd$f?mLGC#UHAfFk{2)}^98LTIRNNX({2o+15Gs!Do@l5z%st}J_{u;M2f61L)SMhN z@h?#EQZ#YHXOQ$mZl4}prep^5uJ#k-NjLFri&>dq-pahSivq3LrT4)Hxu zagcvO{wju=e*jIq5GsBWO}q&zeilu<0V;kCDvs`+2ROw4LB(P2nFuw9={Lv(M7rvS zigTlhFMx{kqlwRhic3JnL8gJyAuN29aEMz$#bNGQ4>iXQO?)j>+y_m3A5=U5O?(ej zJQOMpbB{bUzDl9uAbUaaYYmOxW~ew!y*+f?qZcX;Q=bM^KMzS96u%dt_AWvbKMfUM zgCq{Jw+?E~RwQwdIc(1%>3Jub_&2CIhtR~6pz4pIi3dT&&qKvw{_=qO>n0BIZ%}cN ze?jiq05#_qn)o`XIP)Kn$%u9!%zR!P;#yE~nECsm=IEh`?}dt+L&ZV1fYKGrd`BGO zQBZN1`RAbK#G#3wfr{rr#nH{Lz#%>nDh@OMKGdA4XySLF;)|i;=;p7*A$}Q6+y@$8 zcX5dSf{Mf3^B!vNKQ!^TP;rjGAeSKG>kZU=A*eXW98mgP2~D5MNaCRM!0`f-KGo60 z|3J+*Kod`asy9IskARBXLd8L@0>$q)sC(RTh^IisLGA>(X9m=q3^eg+Q1L=E@ikEK zQZ(^ZQ1Lo6@!e4ICN%M#Q1Nc4IJ*0%;t*d46^FV16x5teXyPZJ;=9qr??J`)qlw>v zil2gt!`x#EZ7*HHA^s664s*|2s5xKJ#9u?j|3Ssk&FA_XMGd_dvyyq2e&}v!LeZ;t=nGio?ub z1U07*O?&}Vd^%Jd-TZ|(#CJi(VdigynzIj0d_7eB98?_L{2NelkU6067l(%DOC)hn z_#A+=nECEdagaG6_vk^xAreU(Wc~uEIk9Ns^Pu8sP;qqg3!viY z=GP#JgUnwKHKzehd@WSG6HR;{RJ<2Wd=FH7I#e9yo-NRD+kz$zTfejqhxl!%ILQ4V zcb6t##8six;meDH>fgX{&RD?4bqia`?}tsC@%ii6w9j6JHAzUyUZd5-PqADvs`+6Hsw<_gqC1 z2f614)SR1W;#Z*JkI=-wLdBn?10VI*;odz9Wo(+Qfm z3{+eJO*|4Ru7V~W3>DW!6R&}a8={GqLB-9G#6j+?gSyimDh~5kAT)h?;t)@Vii5%* zBb?x5-JXJ&rYa0Yth8FL&dkDiJyRq z??Mwl1{FUH6-Rf^Ssda|q2e(2T!)(T5>5OnRQx-d_%o>ZZ#3~IP;mwpNP2_0ClVT8 zGHBv#(0dl_pyD9+STHa!_(AVKbwU%@NQ9(McQo-tMTodJnt1dwh5M zz8y^*6c!+t9K#`g6^Hl}G;v>$Aq)%*pK*vYu|O2S{0k~mKq7)T#1(Le>*El&Lld_F z8P34K;EO{%5l!3)sy+uQjvnu&P;r?1qoC?raEMRAAwC}}4l|z>nhw`M#nH__k3;+& z4sk|Sh{Mp$Q9u)irB4GK;`TVi{cwoKBZ-5Oyn-sk9gR4|x1))hLDk>IA;;?w12|YhS1}cuO zUKfYBJ(~D_sQUwOh$rC?FTx>S3l&FqX9rXq=1!Qsi*ShV!6AMPhxi8^;#?f4;R&-> z1&6p7n)oSb_=G~mVgA|y-IpB)6^Ho?7GL=|#2avkPsAa<2u*w))IA$ie;ZAFs~RL6-{25u z0T~Q!zk$j(n0i5|IEVt()v)lF0SPcb)*&E^Yv2$!!6EJp6^FSWW^XkP@il1T@1Xul z;)eJSW)4ie28Z}89O8S>#Q#9ezk@?uln2$`oly10IK&;0#Gy$ZY(M}G@mM5rP`uoP znx6p`2L%Tx{C`6C4;Dhj(Zit$hxl|H;=a6KXMx+vAbVlqnTaO8656n?!Xe&`LwpVn z@il1Tu<+jw6^Hp3mJSa<#bN%1slS3l{3#Cc4^VM*^M69c(aqHV$!T z9OBV9#LIDr_u~*>jzjz~4)NPK#J}PYmxs>t!~Dw)^)GDy6HHtmDsG2EeHae$6f|*| zIi+agFnfD(h|fk7hncemO&n&_;qN$n2x3%=C4Ii zahUnA{IVJ<4l@U)em@TJQ&4eqb1p;0(am{@Cf*D6FEeyL5T+g`E{j9l9EW%y4)JUp z;;lHum!pZ#hPrbXns^~JoG+n?!_+@T6Njn)izW_J4_j{z3kR5bE$Fy1OdO^@5r=pa znz%pIowIO=Z^9vd0!>^L8V;AC;;?v!^^fjA#bNG*secX?M_2y=Dvqw62|5ptE-s8i zTm^@?DGqTr9OB_P#M5zzSK<)w!XZ8zhxl3?;(Kw3pMZ+P!gC*VVEZCe92Rbh(D-_U zL;MR4aTe%&6uLS5P;qp7C7|Ny>a}o)yWkLy!6BZ9L%air_yQc_n{bGq!6E((hd7S} zYCl2;8qVTSaai~$LgyDWry+@h!nqM*Ji}rnagaN|Le+1=A$}N#_+=d8 zk8p^8!XeHq4RIJO++gkz!6B}SL);XHxGN6vFdX7(IK*qv#2KLzd%ZZsSE7k?Le-zb zA^s9gTmq_|R|YkFVB+dH#4XUo6`|&Y;1JJ26F&=8UxP!u8%^8>s(ucdxFb}26`FXH z0>nSN(ZoZb>W?9bgVOC%h;oL@NaCP$TMJeH2#5G*9OBHf5CdW94Q7rI4sj(M;>I|{ zU2uqp;t)^8Azq3@ybXu=G#uh<(8N2T;kFlt_$@T?iBR>waEMDl%MVz1E`X}H!XX}v zLp%jdd?nPJIvnCt(8T{k)i1#zz8OvYFjV~!H1RFa^mzw|_**pboly1cQ1f8n027x* z6aNiWuZu$*mY-neXh7AwBdG`Fi>Z)g%n*ho4$2qNQ1$sZ#2e7WQ=sZ+;}GA3CVm>K z{tyoFi)iAtQ1uVc#HT{VUn7Zw{IwP8FD9rwEF3mK%ST5v@xxH@3^ef+X#TH96Ay)o zPrxC*5Qq3C9O8#@h+jh!7l-Dbw`k%VQ1O2_#QCA^1z0%1)GOc+H^d?Cj3y2Xw-7Y( zOVIF)M-m6c3#|Q+gCq`0Z=BHZti~bUgF}1{4)N7E#CPKmKZ8U3E)MZ`IK=2~AuFs{R@d@eeq}8I@7}YYH_- z7KgYgnz$`AJ-gx%4?z_Gey;>x3P&zyfRX+`f_;NJyD^T@^ zaERYT6Ssqw`!8{b|3DLe2{oS`+HZiRA6UCe0!@4(G#r$X#6kXrwSNqd#6kYu166O2 zLp%V7IIJHAa}Ug%d>rcQafnaAA-)iY_$D0Uhj55r!Xf?`hxlh4;+)X_G|ayzpy4Kk zL);uq`~p-xY#j~E9GG}Hn)>@t^|Nt^Z^a>g3{Ct6)SO2+#DAfQ=RwmO7j)bL=1!Qn zB$_y^9jt*S{uyeHF_Jha9m48m*f>4Rd~s;Lh(=NmN}n+C95itmsQNY>;&af%^PuY2 z;1J)9CTe*sN=0j&QC9XEx!A11DYCVmB~-Vse4ralLUcr_03E;R9tQ1fTv5MPBR z4s*{|Bymu@tT5LZMKSA(k8K@tbq3ymfQOC)iSy)gAYXyOh~b8>Kqx1fo``v3EAh;Km?&xM+Q z1c&%#H1T+-`X^}O8=&JvOq!5@g{3!`xH1lLJtT2Z_;^FKGgu>ugTm(u)O>F=@sCjP zFeGu1IU!JUQjx?#=D^ffqltfmn$wL#d={Fx2sFJdMG^@O6NaCRU4l$L1p%sVt z6eMv_x`LU%4o&mhZ1H&PxIEV)_2Nph8aEQOcAwEkV;$n1jwxNlq zL(Ab4IK*$^5PyS1{12KqEd1FGAnt+r7nV;2pyDuh!qlta5I4gi?g$k}H{S~?j&6Pe zn)pv>ywu?kpMgVsI}Y*lIK||rrr-t9Hu@IO&q4a z5=|VYz7cO`1j!upN~U) z8;>hY1%^?vDs!x&C+aigB)WhZ#(vZZF)z>14gVaBR zx@R$xII{X}Na7&%LeO#WYiQz)P;(w4iG$jiMB1qt3x_x}bR#p&Juq{0(ZnY} z&G*M4o{vL(A`bD5IK(gF5Pyq9oYxjLot%TZQx1o?J`QmQ9O8jE#FKG|7vT_Z$05E9 zNgSoTMG^<)YnZ=|;t;=rL;Nug@lQC!ne4EKrw|TtMI7RWIK&-shzH;hPrxBwfJ3|k zhxjZsaRF#Kwg!jzJ~VL=sQL>y#2?}i|A0fB$sRSFVdhKW5ZA;ZZjB}`33X>M4)G)$ z;w3o5dvJ))#v#5IhxmRR;@5GAKSL8&h5G9U4skAM!wgoA^+45&B8h|QW#}?w1|=kM zQ2ts8Rj-RA4pI-@Zo*)NBo0!45~|)6NgSjecHT-5k~ng{PQf8wh9({dNgfOxIK*e- z5MO~qd>5K{D%AY5IK=PZ5Pydzo&`0B(GkJ`g+Iu@FmVAK;z~HgO>v03;1CbPA)bLl zyc&mi7n*oJ#5)XgaENa}5(lLR0q8#4Gic)WQ1Rzz;*+7`tk8o&K;Z^52euzr07)E_ zu3+s_StM~}^*U(cFni6B#6jjjr!^Q{kiDa9AwUNsJ&;=#J57l z-{27Ec7`MXSiBs8syD|W9*9Fc6HWXi)SPA<;xp02KSI^7#38-|P5e1j{b@9D0ZA)lWnc2Zb|C{R=mQImqhm+!5l)>L(zHBdcGB zBo0!q3w8e&G;ulTc?X=(0T7t`&qCE(;t=n|A$}c)IHxD7`wv6S7lDey#^(d9KrUcl zkcEnacp&$~)N4S+(bXG5#nIKqpMbhE1&4Swn)nl_`VOc#%--ct ze@($5z5s{#8XV%gq2e(2!|Xi)6^Gdi3(qS!#2?@ge}hB(D^wh2?^~#U8N49z3$qvI zUrwkvx_Sv5;>u8Qm^m=_>p;cP%`u0H!_>pjsii5bIAz_#~ zxj4itafr9#5T5}Rhq(u4?-Ly2AEDwf_rSv84-Rn-=z#d#35b- z6^EGvbAKyT9NnA=P;r=gn7uQh;^^wvqlqVhG%_$S?174dxX9sl42Sqds5s1gm^shU z#Ir#LGB7awMH7dqm-L6kFS-QG4F;uE3b z==QF}A$}Z(_;)n%Jdgtz7#NrWAmIbzB8LM9R2*jS29N><1_oiMIEag^UJfb_Qx7xW z5KSCrjuV99{i8s5neL%zQ@Zd9*Nbm^ngd;xP4c zXyP#S`e@=X^=@e5F!f1j;xP4fIK;c5;^_XGibH$>R2=57!yt_e3=BJPh#!WEgOnks z+jCHHbaS5J5dR1jM>ppeR2ZM zhC|#PP22$5=nI01!^|&(_RFH7;xO}J>eHa&F!iu{KOZWNuD%K?4pR>^zZoiyu6`;G z@dZ$Em^mAkTP9U+tz@UL74oVL`(C|q_5=T~Fh9r)xz6pnT zKMwJEXyUMNUWY?`CsZ6g91cOnLH+`{2WHMC9O8GO;^^i)gNmb@^9_eMV<;p9(aqt4 zildt&3Kd6JF9#JzSFeXd+zyAhCsZ8W{2-_}y7{qCadh=*P;r=gSb8Xgio?{y(sLD5 z99?}U4)G~aahN%<^gI_Tj&9Bhs5neL%-)Sqadhlj&9Cl9O9pG zi2s9%qnpnj21zIA=8NGFSHmH02o*;+-wG;@ZoVfD@kkuvDNu2A^K+r%=;qhp5bwbu zJ{>BKZvFzOIJ)`kaft87A$|%fj&A;Cs5rX$k8p^8LKBCTCx4;h=;pIQFCKuI4^uA) z6-QSu1r>*>hvhFV9O9->addO+pyKG}ctXX|)dxYv(bdO7#nIKLLB-M4H=v1!K?ZKp9uqS^}+S3(nSg_>`SCf)@V zcSIB44iyhV6aNkskA;e3gfmne7S1sB6jU5teKrp93aB`` zIW0KECqu>2&A)_0{38zWe^7CBd%2<^`3PNH94Zd8w-6fsZaBnaaEPZv#nH_#fr_J> zzZi%3P8{M#pyKG}pM{E}n|}i;j;{VGR2*HsNDL%=(8aZo#6j(9*!-_4R2|tld_7bg-JD%eaddMo z;Sj$I6-PJc8B`qIoR3g(boGCr;^^u{ViEC$9M1AkaddMupyDudVDV@S6-QTZ0~JSC z?~f!7Dpv!b_f_QM5TA=Co(ffe3QarcQ1iQ?;^^j2fr`V-fvI1NLwp@n z9NnDlP;qo~PN0eZhq~t~R2D3N_~@nmEi~&!FNk^I_@j6AtmeP;r>OFmn{48^h7X^`PSD=3C(qcZG_ho0E+u z?hf@=9}e+tIK*$_5NAvRM-Tko0hswJIK;hhh-aaR2SVN1fJ1y54)F~*#Gm32XGlhM ze=pQtejMU*IK*|)#8*M{sRdLV7LTxU%n>RMi!YdZAE-FG`cSAiy81L6;^jERJ8+24 z#38;4hxl$B;+JrUKgJ>c1&26m3TnK-!bc2Ed>u5L)o_R#Ld9X>=^hITK?VjZs5poR zDhIYh&GE(|9)m+X2Zwk$R2<#j2B$r zg(m(GYVR5}ahQ9yL&ag~(=Hj5A{iL=Ld8KmQ2K;Ic|+B^B8elbk3kX# z#aBF3eG`&6viccF;vn@IQ1x4p#6jvgK>^Odz;FUd99jJ*9OBZ@gX2Kjk=5(q5Vyr4 z?uSD>9*1}V4)Jz0@dBuS58)7hg+u%g4spIb)cAs#uYg0`0!_RI>Yid8;tO$z-@zfy z2Hltg3;!Od`5HLHJ#dI;;Sle_A-)QS_%R&f&(OqAK;8Krhd4(8YB2{L+Rb4od$pcTUA2z66K(W*p*&aEM>RA^r%5_(vS#jD^_4SrCV~ z0uFHl9O4c*#3OKsXQ7EpLeJx?!6DvRA^r-7_)i?-+(oG2 ztORwZG7fPg9O5oG#A9%XXX6mB#Ub90Lwq?7@oi}0uyZF*;1IusB#xYq-rx}bhbGPo zD(Dy(7zBzD;R!MaCa#D>+yIBT6PmaP)cjB!;wd=9%h1Fnq2_er5TAiVd=(Dyy*R|r z;1IuuL;M2{ac1ZRTNE471k|hqwa{aeo}* zNjSt?aEMPv6F&%X9>XFW;u~>@A4U_u2Q}v^4)NzW#DC%t=PrX72n#ou`SNJu&mqbf z%y5YN;1JKlAzq6^d@>I4tvJMw;1IutL;MX6alUeh2Vvm=^RFzL_!o#W27MgjjyS}F zk;FmmnUl;AgHq7M4?u(&+Hi>PK@-0QReukMI0Ljp1o9Wi-XBo)S~$cj(Zmfw8W|WE zHlT@zL&d-25a+0bSOiiAvKOXa5{I}J4smN7;@&vK!=U1@{%?LQ$OQ}x@lbIP57|8h zIK-RK#1lap85kHQ;}BnpLwqX^@dHqCba$SFii4~Jxf5pZEga%saES9%p@u)q99bOV z<~YRtafm125U;`^J_U#PE;R8RkjEJq7>+{4Vd1l`0U~h@Dh}d-!UvYF?&A>ufJ2^*GB9L8#X&q||CU0<(bcy> z#bN3zKnzg2g^I(}^Fs5*d>rDdafolnA$}N#_!X!)$QdB_!`#DNgBt!#AO#Ez3}R4m zba%=_#X-tI=D^hJ;SjgSA?^hgM>jthDvoY`5}J4{$Z`e-hGHDz-8jT&K*iDRU5rC~ zJr42RIK)pu#bNG;xs$0DHJoAM#%SWxp#FM^L!7w|)f||5MI7SJXyS{Z<|pG2pMxfz z2vxrehxlx10mcSY^I_sbIK-84h#RAc!@}PVDh~56tQ>HMio^U1Qy+~(JO_t( zIaD0o{068vy7|-4#8-dIU&bMR4=Rps&U2_Zx;cN)#9x6FFfcH1wm{+$-5gOI;)*!Lb#aKB zLB&DVf&2xt*Aq=#86?TTz_1gC_+=d8U(v)3pyr6TLi`1@7bc#7CjJhjfPsM_7fBqs z9<0S7-i0I%vXT!(FfcGog^I(%)3yg~ zu>4{K6^EG*Q}2dDJP<05ZcY?b9NnA(G;vdqCm0wQx^Rdu!6Cj6hxiQ~;-7Gc^R%Oe z8_Yd=XyVRLcRHepOF+Xp5=|VYJ_k)4roIJD9HxFcnmA1TMl^Al`WHCFIXh7O^$qHN zMI7RmIK=(Y#P@SJ`XC6uD%>9j;_7~hxkk!;;V3o z@5Uj128Z}v9O7Sah_iO0hBM5+VmQRrafn;u5ck9(9s(7Ih3D2upb%tWh=q!Sc%bk< z31ToXFy!G7Z@?iw0f+c(s5rX4OQ7N)>yYi;ibMQ74)NzW#DCxr7wSR{f0%!@aEM#u z5Do{vL(Dw_BekjEJq7#2XqVc{b&4I;4;Dh}d-!bb|k0G(ffL;NI~xGYrtEga%+ z(ZpfnkiXHyVe>}@-KgO<0Xk225=k61Zm$Nl_c4+<$o)H^>cx9d%{d4aw?Yy}HYXBE z9AwUWsQUS6;>pl^xelX=$3Vp|;Shg_L;MSxcsA4=#$Jf~VexfjI>f`gIK(A!h^s-x zLApWyf|>7)CJwv*EDS1+Zf`tP9A*woeI5?+dK}_iP;qqgCqu>2&0mBjZUDVkY%>n= z6F9`LLdDVTeSky!4G!_YP;r<$VeYZ)gTxoQcp{p3Ce;0+{iy0;;(9p5J#mOhjB|2V{XCZPH&1ZuuGR2&xm+_OL-#lWBd6$kM^=@S+X zhB(CCaESlHAuc)*)jhwU?oq=bZjM9T1BZA7nm8={lcC};|HATb4pbcGUzqv^9O4sk zh|htFqnp1JDvoacZZz>yXgFNQA^s7ExWFXT@PwJ8gG1a6hj=Ou@kSitvvG*;z#)DX zO}rlJ-`i;7>!ITB(8OWt87HIq7p7hkO&q3P9Zejj-U>||rrsA#9Hu@MO&q4a7)>0e zz70(rrhX=xI86O!G;x^vXE?-}r=W%dOua0c_%UdB>fjK!#Ubv4Lp&CTcpeV%S~T(H z(E79kNgN~uy&jHXCXzU){J8~^1dU_h5Wk8h{urwMJq~eJ=tbwS{Kx_gA5k3QDrn+A zpynH+iJL?3eRRSh9*QRJ4ppClB#zwvsYVh9g#%1|ACfq-`ngEr$m-YN5Z{d^?gMqt z88q=IsQ6#kTQM;1GX{L!5OM#KExegt=b?O&oeH7=tPf zaT^@sSvbV2(Zp3D&S2=lAwCC(_(mM!&vA%b&xTk8^DoTaa2(>DXyVZ7j$t1T@$)#u zKj08oorCHgnE7Tn#6xk2m*Eg!jYE7Fk~k>;La%jTIEo|=%F+rD=P_JD5(lY=1~0>1 zByo^>=yfLyuaLx%)qh12M^?`?7h(}8UXa!EB8elbmqHRpRhZgki?PI=OT%N)I*P}VyHqAM^@j8B#x|p5|TKw`ngEr$m&-ii6g7u ziX@J#{t%Klvih?~;>hZ6A&Dcae~KiIto{d*I7oc}s1jpfU{Ifj8t*XiU>xEZXyOe} zb9!)yFGdsJ3st`jO&n&<6*Tb)Q1y?{#4kX_zoLo5)HBaV^%qRN7@9aty(*eGOuZ$V zI8418nm9~-1e*91s5{Hh#1}%vXQPQ5@Iu_Z2Z#6xH1Q0m`p0PEflzUc1rYOK`8ozF zo`@#y3l%TGAzqI|d;$*f1!&?h_v}OyZ-v@>3@Q#AugFjaxtM|B5)ScuIK*G!5dVfl zoM|B>e9-L`g^Gh*0m?5hcY30U_e0$u0u@I$Cl)FWGY6(V2Zwky4)HdqIJ)`$P;qqg z=b?!g@I(B$7KivT9O9Ru;^_9?$07b2hxm6K;>?R6?m{a#Fs+- ztG^gxKFl1LxF-(rR2<@+XyTip=5N9w{u@mk=6=y7sP2J@D(Rtv;ok)nhxr#)ZcK)X!~6?VzZ{47HXPyyq2lP~pMr{`oBse!d^-^;|0;;Q8 zq2m5%;&Y(laX7?tafsL95br}1hq-4dn)nf@y_=xouyVj*KPcuH81~^1KZQg58V>PC zIK)3g#X+`#%59i?6jq^z+c~H^wV~qZ?lggl!_0xHcg7(eghM##nJ8EfR8g zhqxCG@mL(<{IK;2x5dVckTyi7C->~#{02&S&IK<6yh`Zqs55*y# zf#K-QI~f#OLA= zUx`C}D-Q8PP;r>QVD5j9LtFuRZ~;vHQK)~f;1GX@L!4tPBp%Vt(Locx3^hL#hxj}+ zahUse;1EBGB#zt;xr#&l5t2A4eQtod=Pgtm7GGMYK|Wz%_y!dR@j&Wf;lsKOyMHBc zh@ZhB{sc|jO$=i0XB^^8+adBW_rTN(;t*Fv6NiPr4pbcGUs$LVCsd@#9`{S(Zpfu&C$eR z>OIiJVd|sN#9``7(Zpfu*WeI8k3;+ens_KQJlS@k`WGfHjze4*hqw(6abFzbsc7P2 z(0Z^Chj2zw?-3(xhDio+!ktYB2*k! z4zyeV<$MN)TpZ$+IK*3Vh)={JJ{O1h2BNMT_o12tQ*VqzJRD8j8)|+X4)L96;xKn!#v%Ry zNgTO-@&SkVUnFr*`qY5Bhhsm)U$FSvdl?jh3=D!$aS#ur9_C*K9OA|}#Gm63|Bogv z0d1e~K@Sds*$Wew#UZYPL)->U92WlWP;r=lVdX{uR2*h6OnnLt@nRg}bx?71^V^}~ z=;qHw6ZeP4%XS>%=W&QX!Xf?#hqxH@ATOAEVD{?a5O>5O9*sl16o+^(4)Fyz#P{G3 ze~Bg@3k|ogXyW8wwSNl>??XK`D=cArXgoE)MZZ z9OA7w#3$kqUjh{exdK$4!`yiTO}qi>{>M;pboal3io?u-ssD{boa-oRIK$M7LdDU| zmxGFsCo;xPZh)T`kTH^m|D02N0!-xDg1ZhkzPI0rPHRNxSwh(ml8 z4)Mb{#P8q`|B6GL?-V55VD5*xQyqu66Atk_G;txQf2+{Mr$NQL(Zpfu=b?$i)Nex* zhp9h=CJs}78BH9f{u!D$O#MGJahQ6p)2QJCQ!kAs4pXm(CJs~YfhG=9Uynn45f1Ug zXyU7&;dv8>_$wUZ3};aN1v7^qhqwX`aSJr@4ro2-f960e1lyevu9B_#H;1G|%A)bOmya0!I zGgKVp3Q&0tbLVz6@tsijAA*XbyZ{}(EbZa&XB)bM`@ zP0!Le#7%IBJ3__L?e)bW9*ILd6^D2s4)G4CILu!#_dmrUE_NQ(zhc4={wW;d&v1yd zU4ZC=*$XpA3r$=FYJMON@g6jBnERLE5Z{a>j@&*uj6?hak~k=RGD6*R8!8TqFUF@J zpD-{yfr^88AoVbRea0cqb`g6x?7|^_2~C_=9HRdr4)G5-#Q) zVg7}c8_G~|boJ&q#NBX+2SUZs&5weLqnlrVCawXEmo6OQi*Sf<#UXwkhxkhz;*6J3 z!wu#h5gg)rIK(}0h$r9>FUBF>k3)P9nz$J>+)kj0?-qgh=Q^4=O#OQt;=j?vVdijM zftUx2N0>QEIK=hP#9`*xqKU)I3CAJcheLcL4)F_U;)kH&a36>GI~?MFaftI=MGXg- z`O-MVb>y#+z@yBH2}eH`L8P;qp7J#dJJ;1Ey1 zA)bRnyb>x7^B2th%W#NaM-y*{`nUTAYB<2em*NoLk3;-1n)pR*^Sv(dzFK*vv3;Sk@6L;M5|@f&F3uyB416^Hp3R&Kn3io^U1Q_pZ4)%`GWejMUb zP;qqgm7(J3=3AnP&w|EFFb?rt9OCUb#24Za-;G23Dh~1YIK(;cpoS03{i-;`gV4lR zK>ZtsCjJOopXQ^9!_+sSiNn;-LKBCnUxp?QQ@*#*zd^%uFAni@IK-de5dVxroCSKZ4lJF+?3Fchqwt2aaX7~$Tm>94RcQsnz%XCowZPLba%Ev#bM^a)KA4B zz66K(dZ;+M`8%NE=;j|s6F&kiAFkmLe~Ux>7gQYGUbY9=<3$LExEu~~Q>Zx1{V;b< zz#+a1P5dX+UwIE9?tz&D6Ys(yz6yue^7CB^F^MZh7UJ1 zo#^2Zcf%nbi9@^?hj=dz@ufJ#ci<4eghTud4sn*J*!?SxL);jLcmkTZBsAP|(8L9x z`@E{r#9`_u;}D;ZCJr-a9hx}IoMSk|FQJLU%z20=4m0OB4soMrsNn`vABsb~1WjBV z8V=1k#3$hpUx-6|0}k>1IK(fZiQ7Z#yL&jqU!jSoLDjQEFUW)CBOj=EGMab@RD2_v zxCd1H01olgn>Z`hqxXNaVs3+ZaBn) zaEPZu#X+tBmGdxn&O{Uc26g`us5rX&*Fwc%=D^hN!6AMchxj$9IJ)`wq2lP~ze5u@ zg_Z+g2{|eP# zF!7l<#JA!QzlkPZ2{oVTHLCeAac?wnnEO+4h!-J=Bez?caESLKiG$K-DAYZ(pyIIj z`t}bLf(#6cq2eGONIfhZHsKIIibK5W4XS@(=1f8pUjrQ{S%^b?0}k>1IKE7%C3)FHHS+9O7(mQT+u|F9;P!H(v@Wj&8mIns_ZVUc7LKr{EB;!y!Hc zhxjHO;%9J(Kf@u;@D4Q`VD6W}A?}GL-VOC{D4Mtzw4O~v6Njm-LoIK=0mi3dW% zb2Sd}T{y%~;t;=qL;N`oaW;r|8DRMW%4L9V(_(<-3z#_U{6&yB^vE`_6zqIxkT?ri z1VX^hUj&J>LWIC%0GMO|o38<7gQx@$!2l75nF$htZa)UA2blwNpDaicsvaZ`4NeAK zG;!E@p|)t^u=6&3afrvFiEBamxlkJ9FHkuQJFgOYEgsmNAn{@p7VS2)Cfp^3xpBNK#%6U<*_P`)CRhKa-O+tNl8w}P5$izW`c_sSoK zcp47z3N-O|Q1d&`#1DWR#=yWZ1BdtuH1XNcLhAqy@mpx(%c1JOpo#B;igQ9~kTXC| zJObsLLuqvJR2<^&CH1Pmv#TAPto&^<$*$;D11ysBRO+8F}3Yz#-sQRU7 z;>_%j0(}n-@iS=R7EtvM(8M=F#XsN>XNKAjbH4*ry)2rzJ5<~XP22}6?vExO2o;aV zA)b#zydF(l0NT0fLJ~)A55U3?=6)fl`n5>vLHPnEeiVoJ4K#5Fs5vjt#7&{%KhVTO zpyK>cf5Y693>8Yt*CzkrH=MH5eginBuPhxscFDlUp9o(C0I#UXBuL);Zj{4ms+fB#vypDUvv{dIuzNWcB_?;>habk;FmjVdq`vqlv@Lqi(<< zJ_Ai0b}sY^9O650h@U_chn*LF8%?|m>WPnN;$qN?99W>~4i?UuP;n77ad)V=3YvHs zRNMqjycsI)f+oHdDjtp|egrC>g+sgwP5dNOeHWVebEx<%G;!GZ*lW?mVdq!xLlcLc z+x!wu9Cq$5KQvrn;RX}e#vyKvCJsCQHV9oD+A&K)6WRc;+LS|ybFi;Su}Cj`E}RP#8aT|e2FFwJ6G*D4sju9M;+#Vn0gg7 zaoBlf@i@fu(ZpfrkF7-$hn>518BKfw)cs#@h;u{NMZ(+(Q!kAs4m$_Q2u<7$Ixgyj zCJsAS#|KUPF4R47XyUN*UJ7uCH{lSUf+p?@-QTeUO&oUa%4Zzn%+P!W3kTSFDM4uB zu=7JI(8M{Q`Di8%@eMe{51@(LLe063Ce8s3=jS-Yf1!!P&JAFJhBwS#AyD(h(8OW; z+%<5BTj3D*K@*4VAD@Urd?A`RY=1W_{$cKf?Stllx)&yX0Ls^e(&*wYIK*N8hN*|` zC(TAvpA8M?YBX`!zQtBFab9S8n}#M1+kdwLhxjfW;%Csr7eURxgC-8!2M4nU<}aAI z5>y{d9Ja450!kiHkwkpWHZQZp!#6$hwazk zLKD}8@@1ejOg(JhfgTQV2OQ$C^}jH4VC(sN(bU7l=c0+j*5}_w6Njx!XN1ltz|4o) zr-Vb?5{I}anmBBIZvvY51!y=IpozoQi&mkD&xg9Z2TdHd9&#QI@eMe{Vf!aw{(T2k zcL_?v#9`|a*`f6|x;SiI156yY&d>)dN zs5k?Z2H6WTA0{r2LtGtA{1udM2&G}>#7jcl>4-x-1Wo)WlphDBVdngU^7EiHOq>~N zejN_+DLBOEp^2MA%~^*-{2-dR8uBN=q2e#l#1}xtf1-)6go<-Q!y6W!+o0lVXyS*V;$~>#Tc8VM+|a~#LdC<-#J!>7 z8EE3sQ1MDM@f4_d7n-;Obb-rMBymvv8wE)w3=5FNLG^DVRQ(1t@mo;w18Cx(pyC(M z#Q#FYAE1ewC_ya#jwbF573YJ7A1s_<;tFWuK2Y^WXyRE=aW6FS5~z3<4)H1+;$3Ls z4N!B|;t)TDCO!eG{yv)cYN+^oH1W+)@&9PzJD}o1(0GQ04@_JMOVgNjc@6W^)^ ziI=Tt;ya<@S8<4c#39ZIO-C^QzJr=0fhImv9b&Hr4smNVaYm?mS2S@psCX!vI5$*0 z6^D2!4)Inr@fXl=TY)C-1ohVuG;uem_yZi`-*JeuL-P$R+^V7G$f1d!hx$toO}rPX z-U3a05>(s^O?);~JO+n&F%I!oG;w#Rd#0j^OF+$EibH%Wk~s1@%%f=H&}9`2SJA|w z!?O&}(8Qt6Vfcn74qKPW2F>@Na0b~66BolFu7f6S3`w>O_Gsc3P;po}2Q%LWDjtuf z9=6^zABT7ons_GEoJnZnu=SvekiO-Lmk&Ds9v!UW$XyOLikZ_xe zCT;>1-+)8>I1cgaXyTbrb71uhDBM8qd<_-ZQ@dtDxfAXyWxy zacdmn-Z;dg(Zu&d&B;a+KMf7f1~l@(3Cqc!ZA&G;`fvwyAh$Id&2d4fvk~p$@HfX+t#S2Wm0FpSedTAtaWb;*# z#F5n-pox2fEMj0_a6l4AUjHAABn~nk5^4+#aY*7I^I_tdNaD~Xt6-^OBys4{OR#t? zk~owJ7Vm&^K+Z#U548CJ-Zx>%z`$S*R?WZwP3Ca%M5s74`r+cKP;osd4O)%^GN%d3 zH-geIaag%zh9(X@ev`opO&q#Ckiia3ToU9F1_lP$eg&BM=1_4rH1+9FaW6FS5~#Qz zns^&jJP1vE9#lLGO?*96999p*+;avh4htuk_*JNQ7MeNGV-6Ye(Zpfv;Y-lOq1#d! zD$&HbpoyyvO6W51|_o9j0LB%JbiNp2}Oh*$BhN_=~CY}Tphh8HO zPgg}yaoD~RSh%%8#i7@Dmqf3-oyYthuh z_Kh^5iBE^BZ$}ef2o>)^6JG@tpNJ;D2`WAfP5b~4m~CtE?x~4e}-lbY~RakH1S@j`VVO0Goa#M(Zm-( z#eboRuYijGM-$%;6=#8#)3ES402Sv%6F&(R=R*^}3>6nf6Nl}qkw6oF4plFUCjJ^K zt_~FkITxCwz$LRMk~mZ;SlkI(PJq-ym4L$e#U z!N!5B0g(By`QH?1Ll9>E2I#z6r#-5A1!zC^sXMATtY10L8zByAC&T>{fsd%4g&)Nbl8;vY+=d!Mb4kKtbZ5@COSrFfhROxq`$&>S60=YCr-=?u4Zu zSUU?O4Z;E-O$-bS4?r9w^{{lM0}T(5Gzi1i?ZDbEATf{;&QJ%{AgKqr6Xu>)Byo^> zSi64#k~qjL*t(80XyUN+ECCH~kXjIirDs_E1`-2d*nHIrH1!71@ow0DN|0I*hRuJS zMN$uPC#=8m14$g@FW9^oBQ#Nh%mAr}^($nM#6fbfc@S7R4H5%kSiW0=rXJQ$-hm{J zoWH&xiG$67O8!L>2f3#R8ZR2q0a%b)ko#fdhlWVvAoZ{ZAoZ|*!T}_4l=4BZxH7jSF^NI1xTFX|XTVrRsX2*yC8-r940Uz5fpcNIr+(nIeISPdPS*edhzk;6&3LXsYS*4d5JlhC6)1I1`K-1 z`MJ5Nc_j>bdHE%&dhULqy2T}l$=OhTdS0nsK~a7|YEcQym#G=?X+?>-sSJAQMfs%# z&_qlDRlvl+0IkYVOo6RmgKp~V2u^N~@7>!Fm zte!;H4=R&k`d~CJ{jhNrWc{Fe45kl8gX(Wkl?Kh$Ag6*cENB;j91a$N5YX)m5Dw@Z z1qKFiSir&yCLs_BGL?Y=ww?fF45)~Mg(q}*A$Z&jq!Lx7fz|Aj^nQWlK5=jE4AKhGZ|A#}{MCkerp!UPY+h9hc z>j#aOf#Sje&HfAJAXhOkz|s-OpP)80$gd!?VBrUve*&q5HWxusU|a;XKNchj7J(2j zE{tx3xgR18Coez;C}I6nm;{+z;B4h3@_dQ2Wu%wS-nK(CfTm z)`Q#0a1H|l!y>4DbpQW=>PHuc*$?yoAE;Se)BWL$ z*z@lTEba#_Er;0;bALV~0|RJ_8G1g6fZ7jJ4|4#F52Lei*q=}h@gd9}Q22qC!o&2z z#6j(Muu7N&)S?8a{n^z}0Vsv0i~(c~IR8QAVN?Z3f`Ne{VGG1(Ap1df!t{gKAhn?J z5p4EfSPPP6U{FMh7?^&DECa)QX#6ptN&MIhQBef-2ZYCfu8d(8j_|vo4=QaL7;b

WV@fL81%{*=Xewx_;0&3`iw2nz|p>AW=;J!t_I(!vGrJ0f#@D{s$Ql|HI-L6#k&0 z3YdPFIOzN!kWJ8Nf*H%e03G;+E`NoKgVcgJFd8(k0%L>3VOR#LAI68#=xY6#7#KiD zW}rErK>?~C-CZ#E!^}%#f|TFr`U9Z)Vdt2@)T8SMjRSzg52gT0|A2-c2S^f{en4}H zF#WLb1NjHtZjccg&L9~E2H3uJP;&s(enr>M$-uw>Dd9l65Lm+>qW>vK0YVs~{sq-( T*z_~xLgK$1&2bP@5e5PP(UsXk diff --git a/src/GC/lib/heap.cpp b/src/GC/lib/heap.cpp deleted file mode 100644 index fade27a..0000000 --- a/src/GC/lib/heap.cpp +++ /dev/null @@ -1,671 +0,0 @@ -#include -#include -#include -#include -#include - -#include "heap.hpp" - -#define time_now std::chrono::high_resolution_clock::now() -#define to_us std::chrono::duration_cast - -using std::cout, std::endl, std::vector, std::hex, std::dec; - -namespace GC -{ - /** - * This implementation of the() guarantees laziness - * on the instance and a correct destruction with - * the destructor. - * - * @returns The singleton object. - */ - Heap& Heap::the() - { - static Heap instance; - return instance; - } - - /** - * Initialises the heap singleton and saves the address - * of the calling function's stack frame as the stack_top. - * Presumeably this address points to the stack frame of - * the compiled LLVM executable after linking. - */ - void Heap::init() - { - Heap &heap = Heap::the(); - if (heap.profiler_enabled()) - Profiler::record(HeapInit); -// clang complains because arg for __b_f_a is not 0 which is "unsafe" -#pragma clang diagnostic ignored "-Wframe-address" - heap.m_stack_top = static_cast(__builtin_frame_address(1)); - heap.m_heap_top = heap.m_heap; - } - - void Heap::set_profiler_log_options(RecordOption flags) - { - Profiler::set_log_options(flags); - } - - /** - * Disposes the heap and the profiler at program exit - * which also triggers a heap log file dumped if the - * profiler is enabled. - */ - void Heap::dispose() - { - Heap &heap = Heap::the(); - if (heap.profiler_enabled()) - Profiler::dispose(); - } - - /** - * Allocates a given amount of bytes on the heap. - * - * @param size The amount of bytes to be allocated. - * - * @return A pointer to the address where the memory - * has been allocated. This pointer is supposed - * to be casted to and object pointer. - */ - void *Heap::alloc(size_t size) - { - auto a_start = time_now; - // Singleton - Heap &heap = Heap::the(); - bool profiler_enabled = heap.profiler_enabled(); - - if (profiler_enabled) - Profiler::record(AllocStart, size); - - if (size == 0) - { - cout << "Heap: Cannot alloc 0B. No bytes allocated." << endl; - return nullptr; - } - - if (heap.m_size + size > HEAP_SIZE) - { - // auto a_ms = to_us(c_start - a_start); - // Profiler::record(AllocStart, a_ms); - heap.collect(); - // If memory is not enough after collect, crash with OOM error - if (heap.m_size + size > HEAP_SIZE) - { - if (profiler_enabled) - Profiler::dispose(); - throw std::runtime_error(std::string("Error: Heap out of memory")); - } - } - - // If a chunk was recycled, return the old chunk address - Chunk *reused_chunk = heap.try_recycle_chunks(size); - if (reused_chunk != nullptr) - { - if (profiler_enabled) - Profiler::record(ReusedChunk, reused_chunk); - auto a_end = time_now; - auto a_ms = to_us(a_end - a_start); - Profiler::record(AllocStart, a_ms); - return static_cast(reused_chunk->m_start); - } - - // If no free chunks was found (reused_chunk is a nullptr), - // then create a new chunk - auto new_chunk = new Chunk(size, (uintptr_t *)(heap.m_heap + heap.m_size)); - - heap.m_size += size; - heap.m_allocated_chunks.push_back(new_chunk); - - if (profiler_enabled) - Profiler::record(NewChunk, new_chunk); - - auto a_end = time_now; - auto a_ms = to_us(a_end - a_start); - Profiler::record(AllocStart, a_ms); - return new_chunk->m_start; - } - - /** - * Tries to recycle used and freed chunks that are - * already allocated objects by the OS but freed - * from our Heap. This reduces the amount of GC - * objects slightly which saves time from malloc'ing - * memory from the OS. - * - * @param size Amount of bytes needed for the object - * which is about to be allocated. - * - * @returns If a chunk is found and recycled, a - * pointer to the allocated memory for - * the object is returned. If not, a - * nullptr is returned to signify no - * chunks were found. - */ - Chunk *Heap::try_recycle_chunks(size_t size) - { - Heap &heap = Heap::the(); - // Check if there are any freed chunks large enough for current request - for (size_t i = 0; i < heap.m_freed_chunks.size(); i++) - { - //auto chunk = Heap::get_at(heap.m_freed_chunks, i); - auto chunk = heap.m_freed_chunks[i]; - auto iter = heap.m_freed_chunks.begin(); - advance(iter, i); - if (chunk->m_size > size) - { - // Split the chunk, use one part and add the remaining part to - // the list of freed chunks - size_t diff = chunk->m_size - size; - auto chunk_complement = new Chunk(diff, chunk->m_start + chunk->m_size); - - heap.m_freed_chunks.erase(iter); - heap.m_freed_chunks.push_back(chunk_complement); - heap.m_allocated_chunks.push_back(chunk); - - return chunk; - } - else if (chunk->m_size == size) - { - // Reuse the whole chunk - heap.m_freed_chunks.erase(iter); - heap.m_allocated_chunks.push_back(chunk); - return chunk; - } - } - // If no chunk was found, return nullptr - return nullptr; - } - - /** - * Returns a bool whether the profiler is enabled - * or not. - * - * @returns True or false if the profiler is enabled - * or disabled respectively. - */ - bool Heap::profiler_enabled() { - Heap &heap = Heap::the(); - return heap.m_profiler_enable; - } - - /** - * Collection phase of the garbage collector. When - * an allocation is requested and there is no space - * left on the heap, a collection is triggered. This - * function is private so that the user cannot trigger - * a collection unneccessarily. - */ - void Heap::collect() - { - auto c_start = time_now; - - Heap &heap = Heap::the(); - - if (heap.profiler_enabled()) - Profiler::record(CollectStart); - - // get current stack frame - auto stack_bottom = reinterpret_cast(__builtin_frame_address(0)); - - if (heap.m_stack_top == nullptr) - throw std::runtime_error(std::string("Error: Heap is not initialized, read the docs!")); - - uintptr_t *stack_top = heap.m_stack_top; - - auto work_list = heap.m_allocated_chunks; - mark(stack_bottom, stack_top, work_list); - - sweep(heap); - - free(heap); - - auto c_end = time_now; - - Profiler::record(CollectStart, to_us(c_end - c_start)); - } - - /** - * Iterates through the stack, if an element on the stack points to a chunk, - * called a root chunk, that chunk is marked (i.e. reachable). - * Then it recursively follows all chunks which are possibly reachable from - * the root chunk and mark those chunks. - * If a chunk is marked it is removed from the worklist, since it's no longer of - * concern for this method. - * - * Time complexity: 0(N^2 * log(N)) as upper bound. - * Where N is either the size of the worklist or the size of - * the stack frame, depending on which is the largest. - * - * @param start Pointer to the start of the stack frame. - * @param end Pointer to the end of the stack frame. - * @param worklist The currently allocated chunks, which haven't been marked. - */ - void Heap::mark(uintptr_t *start, const uintptr_t* const end, vector &worklist) - { - Heap &heap = Heap::the(); - bool profiler_enabled = heap.m_profiler_enable; - if (profiler_enabled) - Profiler::record(MarkStart); - - // To find adresses thats in the worklist - for (; start <= end; start++) - { - auto it = worklist.begin(); - auto stop = worklist.end(); - while (it != stop) - { - Chunk *chunk = *it; - auto c_start = reinterpret_cast(chunk->m_start); - auto c_size = reinterpret_cast(chunk->m_size); - auto c_end = reinterpret_cast(c_start + c_size); - - // Check if the stack pointer points to something within the chunk - if (c_start <= *start && *start < c_end) - { - if (!chunk->m_marked) - { - if (profiler_enabled) - Profiler::record(ChunkMarked, chunk); - chunk->m_marked = true; - it = worklist.erase(it); - - // Recursively call mark, to see if the reachable chunk further points to another chunk - mark((uintptr_t *)c_start, (uintptr_t *)c_end, worklist); - } - else - { - ++it; - } - } - else - { - ++it; - } - } - } - } - - - /** - * Sweeps the heap, unmarks the marked chunks for the next cycle, - * adds the unmarked nodes to the list of freed chunks; to be freed. - * - * Time complexity: O(N^2), where N is the number of allocated chunks. - * It is quadratic, in the worst case, - * since each call to erase() is linear. - * - * @param heap Pointer to the heap singleton instance. - */ - void Heap::sweep(Heap &heap) - { - bool profiler_enabled = heap.m_profiler_enable; - if (profiler_enabled) - Profiler::record(SweepStart); - auto iter = heap.m_allocated_chunks.begin(); - // This cannot "iter != stop", results in seg fault, since the end gets updated, I think. - while (iter != heap.m_allocated_chunks.end()) - { - Chunk *chunk = *iter; - - // Unmark the marked chunks for the next iteration. - if (chunk->m_marked) - { - chunk->m_marked = false; - ++iter; - } - else - { - // Add the unmarked chunks to freed chunks and remove from - // the list of allocated chunks - if (profiler_enabled) - Profiler::record(ChunkSwept, chunk); - heap.m_freed_chunks.push_back(chunk); - iter = heap.m_allocated_chunks.erase(iter); - heap.m_size -= chunk->m_size; - } - } - } - - /** - * Frees chunks that was moved to the list m_freed_chunks - * by the sweep phase. If there are more than a certain - * amount of free chunks, delete the free chunks to - * avoid cluttering. - * - * Time complexity: O(N^2), where N is the freed chunks. - * If free_overlap() is called, it runs in O(N^2), - * otherwise O(N). - * - * @param heap Heap singleton instance, only for avoiding - * redundant calls to the singleton get - */ - void Heap::free(Heap &heap) - { - bool profiler_enabled = heap.m_profiler_enable; - if (profiler_enabled) - Profiler::record(FreeStart); - if (heap.m_freed_chunks.size() > FREE_THRESH) - { - bool profiler_enabled = heap.profiler_enabled(); - while (heap.m_freed_chunks.size()) - { - auto chunk = heap.m_freed_chunks.back(); - heap.m_freed_chunks.pop_back(); - if (profiler_enabled) - Profiler::record(ChunkFreed, chunk); - delete chunk; - } - } - // if there are chunks but not more than FREE_THRESH - else if (heap.m_freed_chunks.size()) - { - // essentially, always check for overlap between - // chunks before finishing the allocation - free_overlap(heap); - } - } - - /** - * Checks for overlaps between freed chunks of memory - * and removes overlapping chunks while prioritizing - * the chunks at lower addresses. - * - * Time complexity: O(N^2), where N is the number of freed chunks. - * At each iteration get_at() is called, which is linear. - * - * @param heap Heap singleton instance, only for avoiding - * redundant calls to the singleton get - * - * @note Maybe this should be changed to prioritizing - * larger chunks. Should remove get_at() to indexing, - * since that's constant. - */ - void Heap::free_overlap(Heap &heap) // borde göra en record(ChunkFreed) på onödiga chunks - { - std::vector filtered; - size_t i = 0; - //auto prev = Heap::get_at(heap.m_freed_chunks, i++); - auto prev = heap.m_freed_chunks[i++]; - prev->m_marked = true; - filtered.push_back(prev); - cout << filtered.back()->m_start << endl; - for (; i < heap.m_freed_chunks.size(); i++) - { - prev = filtered.back(); - //auto next = Heap::get_at(heap.m_freed_chunks, i); - auto next = heap.m_freed_chunks[i]; - auto p_start = (uintptr_t)(prev->m_start); - auto p_size = (uintptr_t)(prev->m_size); - auto n_start = (uintptr_t)(next->m_start); - if (n_start >= (p_start + p_size)) - { - next->m_marked = true; - filtered.push_back(next); - } - } - heap.m_freed_chunks.swap(filtered); - - bool profiler_enabled = heap.m_profiler_enable; - // After swap m_freed_chunks contains still available chunks - // and filtered contains all the chunks, so delete unused chunks - for (Chunk *chunk : filtered) - { - // if chunk was filtered away, delete it - if (!chunk->m_marked) - { - if (profiler_enabled) - Profiler::record(ChunkFreed, chunk); - delete chunk; - } - else - { - chunk->m_marked = false; - } - } - } - - void Heap::set_profiler(bool mode) - { - Heap &heap = Heap::the(); - heap.m_profiler_enable = mode; - } - -#ifdef HEAP_DEBUG - /** - * Prints the result of Heap::init() and a dummy value - * for the current stack frame for reference. - */ - void Heap::check_init() - { - Heap &heap = Heap::the(); - cout << "Heap addr:\t" << &heap << "\n"; - cout << "GC m_stack_top:\t" << heap.m_stack_top << "\n"; - auto stack_bottom = reinterpret_cast(__builtin_frame_address(0)); - cout << "GC stack_bottom:\t" << stack_bottom << endl; - } - - /** - * Conditional collection, only to be used in debugging - * - * @param flags Bitmap of flags - */ - void Heap::collect(CollectOption flags) - { - set_profiler(true); - - Heap &heap = Heap::the(); - - if (heap.m_profiler_enable) - Profiler::record(CollectStart); - - cout << "DEBUG COLLECT\nFLAGS: "; - if (flags & MARK) - cout << "\n - MARK"; - if (flags & SWEEP) - cout << "\n - SWEEP"; - if (flags & FREE) - cout << "\n - FREE"; - cout << "\n"; - - // get the frame adress, whwere local variables and saved registers are located - auto stack_bottom = reinterpret_cast(__builtin_frame_address(0)); - cout << "Stack bottom in collect:\t" << stack_bottom << "\n"; - uintptr_t *stack_top = heap.m_stack_top; - - cout << "Stack end in collect:\t " << stack_top << endl; - auto work_list = heap.m_allocated_chunks; - - if (flags & MARK) - mark(stack_bottom, stack_top, work_list); - - if (flags & SWEEP) - sweep(heap); - - if (flags & FREE) - free(heap); - } - - // Mark child references from the root references - void mark_test(vector &worklist) - { - while (worklist.size() > 0) - { - Chunk *ref = worklist.back(); - worklist.pop_back(); - Chunk *child = (Chunk *)ref; // this is probably not correct - if (child != nullptr && !child->m_marked) - { - child->m_marked = true; - worklist.push_back(child); - mark_test(worklist); - } - } - } - - // Mark the root references and look for child references to them - void mark_from_roots(uintptr_t *start, const uintptr_t *end) - { - vector worklist; - for (; start > end; start--) - { - if (*start % 8 == 0) - { // all pointers must be aligned as double words - Chunk *ref = (Chunk *)*start; - if (ref != nullptr && !ref->m_marked) - { - ref->m_marked = true; - worklist.push_back(ref); - mark_test(worklist); - } - } - } - } - - // For testing purposes - void Heap::print_line(Chunk *chunk) - { - cout << "Marked: " << chunk->m_marked << "\nStart adr: " << chunk->m_start << "\nSize: " << chunk->m_size << " B\n" - << endl; - } - - void Heap::print_worklist(std::vector &list) - { - for (auto cp : list) - cout << "Chunk at:\t" << cp->m_start << "\nSize:\t\t" << cp->m_size << "\n"; - cout << endl; - } - - void Heap::print_contents() - { - Heap &heap = Heap::the(); - if (heap.m_allocated_chunks.size()) - { - cout << "\nALLOCATED CHUNKS #" << dec << heap.m_allocated_chunks.size() << endl; - for (auto chunk : heap.m_allocated_chunks) - print_line(chunk); - } - else - { - cout << "NO ALLOCATIONS\n" << endl; - } - if (heap.m_freed_chunks.size()) - { - cout << "\nFREED CHUNKS #" << dec << heap.m_freed_chunks.size() << endl; - for (auto fchunk : heap.m_freed_chunks) - print_line(fchunk); - } - else - { - cout << "NO FREED CHUNKS" << endl; - } - } - - void Heap::print_summary() - { - Heap &heap = Heap::the(); - if (heap.m_allocated_chunks.size()) - { - cout << "\nALLOCATED CHUNKS #" << dec << heap.m_allocated_chunks.size() << endl; - } - else - { - cout << "NO ALLOCATIONS\n" << endl; - } - if (heap.m_freed_chunks.size()) - { - cout << "\nFREED CHUNKS #" << dec << heap.m_freed_chunks.size() << endl; - } - else - { - cout << "NO FREED CHUNKS" << endl; - } - } - - void Heap::print_allocated_chunks(Heap *heap) { - cout << "--- Allocated Chunks ---\n" << endl; - for (auto chunk : heap->m_allocated_chunks) { - print_line(chunk); - } - } - - Chunk *Heap::try_recycle_chunks_new(size_t size) - { - Heap &heap = Heap::the(); - // Check if there are any freed chunks large enough for current request - for (size_t i = 0; i < heap.m_freed_chunks.size(); i++) - { - auto chunk = heap.m_freed_chunks[i]; //Heap::get_at(heap.m_freed_chunks, i); - auto iter = heap.m_freed_chunks.begin(); - //advance(iter, i); - i++; - if (chunk->m_size > size) - { - // Split the chunk, use one part and add the remaining part to - // the list of freed chunks - size_t diff = chunk->m_size - size; - auto chunk_complement = new Chunk(diff, chunk->m_start + chunk->m_size); - - heap.m_freed_chunks.erase(iter); - heap.m_freed_chunks.push_back(chunk_complement); - heap.m_allocated_chunks.push_back(chunk); - - return chunk; - } - else if (chunk->m_size == size) - { - // Reuse the whole chunk - heap.m_freed_chunks.erase(iter); - heap.m_allocated_chunks.push_back(chunk); - return chunk; - } - } - // If no chunk was found, return nullptr - return nullptr; - } - - void Heap::free_overlap_new(Heap &heap) // borde göra en record(ChunkFreed) på onödiga chunks - { - std::vector filtered; - size_t i = 0; - auto prev = heap.m_freed_chunks[i++]; //Heap::get_at(heap.m_freed_chunks, i++); - prev->m_marked = true; - filtered.push_back(prev); - cout << filtered.back()->m_start << endl; - for (; i < heap.m_freed_chunks.size(); i++) - { - prev = filtered.back(); - auto next = heap.m_freed_chunks[i]; //Heap::get_at(heap.m_freed_chunks, i); - auto p_start = (uintptr_t)(prev->m_start); - auto p_size = (uintptr_t)(prev->m_size); - auto n_start = (uintptr_t)(next->m_start); - if (n_start >= (p_start + p_size)) - { - next->m_marked = true; - filtered.push_back(next); - } - } - heap.m_freed_chunks.swap(filtered); - - bool profiler_enabled = heap.m_profiler_enable; - // After swap m_freed_chunks contains still available chunks - // and filtered contains all the chunks, so delete unused chunks - for (Chunk *chunk : filtered) - { - // if chunk was filtered away, delete it - if (!chunk->m_marked) - { - if (profiler_enabled) - Profiler::record(ChunkFreed, chunk); - delete chunk; - } - else - { - chunk->m_marked = false; - } - } - } - -#endif -} \ No newline at end of file diff --git a/src/GC/lib/profiler.cpp b/src/GC/lib/profiler.cpp deleted file mode 100644 index ae31f0d..0000000 --- a/src/GC/lib/profiler.cpp +++ /dev/null @@ -1,311 +0,0 @@ -#include -#include -#include -#include -#include -#include -#include -#include - -#include "chunk.hpp" -#include "event.hpp" -#include "profiler.hpp" - -// #define MAC_OS - -namespace GC -{ - Profiler& Profiler::the() - { - static Profiler instance; - return instance; - } - - RecordOption Profiler::log_options() - { - Profiler &prof = Profiler::the(); - return prof.flags; - } - - void Profiler::set_log_options(RecordOption flags) - { - Profiler &prof = Profiler::the(); - prof.flags = flags; - } - - void Profiler::record_data(GCEvent *event) - { - Profiler &prof = Profiler::the(); - prof.m_events.push_back(event); - - if (prof.m_last_prof_event->m_type == event->get_type()) - prof.m_last_prof_event->m_n++; - else - { - prof.m_prof_events.push_back(prof.m_last_prof_event); - prof.m_last_prof_event = new ProfilerEvent(event->get_type()); - } - } - - /** - * Records an event independent of a chunk. - * - * @param type The type of event to record. - */ - void Profiler::record(GCEventType type) - { - Profiler &prof = Profiler::the(); - if (prof.flags & type) - Profiler::record_data(new GCEvent(type)); - // auto event = new GCEvent(type); - // auto profiler = Profiler::the(); - // profiler.m_events.push_back(event); - } - - /** - * This overload is only used with an AllocStart - * event. - * - * @param type The type of event to record. - * - * @param size The size of requested to alloc(). - */ - void Profiler::record(GCEventType type, size_t size) - { - Profiler &prof = Profiler::the(); - if (prof.flags & type) - Profiler::record_data(new GCEvent(type, size)); - // auto event = new GCEvent(type, size); - // auto profiler = Profiler::the(); - // profiler.m_events.push_back(event); - } - - void Profiler::dump_trace() - { - Profiler &prof = Profiler::the(); - if (prof.flags & FunctionCalls) - dump_prof_trace(); - else - dump_chunk_trace(); - } - - /** - * Records an event related to a chunk. - * - * @param type The type of event to record. - * - * @param chunk The chunk the event is connected - * to. - */ - void Profiler::record(GCEventType type, Chunk *chunk) - { - // Create a copy of chunk to store in the profiler - // because in free() chunks are deleted and cannot - // be referenced by the profiler. These copied - // chunks are deleted by the profiler on dispose(). - Profiler &prof = Profiler::the(); - if (prof.flags & type) - { - auto chunk_copy = new Chunk(chunk); - auto event = new GCEvent(type, chunk_copy); - Profiler::record_data(event); - } - // auto profiler = Profiler::the(); - // profiler.m_events.push_back(event); - } - - void Profiler::record(GCEventType type, std::chrono::microseconds time) - { - Profiler &prof = Profiler::the(); - if (type == AllocStart) - { - prof.alloc_time += time; - } - else if (type == CollectStart) - { - prof.collect_time += time; - } - } - - void Profiler::dump_prof_trace() - { - Profiler &prof = Profiler::the(); - prof.m_prof_events.push_back(prof.m_last_prof_event); - auto start = prof.m_prof_events.begin(); - auto end = prof.m_prof_events.end(); - int allocs = 0, collects = 0; - - char buffer[22]; - std::ofstream fstr = prof.create_file_stream(); - - while (start != end) - { - auto event = *start++; - - if (event->m_type == AllocStart) - allocs += event->m_n; - else if (event->m_type == CollectStart) - collects += event->m_n; - - fstr << "\n--------------------------------\n" - << Profiler::type_to_string(event->m_type) << " " - << event->m_n << " times:"; - } - fstr << "\n--------------------------------"; - - fstr << "\n\nTime spent on allocations:\t" << prof.alloc_time.count() << " microseconds" - << "\nAllocation cycles:\t" << allocs - << "\nTime spent on collections:\t" << prof.collect_time.count() << " microseconds" - << "\nCollection cycles:\t" << collects - << "\n--------------------------------"; - } - - /** - * Prints the history of the recorded events - * to a log file in the /tests/logs folder. - */ - void Profiler::dump_chunk_trace() - { - Profiler &prof = Profiler::the(); - auto start = prof.m_events.begin(); - auto end = prof.m_events.end(); - - // Buffer for timestamp - char buffer[22]; - - while (start != end) - { - auto event = *start++; - auto e_type = event->get_type(); - - prof.print_chunk_event(event, buffer); - } - } - - void Profiler::print_chunk_event(GCEvent *event, char buffer[22]) - { - Profiler &prof = Profiler::the(); - // File output stream - std::ofstream fstr = prof.create_file_stream(); - std::time_t tt = event->get_time_stamp(); - std::tm *btm = std::localtime(&tt); - std::strftime(buffer, 22, "%a %T", btm); - - fstr << "--------------------------------\n" - << buffer - << "\nEvent:\t" << Profiler::type_to_string(event->get_type()); - // event->type_to_string(); - - - - const Chunk *chunk = event->get_chunk(); - - if (event->get_type() == AllocStart) - { - fstr << "\nSize: " << event->get_size(); - } - else if (chunk) - { - fstr << "\nChunk: " << chunk->m_start - << "\n Size: " << chunk->m_size - << "\n Mark: " << chunk->m_marked; - } - fstr << "\n"; - } - - /** - * Deletes the profiler singleton and all - * the events recorded after recording - * the ProfilerDispose event and dumping - * the history to a log file. - */ - void Profiler::dispose() - { - Profiler::record(ProfilerDispose); - Profiler::dump_trace(); - } - - /** - * Creates a filestream for the future - * log file to print the history to in - * dump_trace(). - * - * @returns The output stream to the file. - */ - std::ofstream Profiler::create_file_stream() - { - // get current time - std::time_t tt = std::time(NULL); - std::tm *ptm = std::localtime(&tt); - - // format to string - char buffer[32]; - std::strftime(buffer, 32, "/log_%a_%H_%M_%S.txt", ptm); - std::string filename(buffer); - - // const std::string ABS_PATH = "/home/virre/dev/systemF/org/language/src/GC/"; - // // const std::string ABS_PATH = "/Users/valtermiari/Desktop/DV/Bachelors/code/language/src/GC"; - // std::string fullpath = ABS_PATH + filename; - - const std::string fullpath = get_log_folder() + filename; - - std::ofstream fstr(fullpath); - return fstr; - } - - /** - * This function retrieves the path to the folder - * of the executable to use for log files. - * - * @returns The path to the logs folder. - * - * @throws A runtime error if the call - * to readlink() fails. - */ - std::string Profiler::get_log_folder() - { -#ifndef MAC_OS - char buffer[1024]; - // chars read from path - ssize_t len = readlink("/proc/self/exe", buffer, sizeof(buffer)-1); - - // if readlink fails - if (len == -1) - { - throw std::runtime_error(std::string("Error: readlink failed on '/proc/self/exe/'")); - } - - buffer[len] = '\0'; - - // convert to string for string operators - auto path = std::string(buffer); - - // remove filename - size_t last_slash = path.find_last_of('/'); - std::string folder = path.substr(0, last_slash); -#else - auto folder = std::string("/Users/valtermiari/Desktop/DV/Bachelors/code/language/src/GC/tests"); -#endif - return folder + "/logs"; - } - - const char *Profiler::type_to_string(GCEventType type) - { - switch (type) - { - case HeapInit: return "HeapInit"; - case AllocStart: return "AllocStart"; - case CollectStart: return "CollectStart"; - case MarkStart: return "MarkStart"; - case ChunkMarked: return "ChunkMarked"; - case ChunkSwept: return "ChunkSwept"; - case ChunkFreed: return "ChunkFreed"; - case NewChunk: return "NewChunk"; - case ReusedChunk: return "ReusedChunk"; - case ProfilerDispose: return "ProfilerDispose"; - case SweepStart: return "SweepStart"; - case FreeStart: return "FreeStart"; - default: return "[Unknown]"; - } - } -} \ No newline at end of file diff --git a/src/GC/tests/MarkSweep.cpp b/src/GC/tests/MarkSweep.cpp deleted file mode 100644 index ab219d2..0000000 --- a/src/GC/tests/MarkSweep.cpp +++ /dev/null @@ -1,87 +0,0 @@ -#include -#include -#define HEAP_SIZE 65536 // Arbitrary for now, 2^16 -using namespace std; - -/* A simple mark and sweep algorithm */ - -// Shouldn't be exposed. For now, it is -struct ObjectHeader { - size_t size = sizeof(this); - bool marked = false; - -}; - -struct Object : ObjectHeader { - char name; // should be something like id, but for testing sake its char - Object* child; - // Object(char name_) {} - Object(char name_, Object* child_) { - name = name_; - child = child_; - } -}; - -// Representing the heap as a simple struct for now -struct Heap { - Object heap_space[HEAP_SIZE]; -}; - -// For now it assumes that it is given root objects from the start, no root finding included -class MarkSweep { - public: - void mark(Object* obj) { - if (!markedBit(obj)) { - markBit(obj); - Object* ref = obj->child; - if (ref != nullptr) { - mark(ref); - } - } - } - - void sweep(vector worklist) { - for (Object* obj: worklist) { - if (!markedBit(obj) && obj != nullptr) { - delete obj; - } - } - } - - private: - bool markedBit(Object* obj) { - return obj->marked; - } - - void markBit(Object* obj) { - obj->marked = true; - } - -}; - -int main() { - Object* b = new Object('B', nullptr); - // b->name = 'B'; - // b->child = nullptr; - Object* c = new Object('C', b); - // c->name = 'C'; - // c->child = b; // c -> d - Object* d = new Object('D', nullptr); - // d->name = 'D'; - // d->child = nullptr; - - //Heap* heap = new Heap{*c, *b, *d}; - vector worklist = {c, b, d}; - MarkSweep* gc = new MarkSweep(); - - gc->mark(c); - cout << "Expected 1, got: " << b->marked << '\n'; - cout << "Expected 1, got: " << c->marked << '\n'; - cout << "Expected 0, got: " << d->marked << '\n'; - - gc->sweep(worklist); - cout << b->name << '\n'; - cout << c->name << '\n'; - cout << d->name << '\n'; // The object at d is now deleted (freed) - return 0; -} \ No newline at end of file diff --git a/src/GC/tests/advance.cpp b/src/GC/tests/advance.cpp deleted file mode 100644 index 89dca71..0000000 --- a/src/GC/tests/advance.cpp +++ /dev/null @@ -1,83 +0,0 @@ -#include -#include -#include -#include -#include -#include - -// void time_test() -// { -// using TimeStamp = std::chrono::_V2::system_clock::time_point; - -// std::list l; -// char c = 'a'; -// for (int i = 1; i <= 5; i++) { -// l.push_back(c++); -// } - -// auto iter = l.begin(); -// auto stop = l.end(); - -// while (iter != stop) { -// std::cout << *iter << " "; - -// iter++; -// } -// std::cout << std::endl; -// iter = l.begin(); -// while (*iter != *stop) { -// std::cout << *iter << " "; -// iter++; -// } -// std::cout << std::endl; - -// std::cout << "rebased" << std::endl; -// std::cout << "iter: " << *iter << "\nstop: " << *stop << std::endl; - -// TimeStamp ts = std::chrono::system_clock::now(); -// std::time_t tt = std::chrono::system_clock::to_time_t(ts); -// std::string tstr = std::ctime(&tt); -// tstr.resize(tstr.size()-1); -// std::cout << tstr << std::endl; -// } - -void iter_test() -{ - std::list list; - list.push_back(1); - list.push_back(2); - list.push_back(4); - list.push_back(5); - - auto iter = list.begin(); - - while (iter != list.end()) - { - if (*iter == 4) - { - iter = list.erase(iter); - std::cout << *iter << "\n"; - list.insert(iter, 3); - // list.insert(iter, 3); - // std::cout << "n: " << *(++iter) << "\n"; - // iter = list.erase(++iter); - } - iter++; - } - - for (int i : list) - { - std::cout << i << " "; - } - std::cout << std::endl; -} - - - -int main() { - std::cout << "hello" << std::endl; - - iter_test(); - - return 0; -} \ No newline at end of file diff --git a/src/GC/tests/alloc_free.cpp b/src/GC/tests/alloc_free.cpp deleted file mode 100644 index 4a0f6f8..0000000 --- a/src/GC/tests/alloc_free.cpp +++ /dev/null @@ -1,32 +0,0 @@ -#include - -#include "heap.hpp" - -struct Obj { - int a; - int b; - int c; -}; - -int main() { - GC::Heap::init(); - Obj *obj; - - for (int i = 0; i < 4; i++) { - obj = static_cast(GC::Heap::alloc(sizeof(Obj))); - obj->a = i * i + 1; - obj->b = i * i + 2; - obj->c = i * i + 3; - } - - // heap->force_collect(); - auto heap = GC::Heap::debug_the(); - heap->collect(COLLECT_ALL); - - std::cout << obj->a << ", " << obj->b << ", " << obj->c << std::endl; - - //delete heap; - GC::Heap::dispose(); - - return 0; -} \ No newline at end of file diff --git a/src/GC/tests/alloc_free_list.cpp b/src/GC/tests/alloc_free_list.cpp deleted file mode 100644 index a0d1a27..0000000 --- a/src/GC/tests/alloc_free_list.cpp +++ /dev/null @@ -1,250 +0,0 @@ -#include -#include - -#include "heap.hpp" - -using GC::Chunk; - -void alloc_test(); -void add_to_free_list(Chunk *chunk); -void merge_free_list(Chunk *chunk, bool do_merge); -void do_merge_list(); -void print_free_list(); - -std::list m_free_list; - -int main() -{ - alloc_test(); - - // std::list test; - - // test.push_back(1); - // test.push_back(2); - // test.push_back(3); - // test.push_back(4); - // test.push_back(5); - - // auto iter = test.begin(); - - // std::cout << "First? " << *(iter++) << "\n"; - // std::cout << "Second? " << *(iter--) << "\n"; - // std::cout << "First? " << *iter << std::endl; - - // auto i = test.begin(); - // while (i != test.end()) - // { - // std::cout << *i << " "; - // ++i; - // } - - // if (i == test.end()) - // std::cout << "great success!"; - - // std::cout << std::endl; - - return 0; -} - -void alloc_test() -{ - auto tmp = static_cast(__builtin_frame_address(0)); - - auto c1 = new Chunk((size_t)(8), tmp); - auto c2 = new Chunk((size_t)(4), c1->m_start + (size_t)(8)); - auto c3 = new Chunk((size_t)(16), c2->m_start + (size_t)(4)); - auto c4 = new Chunk((size_t)(4), c3->m_start + (size_t)(16)); - auto c5 = new Chunk((size_t)(32), c4->m_start + (size_t)(4)); - - // std::cout << "test: " << (uintptr_t *)(tmp + (size_t)(2)) << std::endl; - - std::cout << "tmp: " << tmp << "\ntmp: " << (tmp + (size_t)(28)) << std::endl; - - // add_to_free_list(c1); - // add_to_free_list(c2); - // add_to_free_list(c3); - // add_to_free_list(c4); - // add_to_free_list(c5); - - merge_free_list(c1, false); - merge_free_list(c2, false); - merge_free_list(c3, false); - merge_free_list(c4, false); - merge_free_list(c5, false); - - std::cout << "----- BEFORE MERGE ----------------------"; - // print_free_list(); - - do_merge_list(); - - std::cout << "----- AFTER MERGE -----------------------"; - // print_free_list(); -} - -void add_to_free_list(Chunk *chunk) -{ - Chunk *curr; - auto iter = m_free_list.begin(); - uintptr_t *prev_start = nullptr; - uintptr_t *prev_end = nullptr; - - if (m_free_list.size() == 0) - { - m_free_list.push_back(chunk); - return; - } - - while (iter != m_free_list.end()) - { - curr = *iter; - - // If the curr chunk is aligned before param - if (curr->m_start + curr->m_size == chunk->m_start) - { - Chunk *merged = new Chunk( - curr->m_size + chunk->m_size, - curr->m_start); - iter = m_free_list.erase(iter); - m_free_list.insert(iter, merged); - return; - } - - // If the curr chunk is aligned after param - if (chunk->m_start + chunk->m_size == curr->m_start) - { - Chunk *merged = new Chunk( - curr->m_size + chunk->m_size, - chunk->m_start); - iter = m_free_list.erase(iter); - m_free_list.insert(iter, merged); - return; - } - - // If the first chunk starts after param - if (prev_start == nullptr && curr->m_start > chunk->m_start) - { - m_free_list.insert(iter, chunk); - return; - } - - if (prev_end < chunk->m_start && (chunk->m_start + chunk->m_size) < curr->m_start) - { - m_free_list.insert(iter, chunk); - return; - } - - prev_start = curr->m_start; - prev_end = prev_start + curr->m_size; - iter++; - } - - // This is only reachable if the chunk is at the end - m_free_list.push_back(chunk); -} - -void merge_free_list(Chunk *chunk, bool do_merge) -{ - auto i = m_free_list.begin(); - uintptr_t *prev_start = nullptr, *prev_end; - bool chunk_inserted = false; - - while (i != m_free_list.end()) - { - - // if chunk is left-aligned - if ((*i)->m_start + (*i)->m_size == chunk->m_start) - { - m_free_list.insert(++i, chunk); - chunk_inserted = true; - break; - } - - // if chunk is right-aligned - if (chunk->m_start + chunk->m_size == (*i)->m_start) - { - m_free_list.insert(i, chunk); - chunk_inserted = true; - break; - } - - // is new first - if (prev_start == nullptr && (*i)->m_start > chunk->m_start) - { - m_free_list.insert(i, chunk); - chunk_inserted = true; - break; - } - - // if between chunks - if (prev_end < chunk->m_start && (chunk->m_start + chunk->m_size) < (*i)->m_start) - { - m_free_list.insert(i, chunk); - chunk_inserted = true; - break; - } - - prev_start = (*i)->m_start; - prev_end = (*i)->m_start + (*i)->m_size; - i++; - } - - // is new last - if (!chunk_inserted && i == m_free_list.end()) - m_free_list.push_back(chunk); - - if (do_merge) - do_merge_list(); -} - -void do_merge_list() -{ - std::cout << "DO MERGE" << std::endl; - auto i = m_free_list.begin(); - Chunk *prev = *(i++), *curr; - print_free_list(); - - while (i != m_free_list.end()) - { - curr = *i; - - if ((prev->m_start + prev->m_size) == curr->m_start) - { - Chunk *merged = new Chunk( - prev->m_size + curr->m_size, - prev->m_start - ); - - // replace current and previous with merged - i = m_free_list.erase(i); - i = m_free_list.erase(--i); - m_free_list.insert(i, merged); - - prev = merged; - } - else - { - prev = curr; - i++; - } - print_free_list(); - } - print_free_list(); -} - -void print_free_list() -{ - std::cout << "free-list count: " << m_free_list.size() << "\n"; - - auto iter = m_free_list.begin(); - size_t cnt = 1; - - while (iter != m_free_list.end()) - { - std::cout << "C" << cnt << ":\n\tstart: " << (*iter)->m_start - << "\n\tsize: " << (*iter)->m_size << "\n"; - iter++; - cnt++; - } - - std::cout << std::endl; -} \ No newline at end of file diff --git a/src/GC/tests/events.cpp b/src/GC/tests/events.cpp deleted file mode 100644 index e517092..0000000 --- a/src/GC/tests/events.cpp +++ /dev/null @@ -1,44 +0,0 @@ -#include -#include - -using namespace std; -// broken :( -// [event_source(native)] -class ESource { -public: - __event void TestEvent(int eValue); -}; - -// [event_receiver(native)] -class EReceiver { -public: - void Handler1(int eValue) { - cout << "Handler1 with: " << eValue << endl; - } - - void Handler2(int eValue) { - cout << "Handler2 with: " << eValue << endl; - } - - void hookEvent(ESource *eSource) { - __hook(&ESource::TestEvent, eSource, &EReceiver::Handler1); - __hook(&ESource::TestEvent, eSource, &EReceiver::Handler2); - } - - void unhookEvent(ESource *eSource) { - __unhook(&ESource::TestEvent, eSource, &EReceiver::Handler1); - __unhook(&ESource::TestEvent, eSource, &EReceiver::Handler2); - } -}; - -int main() { - - ESource src; - EReceiver rcv; - - rcv.hookEvent(&src); - __raise src.TestEvent(12); - rcv.unhookEvent(&src); - - return 0; -} \ No newline at end of file diff --git a/src/GC/tests/extern_lib.cpp b/src/GC/tests/extern_lib.cpp deleted file mode 100644 index fa30051..0000000 --- a/src/GC/tests/extern_lib.cpp +++ /dev/null @@ -1,94 +0,0 @@ -#include -#include - -#include "heap.hpp" - -GC::Heap& singleton_test(); -void init_gc(GC::Heap& heap); -void frame_test(GC::Heap& heap); - -int main() { - std::cout << "in main" << std::endl; - GC::Heap &heap = singleton_test(); - - init_gc(heap); - frame_test(heap); - - heap.dispose(); - - return 0; -} - -/** - * This test is supposed to determine if the singleton pattern - * implementation is working correctly. This test passes if the - * first and second call prints the same memory address. - * - * Result: pass - * - * @return Pointer to the Heap singleton instance -*/ -GC::Heap& singleton_test() { - std::cout << "TESTING SINGLETON INSTANCES" << std::endl; - std::cout << "===========================" << std::endl; - std::cout << "Call 1:\t" << &GC::Heap::the() << std::endl; // First call which initializes the singleton instance - GC::Heap &heap = GC::Heap::the(); // Second call which should return the initialized instance - std::cout << "Call 2:\t" << &heap << std::endl; - std::cout << "===========================" << std::endl; - return heap; -} - - -/** - * This test calls Heap::init() which saves the stack-frame - * address from the calling function (this function). - * Heap::init() is supposed to be called at the absolute - * start of the program to save the address of the - * topmost stack frame. This test doesn't do anything - * but prepares for the next test(s). - * - * @param heap The Heap pointer to the singleton instance. - * -*/ -void init_gc(GC::Heap& heap){ - std::cout << "\n\n INITIALIZING THE HEAP" << std::endl; - std::cout << "===========================" << std::endl; - heap.init(); - heap.set_profiler(true); - std::cout << "===========================" << std::endl; -} - -/** - * This function tests the functionality of the intrinsic - * function `__builtin_frame_address` which returns the - * address of the corresponding level of stack frame. - * When given a param of 0, it returns the current stack frame. - * When given a param of 1, it returns the previous stack - * frame, and so on. - * - * This test passes on two conditions: - * 1) if the address of the current frame is smaller than - * the address of the previous frame (assumed). - * 2) if the previous frame has the same address as the one - * saved in the Heap instance after running Heap::init(). - * - * Result: pass - * - * @param heap The Heap instance -*/ -void frame_test(GC::Heap& heap) { - std::cout << "\n\n TESTING FRAME ADDRESSES" << std::endl; - std::cout << "===========================" << std::endl; - -#pragma clang diagnostic ignored "-Wframe-address" // clang++ directive to ignore warnings about __b_f_a - auto curr_frame = reinterpret_cast(__builtin_frame_address(0)); // addr of curr stack frame - std::cout << "Current stack frame:\t" << curr_frame << std::endl; -#pragma clang diagnostic ignored "-Wframe-address" - auto prev_frame = reinterpret_cast(__builtin_frame_address(1)); // addr of prev stack frame - std::cout << "Previous stack frame:\t" << prev_frame << std::endl; - - heap.check_init(); // prints the saved absolute top of the stack - // auto alloced = heap->alloc(sizeof(unsigned long)); - - std::cout << "===========================" << std::endl; -} \ No newline at end of file diff --git a/src/GC/tests/file.cpp b/src/GC/tests/file.cpp deleted file mode 100644 index f4a0373..0000000 --- a/src/GC/tests/file.cpp +++ /dev/null @@ -1,77 +0,0 @@ -#include -#include -#include -#include -#include -#include - -void time_string(char *buffer); -void print_log_file(const std::string TESTS_PATH); -void readlink_test(); -void null_test(); - -int main() -{ - // char time_buffer[31]; - // time_string(time_buffer); - - // const std::string TESTS_PATH = "/home/virre/dev/systemF/org/language/src/GC/tests/"; - // print_log_file(TESTS_PATH); - - // readlink_test(); - - null_test(); - - return 0; -} - -void time_string(char *const buffer) -{ - std::time_t tt = std::time(NULL); - std::tm *ptm = std::localtime(&tt); - std::strftime(buffer, 31, "/logs/log_%a_%H_%M_%S.txt", ptm); - std::cout << buffer << std::endl; -} - -void print_log_file(const std::string TESTS_PATH) -{ - std::string path = TESTS_PATH + "/testlog.txt"; - - std::ofstream testF(path); - - testF << "hellow york"; - - testF.close(); -} - -void readlink_test() -{ - char buffer[1024]; - ssize_t len = readlink("/proc/self/exe", buffer, sizeof(buffer)-1); - if (len == -1) - { - std::cout << "readlink error" << std::endl; - return; - } - - buffer[len] = '\0'; - std::cout << "readlink:\n" << "'''" << buffer << "'''"; // << std::endl; - - auto path = std::string(buffer); - std::cout << path << "\nlen: " << path.size() << "\ncap:" << path.capacity(); - - size_t last_slash = path.find_last_of('/'); - std::string folder = path.substr(0, last_slash); - - std::cout << "\n" << folder; - - std::string log_path = folder + "/log_file_bla.txt"; - std::cout << "\n" << log_path << std::endl; - -} - -void null_test() { - int *p = nullptr; - - std::cout << "P: " << nullptr << std::endl; -} \ No newline at end of file diff --git a/src/GC/tests/game.cpp b/src/GC/tests/game.cpp deleted file mode 100644 index e01ec8e..0000000 --- a/src/GC/tests/game.cpp +++ /dev/null @@ -1,95 +0,0 @@ -#include - -#include "player.hpp" -#include "heap.hpp" - -#define X_LENGTH 1000 -#define Y_LENGTH 500 -#define MAX_PLAYERS 100 - -/* -* Description: -* This class is designed to test the Garbage Collector with a mock game, -* that consists of several live objects in the form of players, that in -* turn consists partially of Point objects. -* -* Goal: -* to find out if all the objects are allocated successfully -* and to see if they are reachable from the stack, i.e. they can get marked. -* -* Result: -* all objects gets allocated, but only Game object gets marked. -*/ - - -class Game { - -private: - - std::vector *players; - //std::vector *players; - Point *dimensions; - -public: - - Game() { - dimensions->x = X_LENGTH; - dimensions->y = Y_LENGTH; - } - - void init() { - players = static_cast*>(GC::Heap::alloc(sizeof(Player*) * MAX_PLAYERS)); - //players = static_cast*>(GC::Heap::alloc(sizeof(Player) * MAX_PLAYERS)); - dimensions = static_cast(GC::Heap::alloc(sizeof(Point))); - dimensions->x = X_LENGTH; - dimensions->y = Y_LENGTH; - } - - void add_player(Player *p) { - players->push_back(p); - } - - Player* create_player(string *s, Point *pos, Point *size, Point *dir) { - Player *p = static_cast(GC::Heap::alloc(sizeof(Player))); - /* - Cannot allocate by new, since it the allocates outside of "out" heap. That also lead so us having to - define an alternative constructor, that's actually a method. Since our "alloc" does not call the constructor - of the object - */ - p->init(s, pos, size, dir); - return p; - } - - void create_players(int nr) { - for (int i = 0; i < nr; i++) { - - std::string *str = static_cast(GC::Heap::alloc(sizeof(std::string))); - Point *pos = static_cast(GC::Heap::alloc(sizeof(Point))); - Point *size = static_cast(GC::Heap::alloc(sizeof(Point))); - Point *dir = static_cast(GC::Heap::alloc(sizeof(Point))); - - Player *p = create_player(str, pos, size, dir); - add_player(p); - } - } - -}; - -int main() { - GC::Heap::init(); - GC::Heap *gc = GC::Heap::debug_the(); - gc->check_init(); - - Game *game = static_cast(gc->alloc(sizeof(Game))); - game->init(); - game->create_players(2); - - std::cout << "Player size: " << sizeof(Player) << std::endl; - std::cout << "Game size: " << sizeof(Game) << std::endl; - std::cout << "Point size: " << sizeof(Point) << std::endl; - - gc->collect(GC::MARK); - gc->print_contents(); - - return 0; -} \ No newline at end of file diff --git a/src/GC/tests/h_test.cpp b/src/GC/tests/h_test.cpp deleted file mode 100644 index 625e36a..0000000 --- a/src/GC/tests/h_test.cpp +++ /dev/null @@ -1,107 +0,0 @@ -#include -#include - -#include "heap.hpp" - -using std::cout, std::endl; - -struct Node { - int id; - Node *child; -}; - -Node *create_chain(int depth) { - cout << "entering create_chain"; - std::vector nodes; - if (depth > 0) { - Node *last_node = static_cast(GC::Heap::alloc(sizeof(Node))); - last_node->id = depth; - last_node->child = nullptr; - nodes.push_back(last_node); - for (size_t i = 0; i < depth; i++) { - Node *node = static_cast(GC::Heap::alloc(sizeof(Node))); - node->id = depth-i; - node->child = nodes[i]; - nodes.push_back(node); - } - cout << "\nexiting create_chain" << endl; - return nodes[depth]; - } - else - return 0; -} - -void create_array(size_t size) { - int *arr = static_cast(GC::Heap::alloc(sizeof(int) * size)); -} - -void detach_pointer(long **ptr) { - cout << "entering detach_pointer"; - long *dummy_ptr = nullptr; - *ptr = dummy_ptr; - cout << "\nexiting detach_pointer" << endl; -} - -Node *test_chain(int depth, bool detach) { - cout << "entering test_chain"; - auto stack_start = reinterpret_cast(__builtin_frame_address(0)); - - Node *node_chain = create_chain(depth); - if (detach) - node_chain->child = nullptr; - - cout << "\nexiting test_chain" << endl; - return node_chain; -} - -void test_some_types() { - cout << "entering test_some_types" << endl; - auto stack_start = reinterpret_cast(__builtin_frame_address(0)); - std::cout << "Stack start from test_some_types:\t" << stack_start << std::endl; - - long *l = static_cast(GC::Heap::alloc(sizeof(long))); - std::cout << "l points to:\t\t" << l << std::endl; - detach_pointer(&l); - std::cout << "l points to:\t\t" << l << std::endl; - - // Some more dummy values of different sizes, to test stack pointer alignment - int *i = static_cast(GC::Heap::alloc(sizeof(int))); - char *c = static_cast(GC::Heap::alloc(sizeof(int))); - short *s = static_cast(GC::Heap::alloc(sizeof(short))); - cout << "exiting test_some_types" << endl; -} - -int main() { - cout << "entering main" << endl; - using namespace std::literals; - - auto start = std::chrono::high_resolution_clock::now(); - //std::cout << "Value of start: " << start.time_since_epoch().count() << std::endl; - GC::Heap::init(); - GC::Heap &gc = GC::Heap::the(); - gc.set_profiler(true); - GC::Profiler::set_log_options(GC::FunctionCalls); - gc.check_init(); - auto stack_start = reinterpret_cast(__builtin_frame_address(0)); - - Node *root1 = static_cast(gc.alloc(sizeof(Node))); - Node *root2 = static_cast(gc.alloc(sizeof(Node))); - root1 = test_chain(58000, false); - root2 = test_chain(58000, false); - - - gc.collect(GC::COLLECT_ALL); - auto end = std::chrono::high_resolution_clock::now(); - //std::cout << "Value of end: " << end.time_since_epoch().count() << std::endl; - - gc.print_summary(); - gc.dispose(); - - std::cout - << "Execution time: " - << std::chrono::duration_cast(end - start).count() << " ≈ " - << (end - start) / 1ms << "ms ≈ " - << (end - start) / 1s << "s.\n"; - - return 0; -} \ No newline at end of file diff --git a/src/GC/tests/linkedlist.cpp b/src/GC/tests/linkedlist.cpp deleted file mode 100644 index 61ab3c4..0000000 --- a/src/GC/tests/linkedlist.cpp +++ /dev/null @@ -1,74 +0,0 @@ -#include -#include - -#include "heap.hpp" - -#define allocNode static_cast(GC::Heap::alloc(sizeof(Node))) - -using std::cout, std::endl; - -struct Node // sizeof(Node) = 16 -{ - int value; - Node *next {nullptr}; -}; - -Node *create_list(size_t length) -{ - Node *head = allocNode; - head->value = 0; - - Node *prev = head; - - for (size_t i = 1; i < length; i++) - { - Node *next = allocNode; - next->value = i; - prev->next = next; - prev = next; - } - - return head; -} - -void print_list(Node* head) -{ - cout << "\nPrinting list...\n"; - while (head != nullptr) - { - cout << head->value << " "; - head = head->next; - } - cout << endl; -} - -void clear_list(Node *head) -{ - while (head != nullptr) - { - Node *tmp = head->next; - head->next = nullptr; - head = tmp; - } -} - -void run_list_test() -{ - Node *list = create_list(10); - print_list(list); -} - -int main() -{ - GC::Heap::init(); - GC::Heap &heap = GC::Heap::the(); - heap.set_profiler(true); - GC::Profiler::set_log_options(GC::FunctionCalls); - - for (int i = 0; i < 10; i++) - run_list_test(); - - GC::Heap::dispose(); - - return 0; -} \ No newline at end of file diff --git a/src/GC/tests/linker.cpp b/src/GC/tests/linker.cpp deleted file mode 100644 index fb5b979..0000000 --- a/src/GC/tests/linker.cpp +++ /dev/null @@ -1,16 +0,0 @@ -#include - -#include "heap.hpp" - -struct Obj { - int a; - int b; - int c; -}; - -int main() { - - - - return 0; -} \ No newline at end of file diff --git a/src/GC/tests/player.hpp b/src/GC/tests/player.hpp deleted file mode 100644 index 8a8e30f..0000000 --- a/src/GC/tests/player.hpp +++ /dev/null @@ -1,51 +0,0 @@ -#include - -using std::string; - -class Point { - -public: - - int x, y; - Point() {} - Point(int _x, int _y) : x(_x), y(_y) {} -}; - -class Player { - -private: - - string *name; - Point *position; - Point *size; - Point *direction; - -public: - - Player() {} - -/* Player(string n, Point pos, Point s, Point dir) - : name(n), position(pos.x, pos.y), size(s.x, s.y), direction(dir.x, dir.y) - {} */ - - void move() { - position->x += direction->x; - position->y += direction->y; - } - - void set_speed(int dx, int dy) { - direction->x = dx; - direction->y = dy; - } - - // This is probably neccessary to initialize an object with our GC - // Since allocation and construction cannot be done at the same time - void init(string *n, Point *pos, Point *s, Point *dir) { - name = n; - position = pos; - size = s; - direction = dir; - - } - -}; diff --git a/src/GC/tests/stack.cpp b/src/GC/tests/stack.cpp deleted file mode 100644 index 8f8382e..0000000 --- a/src/GC/tests/stack.cpp +++ /dev/null @@ -1,76 +0,0 @@ -#include -#include -#include -#include - -/* - * Stack.cpp - * - Tests stack scanning and stack pointers - * - * Goal: Find the values of the following variables - * and their position on the stack - * - unsigned long a - * - unsigned long b - * - unsigned long global_1 - * - unsigned long global_2 - * - * Result: Passed -*/ - - - - -std::vector iv; - -void collect() { - std::cout << "in collect" << std::endl; - - uintptr_t *stack_start = reinterpret_cast(__builtin_frame_address(0)); - - // denna orsakar segfault om man ger __b_f_a ett värde större än 2 - // uintptr_t *stack_end = reinterpret_cast(__builtin_frame_address(100)); - - std::cout << "SP1:\t" << stack_start << "\nSP2:\t" << (stack_start - 1*sizeof(int)) << std::endl; - std::cout << "SP-:\t" << --stack_start << std::endl; - - const uintptr_t *stack_end = (stack_start + 30*sizeof(int)); - int vars_found = 0; - - while (stack_start < stack_end) { - - if (std::find(iv.begin(), iv.end(), stack_start) != iv.end()) { - vars_found++; - std::cout << "Found " << *(reinterpret_cast(stack_start)) << " at " << stack_start << std::endl; - } - - // std::cout << "SP address:\t\t" << stack_start << "\nSP value:\t\t" << *(reinterpret_cast(stack_start)) << std::endl; - - stack_start++; - } - - if (vars_found == 0) { - std::cout << "Found nothing" << std::endl; - } -} - -int add(unsigned long a, unsigned long b) { - iv.push_back(reinterpret_cast(&a)); - iv.push_back(reinterpret_cast(&b)); - std::cout << "'a':\t" << &a << "\n'b':\t" << &b << std::endl; - collect(); - return a + b; -} - -int main() { - - unsigned long global_1 = 16; - unsigned long global_2 = 32; - - iv.push_back(&global_1); - iv.push_back(&global_2); - - std::cout << "'g1':\t" << &global_1 << "\n'g2':\t" << &global_2 << std::endl; - - add(3,2); - return 0; -} \ No newline at end of file diff --git a/src/GC/tests/stack2.cpp b/src/GC/tests/stack2.cpp deleted file mode 100644 index f1a78bc..0000000 --- a/src/GC/tests/stack2.cpp +++ /dev/null @@ -1,51 +0,0 @@ -#include -#include - -void dummy1(); -void dummy2(); - -int main() { - - uintptr_t *prev1 = reinterpret_cast(__builtin_frame_address(0)); - uintptr_t *prev2 = static_cast(__builtin_frame_address(0)); - - std::cout << "reinterpret:\t" << prev1 << "\nstatic:\t\t" << prev2 << std::endl; - - std::cout << "Start:\t\t" << prev1 << std::endl; -#pragma clang diagnostic ignored "-Wframe-address" - uintptr_t *tmp = reinterpret_cast(__builtin_frame_address(1)); - std::cout << "Frame 1:\t" << tmp << "\t\tDiff:\t" << std::hex << "0x"<< tmp - prev1 << std::endl; - prev1 = tmp; - -#pragma clang diagnostic ignored "-Wframe-address" - tmp = reinterpret_cast(__builtin_frame_address(2)); - std::cout << "Frame 2:\t" << tmp << "\tDiff:\t" << std::hex << "0x" << tmp - prev1 << std::endl; - prev1 = tmp; - -// arg > 2 for __builtin_frame_address() results in segfault -// #pragma clang diagnostic ignored "-Wframe-address" -// tmp = reinterpret_cast(__builtin_frame_address(3)); -// std::cout << "Frame 3:\t" << tmp << "\tDiff:\t" << std::hex << "0x" << prev1 - tmp << std::endl; - - dummy1(); - - return 0; -} - -void dummy1() { - std::cout << "D1 SFrame:\t" << __builtin_frame_address(0); -#pragma clang diagnostic ignored "-Wframe-address" - std::cout << "\t\tPrev:\t" << __builtin_frame_address(1) << std::endl; - std::cout << "D1 RA:\t\t" << std::hex << __builtin_return_address(0) << std::endl; - dummy2(); -} - -void dummy2() { - std::cout << "Frame:\t\t" << __builtin_frame_address(0); -#pragma clang diagnostic ignored "-Wframe-address" - std::cout << "\t\tPrev:\t" << __builtin_frame_address(1) << std::endl; - void *ra = __builtin_return_address(0); - std::cout << "D2 RA:\t\t" << std::hex << ra << std::endl; - // gives same value as pure 'ra' - // std::cout << "D2 ERA:\t\t" << std::hex << __builtin_extract_return_addr(ra) << std::endl; -} \ No newline at end of file diff --git a/src/GC/tests/struct_test.cpp b/src/GC/tests/struct_test.cpp deleted file mode 100644 index 2b2b677..0000000 --- a/src/GC/tests/struct_test.cpp +++ /dev/null @@ -1,41 +0,0 @@ -#include - -#include "heap.hpp" - -using namespace std; - -struct Node { - int value; - Node *left; - Node *right; -}; - -int getValue(); -Node *createNode(); -void insert(); - -int main() { - GC::Heap::init(); - Node *node = static_cast(GC::Heap::alloc(sizeof(Node))); - - return 0; -} - -int getValue() { - cout << "Enter a value to insert: "; - int value; - cin >> value; - return value; -} - -Node *createNode() { - Node *node = static_cast(GC::Heap::alloc(sizeof(Node))); - node->value = getValue(); - return node; -} - -void insert(Node *root) { - Node *node = createNode(); - Node *curr = root; - while (curr) -} \ No newline at end of file diff --git a/src/GC/tests/wrapper.c b/src/GC/tests/wrapper.c deleted file mode 100644 index d6f042c..0000000 --- a/src/GC/tests/wrapper.c +++ /dev/null @@ -1,96 +0,0 @@ -#include -#include -#include - -#include "cheap.h" - -typedef struct object -{ - int x, y, z; - double velocity; -} Object; - -void test_init() -{ - printf("----- IN TEST_INIT ----------------------------\n"); - - cheap_init(); - - printf("----- EXIT TEST_INIT --------------------------\n"); -} - -/* Uncomment ONLY if run with DEBUG defined in cheap.h */ - -cheap_t *test_the() -{ - printf("----- IN TEST_THE -----------------------------\n"); - - cheap_t *fst_heap = cheap_the(); - - printf("Heap 1:\t%p\n", fst_heap->obj); - - cheap_t *snd_heap = cheap_the(); - - printf("Heap 2:\t%p\n", snd_heap->obj); - - printf("----- EXIT TEST_THE ---------------------------\n"); - - free(snd_heap); - return fst_heap; -} - -void test_profiler(cheap_t *heap) -{ - printf("----- IN TEST_PROFILER ------------------------\n"); - - cheap_set_profiler(heap, false); - cheap_set_profiler(heap, true); - cheap_profiler_log_options(heap, FuncCallsOnly); - - printf("----- EXIT TEST_PROFILER ----------------------\n"); -} - -Object *test_alloc() -{ - printf("----- IN TEST_ALLOC ---------------------------\n"); - - Object *o; - o = (Object *)(cheap_alloc(sizeof(Object))); - - o->x = 3; - o->y = 4; - o->z = 5; - o->velocity = 1.0f; - - printf("----- EXIT TEST_ALLOC -------------------------\n"); - return o; -} - -void test_dispose() -{ - printf("----- IN TEST_DISPOSE -------------------------\n"); - - cheap_dispose(); - - printf("----- EXIT TEST_DISPOSE -----------------------\n"); -} - -int main() -{ - test_init(); - - /* Uncomment ONLY if run with DEBUG defined in cheap.h */ - cheap_t *heap = test_the(); - test_profiler(heap); - - Object *o = test_alloc(); - printf("Object size: %lu\n", sizeof(Object)); - printf("Object:\n\tx: %d\n\ty: %d\n\tz: %d\n\tvel: %f\n", o->x, o->y, o->z, o->velocity); - - test_dispose(); - - /* Sefault I don't understand, don't uncomment */ - // free(heap); - // free(o); - return 0; -} \ No newline at end of file diff --git a/src/GC/tests/wrapper_test.c b/src/GC/tests/wrapper_test.c deleted file mode 100644 index 729cf69..0000000 --- a/src/GC/tests/wrapper_test.c +++ /dev/null @@ -1,45 +0,0 @@ -#include -#include - -#include "cheap.h" - -typedef struct node { - int id; - struct node *child; -} Node; - -// Global variables make the test less complex -Node *HEAD = NULL; -Node *CURRENT = NULL; - -// Creates a linked list of length depth. Global head "HEAD" is updated. -void *create_linked_list(int depth) { - HEAD = (Node*)(cheap_alloc(sizeof(Node))); - HEAD->id = 0; - // Purposely omitting adding a child to "last_node", since its the last node - for (int i = 1; i < depth - 1; i++) { - insert_first(i); - } -} - -void *insert_first(int node_id) { - Node *new_head; - new_head = (Node*)(cheap_alloc(sizeof(Node))); - new_head->id = node_id; - new_head->child = HEAD; - - HEAD = new_head; -} - -void test_linked_list(int list_length){ - cheap_init(); - cheap_t *heap = cheap_the(); - cheap_set_profiler(heap, true); - create_linked_list(list_length); - cheap_dispose(); - free(heap); -} - -int main (int argc, char **argv) { - test_linked_list(30); -} \ No newline at end of file diff --git a/src/GC/todo.md b/src/GC/todo.md deleted file mode 100644 index 83fcf2c..0000000 --- a/src/GC/todo.md +++ /dev/null @@ -1,11 +0,0 @@ -# Garbage collection - -## Project -Deliver to samuel - -## GC TODO: -- PR till master - -## Tests TODO -- Write complex datastructures for tests with larger programs -- Testa `__builtin_frame_address` mer specifikt för att se om första stack framen skannas \ No newline at end of file diff --git a/src/Main.hs b/src/Main.hs index ea6103a..b487222 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -138,7 +138,8 @@ main' opts s = log monomorphized printToErr "\n -- Compiler --" - generatedCode <- fromErr $ generateCode monomorphized (gc opts) + -- generatedCode <- fromErr $ generateCode monomorphized (gc opts) + generatedCode <- fromErr $ generateCode monomorphized False check <- doesPathExist "output" when check (removeDirectoryRecursive "output") @@ -148,7 +149,8 @@ main' opts s = writeFile "output/llvm.ll" generatedCode debugDotViz - compile generatedCode (gc opts) + -- compile generatedCode (gc opts) + compile generatedCode False printToErr "Compilation done!" printToErr "\n-- Program output --" print =<< spawnWait "./output/hello_world" From 72e599d5de337be180e7d65b356932f9d5d9085d Mon Sep 17 00:00:00 2001 From: Martin Fredin Date: Sat, 6 May 2023 22:49:08 +0200 Subject: [PATCH 372/372] Add closures and fix lets in monomorphizer --- language.cabal | 3 + sample-programs/working/addition.chrf | 6 + sample-programs/working/apply.crf | 7 + sample-programs/working/closure.crf | 10 + sample-programs/working/foldr.crf | 15 + sample-programs/working/lambda-2.crf | 25 ++ sample-programs/working/lambda.crf | 21 ++ sample-programs/working/let.crf | 3 + sample-programs/working/map.crf | 16 + sample-programs/working/simple.crf | 7 + src/Codegen/Auxillary.hs | 38 +-- src/Codegen/Codegen.hs | 71 +++-- src/Codegen/CompilerState.hs | 134 ++++++--- src/Codegen/Emits.hs | 416 +++++++++++++++++--------- src/Codegen/LlvmIr.hs | 49 ++- src/LambdaLifter.hs | 161 ++++++---- src/LambdaLifterIr.hs | 140 +++++++++ src/Monomorphizer/DataTypeRemover.hs | 47 +-- src/Monomorphizer/Monomorphizer.hs | 276 ++++++++++------- src/Monomorphizer/MonomorphizerIr.hs | 115 ++++--- src/Monomorphizer/MorbIr.hs | 118 ++++---- src/TypeChecker/ReportTEVar.hs | 58 ++-- src/TypeChecker/TypeCheckerBidir.hs | 16 +- src/TypeChecker/TypeCheckerHm.hs | 118 ++++---- src/TypeChecker/TypeCheckerIr.hs | 77 ++--- test_map2.ll | 185 ++++++++++++ 26 files changed, 1440 insertions(+), 692 deletions(-) create mode 100644 sample-programs/working/addition.chrf create mode 100644 sample-programs/working/apply.crf create mode 100644 sample-programs/working/closure.crf create mode 100644 sample-programs/working/foldr.crf create mode 100644 sample-programs/working/lambda-2.crf create mode 100644 sample-programs/working/lambda.crf create mode 100644 sample-programs/working/let.crf create mode 100644 sample-programs/working/map.crf create mode 100644 sample-programs/working/simple.crf create mode 100644 src/LambdaLifterIr.hs create mode 100644 test_map2.ll diff --git a/language.cabal b/language.cabal index af7178c..e299f24 100644 --- a/language.cabal +++ b/language.cabal @@ -43,6 +43,7 @@ executable language TypeChecker.ReportTEVar TypeChecker.RemoveForall LambdaLifter + LambdaLifterIr Monomorphizer.Monomorphizer Monomorphizer.MonomorphizerIr Monomorphizer.MorbIr @@ -101,6 +102,8 @@ Test-suite language-testsuite TypeChecker.TypeChecker AnnForall ReportForall + LambdaLifterIr + LambdaLifter TypeChecker.TypeCheckerHm TypeChecker.TypeCheckerBidir TypeChecker.ReportTEVar diff --git a/sample-programs/working/addition.chrf b/sample-programs/working/addition.chrf new file mode 100644 index 0000000..7bddab7 --- /dev/null +++ b/sample-programs/working/addition.chrf @@ -0,0 +1,6 @@ + + +add : Int -> Int -> Int -> Int +add x y z = x + y + z + +main = add 8 6 2 diff --git a/sample-programs/working/apply.crf b/sample-programs/working/apply.crf new file mode 100644 index 0000000..61c76ad --- /dev/null +++ b/sample-programs/working/apply.crf @@ -0,0 +1,7 @@ + + + +apply : (Int -> Int) -> Int -> Int +apply f y = f y + +main = apply (\y. y + y) 5 diff --git a/sample-programs/working/closure.crf b/sample-programs/working/closure.crf new file mode 100644 index 0000000..b85ab32 --- /dev/null +++ b/sample-programs/working/closure.crf @@ -0,0 +1,10 @@ + + + + +apply : (Int -> Int) -> Int -> Int +apply f z = f z + +main = + let x = 10 in + apply (\y. y + x) 6 diff --git a/sample-programs/working/foldr.crf b/sample-programs/working/foldr.crf new file mode 100644 index 0000000..da798ac --- /dev/null +++ b/sample-programs/working/foldr.crf @@ -0,0 +1,15 @@ + +data List a where + Nil : List a + Cons : a -> List a -> List a + +foldr : (a -> b -> b) -> b -> List a -> b +foldr f y xs = case xs of + Nil => y + Cons x xs => f x (foldr f y xs) + + +main = let z = 2 in foldr (\x.\y. x + y + z) 0 (Cons 1000 (Cons 100 Nil)) + + + diff --git a/sample-programs/working/lambda-2.crf b/sample-programs/working/lambda-2.crf new file mode 100644 index 0000000..f081d92 --- /dev/null +++ b/sample-programs/working/lambda-2.crf @@ -0,0 +1,25 @@ +data List (a) where + Nil : List (a) + Cons : a -> List (a) -> List (a) + +map : (a -> b) -> List (a) -> List (b) +map f xs = case xs of + Nil => Nil + Cons x xs => Cons (f x) (map f xs) + +add : Int -> Int -> Int +add x y = x + y + +foldr : (a -> b -> b) -> b -> List (a) -> b +foldr f y xs = case xs of + Nil => y + Cons x xs => f x (foldr f y xs) + +f : List (Int) +f = ((\x.\ys. map (\y. add y x) ys) 4 (Cons 1 (Cons 2 Nil))) +-- [5, 6] + +main : Int +main = foldr add 0 f + + diff --git a/sample-programs/working/lambda.crf b/sample-programs/working/lambda.crf new file mode 100644 index 0000000..3dcb947 --- /dev/null +++ b/sample-programs/working/lambda.crf @@ -0,0 +1,21 @@ +data List a where + Nil : List a + Cons : a -> List a -> List a + +map : (a -> b) -> List a -> List b +map f xs = case xs of + Nil => Nil + Cons x xs => Cons (f x) (map f xs) + + +f : List Int +f = (\x.\ys. map (\y. y + x) ys) 4 (Cons 1 (Cons 2 Nil)) +-- [5, 6] + +sum : List Int -> Int +sum xs = case xs of + Nil => 0 + Cons x xs => x + sum xs + +main = sum f + diff --git a/sample-programs/working/let.crf b/sample-programs/working/let.crf new file mode 100644 index 0000000..9ed4abe --- /dev/null +++ b/sample-programs/working/let.crf @@ -0,0 +1,3 @@ + + +main = let x = 10 in 6 + x diff --git a/sample-programs/working/map.crf b/sample-programs/working/map.crf new file mode 100644 index 0000000..4e77ad8 --- /dev/null +++ b/sample-programs/working/map.crf @@ -0,0 +1,16 @@ + +data List a where + Nil : List a + Cons : a -> List a -> List a + +map : (a -> b) -> List a -> List b +map f xs = case xs of + Nil => Nil + Cons x xs => Cons (f x) (map f xs) + +sum : List Int -> Int +sum xs = case xs of + Nil => 0 + Cons x xs => x + (sum xs) + +main = let y = 10 in sum (map (\x. x + y) (Cons 2 (Cons 4 Nil))) diff --git a/sample-programs/working/simple.crf b/sample-programs/working/simple.crf new file mode 100644 index 0000000..04d3ef8 --- /dev/null +++ b/sample-programs/working/simple.crf @@ -0,0 +1,7 @@ + + + +f = 10 + + +main = f + 6 diff --git a/src/Codegen/Auxillary.hs b/src/Codegen/Auxillary.hs index c95be39..af31504 100644 --- a/src/Codegen/Auxillary.hs +++ b/src/Codegen/Auxillary.hs @@ -1,25 +1,25 @@ module Codegen.Auxillary where -import Codegen.LlvmIr (LLVMType (..), LLVMValue (..)) -import Control.Monad (foldM_) -import Monomorphizer.MonomorphizerIr as MIR (ExpT, Type (..)) -import TypeChecker.TypeCheckerIr qualified as TIR +import Codegen.LlvmIr (LLVMType (..), LLVMValue (..)) +import Control.Monad (foldM_) +import Monomorphizer.MonomorphizerIr as MIR (Exp, T, Type (..)) +import qualified TypeChecker.TypeCheckerIr as TIR type2LlvmType :: MIR.Type -> LLVMType type2LlvmType (MIR.TLit id@(TIR.Ident name)) = case name of - "Int" -> I64 + "Int" -> I64 "Char" -> I8 "Bool" -> I1 - _ -> CustomType id + _ -> CustomType id type2LlvmType (MIR.TFun t xs) = do let (t', xs') = function2LLVMType xs [type2LlvmType t] Function t' xs' where function2LLVMType :: Type -> [LLVMType] -> (LLVMType, [LLVMType]) function2LLVMType (TFun t xs) s = function2LLVMType xs (type2LlvmType t : s) - function2LLVMType x s = (type2LlvmType x, s) + function2LLVMType x s = (type2LlvmType x, s) -getType :: ExpT -> LLVMType +getType :: T Exp -> LLVMType getType (_, t) = type2LlvmType t extractTypeName :: MIR.Type -> TIR.Ident @@ -30,21 +30,21 @@ extractTypeName (MIR.TFun t xs) = in TIR.Ident $ i <> "_$_" <> is valueGetType :: LLVMValue -> LLVMType -valueGetType (VInteger _) = I64 -valueGetType (VChar _) = I8 -valueGetType (VIdent _ t) = t -valueGetType (VConstant s) = Array (fromIntegral $ length s) I8 +valueGetType (VInteger _) = I64 +valueGetType (VChar _) = I8 +valueGetType (VIdent _ t) = t +valueGetType (VConstant s) = Array (fromIntegral $ length s) I8 valueGetType (VFunction _ _ t) = t typeByteSize :: LLVMType -> Integer -typeByteSize I1 = 1 -typeByteSize I8 = 1 -typeByteSize I32 = 4 -typeByteSize I64 = 8 -typeByteSize Ptr = 8 -typeByteSize (Ref _) = 8 +typeByteSize I1 = 1 +typeByteSize I8 = 1 +typeByteSize I32 = 4 +typeByteSize I64 = 8 +typeByteSize Ptr = 8 +typeByteSize (Ref _) = 8 typeByteSize (Function _ _) = 8 -typeByteSize (Array n t) = n * typeByteSize t +typeByteSize (Array n t) = n * typeByteSize t typeByteSize (CustomType _) = 8 enumerateOneM_ :: Monad m => (Integer -> a -> m b) -> [a] -> m () diff --git a/src/Codegen/Codegen.hs b/src/Codegen/Codegen.hs index be92a35..6f66c36 100644 --- a/src/Codegen/Codegen.hs +++ b/src/Codegen/Codegen.hs @@ -1,18 +1,24 @@ +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE OverloadedStrings #-} + module Codegen.Codegen (generateCode) where -import Codegen.CompilerState ( - CodeGenerator (instructions), - initCodeGenerator, - ) -import Codegen.Emits (compileScs) -import Codegen.LlvmIr as LIR (llvmIrToString) -import Control.Monad.State ( - execStateT, - ) -import Data.List (sortBy) -import Grammar.ErrM (Err) -import Monomorphizer.MonomorphizerIr as MIR (Bind (..), Data (..), Def (DBind, DData), Program (..), Type (TLit)) -import TypeChecker.TypeCheckerIr (Ident (..)) +import Codegen.CompilerState (CodeGenerator (..), + StructType (inst), + initCodeGenerator) +import Codegen.Emits (compileScs) +import Codegen.LlvmIr as LIR (LLVMIr (UnsafeRaw), + llvmIrToString) +import Control.Monad.State (execStateT) +import Data.Functor ((<&>)) +import Data.List (sortBy) +import qualified Data.Map as Map +import Grammar.ErrM (Err) +import Monomorphizer.MonomorphizerIr as MIR (Bind (..), Data (..), + Def (DBind, DData), + Program (..), + Type (TLit)) +import TypeChecker.TypeCheckerIr (Ident (..)) {- | Compiles an AST and produces a LLVM Ir string. An easy way to actually "compile" this output is to @@ -20,16 +26,43 @@ import TypeChecker.TypeCheckerIr (Ident (..)) -} generateCode :: MIR.Program -> Bool -> Err String generateCode (MIR.Program scs) addGc = do - let tree = filter (not . detectPrelude) (sortBy lowData scs) - let codegen = initCodeGenerator addGc tree - llvmIrToString . instructions <$> execStateT (compileScs tree) codegen + let tree = filter (not . detectPrelude) (sortBy lowData scs) + codegen = initCodeGenerator addGc tree + + -- Append instructions + execStateT (compileScs tree) codegen <&> \state -> + llvmIrToString $ defaultStart + ++ (if addGc then gcStart else []) + ++ map inst (Map.elems state.structTypes) + ++ state.instructions detectPrelude :: Def -> Bool -detectPrelude (DData (Data (TLit (Ident "Bool")) _)) = True +detectPrelude (DData (Data (TLit (Ident "Bool")) _)) = True detectPrelude (DBind (Bind (Ident ('l' : 't' : '$' : _), _) _ _)) = True -detectPrelude _ = False +detectPrelude _ = False lowData :: Def -> Def -> Ordering lowData (DData _) (DBind _) = LT lowData (DBind _) (DData _) = GT -lowData _ _ = EQ \ No newline at end of file +lowData _ _ = EQ + +defaultStart :: [LLVMIr] +defaultStart = + [ UnsafeRaw "target triple = \"x86_64-pc-linux-gnu\"\n" + , UnsafeRaw "target datalayout = \"e-m:o-i64:64-f80:128-n8:16:32:64-S128\"\n" + , UnsafeRaw "@.str = private unnamed_addr constant [3 x i8] c\"%i\n\", align 1\n" + , UnsafeRaw "@.non_exhaustive_patterns = private unnamed_addr constant [41 x i8] c\"Non-exhaustive patterns in case at %i:%i\n\"\n" + , UnsafeRaw "declare i32 @printf(ptr noalias nocapture, ...)\n" + , UnsafeRaw "declare i32 @exit(i32 noundef)\n" + , UnsafeRaw "declare ptr @malloc(i32 noundef)\n" + ] + +gcStart :: [LLVMIr] +gcStart = + [ UnsafeRaw "declare external void @cheap_init()\n" + , UnsafeRaw "declare external ptr @cheap_alloc(i64)\n" + , UnsafeRaw "declare external void @cheap_dispose()\n" + , UnsafeRaw "declare external ptr @cheap_the()\n" + , UnsafeRaw "declare external void @cheap_set_profiler(ptr, i1)\n" + , UnsafeRaw "declare external void @cheap_profiler_log_options(ptr, i64)\n" + ] diff --git a/src/Codegen/CompilerState.hs b/src/Codegen/CompilerState.hs index 523cc54..b455712 100644 --- a/src/Codegen/CompilerState.hs +++ b/src/Codegen/CompilerState.hs @@ -1,46 +1,101 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE OverloadedStrings #-} + module Codegen.CompilerState where import Auxiliary (snoc) import Codegen.Auxillary (type2LlvmType, typeByteSize) -import Codegen.LlvmIr as LIR (LLVMIr (UnsafeRaw), - LLVMType) -import Control.Monad.State (StateT, gets, modify) +import Codegen.LlvmIr as LIR (LLVMIr (SetVariable, Type), + LLVMType (CustomType, Function, I64, Ptr), + LLVMValue (VFunction, VIdent), + Visibility (Global), + typeOf) +import Control.Monad.State (StateT, gets, modify, void) import Data.Map (Map) import qualified Data.Map as Map import Grammar.ErrM (Err) -import Monomorphizer.MonomorphizerIr as MIR +import Monomorphizer.MonomorphizerIr (Ident (..), Inj (..), T, + flattenType) +import qualified Monomorphizer.MonomorphizerIr as MIR import qualified TypeChecker.TypeCheckerIr as TIR -- | The record used as the code generator state data CodeGenerator = CodeGenerator { instructions :: [LLVMIr] - , functions :: Map MIR.Id FunctionInfo + , functions :: Map (T Ident) FunctionInfo , customTypes :: Map LLVMType Integer - , constructors :: Map TIR.Ident ConstructorInfo + , constructors :: Map Ident ConstructorInfo , variableCount :: Integer , labelCount :: Integer , gcEnabled :: Bool + , structTypes :: Map Ident StructType + -- ^ Custom stucture types + , locals :: [(Ident, LocalElem)] + -- ^ Arguments and variables in local environment + , globals :: Map Ident (LLVMType, LLVMValue) } +data StructType = StructType + { ptr :: LLVMType + , typs :: [LLVMType] + , inst :: LLVMIr + } + +data LocalElem = LocalElem + { typ :: LLVMType + , val :: LLVMValue + } + + -- | A state type synonym type CompilerState a = StateT CodeGenerator Err a data FunctionInfo = FunctionInfo { numArgs :: Int - , arguments :: [Id] + , arguments :: [T Ident] } deriving (Show) data ConstructorInfo = ConstructorInfo { numArgsCI :: Int - , argumentsCI :: [Id] + , argumentsCI :: [T Ident] , numCI :: Integer , returnTypeCI :: MIR.Type } deriving (Show) + +addStructType_ :: Ident -> [LLVMType] -> CompilerState () +addStructType_ = fmap void . addStructType + +addStructType :: Ident -> [LLVMType] -> CompilerState LLVMType +addStructType x ts = do + modify $ \s -> s { structTypes = Map.insert x struct s.structTypes } + pure t + where + struct = StructType + { ptr = t + , typs = ts + , inst = Type x ts + } + t = CustomType x + -- | Adds a instruction to the CodeGenerator state emit :: LLVMIr -> CompilerState () -emit l = modify $ \t -> t{instructions = Auxiliary.snoc l $ instructions t} + +-- Add variable to environment +emit l@(SetVariable x _) = modify $ \t -> + t { instructions = Auxiliary.snoc l t.instructions + , locals = snoc (x, local) + t.locals + } + where + local = LocalElem { typ = typeOf l + , val = VIdent x (typeOf l) + } + +emit l = modify $ \t -> t { instructions = Auxiliary.snoc l t.instructions } -- | Increases the variable counter in the CodeGenerator state increaseVarCount :: CompilerState () @@ -63,16 +118,19 @@ getNewLabel = do {- | Produces a map of functions infos from a list of binds, which contains useful data for code generation. -} -getFunctions :: [MIR.Def] -> Map Id FunctionInfo +getFunctions :: [MIR.Def] -> Map (T Ident) FunctionInfo getFunctions bs = Map.fromList $ go bs where go [] = [] go (MIR.DBind (MIR.Bind id args _) : xs) = - (id, FunctionInfo{numArgs = length args, arguments = args}) - : go xs + (id, FunctionInfo { numArgs = length args + , arguments = args + } + ) + : go xs go (_ : xs) = go xs -createArgs :: [MIR.Type] -> [Id] +createArgs :: [MIR.Type] -> [T Ident] createArgs xs = fst $ foldl (\(acc, l) t -> (acc ++ [(TIR.Ident ("arg_" <> show l), t)], l + 1)) ([], 0) xs {- | Produces a map of functions infos from a list of binds, @@ -113,35 +171,43 @@ getTypes bs = Map.fromList $ go bs variantTypes fi = init $ map type2LlvmType (flattenType fi) biggestVariant ts = 8 + maximum (sum . (\(Inj _ fi) -> typeByteSize <$> variantTypes fi) <$> ts) +getGlobals :: [MIR.Def] -> Map Ident (LLVMType, LLVMValue) +getGlobals scs = Map.fromList [ go b | MIR.DBind b <- scs ] + where + go bind | x == "main" = let typ = Function I64 [] + in (x, (typ, VFunction x Global typ)) + | otherwise = (x, (typ, VFunction x Global typ)) + where + typ = Function tr $ Ptr : ts + Function tr ts = type2LlvmType' t + + (x, t) = case bind of + MIR.Bind xt _ _ -> xt + MIR.BindC _ xt _ _ -> xt + + -- Higher order function arguments are replaced with ptr + type2LlvmType' = go [] + where + go acc = \case + MIR.TFun (MIR.TFun _ _) t2 -> go (snoc Ptr acc) t2 + MIR.TFun t1 t2 -> go (snoc (type2LlvmType t1) acc) t2 + t -> Function (type2LlvmType t) acc + + + + initCodeGenerator :: Bool -> [MIR.Def] -> CodeGenerator initCodeGenerator addGc scs = CodeGenerator - { instructions = defaultStart <> if addGc then gcStart else [] + { instructions = [] , functions = getFunctions scs , constructors = getConstructors scs , customTypes = getTypes scs + , structTypes = mempty , variableCount = 0 , labelCount = 0 , gcEnabled = addGc + , locals = mempty + , globals = getGlobals scs } -defaultStart :: [LLVMIr] -defaultStart = - [ UnsafeRaw "target triple = \"x86_64-pc-linux-gnu\"\n" - , UnsafeRaw "target datalayout = \"e-m:o-i64:64-f80:128-n8:16:32:64-S128\"\n" - , UnsafeRaw "@.str = private unnamed_addr constant [3 x i8] c\"%i\n\", align 1\n" - , UnsafeRaw "@.non_exhaustive_patterns = private unnamed_addr constant [41 x i8] c\"Non-exhaustive patterns in case at %i:%i\n\"\n" - , UnsafeRaw "declare i32 @printf(ptr noalias nocapture, ...)\n" - , UnsafeRaw "declare i32 @exit(i32 noundef)\n" - , UnsafeRaw "declare ptr @malloc(i32 noundef)\n" - ] - -gcStart :: [LLVMIr] -gcStart = - [ UnsafeRaw "declare external void @cheap_init()\n" - , UnsafeRaw "declare external ptr @cheap_alloc(i64)\n" - , UnsafeRaw "declare external void @cheap_dispose()\n" - , UnsafeRaw "declare external ptr @cheap_the()\n" - , UnsafeRaw "declare external void @cheap_set_profiler(ptr, i1)\n" - , UnsafeRaw "declare external void @cheap_profiler_log_options(ptr, i64)\n" - ] diff --git a/src/Codegen/Emits.hs b/src/Codegen/Emits.hs index bc19f87..9c6f59f 100644 --- a/src/Codegen/Emits.hs +++ b/src/Codegen/Emits.hs @@ -1,36 +1,40 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE OverloadedStrings #-} module Codegen.Emits where -import Codegen.Auxillary -import Codegen.CompilerState -import Codegen.LlvmIr as LIR -import Control.Applicative ((<|>)) -import Control.Monad (when) -import Control.Monad.State (gets, modify) -import Data.Bifunctor qualified as BI -import Data.Char (ord) -import Data.Coerce (coerce) -import Data.Map qualified as Map -import Data.Maybe (fromJust, fromMaybe, isNothing) -import Data.Tuple.Extra (dupe, first, second) -import Debug.Trace (trace, traceShow) -import Grammar.Print -import Monomorphizer.MonomorphizerIr as MIR -import TypeChecker.TypeCheckerIr qualified as TIR +import Auxiliary (snoc) +import Codegen.Auxillary +import Codegen.CompilerState +import Codegen.LlvmIr as LIR +import Control.Applicative (Applicative (liftA2), (<|>)) +import Control.Monad (forM_, when, zipWithM_) +import Control.Monad.Extra (whenJust) +import Control.Monad.State (gets, modify) +import Data.Char (ord) +import Data.Coerce (coerce) +import Data.Foldable.Extra (notNull) +import qualified Data.Map as Map +import Data.Maybe (fromJust, fromMaybe, isNothing) +import Data.Tuple.Extra (second) +import Grammar.Print (printTree) +import Monomorphizer.MonomorphizerIr -compileScs :: [MIR.Def] -> CompilerState () + +compileScs :: [Def] -> CompilerState () compileScs [] = do emit $ UnsafeRaw "\n" + mapM_ createConstructor =<< gets (Map.toList . constructors) -- as a last step create all the constructors -- //TODO maybe merge this with the data type match? - c <- gets (Map.toList . constructors) - mapM_ - ( \(id, ci) -> do - let t = returnTypeCI ci - let t' = type2LlvmType t - let x = BI.second type2LlvmType <$> argumentsCI ci + where + createConstructor (id, ci) = do + let t = returnTypeCI ci + t' = type2LlvmType t + x = (mkCxtName, Ptr) : map (second type2LlvmType) ci.argumentsCI emit $ Define FastCC t' id x top <- getNewVar ptr <- getNewVar @@ -56,7 +60,7 @@ compileScs [] = do cTypes <- gets customTypes enumerateOneM_ - ( \i (TIR.Ident arg_n, arg_t) -> do + ( \i (Ident arg_n, arg_t) -> do let arg_t' = type2LlvmType arg_t emit $ Comment (toIr arg_t' <> " " <> arg_n <> " " <> show i) elemPtr <- getNewVar @@ -78,11 +82,11 @@ compileScs [] = do heapPtr <- getNewVar useGc <- gets gcEnabled emit $ SetVariable heapPtr (if useGc then GcMalloc s else Malloc s) - emit $ Store arg_t' (VIdent (TIR.Ident arg_n) arg_t') Ptr heapPtr + emit $ Store arg_t' (VIdent (Ident arg_n) arg_t') Ptr heapPtr emit $ Store (Ref arg_t') (VIdent heapPtr arg_t') Ptr elemPtr Nothing -> do emit $ Comment "Just store" - emit $ Store arg_t' (VIdent (TIR.Ident arg_n) arg_t') Ptr elemPtr + emit $ Store arg_t' (VIdent (Ident arg_n) arg_t') Ptr elemPtr ) (argumentsCI ci) @@ -95,34 +99,83 @@ compileScs [] = do emit $ UnsafeRaw "\n" modify $ \s -> s{variableCount = 0} - ) - c -compileScs (MIR.DBind (MIR.Bind (name, t) args exp) : xs) = do - let t_return = type2LlvmType . last . flattenType $ t + +compileScs (DBind bind : xs) = do emit $ UnsafeRaw "\n" - emit . Comment $ show name <> ": " <> show exp - let args' = map (second type2LlvmType) args + emit . Comment $ show name <> ": " <> show (fst exp) + + Function t_return t_args <- gets $ fst + . fromJust + . Map.lookup name + . globals + + let args' = zip (mkCxtName : map fst args) t_args + emit $ Define FastCC t_return name args' - useGc <- gets gcEnabled - when (name == "main") (mapM_ emit (firstMainContent useGc)) - functionBody <- exprToValue exp - if name == "main" - then mapM_ emit $ lastMainContent useGc functionBody - else emit $ Ret t_return functionBody + modify $ \s -> s { locals = foldr insertArg s.locals args' } + + -- Dereference ptr arguments + when (notNull args') $ + forM_ (tail args') $ \(x, t) -> when (t == Ptr) $ do + let t_deref = + let + Function t ts = type2LlvmType . fromJust $ lookup x args + in + Function t (Ptr : ts) + + emit . SetVariable (mkDerefName x) + $ Load t_deref Ptr x + + whenJust mcxt loadFreeVars + + gcEnabled <- gets gcEnabled + when isMain $ mapM_ emit (firstMainContent gcEnabled) + + result <- exprToValue exp + + if isMain + then mapM_ emit $ lastMainContent gcEnabled result + else emit $ Ret t_return result + emit DefineEnd - modify $ \s -> s{variableCount = 0} + -- Reset variable count and empty locals + modify $ \s -> s { variableCount = 0, locals = mempty } compileScs xs -compileScs (MIR.DData (MIR.Data typ ts) : xs) = do - let (TIR.Ident outer_id) = extractTypeName typ + where + loadFreeVars cxt = do + emit $ Comment "Load free variables" + zipWithM_ go cxt' [1 ..] + where + go (x, t) i = do + vc <- getNewVar + emit . SetVariable vc + $ GetElementPtrInbounds (CustomType $ mkClosureName name) Ptr (VIdent mkCxtName Ptr) + I32 (VInteger 0) I32 (VInteger i) -- TODO fix indices + emit . SetVariable x $ Load t Ptr vc + cxt' = map (second type2LlvmType) cxt + + isMain = name == "main" + + (name, args, exp, mcxt) = case bind of + Bind (name, _) args exp -> (name, args, exp, Nothing) + BindC cxt (name, _) args exp -> (name, args, exp, Just cxt) + + + insertArg (x, t) = snoc (x, LocalElem { val = VIdent x t, typ = t }) + +compileScs (DData (Data typ ts) : xs) = do + let (Ident outer_id) = extractTypeName typ -- //TODO this could be extracted from the customTypes map let variantTypes fi = init $ map type2LlvmType (flattenType fi) let biggestVariant = 7 + maximum (sum . (\(Inj _ fi) -> typeByteSize <$> variantTypes fi) <$> ts) - emit $ LIR.Type (TIR.Ident outer_id) [I8, Array biggestVariant I8] + -- Add data type (e.g. %List) to top of the file + addStructType_ (Ident outer_id) [I8, Array biggestVariant I8] typeSets <- gets customTypes mapM_ ( \(Inj inner_id fi) -> do let types = (\s -> if Map.member s typeSets then Ref s else s) <$> variantTypes fi - emit $ LIR.Type inner_id (I8 : types) + -- Add constructor type (e.g. %Cons) to top of the file + addStructType_ inner_id (I8 : types) ) ts compileScs xs @@ -149,16 +202,16 @@ lastMainContent False var = , Ret I64 (VInteger 0) ] -compileExp :: ExpT -> CompilerState () -compileExp (MIR.ELit lit, _t) = emitLit lit -compileExp (MIR.EAdd e1 e2, t) = emitAdd t e1 e2 -compileExp (MIR.EVar name, _t) = emitIdent name -compileExp (MIR.EApp e1 e2, t) = emitApp t e1 e2 -compileExp (MIR.ELet bind e, _) = emitLet bind e -compileExp (MIR.ECase e cs, t) = emitECased t e (map (t,) cs) +compileExp :: T Exp -> CompilerState () +compileExp (ELit lit, _t) = emitLit lit +compileExp (EAdd e1 e2, t) = emitAdd t e1 e2 +compileExp (EVar name, _t) = emitIdent name +compileExp (EApp e1 e2, t) = emitApp t e1 e2 +compileExp (ELet bind e, _) = emitLet bind e +compileExp (ECase e cs, t) = emitECased t e (map (t,) cs) -emitLet :: MIR.Bind -> ExpT -> CompilerState () -emitLet (MIR.Bind id [] innerExp) e = do +emitLet :: Bind -> T Exp -> CompilerState () +emitLet (Bind id [] innerExp) e = do evaled <- exprToValue innerExp tempVar <- getNewVar let t = type2LlvmType . snd $ innerExp @@ -168,14 +221,14 @@ emitLet (MIR.Bind id [] innerExp) e = do compileExp e emitLet b _ = error $ "Non empty argument list in let-bind " <> show b -emitECased :: MIR.Type -> ExpT -> [(MIR.Type, Branch)] -> CompilerState () +emitECased :: Type -> T Exp -> [(Type, Branch)] -> CompilerState () emitECased t e cases = do let cs = snd <$> cases let ty = type2LlvmType t let rt = type2LlvmType (snd e) vs <- exprToValue e lbl <- getNewLabel - let label = TIR.Ident $ "escape_" <> show lbl + let label = Ident $ "escape_" <> show lbl stackPtr <- getNewVar emit $ SetVariable stackPtr (Alloca ty) mapM_ (emitCases rt ty label stackPtr vs) cs @@ -192,14 +245,14 @@ emitECased t e cases = do res <- getNewVar emit $ SetVariable res (Load ty Ptr stackPtr) where - emitCases :: LLVMType -> LLVMType -> TIR.Ident -> TIR.Ident -> LLVMValue -> Branch -> CompilerState () - emitCases rt ty label stackPtr vs (Branch (MIR.PInj consId cs, _t) exp) = do + emitCases :: LLVMType -> LLVMType -> Ident -> Ident -> LLVMValue -> Branch -> CompilerState () + emitCases rt ty label stackPtr vs (Branch (PInj consId cs, _t) exp) = do emit $ Comment "Inj" cons <- gets constructors let r = fromJust $ Map.lookup consId cons - lbl_failPos <- (\x -> TIR.Ident $ "failed_" <> show x) <$> getNewLabel - lbl_succPos <- (\x -> TIR.Ident $ "success_" <> show x) <$> getNewLabel + lbl_failPos <- (\x -> Ident $ "failed_" <> show x) <$> getNewLabel + lbl_succPos <- (\x -> Ident $ "success_" <> show x) <$> getNewLabel consVal <- getNewVar emit $ SetVariable consVal (ExtractValue rt vs 0) @@ -215,10 +268,10 @@ emitECased t e cases = do emit $ Store rt vs Ptr castPtr emit $ SetVariable casted (Load (CustomType (coerce consId)) Ptr castPtr) enumerateOneM_ - ( \i c -> do + ( \i (c, t) -> do case c of - PVar (x, topT) -> do - let topT' = type2LlvmType topT + PVar x -> do + let topT' = type2LlvmType t let botT' = CustomType (coerce consId) emit . Comment $ "ident " <> toIr topT' cTypes <- gets customTypes @@ -228,7 +281,7 @@ emitECased t e cases = do emit $ SetVariable deref (ExtractValue botT' (VIdent casted Ptr) i) emit $ SetVariable x (Load topT' Ptr deref) else emit $ SetVariable x (ExtractValue botT' (VIdent casted Ptr) i) - PLit (_l, _t) -> error "Nested pattern matching to be implemented" + PLit _l -> error "Nested pattern matching to be implemented" PInj _id _ps -> error "Nested pattern matching to be implemented" PCatch -> pure () PEnum _id -> error "Nested pattern matching to be implemented" @@ -238,22 +291,22 @@ emitECased t e cases = do emit $ Store ty val Ptr stackPtr emit $ Br label emit $ Label lbl_failPos - emitCases _rt ty label stackPtr vs (Branch (MIR.PLit (i, ct), t) exp) = do + emitCases _rt ty label stackPtr vs (Branch (PLit i, t) exp) = do emit $ Comment "Plit" let i' = case i of - MIR.LInt i -> VInteger i - MIR.LChar i -> VChar (ord i) + LInt i -> VInteger i + LChar i -> VChar (ord i) ns <- getNewVar - lbl_failPos <- (\x -> TIR.Ident $ "failed_" <> show x) <$> getNewLabel - lbl_succPos <- (\x -> TIR.Ident $ "success_" <> show x) <$> getNewLabel - emit $ SetVariable ns (Icmp LLEq (type2LlvmType ct) vs i') + lbl_failPos <- (\x -> Ident $ "failed_" <> show x) <$> getNewLabel + lbl_succPos <- (\x -> Ident $ "success_" <> show x) <$> getNewLabel + emit $ SetVariable ns (Icmp LLEq (type2LlvmType t) vs i') emit $ BrCond (VIdent ns ty) lbl_succPos lbl_failPos emit $ Label lbl_succPos val <- exprToValue exp emit $ Store ty val Ptr stackPtr emit $ Br label emit $ Label lbl_failPos - emitCases rt ty label stackPtr vs (Branch (MIR.PVar (id, _), _) exp) = do + emitCases rt ty label stackPtr vs (Branch (PVar id, _) exp) = do emit $ Comment "Pvar" -- //TODO this is pretty disgusting and would heavily benefit from a rewrite valPtr <- getNewVar @@ -263,20 +316,20 @@ emitECased t e cases = do val <- exprToValue exp emit $ Store ty val Ptr stackPtr emit $ Br label - lbl_failPos <- (\x -> TIR.Ident $ "failed_" <> show x) <$> getNewLabel + lbl_failPos <- (\x -> Ident $ "failed_" <> show x) <$> getNewLabel emit $ Label lbl_failPos - emitCases rt ty label stackPtr vs (Branch (MIR.PEnum (TIR.Ident "True$Bool"), t) exp) = do - emitCases rt ty label stackPtr vs (Branch (MIR.PLit (MIR.LInt 1, TLit "Bool"), t) exp) - emitCases rt ty label stackPtr vs (Branch (MIR.PEnum (TIR.Ident "False$Bool"), _) exp) = do - emitCases rt ty label stackPtr vs (Branch (MIR.PLit (MIR.LInt 0, TLit "Bool"), t) exp) - emitCases rt ty label stackPtr vs br@(Branch (MIR.PEnum consId, _) exp) = do + emitCases rt ty label stackPtr vs (Branch (PEnum (Ident "True$Bool"), t) exp) = do + emitCases rt ty label stackPtr vs (Branch (PLit $ LInt 1, t) exp) + emitCases rt ty label stackPtr vs (Branch (PEnum (Ident "False$Bool"), _) exp) = do + emitCases rt ty label stackPtr vs (Branch (PLit (LInt 0), t) exp) + emitCases rt ty label stackPtr vs br@(Branch (PEnum consId, _) exp) = do emit $ Comment "Penum" cons <- gets constructors let r = Map.lookup consId cons when (isNothing r) (error $ "Constructor: '" ++ printTree consId ++ "' does not exist in cons state:\n" ++ show cons ++ "\nin pattern\n'" ++ printTree br ++ "'\n") - lbl_failPos <- (\x -> TIR.Ident $ "failed_" <> show x) <$> getNewLabel - lbl_succPos <- (\x -> TIR.Ident $ "success_" <> show x) <$> getNewLabel + lbl_failPos <- (\x -> Ident $ "failed_" <> show x) <$> getNewLabel + lbl_succPos <- (\x -> Ident $ "success_" <> show x) <$> getNewLabel consVal <- getNewVar emit $ SetVariable consVal (ExtractValue rt vs 0) @@ -295,98 +348,167 @@ emitECased t e cases = do emit $ Store ty val Ptr stackPtr emit $ Br label emit $ Label lbl_failPos - emitCases _ ty label stackPtr _ (Branch (MIR.PCatch, _) exp) = do + emitCases _ ty label stackPtr _ (Branch (PCatch, _) exp) = do emit $ Comment "Pcatch" val <- exprToValue exp emit $ Store ty val Ptr stackPtr emit $ Br label - lbl_failPos <- (\x -> TIR.Ident $ "failed_" <> show x) <$> getNewLabel + lbl_failPos <- (\x -> Ident $ "failed_" <> show x) <$> getNewLabel emit $ Label lbl_failPos -emitApp :: MIR.Type -> ExpT -> ExpT -> CompilerState () -emitApp rt e1 e2 = appEmitter e1 e2 [] - where - appEmitter :: ExpT -> ExpT -> [ExpT] -> CompilerState () - appEmitter e1 e2 stack = do - let newStack = e2 : stack - case e1 of - (MIR.EApp e1' e2', _) -> appEmitter e1' e2' newStack - (MIR.EVar name, t) -> do - args <- traverse exprToValue newStack - vs <- getNewVar - funcs <- gets functions - consts <- gets constructors - let visibility = - fromMaybe Local $ - Global <$ Map.lookup name consts - <|> Global <$ Map.lookup (name, t) funcs - -- this piece of code could probably be improved, i.e remove the double `const Global` - args' = map (first valueGetType . dupe) args - let call = - case name of - TIR.Ident ('l' : 't' : '$' : _) -> Icmp LLSlt I64 (snd (head args')) (snd (args' !! 1)) - TIR.Ident ('$' : 'm' : 'i' : 'n' : 'u' : 's' : '$' : '$' : _) -> Sub I64 (snd (head args')) (snd (args' !! 1)) - _ -> Call FastCC (type2LlvmType rt) visibility name args' - emit $ Comment $ show rt - emit $ SetVariable vs call - x -> error $ "The unspeakable happened: " <> show x +emitApp :: Type -> T Exp -> T Exp -> CompilerState () +emitApp rt e1 e2 = do + ((EVar name, t), args) <- go (EApp e1 e2, rt) + vs <- getNewVar + funcs <- gets functions + consts <- gets constructors + let visibility = + fromMaybe Local $ + Global <$ Map.lookup name consts + <|> Global <$ Map.lookup (name, t) funcs + -- this piece of code could probably be improved, i.e remove the double `const Global` -emitIdent :: TIR.Ident -> CompilerState () + call <- case name of + Ident ('l' : 't' : '$' : _) -> + pure $ Icmp LLSlt I64 (snd (head args)) (snd (args !! 1)) + Ident ('$' : 'm' : 'i' : 'n' : 'u' : 's' : '$' : '$' : _) -> + pure $ Sub I64 (snd (head args)) (snd (args !! 1)) + + -- FIXME + _ -> do + let closure_call LocalElem { typ = Ptr, val } = (mkDerefName name, (Ptr, val) : args) + + (name, args) <- gets $ maybe (name, (Ptr, VNull) : args) closure_call + . lookup name + . locals + + pure $ Call FastCC (type2LlvmType rt) visibility name args + + emit $ Comment $ show (type2LlvmType rt) + emit $ SetVariable vs call + + where + + go :: T Exp -> CompilerState (T Exp, [(LLVMType, LLVMValue)]) + go et@(e, _) = case e of + EApp e1 e2@(_, t) -> do + (x, as) <- go e1 + a <- exprToValue e2 + let t' = type2LlvmType' t + pure (x, snoc (t', a) as) + _ -> pure (et, []) + + type2LlvmType' = \case + TFun _ _ -> Ptr + t -> type2LlvmType t + +emitIdent :: Ident -> CompilerState () emitIdent id = do -- !!this should never happen!! emit $ Comment "This should not have happened!" emit $ Variable id emit $ UnsafeRaw "\n" -emitLit :: MIR.Lit -> CompilerState () +emitLit :: Lit -> CompilerState () emitLit i = do -- !!this should never happen!! let (i', t) = case i of - (MIR.LInt i'') -> (VInteger i'', I64) - (MIR.LChar i'') -> (VChar $ ord i'', I8) + (LInt i'') -> (VInteger i'', I64) + (LChar i'') -> (VChar $ ord i'', I8) varCount <- getNewVar emit $ Comment "This should not have happened!" emit $ SetVariable varCount (Add t i' (VInteger 0)) -emitAdd :: MIR.Type -> ExpT -> ExpT -> CompilerState () +emitAdd :: Type -> T Exp -> T Exp -> CompilerState () emitAdd t e1 e2 = do v1 <- exprToValue e1 v2 <- exprToValue e2 v <- getNewVar emit $ SetVariable v (Add (type2LlvmType t) v1 v2) -exprToValue :: ExpT -> CompilerState LLVMValue -exprToValue = \case - (MIR.ELit i, _t) -> pure $ case i of - (MIR.LInt i) -> VInteger i - (MIR.LChar i) -> VChar $ ord i - (MIR.EVar (TIR.Ident "True$Bool"), _t) -> pure $ VInteger 1 - (MIR.EVar (TIR.Ident "False$Bool"), _t) -> pure $ VInteger 0 - (MIR.EVar name, t) -> do - funcs <- gets functions - cons <- gets constructors - let res = - Map.lookup (name, t) funcs - <|> ( \c -> - FunctionInfo - { numArgs = numArgsCI c - , arguments = argumentsCI c - } - ) - <$> Map.lookup name cons - case res of - Just fi -> do - if numArgs fi == 0 - then do - vc <- getNewVar - emit $ - SetVariable - vc - (Call FastCC (type2LlvmType t) Global name []) - pure $ VIdent vc (type2LlvmType t) - else pure $ VFunction name Global (type2LlvmType t) - Nothing -> pure $ VIdent name (type2LlvmType t) - e -> do - compileExp e + +exprToValue :: T Exp -> CompilerState LLVMValue +exprToValue et@(e, t) = case e of + ELit (LInt i) -> pure $ VInteger i + ELit (LChar c) -> pure . VChar $ ord c + + EVar "True$Bool" -> pure $ VInteger 1 + EVar "False$Bool" -> pure $ VInteger 0 + + EVar name -> gets (Map.lookup name . globals) >>= \case + Just (typ@(Function _ ts), val) | length ts > 1 -> do + type_struct <- addStructType (mkClosureName name) [typ] + emit $ Comment "Allocating structure" + emit . SetVariable name $ Alloca type_struct + emit $ Store typ val Ptr name + pure $ VIdent name Ptr + + Just _ | name == "main" -> do + vc <- getNewVar + emit $ SetVariable vc (Call FastCC I64 Global name []) + pure $ VIdent vc I64 + + + Just (Function t_return [_], _) -> do + vc <- getNewVar + emit $ SetVariable vc (Call FastCC t_return Global name [(Ptr, VNull)]) + pure $ VIdent vc t_return + + Just _ -> error "Bad" + + Nothing -> gets (Map.lookup name . constructors) >>= \case + + Just ConstructorInfo {numArgsCI} + | numArgsCI == 0 -> do + vc <- getNewVar + emit $ SetVariable vc call + pure $ VIdent vc (type2LlvmType t) + | otherwise -> pure $ VFunction name Global (type2LlvmType t) + where + call = Call FastCC (type2LlvmType t) Global name [] + + Nothing -> gets $ val + . fromJust + . lookup name + . locals + + EVarC cxt name -> do + let cxt' = flip map cxt $ \(x, t) -> let t' = type2LlvmType t + in (t', VIdent x t') + cxt'' <- gets $ (:cxt') + . fromJust + . Map.lookup name + . globals + + -- Create a new type for function pointer and arguments + type_struct <- addStructType (mkClosureName name) $ map fst cxt'' + emit $ Comment "Allocating structure" + emit . SetVariable name $ Alloca type_struct + + let ptr_struct = VIdent name Ptr + storeArg (t, v) i = do + vc <- getNewVar + emit . SetVariable vc + $ GetElementPtrInbounds type_struct Ptr ptr_struct + I32 (VInteger 0) I32 (VInteger i) -- TODO fix indices + emit $ Store t v Ptr vc + + -- Store arguments in structure + zipWithM_ storeArg cxt'' [0 ..] + pure ptr_struct + + _ -> do + compileExp et v <- getVarCount - pure $ VIdent (TIR.Ident $ show v) (getType e) + pure $ VIdent (Ident $ show v) (getType et) + + +mkClosureName :: Ident -> Ident +mkClosureName (Ident s) = Ident $ "Closure_" ++ s + +mkDerefName :: Ident -> Ident +mkDerefName (Ident s) = Ident $ s ++ "_deref" + +mkCxtName :: Ident +mkCxtName = Ident "cxt" + diff --git a/src/Codegen/LlvmIr.hs b/src/Codegen/LlvmIr.hs index cc77cf9..0e0a6ce 100644 --- a/src/Codegen/LlvmIr.hs +++ b/src/Codegen/LlvmIr.hs @@ -9,17 +9,18 @@ module Codegen.LlvmIr ( Visibility (..), CallingConvention (..), ToIr (..), + typeOf ) where -import Data.List (intercalate) -import TypeChecker.TypeCheckerIr (Ident (..)) +import Data.List (intercalate) +import TypeChecker.TypeCheckerIr (Ident (..)) data CallingConvention = TailCC | FastCC | CCC | ColdCC deriving (Show, Eq, Ord) instance ToIr CallingConvention where toIr :: CallingConvention -> String toIr TailCC = "tailcc" toIr FastCC = "fastcc" - toIr CCC = "ccc" + toIr CCC = "ccc" toIr ColdCC = "coldcc" -- | A datatype which represents some basic LLVM types @@ -38,6 +39,9 @@ data LLVMType class ToIr a where toIr :: a -> String +instance ToIr a => ToIr [a] where + toIr = concatMap toIr + instance ToIr LLVMType where toIr :: LLVMType -> String toIr = \case @@ -66,8 +70,8 @@ data LLVMComp instance ToIr LLVMComp where toIr :: LLVMComp -> String toIr = \case - LLEq -> "eq" - LLNe -> "ne" + LLEq -> "eq" + LLNe -> "ne" LLUgt -> "ugt" LLUge -> "uge" LLUlt -> "ult" @@ -80,7 +84,7 @@ instance ToIr LLVMComp where data Visibility = Local | Global deriving (Show, Eq, Ord) instance ToIr Visibility where toIr :: Visibility -> String - toIr Local = "%" + toIr Local = "%" toIr Global = "@" {- | Represents a LLVM "value", as in an integer, a register variable, @@ -92,16 +96,18 @@ data LLVMValue | VIdent Ident LLVMType | VConstant String | VFunction Ident Visibility LLVMType + | VNull deriving (Show, Eq, Ord) instance ToIr LLVMValue where toIr :: LLVMValue -> String toIr v = case v of - VInteger i -> show i - VChar i -> show i - VIdent (Ident n) _ -> "%" <> n + VInteger i -> show i + VChar i -> show i + VIdent (Ident n) _ -> "%" <> n VFunction (Ident n) vis _ -> toIr vis <> n - VConstant s -> "c" <> show s + VConstant s -> "c" <> show s + VNull -> "null" type Params = [(Ident, LLVMType)] type Args = [(LLVMType, LLVMValue)] @@ -139,6 +145,21 @@ data LLVMIr -- instructions should be used in its place deriving (Show, Eq, Ord) + +-- TODO add missing clauses +typeOf :: LLVMIr -> LLVMType +typeOf = \case + Add t _ _ -> t + Sub t _ _ -> t + Mul t _ _ -> t + Div t _ _ -> t + Load t _ _ -> t + Store t _ _ _ -> t + Type x _ -> CustomType x + SetVariable _ ir -> typeOf ir + + + -- | Converts a list of LLVMIr instructions to a string llvmIrToString :: [LLVMIr] -> String llvmIrToString = go 0 @@ -147,9 +168,9 @@ llvmIrToString = go 0 go _ [] = mempty go i (x : xs) = do let (i', n) = case x of - Define{} -> (i + 1, 0) + Define{} -> (i + 1, 0) DefineEnd -> (i - 1, 0) - _ -> (i, i) + _ -> (i, i) insToString n x <> go i' xs -- \| Converts a LLVM inststruction to a String, allowing for printing etc. @@ -224,10 +245,10 @@ llvmIrToString = go 0 , ")\n" ] (Alloca t) -> unwords ["alloca", toIr t, "\n"] - (Malloc t) -> + (Malloc t) -> concat [ "call ptr @malloc(i64 ", show t, ")\n"] - (GcMalloc t) -> + (GcMalloc t) -> concat [ "call ptr @cheap_alloc(i64 ", show t, ")\n"] (Store t1 val t2 (Ident id2)) -> diff --git a/src/LambdaLifter.hs b/src/LambdaLifter.hs index 5581814..9369442 100644 --- a/src/LambdaLifter.hs +++ b/src/LambdaLifter.hs @@ -11,9 +11,11 @@ import Control.Monad.State (MonadState (get, put), State, evalState) import Data.Function (on) import Data.List (delete, mapAccumL, (\\)) +import Data.Tuple.Extra (first, second) +import LambdaLifterIr (T) +import qualified LambdaLifterIr as L import Prelude hiding (exp) -import TypeChecker.TypeCheckerIr - +import TypeChecker.TypeCheckerIr hiding (T) -- | Lift lambdas and let expression into supercombinators. -- Three phases: @@ -21,12 +23,13 @@ import TypeChecker.TypeCheckerIr -- @abstract@ converts lambdas into let expressions. -- @collectScs@ moves every non-constant let expression to a top-level function. -- -lambdaLift :: Program -> Program -lambdaLift (Program ds) = Program (datatypes ++ binds) +lambdaLift :: Program -> L.Program +lambdaLift (Program ds) = L.Program (datatypes ++ binds) where - datatypes = flip filter ds $ \case DData _ -> True - _ -> False - binds = map DBind $ (collectScs . abstract . freeVars) [b | DBind b <- ds] + datatypes = [L.DData (toLirData d) | DData d <- ds] + + binds = map L.DBind $ (collectScs . abstract . freeVars) [b | DBind b <- ds] + -- | Annotate free variables freeVars :: [Bind] -> [ABind] @@ -36,7 +39,7 @@ freeVars binds = [ let ae = freeVarsExp [] e | Bind n xs e <- binds ] -freeVarsExp :: Frees -> ExpT -> Ann AExpT +freeVarsExp :: Frees -> T Exp -> Ann (T AExp) freeVarsExp localVars (ae, t) = case ae of EVar n | elem (n,t) localVars -> Ann { frees = [(n, t)] , term = (AVar n, t) @@ -121,27 +124,47 @@ data Ann a = Ann , term :: a } deriving (Show, Eq) -data ABind = ABind Id [Id] (Ann AExpT) deriving (Show, Eq) -data ABranch = ABranch (Pattern, Type) (Ann AExpT) deriving (Show, Eq) - -type AExpT = (AExp, Type) +data ABind = ABind (T Ident) [T Ident] (Ann (T AExp)) deriving (Show, Eq) +data ABranch = ABranch (Pattern, Type) (Ann (T AExp)) deriving (Show, Eq) data AExp = AVar Ident | AInj Ident | ALit Lit - | ALet (Ann ABind) (Ann AExpT) - | AApp (Ann AExpT) (Ann AExpT) - | AAdd (Ann AExpT) (Ann AExpT) - | AAbs Ident (Ann AExpT) - | ACase (Ann AExpT) [Ann ABranch] + | ALet (Ann ABind) (Ann (T AExp)) + | AApp (Ann (T AExp)) (Ann (T AExp)) + | AAdd (Ann (T AExp)) (Ann (T AExp)) + | AAbs Ident (Ann (T AExp)) + | ACase (Ann (T AExp)) [Ann ABranch] deriving (Show, Eq) -abstract :: [ABind] -> [Bind] + + +data BBind = BBind (T Ident) [T Ident] (T BExp) + | BBindCxt [T Ident] (T Ident) [T Ident] (T BExp) + deriving (Eq, Ord, Show) + + +data BBranch = BBranch (T Pattern) (T BExp) + deriving (Eq, Ord, Show) + +data BExp + = BVar Ident + | BVarC [T Ident] Ident + | BInj Ident + | BLit Lit + | BLet BBind (T BExp) + | BApp (T BExp)(T BExp) + | BAdd (T BExp)(T BExp) + | BCase (T BExp) [BBranch] + deriving (Eq, Ord, Show) + + +abstract :: [ABind] -> [BBind] abstract bs = evalState (mapM (abstractAnnBind . Ann []) bs) 0 -abstractAnnBind :: Ann ABind -> State Int Bind +abstractAnnBind :: Ann ABind -> State Int BBind abstractAnnBind Ann { term = ABind name vars annae } = - Bind name (vars' <|| vars) <$> abstractAnnExp annae' + BBind name (vars' <|| vars) <$> abstractAnnExp annae' where (annae', vars') = go [] annae where @@ -149,24 +172,27 @@ abstractAnnBind Ann { term = ABind name vars annae } = Ann { term = (AAbs x ae, TFun t _) } -> go (snoc (x, t) acc) ae ae -> (ae, acc) -abstractAnnExp :: Ann AExpT -> State Int ExpT +abstractAnnExp :: Ann (T AExp) -> State Int (T BExp) abstractAnnExp Ann {frees, term = (annae, typ) } = case annae of - AVar n -> pure (EVar n, typ) - AInj n -> pure (EInj n, typ) - ALit lit -> pure (ELit lit, typ) - AApp annae1 annae2 -> (, typ) <$> onM EApp abstractAnnExp annae1 annae2 - AAdd annae1 annae2 -> (, typ) <$> onM EAdd abstractAnnExp annae1 annae2 + AVar n -> pure (BVar n, typ) + AInj n -> pure (BInj n, typ) + ALit lit -> pure (BLit lit, typ) + AApp annae1 annae2 -> (, typ) <$> onM BApp abstractAnnExp annae1 annae2 + AAdd annae1 annae2 -> (, typ) <$> onM BAdd abstractAnnExp annae1 annae2 - -- \x. \y. x + y + z ⇒ let sc x y z = x + y + z in sc AAbs x annae' -> do i <- nextNumber rhs <- abstractAnnExp annae'' let sc_name = Ident ("sc_" ++ show i) - e@(_, t) = foldl applyFree (EVar sc_name, typ) frees - pure (ELet (Bind (sc_name, typ) vars rhs) e ,t) + sc | null frees = (BVar sc_name, typ) + | otherwise = (BVarC frees sc_name, typ) + bind | null frees = BBind (sc_name, typ) vars rhs + | otherwise = BBindCxt frees (sc_name, typ) vars rhs + + pure (BLet bind sc ,typ) where - vars = frees <| (x, t_x) <|| ys + vars = [(x, t_x)] <|| ys t_x = case typ of TFun t _ -> t _ -> error "Impossible" @@ -176,54 +202,48 @@ abstractAnnExp Ann {frees, term = (annae, typ) } = case annae of Ann { term = (AAbs x ae, TFun t _) } -> go (snoc (x, t) acc) ae ae -> (ae, acc) - - applyFree :: (Exp' Type, Type) -> (Ident, Type) -> (Exp' Type, Type) - applyFree (e, t_e) (x, t_x) = (EApp (e, t_e) (EVar x, t_x), t_e') - where - t_e' = case t_e of TFun _ t -> t - _ -> error "Impossible" - ACase annae' bs -> do bs <- mapM go bs e <- abstractAnnExp annae' - pure (ECase e bs, typ) + pure (BCase e bs, typ) where - go Ann { term = ABranch p annae } = Branch p <$> abstractAnnExp annae + go Ann { term = ABranch p annae } = BBranch p <$> abstractAnnExp annae ALet b annae' -> - (, typ) <$> liftA2 ELet (abstractAnnBind b) (abstractAnnExp annae') + (, typ) <$> liftA2 BLet (abstractAnnBind b) (abstractAnnExp annae') -- | Collects supercombinators by lifting non-constant let expressions -collectScs :: [Bind] -> [Bind] +collectScs :: [BBind] -> [L.Bind] collectScs = concatMap collectFromRhs where - collectFromRhs (Bind name parms rhs) = + collectFromRhs (BBind name parms rhs) = let (rhs_scs, rhs') = collectScsExp rhs - in Bind name parms rhs' : rhs_scs + in L.Bind name parms rhs' : rhs_scs + collectFromRhs (BBindCxt cxt name parms rhs) = + let (rhs_scs, rhs') = collectScsExp rhs + in L.BindC cxt name parms rhs' : rhs_scs -collectScsExp :: ExpT -> ([Bind], ExpT) -collectScsExp expT@(exp, typ) = case exp of - EVar _ -> ([], expT) - EInj _ -> ([], expT) - ELit _ -> ([], expT) +collectScsExp :: T BExp -> ([L.Bind], T L.Exp) +collectScsExp (exp, typ) = case exp of + BVar x -> ([], (L.EVar x, typ)) + BVarC as x -> ([], (L.EVarC as x, typ)) + BInj k -> ([], (L.EInj k, typ)) + BLit lit -> ([], (L.ELit lit, typ)) - EApp e1 e2 -> (scs1 ++ scs2, (EApp e1' e2', typ)) + BApp e1 e2 -> (scs1 ++ scs2, (L.EApp e1' e2', typ)) where (scs1, e1') = collectScsExp e1 (scs2, e2') = collectScsExp e2 - EAdd e1 e2 -> (scs1 ++ scs2, (EAdd e1' e2', typ)) + BAdd e1 e2 -> (scs1 ++ scs2, (L.EAdd e1' e2', typ)) where (scs1, e1') = collectScsExp e1 (scs2, e2') = collectScsExp e2 - EAbs par e -> (scs, (EAbs par e', typ)) - where - (scs, e') = collectScsExp e - ECase e branches -> (scs ++ scs_e, (ECase e' branches', typ)) + BCase e branches -> (scs ++ scs_e, (L.ECase e' branches', typ)) where (scs, branches') = mapAccumL f [] branches (scs_e, e') = collectScsExp e @@ -234,15 +254,24 @@ collectScsExp expT@(exp, typ) = case exp of -- -- > f = let sc x y = rhs in e -- - ELet (Bind name parms rhs) e - | null parms -> (rhs_scs ++ et_scs, (ELet bind et', snd et')) + BLet (BBind name parms rhs) e + | null parms -> (rhs_scs ++ et_scs, (L.ELet name rhs' et', snd et')) | otherwise -> (bind : rhs_scs ++ et_scs, et') where - bind = Bind name parms rhs' + bind = L.Bind name parms rhs' (rhs_scs, rhs') = collectScsExp rhs (et_scs, et') = collectScsExp e -collectScsBranch (Branch patt exp) = (scs, Branch patt exp') + + BLet (BBindCxt cxt name parms rhs) e + | null parms -> (rhs_scs ++ et_scs, (L.ELet name rhs' et', snd et')) + | otherwise -> (bind : rhs_scs ++ et_scs, et') + where + bind = L.BindC cxt name parms rhs' + (rhs_scs, rhs') = collectScsExp rhs + (et_scs, et') = collectScsExp e + +collectScsBranch (BBranch patt exp) = (scs, L.Branch (first toLirPattern patt) exp') where (scs, exp') = collectScsExp exp nextNumber :: State Int Int @@ -259,3 +288,19 @@ xs <| x | elem x xs = xs (<||) :: Eq a => [a] -> [a] -> [a] xs <|| ys = foldl (<|) xs ys + + +toLirData (Data t injs) = L.Data t (map toLirInj injs) +toLirInj (Inj n t) = L.Inj n t + +toLirPattern :: Pattern -> L.Pattern +toLirPattern = \case + PVar x -> L.PVar x + PLit lit -> L.PLit lit + PCatch -> L.PCatch + PEnum k -> L.PEnum k + PInj k ps -> L.PInj k (map (first toLirPattern) ps) + + + + diff --git a/src/LambdaLifterIr.hs b/src/LambdaLifterIr.hs new file mode 100644 index 0000000..9ba57f7 --- /dev/null +++ b/src/LambdaLifterIr.hs @@ -0,0 +1,140 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE PatternSynonyms #-} + +module LambdaLifterIr ( + module Grammar.Abs, + module LambdaLifterIr, + module TypeChecker.TypeCheckerIr +) where + +import Data.List (intercalate) +import Grammar.Abs (Lit (..)) +import Grammar.Print +import Prelude hiding (exp) +import qualified Prelude as C (Eq, Ord, Show) +import TypeChecker.TypeCheckerIr (Ident (..), TVar (..), Type (..)) + +newtype Program = Program [Def] + deriving (C.Eq, C.Ord, C.Show) + +data Def + = DBind Bind + | DData Data + deriving (C.Eq, C.Ord, C.Show) + +data Data = Data Type [Inj] + deriving (C.Eq, C.Ord, C.Show) + +data Inj = Inj Ident Type + deriving (C.Eq, C.Ord, C.Show) + +data Pattern + = PVar Ident + | PLit Lit + | PCatch + | PEnum Ident + | PInj Ident [(Pattern, Type)] + deriving (C.Eq, C.Ord, C.Show) + +data Exp + = EVar Ident + | EVarC [T Ident] Ident + | EInj Ident + | ELit Lit + | ELet (T Ident) (T Exp) (T Exp) + | EApp (T Exp)(T Exp) + | EAdd (T Exp)(T Exp) + | ECase (T Exp) [Branch] + deriving (C.Eq, C.Ord, C.Show) + + +type T a = (a, Type) + +data Bind = Bind (T Ident) [T Ident] (T Exp) + | BindC [T Ident] (T Ident) [T Ident] (T Exp) + deriving (C.Eq, C.Ord, C.Show) + +data Branch = Branch (T Pattern) (T Exp) + deriving (C.Eq, C.Ord, C.Show) + +instance Print Program where + prt i (Program sc) = prt i sc + +instance Print Bind where + prt i (Bind sig parms rhs) = concatD + [ prt i sig + , prt i parms + , doc $ showString "=" + , prt i rhs + ] + prt i (BindC cxt sig parms rhs) = + prPrec i 0 $ + concatD + [ doc . showString $ "{" ++ intercalate ", " (map (\(x, _) -> printTree x ++ "^") cxt) ++ "}" ++ printTree sig + , prt i parms + , doc $ showString "=" + , prt i rhs + ] + +instance Print [Bind] where + prt _ [] = concatD [] + prt i [x] = concatD [prt i x] + prt i (x : xs) = concatD [prt i x, doc (showString ";"), prt i xs] + +instance Print Exp where + prt i = \case + EVar lident -> prPrec i 3 (concatD [prt 0 lident]) + EVarC as lident -> doc . showString + $ "{" ++ intercalate ", " (map go as) ++ "}" ++ printTree lident + where + go (x, _) = printTree x ++ "^=" ++ printTree (EVar x) + EInj uident -> prPrec i 3 (concatD [prt 0 uident]) + ELit lit -> prPrec i 3 (concatD [prt 0 lit]) + EApp exp1 exp2 -> prPrec i 2 (concatD [prt 2 exp1, prt 3 exp2]) + EAdd exp1 exp2 -> prPrec i 1 (concatD [prt 1 exp1, doc (showString "+"), prt 2 exp2]) + ELet lident exp1 exp2 -> prPrec i 0 (concatD [doc (showString "let"), prt 0 lident, doc (showString "="), prt 0 exp1 , doc (showString "in"), prt 0 exp2]) + ECase exp branchs -> prPrec i 0 (concatD [doc (showString "case"), prt 0 exp, doc (showString "of"), doc (showString "{"), prt 0 branchs, doc (showString "}")]) + + +instance Print Branch where + prt i (Branch (pattern_, t) exp) = prPrec i 0 (concatD [doc (showString "("), prt 0 pattern_, doc (showString " : "), prt 0 t, doc (showString ")"), doc (showString "=>"), prt 0 exp]) + +instance Print [Branch] where + prt _ [] = concatD [] + prt _ [x] = concatD [prt 0 x] + prt _ (x : xs) = concatD [prt 0 x, doc (showString ";"), prt 0 xs] + +instance Print Def where + prt i = \case + DBind bind -> prPrec i 0 (concatD [prt 0 bind]) + DData data_ -> prPrec i 0 (concatD [prt 0 data_]) + +instance Print Data where + prt i = \case + Data type_ injs -> prPrec i 0 (concatD [doc (showString "data"), prt 0 type_, doc (showString "where"), doc (showString "{"), prt 0 injs, doc (showString "}")]) + +instance Print Inj where + prt i = \case + Inj uident type_ -> prt i (uident, type_) + +instance Print [Inj] where + prt _ [] = concatD [] + prt i [x] = prt i x + prt i (x : xs) = prPrec i 0 $ concatD [prt i x, doc $ showString "\n ", prt i xs] + +instance Print Pattern where + prt i = \case + PVar name -> prPrec i 1 (concatD [prt 0 name]) + PLit lit -> prPrec i 1 (concatD [prt 0 lit]) + PCatch -> prPrec i 1 (concatD [doc (showString "_")]) + PEnum name -> prPrec i 1 (concatD [prt 0 name]) + PInj uident patterns -> prPrec i 0 (concatD [prt 0 uident, prt 1 patterns]) + +instance Print [Def] where + prt _ [] = concatD [] + prt _ [x] = concatD [prt 0 x] + prt _ (x : xs) = concatD [prt 0 x, doc (showString ";"), prt 0 xs] + +pattern DBind' id vars expt = DBind (Bind id vars expt) +pattern DData' typ injs = DData (Data typ injs) + diff --git a/src/Monomorphizer/DataTypeRemover.hs b/src/Monomorphizer/DataTypeRemover.hs index e4caef0..c3e2eb5 100644 --- a/src/Monomorphizer/DataTypeRemover.hs +++ b/src/Monomorphizer/DataTypeRemover.hs @@ -1,8 +1,11 @@ + module Monomorphizer.DataTypeRemover (removeDataTypes) where -import Monomorphizer.MonomorphizerIr qualified as M2 -import Monomorphizer.MorbIr qualified as M1 -import TypeChecker.TypeCheckerIr (Ident (Ident)) +import Data.Bifunctor (Bifunctor (bimap)) +import Monomorphizer.MonomorphizerIr (Ident (..)) +import qualified Monomorphizer.MonomorphizerIr as M2 +import qualified Monomorphizer.MorbIr as M1 +import Prelude hiding (exp) removeDataTypes :: M1.Program -> M2.Program removeDataTypes (M1.Program defs) = M2.Program (map pDef defs) @@ -18,43 +21,43 @@ pCons :: M1.Inj -> M2.Inj pCons (M1.Inj ident t) = M2.Inj ident (pType t) pType :: M1.Type -> M2.Type -pType (M1.TLit ident) = M2.TLit ident -pType (M1.TFun t1 t2) = M2.TFun (pType t1) (pType t2) +pType (M1.TLit ident) = M2.TLit ident +pType (M1.TFun t1 t2) = M2.TFun (pType t1) (pType t2) pType (M1.TData (Ident "Bool") _) = M2.TLit (Ident "Bool") -pType d = M2.TLit (Ident (newName d)) -- This is the step +pType d = M2.TLit (Ident (newName d)) -- This is the step newName :: M1.Type -> String -newName (M1.TLit (Ident str)) = str -newName (M1.TFun t1 t2) = newName t1 ++ newName t2 +newName (M1.TLit (Ident str)) = str +newName (M1.TFun t1 t2) = newName t1 ++ newName t2 newName (M1.TData (Ident str) args) = str ++ concatMap newName args pBind :: M1.Bind -> M2.Bind pBind (M1.Bind id argIds expt) = M2.Bind (pId id) (map pId argIds) (pExpT expt) +pBind (M1.BindC cxt id argIds expt) = + M2.BindC (map pId cxt) (pId id) (map pId argIds) (pExpT expt) pId :: (Ident, M1.Type) -> (Ident, M2.Type) pId (ident, t) = (ident, pType t) -pExpT :: M1.ExpT -> M2.ExpT +pExpT :: M1.T M1.Exp -> M2.T M2.Exp pExpT (exp, t) = (pExp exp, pType t) pExp :: M1.Exp -> M2.Exp -pExp (M1.EVar ident) = M2.EVar ident -pExp (M1.ELit lit) = M2.ELit (pLit lit) -pExp (M1.ELet bind expt) = M2.ELet (pBind bind) (pExpT expt) -pExp (M1.EApp e1 e2) = M2.EApp (pExpT e1) (pExpT e2) -pExp (M1.EAdd e1 e2) = M2.EAdd (pExpT e1) (pExpT e2) +pExp (M1.EVar ident) = M2.EVar ident +pExp (M1.EVarC as ident) = M2.EVarC (map pId as) ident +pExp (M1.ELit lit) = M2.ELit lit +pExp (M1.ELet bind expt) = M2.ELet (pBind bind) (pExpT expt) +pExp (M1.EApp e1 e2) = M2.EApp (pExpT e1) (pExpT e2) +pExp (M1.EAdd e1 e2) = M2.EAdd (pExpT e1) (pExpT e2) pExp (M1.ECase expT branches) = M2.ECase (pExpT expT) (map pBranch branches) pBranch :: M1.Branch -> M2.Branch pBranch (M1.Branch (patt, t) expt) = M2.Branch (pPattern patt, pType t) (pExpT expt) pPattern :: M1.Pattern -> M2.Pattern -pPattern (M1.PVar id) = M2.PVar (pId id) -pPattern (M1.PLit (lit, t)) = M2.PLit (pLit lit, pType t) -pPattern (M1.PInj ident patts) = M2.PInj ident (map pPattern patts) -pPattern M1.PCatch = M2.PCatch -pPattern (M1.PEnum ident) = M2.PEnum ident +pPattern (M1.PVar ident) = M2.PVar ident +pPattern (M1.PLit lit) = M2.PLit lit +pPattern (M1.PInj ident patts) = M2.PInj ident (map (bimap pPattern pType) patts) +pPattern M1.PCatch = M2.PCatch +pPattern (M1.PEnum ident) = M2.PEnum ident -pLit :: M1.Lit -> M2.Lit -pLit (M1.LInt v) = M2.LInt v -pLit (M1.LChar c) = M2.LChar c diff --git a/src/Monomorphizer/Monomorphizer.hs b/src/Monomorphizer/Monomorphizer.hs index 3a8bd9e..4b25aaa 100644 --- a/src/Monomorphizer/Monomorphizer.hs +++ b/src/Monomorphizer/Monomorphizer.hs @@ -1,4 +1,5 @@ -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedRecordDot #-} {- | For now, converts polymorphic functions to concrete ones based on usage. Assumes lambdas are lifted. @@ -25,30 +26,35 @@ bind) is added to the resulting set of binds. -} module Monomorphizer.Monomorphizer (monomorphize, morphExp, morphBind) where -import Monomorphizer.DataTypeRemover (removeDataTypes) -import Monomorphizer.MonomorphizerIr qualified as O -import Monomorphizer.MorbIr qualified as M -import TypeChecker.TypeCheckerIr (Ident (Ident)) -import TypeChecker.TypeCheckerIr qualified as T -import Control.Monad.Reader ( - MonadReader (ask, local), - Reader, - asks, - runReader, - ) -import Control.Monad.State ( - MonadState (get), - StateT (runStateT), - gets, - modify, - ) -import Data.Coerce (coerce) -import Data.Map qualified as Map -import Data.Maybe (catMaybes) -import Data.Set qualified as Set -import Grammar.Print (printTree) -import Debug.Trace (trace) +import Control.Monad.Reader (MonadReader (ask, local), + Reader, asks, runReader) +import Control.Monad.State (MonadState (get), + StateT (runStateT), gets, + modify) +import Data.Coerce (coerce) +import qualified Data.Map as Map +import Data.Maybe (catMaybes) +import qualified Data.Set as Set +import Debug.Trace (trace) +import Grammar.Print (printTree) +import Monomorphizer.DataTypeRemover (removeDataTypes) +import qualified Monomorphizer.MonomorphizerIr as O +import qualified Monomorphizer.MorbIr as M +-- import TypeChecker.TypeCheckerIr (Ident (Ident)) +import LambdaLifterIr (Ident (..)) +-- import TypeChecker.TypeCheckerIr qualified as T +import qualified LambdaLifterIr as L + +import Control.Monad.Reader (MonadReader (ask, local), + Reader, asks, runReader) +import Control.Monad.State (MonadState, StateT (runStateT), + gets, modify) +import qualified Data.Map as Map +import Data.Maybe (catMaybes, fromJust) +import qualified Data.Set as Set +import Data.Tuple.Extra (secondM) +import Grammar.Print (printTree) {- | EnvM is the monad containing the read-only state as well as the output state containing monomorphized functions and to-be monomorphized @@ -64,18 +70,18 @@ Binds, Polymorphic Data types (monomorphized in a later step) and Marked bind, which means that it is in the process of monomorphization and should not be monomorphized again. -} -data Outputted = Marked | Complete M.Bind | Data M.Type T.Data deriving (Show) +data Outputted = Marked | Complete M.Bind | Data M.Type L.Data deriving (Show) -- | Static environment. data Env = Env - { input :: Map.Map Ident T.Bind + { input :: Map.Map Ident L.Bind -- ^ All binds in the program. - , dataDefs :: Map.Map Ident T.Data + , dataDefs :: Map.Map Ident L.Data -- ^ All constructors mapped to their respective polymorphic data def -- which includes all other constructors. - , polys :: Map.Map Ident M.Type + , polys :: Map.Map Ident M.Type -- ^ Maps polymorphic identifiers with concrete types. - , locals :: Set.Set Ident + , locals :: Set.Set Ident -- ^ Local variables. } @@ -84,12 +90,13 @@ localExists :: Ident -> EnvM Bool localExists ident = asks (Set.member ident . locals) -- | Gets a polymorphic bind from an id. -getInputBind :: Ident -> EnvM (Maybe T.Bind) +getInputBind :: Ident -> EnvM (Maybe L.Bind) 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 (Map.insert ident (Complete b)) +addOutputBind b@(M.BindC _ (ident, _) _ _) = modify (Map.insert ident (Complete b)) {- | Marks a global bind as being processed, meaning that when encountered again, it should not be recursively processed. @@ -106,8 +113,8 @@ isConsMarked :: Ident -> EnvM Bool isConsMarked ident = gets (Map.member ident) -- | Finds main bind. -getMain :: EnvM T.Bind -getMain = asks (\env -> case Map.lookup (T.Ident "main") (input env) of +getMain :: EnvM L.Bind +getMain = asks (\env -> case Map.lookup (Ident "main") (input env) of Just mainBind -> mainBind Nothing -> error "main not found in monomorphizer!" ) @@ -116,13 +123,13 @@ getMain = asks (\env -> case Map.lookup (T.Ident "main") (input env) of error when encountering different structures between the two arguments. Debug: First argument is the name of the bind. -} -mapTypes :: Ident -> T.Type -> M.Type -> [(Ident, M.Type)] -mapTypes _ident (T.TLit _) (M.TLit _) = [] -mapTypes _ident (T.TVar (T.MkTVar i1)) tm = [(i1, tm)] -mapTypes ident (T.TFun pt1 pt2) (M.TFun mt1 mt2) = +mapTypes :: Ident -> L.Type -> M.Type -> [(Ident, M.Type)] +mapTypes _ident (L.TLit _) (M.TLit _) = [] +mapTypes _ident (L.TVar (L.MkTVar i1)) tm = [(i1, tm)] +mapTypes ident (L.TFun pt1 pt2) (M.TFun mt1 mt2) = mapTypes ident pt1 mt1 ++ mapTypes ident pt2 mt2 -mapTypes ident (T.TData tIdent pTs) (M.TData mIdent mTs) = +mapTypes ident (L.TData tIdent pTs) (M.TData mIdent mTs) = if tIdent /= mIdent then error "the data type names of monomorphic and polymorphic data types does not match" else foldl (\xs (p, m) -> mapTypes ident p m ++ xs) [] (zip pTs mTs) @@ -130,30 +137,30 @@ mapTypes ident t1 t2 = error $ "in bind: '" ++ printTree ident ++ "', " ++ "structure of types not the same: '" ++ printTree t1 ++ "', '" ++ printTree t2 ++ "'" -- | Gets the mapped monomorphic type of a polymorphic type in the current context. -getMonoFromPoly :: T.Type -> EnvM M.Type +getMonoFromPoly :: L.Type -> EnvM M.Type getMonoFromPoly t = do env <- ask return $ getMono (polys env) t where - getMono :: Map.Map Ident M.Type -> T.Type -> M.Type + getMono :: Map.Map Ident M.Type -> L.Type -> M.Type getMono polys t = case t of - (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 + (L.TLit ident) -> M.TLit ident + (L.TFun t1 t2) -> M.TFun (getMono polys t1) (getMono polys t2) + (L.TVar (L.MkTVar ident)) -> case Map.lookup ident polys of Just concrete -> concrete - Nothing -> M.TLit (Ident "void") + Nothing -> M.TLit (Ident "void") -- error $ "type not found! type: " ++ show ident ++ ", error in previous compilation steps" - (T.TData ident args) -> M.TData ident (map (getMono polys) args) + (L.TData ident args) -> M.TData ident (map (getMono polys) args) {- | If ident not already in env's output, morphed bind to output (and all referenced binds within this bind). Returns the annotated bind name. -} -morphBind :: M.Type -> T.Bind -> EnvM Ident -morphBind expectedType b@(T.Bind (ident, btype) args (exp, expt)) = do +morphBind :: M.Type -> L.Bind -> EnvM Ident +morphBind expectedType b@(L.Bind (ident, btype) args (exp, expt)) = do -- The "new name" is used to find out if it is already marked or not. let name' = newFuncName expectedType b - bindMarked <- isBindMarked (coerce name') + bindMarked <- isBindMarked name' local ( \env -> env @@ -168,26 +175,59 @@ morphBind expectedType b@(T.Bind (ident, btype) args (exp, expt)) = do else do -- Mark so that this bind will not be processed in recursive or cyclic -- function calls - markBind (coerce name') + markBind name' expt' <- getMonoFromPoly expt exp' <- morphExp expt' exp -- Get monomorphic type sof args args' <- mapM morphArg args addOutputBind $ M.Bind - (coerce name', expectedType) + (name', expectedType) args' (exp', expt') return name' +morphBind expectedType b@(L.BindC cxt (ident, btype) args (exp, expt)) = do + -- The "new name" is used to find out if it is already marked or not. + let name' = newFuncName expectedType b + bindMarked <- isBindMarked name' + local + ( \env -> + env + { locals = Set.fromList (map fst args) + , polys = Map.fromList (mapTypes ident btype expectedType) + } + ) + $ do + -- 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' + -- Get monomorphic type sof args + args' <- mapM morphArg args + cxt' <- mapM (secondM getMonoFromPoly) cxt + expt' <- getMonoFromPoly expt + exp' <- local (\env -> foldr (addLocal . fst) env cxt) + (morphExp expt' exp) + addOutputBind $ + M.BindC cxt' + (name', expectedType) + args' + (exp', expt') + return name' + + -- | Monomorphizes arguments of a bind. -morphArg :: (Ident, T.Type) -> EnvM (Ident, M.Type) +morphArg :: (Ident, L.Type) -> EnvM (Ident, M.Type) morphArg (ident, t) = do t' <- getMonoFromPoly t return (ident, t') -- | Gets the data bind from the name of a constructor. -getInputData :: Ident -> EnvM (Maybe T.Data) +getInputData :: Ident -> EnvM (Maybe L.Data) getInputData ident = do env <- ask return $ Map.lookup ident (dataDefs env) @@ -201,50 +241,50 @@ morphCons expectedType ident newIdent = do --trace ("Tjofras:" ++ show (newName expectedType ident)) $ return () maybeD <- getInputData ident case maybeD of - Nothing -> error $ "identifier '" ++ show ident ++ "' not found" + -- closures can have unbound variables + Nothing -> pure () Just d -> do modify (\output -> Map.insert newIdent (Data expectedType d) output) -- | Converts literals from input to output tree. -convertLit :: T.Lit -> M.Lit -convertLit (T.LInt v) = M.LInt v -convertLit (T.LChar v) = M.LChar v +convertLit :: L.Lit -> M.Lit +convertLit (L.LInt v) = M.LInt v +convertLit (L.LChar v) = M.LChar v + -- | Monomorphizes an expression, given an expected type. -morphExp :: M.Type -> T.Exp -> EnvM M.Exp +morphExp :: M.Type -> L.Exp -> EnvM M.Exp morphExp expectedType exp = case exp of - T.ELit lit -> return $ M.ELit (convertLit lit) + L.ELit lit -> return $ M.ELit lit -- Constructor - T.EInj ident -> do + L.EInj ident -> do let ident' = newName (getDataType expectedType) ident morphCons expectedType ident ident' return $ M.EVar ident' - T.EApp (e1, _t1) (e2, t2) -> do + L.EApp (e1, _t1) (e2, t2) -> do t2' <- getMonoFromPoly t2 e2' <- morphExp t2' e2 e1' <- morphExp (M.TFun t2' expectedType) e1 return $ M.EApp (e1', M.TFun t2' expectedType) (e2', t2') - T.EAdd (e1, t1) (e2, t2) -> do + L.EAdd (e1, t1) (e2, t2) -> do t1' <- getMonoFromPoly t1 t2' <- getMonoFromPoly t2 e1' <- morphExp t1' e1 e2' <- morphExp t2' e2 return $ M.EAdd (e1', expectedType) (e2', expectedType) - T.EAbs ident (exp, t) -> local (\env -> env{locals = Set.insert ident (locals env)}) $ do - t' <- getMonoFromPoly t - morphExp t' exp - T.ECase (exp, t) bs -> do + L.ECase (exp, t) bs -> do t' <- getMonoFromPoly t exp' <- morphExp t' exp bs' <- mapM morphBranch bs return $ M.ECase (exp', t') (catMaybes bs') -- Ideally constructors should be EInj, though this code handles them -- as well. - T.EVar ident -> do + -- FIXME MAKE EVAR AND EINJ SEPARATE!!! + L.EVar ident -> do isLocal <- localExists ident if isLocal then do - return $ M.EVar (coerce ident) + return $ M.EVar ident else do bind <- getInputBind ident case bind of @@ -252,38 +292,51 @@ morphExp expectedType exp = case exp of Just bind' -> do -- New bind to process newBindName <- morphBind expectedType bind' - return $ M.EVar (coerce newBindName) - T.ELet (T.Bind (identB, tB) args (expB, tExpB)) (exp, tExp) -> - if length args > 0 then error "only constants in lets allowed" - else do + return $ M.EVar newBindName + L.EVarC as ident -> do + isLocal <- localExists ident + if isLocal + then do + return $ M.EVar ident + else do + bind <- fromJust <$> getInputBind ident + as' <- mapM (secondM getMonoFromPoly) as + -- New bind to process + newBindName <- morphBind expectedType bind + return $ M.EVarC as' newBindName + -- Ideally constructors should be EInj, though this code handles them + -- as well. + + + L.ELet (identB, tB) (expB, tExpB) (exp, tExp) -> do tB' <- getMonoFromPoly tB tExpB' <- getMonoFromPoly tExpB tExp' <- getMonoFromPoly tExp expB' <- morphExp tExpB' expB - exp' <- morphExp tExp' exp + exp' <- local (addLocal identB) (morphExp tExp' exp) return $ M.ELet (M.Bind (identB, tB') [] (expB', tExpB')) (exp', tExp') -- | Monomorphizes case-of branches. -morphBranch :: T.Branch -> EnvM (Maybe M.Branch) -morphBranch (T.Branch (p, pt) (e, et)) = do +morphBranch :: L.Branch -> EnvM (Maybe M.Branch) +morphBranch (L.Branch (p, pt) (e, et)) = do pt' <- getMonoFromPoly pt et' <- getMonoFromPoly et env <- ask maybeMorphedPattern <- morphPattern p pt' case maybeMorphedPattern of Nothing -> return Nothing - Just (p', newLocals) -> + Just (p', newLocals) -> local (const env { locals = Set.union (locals env) newLocals }) $ do e' <- morphExp et' e - return $ Just (M.Branch (p', pt') (e', et')) + return $ Just (M.Branch p' (e', et')) -morphPattern :: T.Pattern -> M.Type -> EnvM (Maybe (M.Pattern, Set.Set Ident)) +morphPattern :: L.Pattern -> M.Type -> EnvM (Maybe (M.T M.Pattern, Set.Set Ident)) morphPattern p expectedType = case p of - T.PVar ident -> return $ Just (M.PVar (ident, expectedType), Set.singleton ident) - T.PLit lit -> return $ Just (M.PLit (convertLit lit, expectedType), Set.empty) - T.PCatch -> return $ Just (M.PCatch, Set.empty) - T.PEnum ident -> return $ Just (M.PEnum (newName expectedType ident), Set.empty) - T.PInj ident pts -> do let newIdent = newName expectedType ident + L.PVar ident -> return $ Just ((M.PVar ident, expectedType), Set.singleton ident) + L.PLit lit -> return $ Just ((M.PLit (convertLit lit), expectedType), Set.empty) + L.PCatch -> return $ Just ((M.PCatch, expectedType), Set.empty) + L.PEnum ident -> return $ Just ((M.PEnum (newName expectedType ident), expectedType), Set.empty) + L.PInj ident pts -> do let newIdent = newName expectedType ident outEnv <- get trace ("WOW: " ++ show (newName expectedType ident)) $ return () trace ("WOW2: " ++ show (outEnv)) $ return () @@ -297,13 +350,18 @@ morphPattern p expectedType = case p of let maybePsSets = sequence psSets case maybePsSets of Nothing -> return Nothing - Just psSets' -> return $ Just - (M.PInj newIdent (map fst psSets'), Set.unions $ map snd psSets') + Just psSets' -> return $ Just + ((M.PInj newIdent (map fst psSets'), expectedType), Set.unions $ map snd psSets') else return Nothing -- | Creates a new identifier for a function with an assigned type. -newFuncName :: M.Type -> T.Bind -> Ident -newFuncName t (T.Bind (ident@(Ident bindName), _) _ _) = +newFuncName :: M.Type -> L.Bind -> Ident +newFuncName t (L.Bind (ident@(Ident bindName), _) _ _) = + if bindName == "main" + then Ident bindName + else newName t ident + +newFuncName t (L.BindC _ (ident@(Ident bindName), _) _ _) = if bindName == "main" then Ident bindName else newName t ident @@ -317,8 +375,8 @@ newName t (Ident str) = Ident $ str ++ "$" ++ newName' t newName' (M.TData (Ident str) ts) = str ++ foldl (\s t -> s ++ "." ++ newName' t) "" ts -- | Monomorphization step. -monomorphize :: T.Program -> O.Program -monomorphize (T.Program defs) = +monomorphize :: L.Program -> O.Program +monomorphize (L.Program defs) = removeDataTypes $ M.Program ( getDefsFromOutput @@ -336,7 +394,7 @@ 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.Def] -> Env +createEnv :: [L.Def] -> Env createEnv defs = Env { input = Map.fromList bindPairs @@ -346,33 +404,34 @@ createEnv defs = } where bindPairs = (map (\b -> (getBindName b, b)) . getBindsFromDefs) defs - dataPairs :: [(Ident, T.Data)] - dataPairs = (foldl (\acc d@(T.Data _ cs) -> map ((,d) . getConsName) cs ++ acc) [] . getDataFromDefs) defs + dataPairs :: [(Ident, L.Data)] + dataPairs = (foldl (\acc d@(L.Data _ cs) -> map ((,d) . getConsName) cs ++ acc) [] . getDataFromDefs) defs -- | Gets a top-lefel function name. -getBindName :: T.Bind -> Ident -getBindName (T.Bind (ident, _) _ _) = ident +getBindName :: L.Bind -> Ident +getBindName (L.Bind (ident, _) _ _) = ident +getBindName (L.BindC _ (ident, _) _ _) = ident -- Helper functions -- Gets custom data declarations form defs. -getDataFromDefs :: [T.Def] -> [T.Data] +getDataFromDefs :: [L.Def] -> [L.Data] getDataFromDefs = foldl ( \bs -> \case - T.DBind _ -> bs - T.DData d -> d : bs + L.DBind _ -> bs + L.DData d -> d : bs ) [] -getConsName :: T.Inj -> Ident -getConsName (T.Inj ident _) = ident +getConsName :: L.Inj -> Ident +getConsName (L.Inj ident _) = ident -getBindsFromDefs :: [T.Def] -> [T.Bind] +getBindsFromDefs :: [L.Def] -> [L.Bind] getBindsFromDefs = foldl ( \bs -> \case - T.DBind b -> b : bs - T.DData _ -> bs + L.DBind b -> b : bs + L.DData _ -> bs ) [] @@ -384,19 +443,19 @@ getDefsFromOutput o = (binds, dataInput) = splitBindsAndData o -- | Splits the output into binds and data declaration components (used in createNewData) -splitBindsAndData :: Output -> ([M.Bind], [(Ident, M.Type, T.Data)]) +splitBindsAndData :: Output -> ([M.Bind], [(Ident, M.Type, L.Data)]) splitBindsAndData output = foldl ( \(oBinds, oData) (ident, o) -> case o of - Marked -> error "internal bug in monomorphizer" + Marked -> error "internal bug in monomorphizer" Complete b -> (b : oBinds, oData) - Data t d -> (oBinds, (ident, t, d) : oData) + Data t d -> (oBinds, (ident, t, d) : oData) ) ([], []) (Map.toList output) -- | Converts all found constructors to monomorphic data declarations. -createNewData :: [(Ident, M.Type, T.Data)] -> Map.Map Ident M.Data -> Map.Map Ident M.Data +createNewData :: [(Ident, M.Type, L.Data)] -> Map.Map Ident M.Data -> Map.Map Ident M.Data createNewData [] o = o createNewData ((consIdent, consType, polyData) : input) o = createNewData input $ @@ -406,14 +465,17 @@ createNewData ((consIdent, consType, polyData) : input) o = (M.Data newDataType [newCons]) o where - T.Data (T.TData polyDataIdent _) _ = polyData + L.Data (L.TData polyDataIdent _) _ = polyData newDataType = getDataType consType newDataName = newName newDataType polyDataIdent newCons = M.Inj consIdent consType -- | Gets the Data Type of a constructor type (a -> Just a becomes Just a). getDataType :: M.Type -> M.Type -getDataType (M.TFun _t1 t2) = getDataType t2 +getDataType (M.TFun _t1 t2) = getDataType t2 getDataType tData@(M.TData _ _) = tData -getDataType _ = error "???" +getDataType _ = error "???" + +addLocal :: Ident -> Env -> Env +addLocal x env = env { locals = Set.insert x env.locals } diff --git a/src/Monomorphizer/MonomorphizerIr.hs b/src/Monomorphizer/MonomorphizerIr.hs index 052cdc1..59ad067 100644 --- a/src/Monomorphizer/MonomorphizerIr.hs +++ b/src/Monomorphizer/MonomorphizerIr.hs @@ -1,11 +1,14 @@ {-# LANGUAGE LambdaCase #-} -module Monomorphizer.MonomorphizerIr (module Monomorphizer.MonomorphizerIr) where +module Monomorphizer.MonomorphizerIr ( + module Monomorphizer.MonomorphizerIr, + module LambdaLifterIr +) where -import Grammar.Print -import TypeChecker.TypeCheckerIr qualified as TIR (Ident (..)) - -type Id = (TIR.Ident, Type) +import Data.List (intercalate) +import Grammar.Print +import LambdaLifterIr (Ident (..), Lit (..)) +import Prelude hiding (exp) newtype Program = Program [Def] deriving (Show, Ord, Eq) @@ -16,90 +19,80 @@ data Def = DBind Bind | DData Data data Data = Data Type [Inj] deriving (Show, Ord, Eq) -data Bind = Bind Id [Id] ExpT +data Bind = Bind (T Ident) [T Ident] (T Exp) + | BindC [T Ident] (T Ident) [T Ident] (T Exp) deriving (Show, Ord, Eq) +type T a = (a, Type) + data Exp - = EVar TIR.Ident + = EVar Ident + | EVarC [T Ident] Ident | ELit Lit - | ELet Bind ExpT - | EApp ExpT ExpT - | EAdd ExpT ExpT - | ECase ExpT [Branch] + | ELet Bind (T Exp) + | EApp (T Exp) (T Exp) + | EAdd (T Exp) (T Exp) + | ECase (T Exp) [Branch] deriving (Show, Ord, Eq) data Pattern - = PVar Id - | PLit (Lit, Type) - | PInj TIR.Ident [Pattern] + = PVar Ident + | PLit Lit + | PInj Ident [T Pattern] | PCatch - | PEnum TIR.Ident + | PEnum Ident deriving (Eq, Ord, Show) -data Branch = Branch (Pattern, Type) ExpT +data Branch = Branch (T Pattern) (T Exp) deriving (Eq, Ord, Show) -type ExpT = (Exp, Type) - -data Inj = Inj TIR.Ident Type +data Inj = Inj Ident Type deriving (Show, Ord, Eq) -data Lit - = LInt Integer - | LChar Char - deriving (Show, Ord, Eq) - -data Type = TLit TIR.Ident | TFun Type Type +data Type = TLit Ident | TFun Type Type deriving (Show, Ord, Eq) flattenType :: Type -> [Type] flattenType (TFun t1 t2) = t1 : flattenType t2 -flattenType x = [x] +flattenType x = [x] instance Print Program where prt i (Program sc) = prPrec i 0 $ prt 0 sc -instance Print (Bind) where +instance Print Bind where prt i (Bind sig@(name, _) parms rhs) = prPrec i 0 $ concatD - [ prtSig sig + [ prt 0 sig , prt 0 name - , prtIdPs 0 parms + , prt 0 parms , doc $ showString "=" , prt 0 rhs ] -prtSig :: Id -> Doc -prtSig (name, t) = - concatD - [ prt 0 name - , doc $ showString ":" - , prt 0 t - , doc $ showString ";" - ] + prt i (BindC cxt sig parms rhs) = + prPrec i 0 $ + concatD + [ doc . showString $ "{" ++ intercalate ", " (map (\(x, _) -> printTree x ++ "^") cxt) ++ "}" ++ printTree sig + , prt i parms + , doc $ showString "=" + , prt i rhs + ] -instance Print (ExpT) where - prt i (e, t) = - concatD - [ doc $ showString "(" - , prt i e - , doc $ showString "," - , prt i t - , doc $ showString ")" - ] instance Print [Bind] where - prt _ [] = concatD [] - prt _ [x] = concatD [prt 0 x] + 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 (prt i) instance Print Exp where prt i = \case EVar name -> prPrec i 3 $ prt 0 name + EVarC as lident -> doc . showString + $ "{" ++ intercalate ", " (map go as) ++ "}" ++ printTree lident + where + go (x, _) = printTree x ++ "^=" ++ printTree (EVar x) ELit lit -> prPrec i 3 $ prt 0 lit ELet b e -> prPrec i 3 $ @@ -134,16 +127,16 @@ instance Print Exp where ] instance Print Branch where - prt i (Branch (pattern_, t) exp) = prPrec i 0 (concatD [doc (showString "("), prt 0 pattern_, doc (showString " : "), prt 0 t, doc (showString ")"), doc (showString "=>"), prt 0 exp]) + prt i (Branch patt exp) = prPrec i 0 (concatD [prt i patt, doc (showString "=>"), prt 0 exp]) instance Print [Branch] where - prt _ [] = concatD [] - prt _ [x] = concatD [prt 0 x] + prt _ [] = concatD [] + prt _ [x] = concatD [prt 0 x] prt _ (x : xs) = concatD [prt 0 x, doc (showString ";"), prt 0 xs] instance Print Def where prt i = \case - DBind bind -> prPrec i 0 (concatD [prt 0 bind]) + DBind bind -> prPrec i 0 (concatD [prt 0 bind]) DData data_ -> prPrec i 0 (concatD [prt 0 data_]) instance Print Data where @@ -152,23 +145,23 @@ instance Print Data where instance Print Inj where prt i = \case - Inj uident type_ -> prPrec i 0 (concatD [prt 0 uident, doc (showString ":"), prt 0 type_]) + Inj uident type_ -> prt i (uident, type_) instance Print Pattern where prt i = \case PVar name -> prPrec i 1 (concatD [prt 0 name]) - PLit (lit, _) -> prPrec i 1 (concatD [prt 0 lit]) + PLit lit -> prPrec i 1 (concatD [prt 0 lit]) PCatch -> prPrec i 1 (concatD [doc (showString "_")]) PEnum name -> prPrec i 1 (concatD [prt 0 name]) PInj uident patterns -> prPrec i 0 (concatD [prt 0 uident, prt 1 patterns]) instance Print [Def] where - prt _ [] = concatD [] - prt _ [x] = concatD [prt 0 x] + prt _ [] = concatD [] + prt _ [x] = concatD [prt 0 x] prt _ (x : xs) = concatD [prt 0 x, doc (showString ";"), prt 0 xs] instance Print [Type] where - prt _ [] = concatD [] + prt _ [] = concatD [] prt _ (x : xs) = concatD [prt 0 x, doc (showString " "), prt 0 xs] instance Print Type where @@ -176,7 +169,3 @@ instance Print Type where TLit uident -> prPrec i 1 (concatD [prt 0 uident]) TFun type_1 type_2 -> prPrec i 0 (concatD [prt 1 type_1, doc (showString "->"), prt 0 type_2]) -instance Print Lit where - prt i = \case - LInt int -> prt i int - LChar char -> prt i char diff --git a/src/Monomorphizer/MorbIr.hs b/src/Monomorphizer/MorbIr.hs index 3e5db6b..35af47c 100644 --- a/src/Monomorphizer/MorbIr.hs +++ b/src/Monomorphizer/MorbIr.hs @@ -1,10 +1,14 @@ {-# LANGUAGE LambdaCase #-} -module Monomorphizer.MorbIr where -import Grammar.Print -import TypeChecker.TypeCheckerIr qualified as TIR (Ident (..)) +module Monomorphizer.MorbIr ( + module Monomorphizer.MorbIr, + module LambdaLifterIr +) where -type Id = (TIR.Ident, Type) +import Data.List (intercalate) +import Grammar.Print +import LambdaLifterIr (Ident (..), Lit (..)) +import Prelude hiding (exp) newtype Program = Program [Def] deriving (Show, Ord, Eq) @@ -15,91 +19,81 @@ data Def = DBind Bind | DData Data data Data = Data Type [Inj] deriving (Show, Ord, Eq) -data Bind = Bind Id [Id] ExpT +data Bind = Bind (T Ident) [T Ident] (T Exp) + | BindC [T Ident] (T Ident) [T Ident] (T Exp) deriving (Show, Ord, Eq) + +type T a = (a, Type) + data Exp - = EVar TIR.Ident + = EVar Ident + | EVarC [T Ident] Ident | ELit Lit - | ELet Bind ExpT - | EApp ExpT ExpT - | EAdd ExpT ExpT - | ECase ExpT [Branch] + | ELet Bind (T Exp) + | EApp (T Exp) (T Exp) + | EAdd (T Exp) (T Exp) + | ECase (T Exp) [Branch] deriving (Show, Ord, Eq) data Pattern - = PVar Id - | PLit (Lit, Type) - | PInj TIR.Ident [Pattern] + = PVar Ident + | PLit Lit + | PInj Ident [T Pattern] | PCatch - | PEnum TIR.Ident + | PEnum Ident deriving (Eq, Ord, Show) -data Branch = Branch (Pattern, Type) ExpT + +data Branch = Branch (T Pattern) (T Exp) deriving (Eq, Ord, Show) -type ExpT = (Exp, Type) - -data Inj = Inj TIR.Ident Type +data Inj = Inj Ident Type deriving (Show, Ord, Eq) -data Lit - = LInt Integer - | LChar Char - deriving (Show, Ord, Eq) - -data Type = TLit TIR.Ident | TFun Type Type | TData TIR.Ident [Type] +data Type = TLit Ident | TFun Type Type | TData Ident [Type] deriving (Show, Ord, Eq) flattenType :: Type -> [Type] flattenType (TFun t1 t2) = t1 : flattenType t2 -flattenType x = [x] +flattenType x = [x] instance Print Program where prt i (Program sc) = prPrec i 0 $ prt 0 sc -instance Print (Bind) where +instance Print Bind where prt i (Bind sig@(name, _) parms rhs) = prPrec i 0 $ concatD - [ prtSig sig + [ prt 0 sig , prt 0 name - , prtIdPs 0 parms + , prt 0 parms , doc $ showString "=" , prt 0 rhs ] -prtSig :: Id -> Doc -prtSig (name, t) = - concatD - [ prt 0 name - , doc $ showString ":" - , prt 0 t - , doc $ showString ";" - ] - -instance Print (ExpT) where - prt i (e, t) = - concatD - [ doc $ showString "(" - , prt i e - , doc $ showString "," - , prt i t - , doc $ showString ")" - ] + prt i (BindC cxt sig parms rhs) = + prPrec i 0 $ + concatD + [ doc . showString $ "{" ++ intercalate ", " (map (\(x, _) -> printTree x ++ "^") cxt) ++ "}" ++ printTree sig + , prt i parms + , doc $ showString "=" + , prt i rhs + ] instance Print [Bind] where - prt _ [] = concatD [] - prt _ [x] = concatD [prt 0 x] + 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 (prt i) - instance Print Exp where prt i = \case EVar name -> prPrec i 3 $ prt 0 name + EVarC as lident -> doc . showString + $ "{" ++ intercalate ", " (map go as) ++ "}" ++ printTree lident + where + go (x, _) = printTree x ++ "^=" ++ printTree (EVar x) ELit lit -> prPrec i 3 $ prt 0 lit ELet b e -> prPrec i 3 $ @@ -134,16 +128,16 @@ instance Print Exp where ] instance Print Branch where - prt i (Branch (pattern_, t) exp) = prPrec i 0 (concatD [doc (showString "("), prt 0 pattern_, doc (showString " : "), prt 0 t, doc (showString ")"), doc (showString "=>"), prt 0 exp]) + prt i (Branch patt exp) = prPrec i 0 (concatD [prt i patt, doc (showString "=>"), prt 0 exp]) instance Print [Branch] where - prt _ [] = concatD [] - prt _ [x] = concatD [prt 0 x] + prt _ [] = concatD [] + prt _ [x] = concatD [prt 0 x] prt _ (x : xs) = concatD [prt 0 x, doc (showString ";"), prt 0 xs] instance Print Def where prt i = \case - DBind bind -> prPrec i 0 (concatD [prt 0 bind]) + DBind bind -> prPrec i 0 (concatD [prt 0 bind]) DData data_ -> prPrec i 0 (concatD [prt 0 data_]) instance Print Data where @@ -152,23 +146,23 @@ instance Print Data where instance Print Inj where prt i = \case - Inj uident type_ -> prPrec i 0 (concatD [prt 0 uident, doc (showString ":"), prt 0 type_]) + Inj uident type_ -> prt i (uident, type_) instance Print Pattern where prt i = \case PVar name -> prPrec i 1 (concatD [prt 0 name]) - PLit (lit, _) -> prPrec i 1 (concatD [prt 0 lit]) + PLit lit -> prPrec i 1 (concatD [prt 0 lit]) PCatch -> prPrec i 1 (concatD [doc (showString "_")]) PEnum name -> prPrec i 1 (concatD [prt 0 name]) PInj uident patterns -> prPrec i 0 (concatD [prt 0 uident, prt 1 patterns]) instance Print [Def] where - prt _ [] = concatD [] - prt _ [x] = concatD [prt 0 x] + prt _ [] = concatD [] + prt _ [x] = concatD [prt 0 x] prt _ (x : xs) = concatD [prt 0 x, doc (showString ";"), prt 0 xs] instance Print [Type] where - prt _ [] = concatD [] + prt _ [] = concatD [] prt _ (x : xs) = concatD [prt 0 x, doc (showString " "), prt 0 xs] instance Print Type where @@ -177,8 +171,4 @@ instance Print Type where TFun type_1 type_2 -> prPrec i 0 (concatD [prt 1 type_1, doc (showString "->"), prt 0 type_2]) TData uident types -> prPrec i 1 (concatD [prt 0 uident, doc (showString "("), prt 0 types, doc (showString ")")]) -instance Print Lit where - prt i = \case - LInt int -> prt i int - LChar char -> prt i char diff --git a/src/TypeChecker/ReportTEVar.hs b/src/TypeChecker/ReportTEVar.hs index 62cd301..c15967a 100644 --- a/src/TypeChecker/ReportTEVar.hs +++ b/src/TypeChecker/ReportTEVar.hs @@ -2,15 +2,15 @@ module TypeChecker.ReportTEVar where -import Auxiliary (onM) -import Control.Applicative (Applicative (liftA2), liftA3) -import Control.Monad.Except (MonadError (throwError)) -import Data.Coerce (coerce) -import Data.Tuple.Extra (secondM) -import Grammar.Abs qualified as G -import Grammar.ErrM (Err) -import Grammar.Print (printTree) -import TypeChecker.TypeCheckerIr hiding (Type (..)) +import Auxiliary (onM) +import Control.Applicative (Applicative (liftA2), liftA3) +import Control.Monad.Except (MonadError (throwError)) +import Data.Coerce (coerce) +import Data.Tuple.Extra (secondM) +import qualified Grammar.Abs as G +import Grammar.ErrM (Err) +import Grammar.Print (printTree) +import TypeChecker.TypeCheckerIr hiding (Type (..)) data Type = TLit Ident @@ -18,7 +18,7 @@ data Type | TData Ident [Type] | TFun Type Type | TAll TVar Type - deriving (Eq, Ord, Show, Read) + deriving (Eq, Ord, Show) class ReportTEVar a b where reportTEVar :: a -> Err b @@ -29,20 +29,20 @@ instance ReportTEVar (Program' G.Type) (Program' Type) where instance ReportTEVar (Def' G.Type) (Def' Type) where reportTEVar = \case DBind bind -> DBind <$> reportTEVar bind - DData dat -> DData <$> reportTEVar dat + DData dat -> DData <$> reportTEVar dat instance ReportTEVar (Bind' G.Type) (Bind' Type) where reportTEVar (Bind id vars rhs) = liftA3 Bind (reportTEVar id) (reportTEVar vars) (reportTEVar rhs) instance ReportTEVar (Exp' G.Type) (Exp' Type) where reportTEVar exp = case exp of - EVar name -> pure $ EVar name - EInj name -> pure $ EInj name - ELit lit -> pure $ ELit lit - ELet bind e -> liftA2 ELet (reportTEVar bind) (reportTEVar e) - EApp e1 e2 -> onM EApp reportTEVar e1 e2 - EAdd e1 e2 -> onM EAdd reportTEVar e1 e2 - EAbs name e -> EAbs name <$> reportTEVar e + EVar name -> pure $ EVar name + EInj name -> pure $ EInj name + ELit lit -> pure $ ELit lit + ELet bind e -> liftA2 ELet (reportTEVar bind) (reportTEVar e) + EApp e1 e2 -> onM EApp reportTEVar e1 e2 + EAdd e1 e2 -> onM EAdd reportTEVar e1 e2 + EAbs name e -> EAbs name <$> reportTEVar e ECase e branches -> liftA2 ECase (reportTEVar e) (reportTEVar branches) instance ReportTEVar (Branch' G.Type) (Branch' Type) where @@ -53,10 +53,10 @@ instance ReportTEVar (Pattern' G.Type, G.Type) (Pattern' Type, Type) where instance ReportTEVar (Pattern' G.Type) (Pattern' Type) where reportTEVar = \case - PVar name -> pure $ PVar name - PLit lit -> pure $ PLit lit - PCatch -> pure PCatch - PEnum name -> pure $ PEnum name + PVar name -> pure $ PVar name + PLit lit -> pure $ PLit lit + PCatch -> pure PCatch + PEnum name -> pure $ PEnum name PInj name ps -> PInj name <$> reportTEVar ps instance ReportTEVar (Data' G.Type) (Data' Type) where @@ -65,10 +65,10 @@ instance ReportTEVar (Data' G.Type) (Data' Type) where instance ReportTEVar (Inj' G.Type) (Inj' Type) where reportTEVar (Inj name typ) = Inj name <$> reportTEVar typ -instance ReportTEVar (Id' G.Type) (Id' Type) where +instance ReportTEVar (a, G.Type) (a, Type) where reportTEVar = secondM reportTEVar -instance ReportTEVar (ExpT' G.Type) (ExpT' Type) where +instance ReportTEVar (T' Exp' G.Type) (T' Exp' Type) where reportTEVar (exp, typ) = liftA2 (,) (reportTEVar exp) (reportTEVar typ) instance ReportTEVar a b => ReportTEVar [a] [b] where @@ -76,9 +76,9 @@ instance ReportTEVar a b => ReportTEVar [a] [b] where instance ReportTEVar G.Type Type where reportTEVar = \case - G.TLit lit -> pure $ TLit (coerce lit) - G.TVar (G.MkTVar i) -> pure $ TVar (MkTVar $ coerce i) - G.TData name typs -> TData (coerce name) <$> reportTEVar typs - G.TFun t1 t2 -> liftA2 TFun (reportTEVar t1) (reportTEVar t2) + G.TLit lit -> pure $ TLit (coerce lit) + G.TVar (G.MkTVar i) -> pure $ TVar (MkTVar $ coerce i) + G.TData name typs -> TData (coerce name) <$> reportTEVar typs + G.TFun t1 t2 -> liftA2 TFun (reportTEVar t1) (reportTEVar t2) G.TAll (G.MkTVar i) t -> TAll (MkTVar $ coerce i) <$> reportTEVar t - G.TEVar tevar -> throwError ("Found TEVar: " ++ printTree tevar) + G.TEVar tevar -> throwError ("Found TEVar: " ++ printTree tevar) diff --git a/src/TypeChecker/TypeCheckerBidir.hs b/src/TypeChecker/TypeCheckerBidir.hs index 04a8d91..184243f 100644 --- a/src/TypeChecker/TypeCheckerBidir.hs +++ b/src/TypeChecker/TypeCheckerBidir.hs @@ -31,6 +31,7 @@ import Grammar.ErrM import Grammar.Print (printTree) import Prelude hiding (exp) import qualified TypeChecker.TypeCheckerIr as T +import TypeChecker.TypeCheckerIr (T, T') -- Implementation is derived from the paper (Dunfield and Krishnaswami 2013) -- https://doi.org/10.1145/2500365.2500582 @@ -172,7 +173,7 @@ typecheckInj (Inj inj_name inj_typ) name tvars -- | Γ ⊢ e ↑ A ⊣ Δ -- Under input context Γ, e checks against input type A, with output context ∆ -check :: Exp -> Type -> Tc (T.ExpT' Type) +check :: Exp -> Type -> Tc (T' T.Exp' Type) -- Γ,α ⊢ e ↑ A ⊣ Δ,α,Θ -- ------------------- ∀I @@ -212,12 +213,6 @@ check (ECase scrut pi) c = do e' <- check e c pure (T.Branch p' e') apply (T.ECase (scrut', a) pi', c) - where - go (pi, b) (Branch p e) = do - p' <- checkPattern p =<< apply a - e'@(_, b') <- infer e - subtype b' b - apply (T.Branch p' e' : pi, b') -- Γ,α ⊢ e ↓ A ⊣ Θ Θ ⊢ [Θ]A <: [Θ]B ⊣ Δ @@ -229,9 +224,6 @@ check e b = do subtype a b' apply (e', b) - - - checkPattern :: Pattern -> Type -> Tc (T.Pattern' Type, Type) checkPattern patt t_patt = case patt of @@ -297,7 +289,7 @@ checkPattern patt t_patt = case patt of -- | Γ ⊢ e ↓ A ⊣ Δ -- Under input context Γ, e infers output type A, with output context ∆ -infer :: Exp -> Tc (T.ExpT' Type) +infer :: Exp -> Tc (T' T.Exp' Type) infer (ELit lit) = apply (T.ELit lit, litType lit) -- Γ ∋ (x : A) Γ ⊢ rec(x) @@ -391,7 +383,7 @@ infer (ECase scrut pi) = do -- | Γ ⊢ A • e ⇓ C ⊣ Δ -- Under input context Γ , applying a function of type A to e infers type C, with output context ∆ -- Instantiate existential type variables until there is an arrow type. -applyInfer :: Type -> Exp -> Tc (T.ExpT' Type, Type) +applyInfer :: Type -> Exp -> Tc (T' T.Exp' Type, Type) -- Γ,ά ⊢ [ά/α]A • e ⇓ C ⊣ Δ -- ------------------------ ∀App diff --git a/src/TypeChecker/TypeCheckerHm.hs b/src/TypeChecker/TypeCheckerHm.hs index f4ec70a..7834ecd 100644 --- a/src/TypeChecker/TypeCheckerHm.hs +++ b/src/TypeChecker/TypeCheckerHm.hs @@ -1,32 +1,32 @@ -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedRecordDot #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QualifiedDo #-} -{-# OPTIONS_GHC -Wno-incomplete-patterns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QualifiedDo #-} -- | A module for type checking and inference using algorithm W, Hindley-Milner module TypeChecker.TypeCheckerHm where -import Auxiliary (int, litType, maybeToRightM, unzip4) -import Auxiliary qualified as Aux -import Control.Monad.Except -import Control.Monad.Identity (Identity, runIdentity) -import Control.Monad.Reader -import Control.Monad.State -import Control.Monad.Writer -import Data.Coerce (coerce) -import Data.Function (on) -import Data.List (foldl', nub, sortOn) -import Data.List.Extra (unsnoc) -import Data.Map (Map) -import Data.Map qualified as M -import Data.Maybe (fromJust) -import Data.Set (Set) -import Data.Set qualified as S -import Debug.Trace (trace, traceShow) -import Grammar.Abs -import Grammar.Print (printTree) -import TypeChecker.TypeCheckerIr qualified as T +import Auxiliary (int, litType, maybeToRightM, unzip4) +import qualified Auxiliary as Aux +import Control.Monad.Except +import Control.Monad.Identity (Identity, runIdentity) +import Control.Monad.Reader +import Control.Monad.State +import Control.Monad.Writer +import Data.Coerce (coerce) +import Data.Function (on) +import Data.List (foldl', nub, sortOn) +import Data.List.Extra (unsnoc) +import Data.Map (Map) +import qualified Data.Map as M +import Data.Maybe (fromJust) +import Data.Set (Set) +import qualified Data.Set as S +import Debug.Trace (trace, traceShow) +import Grammar.Abs +import Grammar.Print (printTree) +import qualified TypeChecker.TypeCheckerIr as T +import TypeChecker.TypeCheckerIr (T, T') {- TODO @@ -41,7 +41,7 @@ typecheck :: Program -> Either String (T.Program' Type, [Warning]) typecheck = onLeft msg . run . checkPrg where onLeft :: (Error -> String) -> Either Error a -> Either String a - onLeft f (Left x) = Left $ f x + onLeft f (Left x) = Left $ f x onLeft _ (Right x) = Right x checkPrg :: Program -> Infer (T.Program' Type) @@ -68,13 +68,13 @@ prettify s (T.Program defs) = T.Program $ map (go s) defs replace :: Map T.Ident T.Ident -> Type -> Type replace m def@(TVar (MkTVar (LIdent a))) = case M.lookup (coerce a) m of - Just t -> TVar . MkTVar . LIdent $ coerce t + Just t -> TVar . MkTVar . LIdent $ coerce t Nothing -> def replace m (TFun t1 t2) = (TFun `on` replace m) t1 t2 replace m (TData name ts) = TData name (map (replace m) ts) replace m def@(TAll (MkTVar forall_) t) = case M.lookup (coerce forall_) m of Just found -> TAll (MkTVar $ coerce found) (replace m t) - Nothing -> def + Nothing -> def replace _ t = t bindCount :: [Def] -> Infer [(Int, Def)] @@ -128,7 +128,7 @@ preRun (x : xs) = case x of s <- gets sigs case M.lookup (coerce n) s of Nothing -> insertSig (coerce n) Nothing >> preRun xs - Just _ -> preRun xs + Just _ -> preRun xs DData d@(Data t _) -> collect (collectTVars t) >> checkData d >> preRun xs where -- Check if function body / signature has been declared already @@ -150,11 +150,11 @@ checkDef (x : xs) = case x of T.Data t $ map (\(Inj name typ) -> T.Inj (coerce name) typ) injs freeOrdered :: Type -> [T.Ident] -freeOrdered (TVar (MkTVar a)) = return (coerce a) +freeOrdered (TVar (MkTVar a)) = return (coerce a) freeOrdered (TAll (MkTVar bound) t) = return (coerce bound) ++ freeOrdered t -freeOrdered (TFun a b) = freeOrdered a ++ freeOrdered b -freeOrdered (TData _ a) = concatMap freeOrdered a -freeOrdered _ = mempty +freeOrdered (TFun a b) = freeOrdered a ++ freeOrdered b +freeOrdered (TData _ a) = concatMap freeOrdered a +freeOrdered _ = mempty -- Much cleaner implementation, unfortunately one minor bug -- checkBind :: Bind -> Infer (T.Bind' Type) @@ -257,13 +257,13 @@ checkInj (Inj c inj_typ) name tvars toTVar :: Type -> Either Error TVar toTVar = \case TVar tvar -> pure tvar - _ -> uncatchableErr "Not a type variable" + _ -> uncatchableErr "Not a type variable" returnType :: Type -> Type returnType (TFun _ t2) = returnType t2 -returnType a = a +returnType a = a -inferExp :: Exp -> Infer (T.ExpT' Type) +inferExp :: Exp -> Infer (T' T.Exp' Type) inferExp e = do (s, (e', t)) <- algoW e let subbed = apply s t @@ -274,7 +274,7 @@ class CollectTVars a where instance CollectTVars Exp where collectTVars (EAnn e t) = collectTVars t `S.union` collectTVars e - collectTVars _ = S.empty + collectTVars _ = S.empty instance CollectTVars Type where collectTVars (TVar (MkTVar i)) = S.singleton (coerce i) @@ -287,7 +287,7 @@ instance CollectTVars Type where collect :: Set T.Ident -> Infer () collect s = modify (\st -> st{takenTypeVars = s `S.union` takenTypeVars st}) -algoW :: Exp -> Infer (Subst, T.ExpT' Type) +algoW :: Exp -> Infer (Subst, T' T.Exp' Type) algoW = \case err@(EAnn e t) -> do (sub0, (e', t')) <- exprErr (algoW e) err @@ -600,12 +600,12 @@ generalize :: Map T.Ident Type -> Type -> Type generalize env t = go (S.toList $ free t S.\\ free env) (removeForalls t) where go :: [T.Ident] -> Type -> Type - go [] t = t + go [] t = t go (x : xs) t = TAll (MkTVar (coerce x)) (go xs t) removeForalls :: Type -> Type - removeForalls (TAll _ t) = removeForalls t + removeForalls (TAll _ t) = removeForalls t removeForalls (TFun t1 t2) = TFun (removeForalls t1) (removeForalls t2) - removeForalls t = t + removeForalls t = t {- | Instantiate a polymorphic type. The free type variables are substituted with fresh ones. @@ -643,7 +643,7 @@ fresh = do ungo :: [TVar] -> Type -> Type -> Bool ungo tvars t1 t2 = case run (go tvars t1 t2) of Right (b, _) -> b - _ -> False + _ -> False -- TODO: Fix the following -- Maybe locally using the Infer monad can cause trouble. -- Since the fresh count starts from zero @@ -656,7 +656,7 @@ fresh = do skipForalls :: Type -> Type skipForalls = \case TAll _ t -> skipForalls t - t -> t + t -> t freshen :: Type -> Infer Type freshen t = do @@ -705,10 +705,10 @@ instance SubstType Type where TLit _ -> t TVar (MkTVar a) -> case M.lookup (coerce a) sub of Nothing -> TVar (MkTVar $ coerce a) - Just t -> t + Just t -> t TAll (MkTVar i) t -> case M.lookup (coerce i) sub of Nothing -> TAll (MkTVar i) (apply sub t) - Just _ -> apply sub t + Just _ -> apply sub t TFun a b -> TFun (apply sub a) (apply sub b) TData name a -> TData name (apply sub a) TEVar (MkTEVar _) -> t @@ -724,7 +724,7 @@ instance SubstType (Map T.Ident Type) where instance SubstType (Map T.Ident (Maybe Type)) where apply s = M.map (fmap $ apply s) -instance SubstType (T.ExpT' Type) where +instance SubstType (T' T.Exp' Type) where apply s (e, t) = (apply s e, apply s t) instance SubstType (T.Exp' Type) where @@ -753,10 +753,10 @@ instance SubstType (T.Branch' Type) where instance SubstType (T.Pattern' Type) where apply s = \case T.PVar iden -> T.PVar iden - T.PLit lit -> T.PLit lit + T.PLit lit -> T.PLit lit T.PInj i ps -> T.PInj i $ apply s ps - T.PCatch -> T.PCatch - T.PEnum i -> T.PEnum i + T.PCatch -> T.PCatch + T.PEnum i -> T.PEnum i instance SubstType (T.Pattern' Type, Type) where apply s (p, t) = (apply s p, apply s t) @@ -764,7 +764,7 @@ instance SubstType (T.Pattern' Type, Type) where instance SubstType a => SubstType [a] where apply s = map (apply s) -instance SubstType (T.Id' Type) where +instance SubstType (T T.Ident Type) where apply s (name, t) = (name, apply s t) -- | Represents the empty substition set @@ -797,11 +797,11 @@ withBindings xs = -- | Run the monadic action with a pattern withPattern :: (Monad m, MonadReader Ctx m) => (T.Pattern' Type, Type) -> m a -> m a withPattern (p, t) ma = case p of - T.PVar x -> withBinding x t ma + T.PVar x -> withBinding x t ma T.PInj _ ps -> foldl' (flip withPattern) ma ps - T.PLit _ -> ma - T.PCatch -> ma - T.PEnum _ -> ma + T.PLit _ -> ma + T.PCatch -> ma + T.PEnum _ -> ma -- | Insert a function signature into the environment insertSig :: T.Ident -> Maybe Type -> Infer () @@ -826,11 +826,11 @@ existInj n = gets (M.lookup n . injections) flattenType :: Type -> [Type] flattenType (TFun a b) = flattenType a <> flattenType b -flattenType a = [a] +flattenType a = [a] typeLength :: Type -> Int typeLength (TFun _ b) = 1 + typeLength b -typeLength _ = 1 +typeLength _ = 1 {- | Catch an error if possible and add the given expression as addition to the error message @@ -913,11 +913,11 @@ newtype Ctx = Ctx {vars :: Map T.Ident Type} deriving (Show) data Env = Env - { count :: Int - , nextChar :: Char - , sigs :: Map T.Ident (Maybe Type) + { count :: Int + , nextChar :: Char + , sigs :: Map T.Ident (Maybe Type) , takenTypeVars :: Set T.Ident - , injections :: Map T.Ident Type + , injections :: Map T.Ident Type , declaredBinds :: Set T.Ident } deriving (Show) diff --git a/src/TypeChecker/TypeCheckerIr.hs b/src/TypeChecker/TypeCheckerIr.hs index a956ff3..9dea744 100644 --- a/src/TypeChecker/TypeCheckerIr.hs +++ b/src/TypeChecker/TypeCheckerIr.hs @@ -1,6 +1,7 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE PatternSynonyms #-} + module TypeChecker.TypeCheckerIr ( module Grammar.Abs, module TypeChecker.TypeCheckerIr, @@ -10,31 +11,30 @@ import Data.String (IsString) import Grammar.Abs (Lit (..)) import Grammar.Print import Prelude -import qualified Prelude as C (Eq, Ord, Read, Show) newtype Program' t = Program [Def' t] - deriving (C.Eq, C.Ord, C.Show, C.Read, Functor) + deriving (Eq, Ord, Show, Functor) data Def' t = DBind (Bind' t) | DData (Data' t) - deriving (C.Eq, C.Ord, C.Show, C.Read, Functor) + deriving (Eq, Ord, Show, Functor) data Type = TLit Ident | TVar TVar | TData Ident [Type] | TFun Type Type - deriving (Eq, Ord, Show, Read) + deriving (Eq, Ord, Show) data Data' t = Data t [Inj' t] - deriving (C.Eq, C.Ord, C.Show, C.Read, Functor) + deriving (Eq, Ord, Show, Functor) data Inj' t = Inj Ident t - deriving (C.Eq, C.Ord, C.Show, C.Read, Functor) + deriving (Eq, Ord, Show, Functor) newtype Ident = Ident String - deriving (C.Eq, C.Ord, C.Show, C.Read, IsString) + deriving (Eq, Ord, Show, IsString) data Pattern' t = PVar Ident @@ -42,30 +42,31 @@ data Pattern' t | PCatch | PEnum Ident | PInj Ident [(Pattern' t, t)] - deriving (C.Eq, C.Ord, C.Show, C.Read, Functor) + deriving (Eq, Ord, Show, Functor) data Exp' t = EVar Ident | EInj Ident | ELit Lit - | ELet (Bind' t) (ExpT' t) - | EApp (ExpT' t) (ExpT' t) - | EAdd (ExpT' t) (ExpT' t) - | EAbs Ident (ExpT' t) - | ECase (ExpT' t) [Branch' t] - deriving (C.Eq, C.Ord, C.Show, C.Read, Functor) + | ELet (Bind' t) (T' Exp' t) + | EApp (T' Exp' t) (T' Exp' t) + | EAdd (T' Exp' t) (T' Exp' t) + | EAbs Ident (T' Exp' t) + | ECase (T' Exp' t) [Branch' t] + deriving (Eq, Ord, Show, Functor) newtype TVar = MkTVar Ident - deriving (C.Eq, C.Ord, C.Show, C.Read) + deriving (Eq, Ord, Show) -type Id' t = (Ident, t) -type ExpT' t = (Exp' t, t) +type T' a t = (a t, t) +type T a t = (a, t) -data Bind' t = Bind (Id' t) [Id' t] (ExpT' t) - deriving (C.Eq, C.Ord, C.Show, C.Read, Functor) -data Branch' t = Branch (Pattern' t, t) (ExpT' t) - deriving (C.Eq, C.Ord, C.Show, C.Read, Functor) +data Bind' t = Bind (T Ident t) [T Ident t] (T' Exp' t) + deriving (Eq, Ord, Show, Functor) + +data Branch' t = Branch (T' Pattern' t) (T' Exp' t) + deriving (Eq, Ord, Show, Functor) instance Print Ident where prt _ (Ident s) = doc $ showString s @@ -81,22 +82,22 @@ instance Print t => Print (Bind' t) where , prt i rhs ] -prtSig :: Print t => Id' t -> Doc -prtSig (name, t) = +prtSig :: Print t => T Ident t -> Doc +prtSig (x, t) = concatD - [ prt 0 name + [ prt 0 x , doc $ showString ":" , prt 0 t ] -instance Print t => Print (ExpT' t) where - prt i (e, t) = +instance (Print a, Print t) => Print (T a t) where + prt i (x, t) = concatD - [ doc $ showString "(" - , prt i e - , doc $ showString ":" - , prt 0 t - , doc $ showString ")" + [ -- doc $ showString "(" + {- , -} prt i x +-- , doc $ showString ":" +-- , prt 0 t +-- , doc $ showString ")" ] instance Print t => Print [Bind' t] where @@ -104,15 +105,6 @@ instance Print t => Print [Bind' t] where prt i [x] = concatD [prt i x] prt i (x : xs) = concatD [prt i x, doc (showString ";"), prt i xs] -instance Print t => Print (Id' t) where - prt i (name, t) = - concatD - [ doc $ showString "(" - , prt i name - , doc $ showString "," - , prt i t - , doc $ showString ")" - ] instance Print t => Print (Exp' t) where prt i = \case @@ -151,9 +143,6 @@ instance Print t => Print [Inj' t] where prt i [x] = prt i x prt i (x : xs) = prPrec i 0 $ concatD [prt i x, doc $ showString "\n ", prt i xs] -instance Print t => Print (Pattern' t, t) where - prt i (p, t) = prPrec i 1 (concatD [prt i p, prt i t]) - instance Print t => Print (Pattern' t) where prt i = \case PVar name -> prPrec i 1 (concatD [prt 0 name]) @@ -189,8 +178,6 @@ type Branch = Branch' Type type Pattern = Pattern' Type type Inj = Inj' Type type Exp = Exp' Type -type ExpT = ExpT' Type -type Id = Id' Type pattern TVar' s = TVar (MkTVar s) pattern DBind' id vars expt = DBind (Bind id vars expt) pattern DData' typ injs = DData (Data typ injs) diff --git a/test_map2.ll b/test_map2.ll new file mode 100644 index 0000000..ae37f18 --- /dev/null +++ b/test_map2.ll @@ -0,0 +1,185 @@ +target triple = "x86_64-pc-linux-gnu" +target datalayout = "e-m:o-i64:64-f80:128-n8:16:32:64-S128" +@.str = private unnamed_addr constant [3 x i8] c"%i +", align 1 +@.non_exhaustive_patterns = private unnamed_addr constant [41 x i8] c"Non-exhaustive patterns in case at %i:%i +" +declare i32 @printf(ptr noalias nocapture, ...) +declare i32 @exit(i32 noundef) +declare ptr @malloc(i32 noundef) +%List = type { i8, [23 x i8] } +%Cons = type { i8, i64, %List* } +%Nil = type { i8 } +; NYTT: kontexttyp +%Closure_sc_0 = type { i64 (i64)*, i64 } + +; Ident "sum$List_Int": (ECase (EVar (Ident "$4xs"),TLit (Ident "List")) [Branch (PEnum (Ident "Nil"),TLit (Ident "List")) (ELit (LInt 0),TLit (Ident "Int")),Branch (PInj (Ident "Cons") [PVar (Ident "$5x",TLit (Ident "Int")),PVar (Ident "$6xs",TLit (Ident "List"))],TLit (Ident "List")) (EAdd (EVar (Ident "$5x"),TLit (Ident "Int")) (EApp (EVar (Ident "sum$List_Int"),TFun (TLit (Ident "List")) (TLit (Ident "Int"))) (EVar (Ident "$6xs"),TLit (Ident "List")),TLit (Ident "Int")),TLit (Ident "Int"))],TLit (Ident "Int")) +define fastcc i64 @sum$List_Int(%List %$4xs) { + %1 = alloca i64 + ; Penum + %2 = extractvalue %List %$4xs, 0 + %3 = icmp eq i8 %2, 1 + br i1 %3, label %lbl_success_3, label %lbl_failed_2 + +lbl_success_3: + %4 = alloca %List + store %List %$4xs, ptr %4 + %5 = load %Nil, ptr %4 + store i64 0, ptr %1 + br label %lbl_escape_1 + +lbl_failed_2: + ; Inj + %6 = extractvalue %List %$4xs, 0 + %7 = icmp eq i8 %6, 0 + br i1 %7, label %lbl_success_5, label %lbl_failed_4 + +lbl_success_5: + %8 = alloca %List + store %List %$4xs, ptr %8 + %9 = load %Cons, ptr %8 + ; ident i64 + %$5x = extractvalue %Cons %9, 1 + ; ident %List + %10 = extractvalue %Cons %9, 2 + %$6xs = load %List, ptr %10 + ; TLit (Ident "Int") + %11 = call fastcc i64 @sum$List_Int(%List %$6xs) + %12 = add i64 %$5x, %11 + store i64 %12, ptr %1 + br label %lbl_escape_1 + +lbl_failed_4: + call i32 (ptr, ...) @printf(ptr noundef @.non_exhaustive_patterns, i64 noundef 12, i64 noundef 6) + call i32 @exit(i32 noundef 1) + br label %lbl_escape_1 + +lbl_escape_1: + %15 = load i64, ptr %1 + ret i64 %15 +} + +; Ident "sc_0$Int_Int": (EAdd (EVar (Ident "$7x"),TLit (Ident "Int")) (ELit (LInt 10),TLit (Ident "Int")),TLit (Ident "Int")) +; ÄNDRAT: lägg till kontextpekare +define fastcc i64 @sc_0$Int_Int(ptr %closure_sc_0, i64 %$7x) { + ; NYTT: Ladda alla fria variabler + %fri_variabel_ptr = getelementptr inbounds %Closure_sc_0, ptr %closure_sc_0, i32 0, i32 1 + %fri_variabel = load i64, ptr %fri_variabel_ptr + ; ÄNDRAT: %fri_variabel istället för 2 + %1 = add i64 %$7x, %fri_variabel + ret i64 %1 +} + +; Ident "map$Int_Int_List_List": (ECase (EVar (Ident "$1xs"),TLit (Ident "List")) [Branch (PEnum (Ident "Nil"),TLit (Ident "List")) (EVar (Ident "Nil"),TLit (Ident "List")),Branch (PInj (Ident "Cons") [PVar (Ident "$2x",TLit (Ident "Int")),PVar (Ident "$3xs",TLit (Ident "List"))],TLit (Ident "List")) (EApp (EApp (EVar (Ident "Cons"),TFun (TLit (Ident "Int")) (TFun (TLit (Ident "List")) (TLit (Ident "List")))) (EApp (EVar (Ident "$0f"),TFun (TLit (Ident "Int")) (TLit (Ident "Int"))) (EVar (Ident "$2x"),TLit (Ident "Int")),TLit (Ident "Int")),TFun (TLit (Ident "List")) (TLit (Ident "List"))) (EApp (EApp (EVar (Ident "map$Int_Int_List_List"),TFun (TFun (TLit (Ident "Int")) (TLit (Ident "Int"))) (TFun (TLit (Ident "List")) (TLit (Ident "List")))) (EVar (Ident "$0f"),TFun (TLit (Ident "Int")) (TLit (Ident "Int"))),TFun (TLit (Ident "List")) (TLit (Ident "List"))) (EVar (Ident "$3xs"),TLit (Ident "List")),TLit (Ident "List")),TLit (Ident "List"))],TLit (Ident "List")) +; ÄNDRAT: ptr istället för i64 (i64)* +define fastcc %List @map$Int_Int_List_List(ptr %$0f, %List %$1xs) { + ; NYTT: ta fram funktionspekaren + %$0f_deref = load i64(i64)*, ptr %$0f + + %1 = alloca %List + ; Penum + %2 = extractvalue %List %$1xs, 0 + %3 = icmp eq i8 %2, 1 + br i1 %3, label %lbl_success_8, label %lbl_failed_7 + +lbl_success_8: + %4 = alloca %List + store %List %$1xs, ptr %4 + %5 = load %Nil, ptr %4 + %6 = call fastcc %List @Nil() + store %List %6, ptr %1 + br label %lbl_escape_6 + +lbl_failed_7: + ; Inj + %7 = extractvalue %List %$1xs, 0 + %8 = icmp eq i8 %7, 0 + br i1 %8, label %lbl_success_10, label %lbl_failed_9 + +lbl_success_10: + %9 = alloca %List + store %List %$1xs, ptr %9 + %10 = load %Cons, ptr %9 + ; ident i64 + %$2x = extractvalue %Cons %10, 1 + ; ident %List + %11 = extractvalue %Cons %10, 2 + %$3xs = load %List, ptr %11 + ; TLit (Ident "Int") + ; ÄNDRAT använd deref + %12 = call fastcc i64 %$0f_deref(ptr %$0f, i64 %$2x) + ; TLit (Ident "List") + ; ÄNDRAT ptr istället för 64 (64)* och skicka med ptr + %13 = call fastcc %List @map$Int_Int_List_List(ptr %$0f, %List %$3xs) + ; TLit (Ident "List") + %14 = call fastcc %List @Cons(i64 %12, %List %13) + store %List %14, ptr %1 + br label %lbl_escape_6 + +lbl_failed_9: + call i32 (ptr, ...) @printf(ptr noundef @.non_exhaustive_patterns, i64 noundef 14, i64 noundef 6) + call i32 @exit(i32 noundef 1) + br label %lbl_escape_6 + +lbl_escape_6: + %17 = load %List, ptr %1 + ret %List %17 +} + + +; Ident "main": (EApp (EVar (Ident "sum$List_Int"),TFun (TLit (Ident "List")) (TLit (Ident "Int"))) (EApp (EApp (EVar (Ident "map$Int_Int_List_List"),TFun (TFun (TLit (Ident "Int")) (TLit (Ident "Int"))) (TFun (TLit (Ident "List")) (TLit (Ident "List")))) (EVar (Ident "sc_0$Int_Int"),TFun (TLit (Ident "Int")) (TLit (Ident "Int"))),TFun (TLit (Ident "List")) (TLit (Ident "List"))) (EApp (EApp (EVar (Ident "Cons"),TFun (TLit (Ident "Int")) (TFun (TLit (Ident "List")) (TLit (Ident "List")))) (ELit (LInt 1),TLit (Ident "Int")),TFun (TLit (Ident "List")) (TLit (Ident "List"))) (EApp (EApp (EVar (Ident "Cons"),TFun (TLit (Ident "Int")) (TFun (TLit (Ident "List")) (TLit (Ident "List")))) (ELit (LInt 2),TLit (Ident "Int")),TFun (TLit (Ident "List")) (TLit (Ident "List"))) (EVar (Ident "Nil"),TLit (Ident "List")),TLit (Ident "List")),TLit (Ident "List")),TLit (Ident "List")),TLit (Ident "Int")) +define fastcc i64 @main() { + %1 = call fastcc %List @Nil() + ; TLit (Ident "List") + %2 = call fastcc %List @Cons(i64 2, %List %1) + ; TLit (Ident "List") + %3 = call fastcc %List @Cons(i64 1, %List %2) + ; TLit (Ident "List") + + ; NYTT: spara funktionspekaren och 100 i kontexten + %closure_sc_0 = alloca %Closure_sc_0 + store i64(i64)* @sc_0$Int_Int, ptr %closure_sc_0 + %fri_variabel_ptr = getelementptr inbounds %Closure_sc_0, ptr %closure_sc_0, i32 0, i32 1 + store i64 100, ptr %fri_variabel_ptr + + + ; store %Closure_sc_0 {i64 (i64)* @sc_0$Int_Int, 100}, ptr %closure_sc_0 + + ; ÄNDRAT ptr %closure_sc_0 istället för i64 (i64)* @sc_0$Int_Int + %4 = call fastcc %List @map$Int_Int_List_List(ptr %closure_sc_0, %List %3) + ; TLit (Ident "Int") + %5 = call fastcc i64 @sum$List_Int(%List %4) + call i32 (ptr, ...) @printf(ptr noundef @.str, i64 noundef %5) + ret i64 0 +} + +define fastcc %List @Cons(i64 %arg_0, %List %arg_1) { + %1 = alloca %List + %2 = getelementptr %List, %List* %1, i64 0, i32 0 + store i8 0, i8* %2 + %3 = bitcast %List* %1 to %Cons* + ; i64 arg_0 1 + %4 = getelementptr %Cons, %Cons* %3, i64 0, i32 1 + ; Just store + store i64 %arg_0, ptr %4 + ; %List arg_1 2 + %5 = getelementptr %Cons, %Cons* %3, i64 0, i32 2 + ; Malloc and store + %6 = call ptr @malloc(i64 24) + store %List %arg_1, ptr %6 + store %List* %6, ptr %5 + ; Return the newly constructed value + %7 = load %List, ptr %1 + ret %List %7 +} + +define fastcc %List @Nil() { + %1 = alloca %List + %2 = getelementptr %List, %List* %1, i64 0, i32 0 + store i8 1, i8* %2 + %3 = bitcast %List* %1 to %Nil* + ; Return the newly constructed value + %4 = load %List, ptr %1 + ret %List %4 +} +

;{8nLcfop0eXQ~5Wm_bf7B8GrE9;xDUu z+R`Ukl&({?nOplSxBKO0&9nUOXVy%O@jHJb@Y{rbqyJ~MdLBer-hE@*?f$dTQF^}p zY?fxn_omtpSS0VN8~tlBU8ACEJi{bcdurD`_18tcb52jw4z}00a?5?4dz6y&=D6S6 z#NRB{{Ay;mL-D)9e#gWwy^9L2JaDTl-7Xvcb^5fPm}8ljYn9@IxAq(jI#eTET5gnf zDl*mmVUuFp#hO)m{!wi%>ES=7b)9S7$Xpki+;=}nFLq}4xea9v>h@1$L|*>aZB?$b zs5zf=3kji;85<7WMy0xU+2C=8X89^WR-REy)eMz1_7htX6KZ($l*#Z%@1^ ziTWv;yieus@x|+%YlEM+u`-hirahk5v)?p+-i^+YxPvJbP| z<+*cq)baGpELsp)USF)WKT>AKKGnK;rqlPEMTt|w_k}wh5Y{;I;dSq_ zo8`rgp(1Tl1uN#?sk{)s%1%y<;lnMlYdqc(N@n-3N9g7I@wk3#&@O)KzkTYnmXja9 z_s=zS{qQBHJZt5Z`EDEc?d^MdWSRVNsnp;z416rde$P=`@p-j=P{jG$dzPNFjz2Ng z?B2;c?%J*#*ZKW6<}VdCo^a+p629}#zUQJ>8>bsMeif8^BHB5pc4v5H_su7@)_*6jP{Ly;!dnUbsxC>8JzRCK1bBZwAUiIfC@5B{tU+H}NdhW#^+pb%# z>$!yc<2fw5ub;QKReFE?*=E7>^he*!1gGk2ymN4uRJ4+p|6Q=Ce0yWeeIvamU!I;n&8^?{y5Iv#tL^!( zwt?%6mQU&PIvzDS-C$e5G~X+qH#e&E2?`07NbOSzyJBTDvmrNaPuPPO%+VVwFWSZ3 zoY}o2E^%Xe>DP!o$8TSFl@t`lV$iVBYxT6+x5w`8NI$vzftU8=ejCQX%|5&QZ;P$< zj_9g(l#tcgu>bc)jfZc}?qIzAWwz>@iLcB}<6M_43@Dw|bX9b|bl9d^`%3AvyL=Ru z2wwNfNaKh}Rc3u1@qJBx{kwZXGOy0;)wS5S=={4b`*|Ms)n^~$_WL|RIEjDBdxm2% zqBEkxJd0nizAk)+bNjW|N9%KM9unVB@;t?-wKnpB)}seGpQ0YmseH~nYu}tH*MAAG zp0aEA{62fD6^FI<-JT|U&+W8*&1J2Nrz=Zpk19RO4v>p`=KDy0(zL+c>n@9Zv@Y*G z+L8CiM&2%>j^hmtzUsYo13PV?#LC1nA2%^Ha@%mxcJkg&&`u|Z#MWI zAk}W$ly|OrVIO}<@&w;gUwL28d}uGrUmlX?K*4{vul zc6naF|6<*D^IO*hF14P#=%8z^@bzPIHmehAjBl>BocEa_=>CM+QVS1!dD5z_{&=c% z)8g3BMMsjN>yG>_TxRt4&na*3@5Rg-3TtCe)wb=iii>2;m)DLe-uLBHgIuqM{{cyj zwRJ^jBUWYR$JOfcE8fGgKf``?GlYQ>xv&j?NQ@R>8&=6JN?iwQ^UrkpD03_P|tDt*_JS~D4y z{Z@tnlS=QMH9Wg1-v4)T`bw`Cj4hu$Bf4t>Ii{V@=GUE{{LwH*?C8rIz43XMcK)fH zy#9=V|LT{Qr2@Apss3{~`lFctw_4N@&J$6A+cg|AJ!|cK4t{uaZ>nB83u|@KgIKq8 z={nbSs*(ra{=R$o@jTIp3#>)9|CrwMD!ftgt6n@^De`Xq-nWPLsr2mWHf^oD{xoob zo77*A%=@+bKd3(2DkBw`S9N-;Zn>DxzsLsl?aS4-|6P06s_Kw)M|Sqb>sGJ$Or2Ky zJbip|a{hw$^vD&`1(SEVzf_Yidc-mJy4H)M0qWti{N*;zTz>!UwK>xiOa2%xcba^y z`NmS?O4m=DZ+Po#PB3@yt6R6c!Q#&Aio;@Rwq_?UY?=N4M~DA}hreTA8+_L8Nba$D z9n3x}!fzD@vN^J>c8h zvGdle>IsT*-T!1u7SG?g(LX_pdDrIJP5%zjuKtlsUt%C0b}i$(iiKH7Tx4l*vKiVNIz09pDZ`q8R^{jXH7=U@;4O7G>32XEAz1@FjThg@Mevhk_pURb*P5in` zCUDBD-Yu&OpI$3Dx#(E7RgqWgoM);V87^j@zra(?k}mdb_ST7+T$itXv|m^2KRKsL zPX3u}T0`Iwtt+nFc`eqf1xwm30!k9uB0~2_cRi@l6=zPBoUR`J#_zm1cl*sRhd-7p zclTVbTxuwx^~YF#ErX@)_UO~;?38$O{*$?M(QpJT|YCF=y{G~E~7f5+lmVE;M){>40Y4|#vz(^uC1 zRl9Fb^68mJ!$p-uR$WwH;$o*0DR!EBy6x6Hi{S-P-V6m9-M@GQVEkyk*BG?)odc`t(1&WUQ8SwiB&gzsL3GW!A&jjedEE z_g{a(>LpOxqf~j$H*DJCGnqW|OWU~ju9?tQa(LlGHN(t4?K0oM*9_~MQ(rLzI0*{XTRerzayvIxqKo& zFVZhe`7%e=d-jaa$4c&RY+S1Lmm}cQ^OgzA&sB43N4j1=^WaoE!>g6u|E2{Cs4ZLi zE4_N6duT~yyg+#6<@U?XQz|zdT9_F9EAnr}cc(up(ow(M8eNwx*`ogURsWaSHVaj5 zWtLSOGW{p)xcr6Hmj87t%NqAAlRJAX?TpgJAN#6*Zrx@b6zuc;!=9G#Wp~fIta*1q zEm+9sh0#ab)%Nm%D{j<0PXF;QQCT9c)VlBYA&;V~6~?F5pD)z%W0p9-aywJkY^kS3 z750CRzJ13Znb5rYn8JRUF7JoOJG4_AP0j~%@3miUwo7`SVExq>r!TG(e#?<*sikYZ zp>(U0dsm=t@cZ3TjWgo^IHs7(6pFBtHrLT{}Ow^;v? zt67gUa{eeDyI%ipTYtBwR`Yq;HIKh8f2J4nGPHkg>$W%v*W3DsUjMoO(etNlzDJ~e z=;C*Q*B=`wCDsW(o^|~FvN!4Pqta#?-^$)CEVXI2!n&VNmD`!8a-G=z?A3)`f%D$` z$VPV`5sfd})Uf{j+34_neN5Bu#g*@?oK}9+OrODerrB{{4$<|MZ!OhlK22J+>G=`+ z0)I;b*G7))r8kNtcCY+lx;2k`^`FEC>9ddC3cqx}Uh_-lX5MC2%m4{;TqG$5nui@=iQBmU;7@{KRCr_`~0(|1m~jXAvL_e*mAs5-n_1P zV-Wtk!81Y6UFE~fz@q5A7ypEFW?k;Or>6CP`t99I%#(cCJpBKL++7xQ-FpA*+V>hK z9!ITcdTuE{kM+b>)0Ec<&)=Acb;R|&JF;+(whixz`I^Go-<>Mw+cTx69RBV0$RO>x z{IALzhrhFKI~uUeSzO!u{OTPuRA$wl*krmObCS5zU+=FkK3N~H(OGg``qnA?^!>Ms z`b;ZN6;(y#vn|*CB4NS2#9%Yagdawa1J}2#ZU4}5=_Tt8$vFM4{#(25SfpRLp(uE- zAo2|CX!bT6MVz>{re9OkbTZCa(T+()TivvZa~wHw>Pd%#Gb+b4M_2qD#+?-lS=NJbH@A8OyYYdxg2xYnd#v?yR%`A~Zuq__ z>ghti`IFUs4Xw=Q_$gyn@A6}=d6j4M5~-YtRhJZJ7j(7mxN_Wk+R953 z*N;7%UHEeQLx6dtP)q!Of19n(1U3P)rds)HnXPQ~1$tSn`ux;6`X?6qaICVMz4T=8{4Tb>n|&8t zUd~VnUfICs&%Ui%;)~<$3mJ*WFDilC*A1x}n`tvN5+JFK?F#V!N-t;Zlv$ zoXVzqA=jgPql`|n?_!r@U9T?PUtY0)$)zfTK+Or_)nyx3e4Oz&-J;{jhnF+#&intk zvuv5qR-V`9{Ts4t`dNxoOx1tMMSU-3TVU?Ra$eK%+~2n3@a)*53%oBrkN=oaapuxJ z0li6g&WGNQc(K*H#{0kKnHG^#ofqEe8LK-jw2NrJcXsuw>a+sy`ZcONNB&p%mE3>- zdfOTAZ&$>o-ngPO@yb^7C>EIxX5kA=A6~6E+kQ?SGP`>Mj?#?P;{@;Iv79 zWc@-_&|+3gYl1?2W0?FL@jjW`kvq3YnYWqMIhx<)I2cnZ&mnj1ZM)m6w?4M#{w=y@ zz_4$o;xiKwoBeEW?v|YAHJtIW?Bd*##k~2ZrZWxs73b`{a3w@rtm-nynafdkUM#(J z%qnSZ>*gD(lFh1Y-R&t8^L!Gj<-RGD=c;S!96Y1FmwgFi=)$zw%y-YT8-?aP6brwV zb+>0)>@?nD+pH-|+~O*}efd<(IenkCLWxr4UkO8g-JmsRw%n*pS-|a~aAUErd%|z& zH&vCLiO08IYba0jvaxqC&QXz!p5D_M;?iSRRjs)~$dvW&zUAK>oGQ($4*j+~eEP{g z9qHfV%KOCgc0VmTHt|nQ0Th-&Y?OeWiz6m)+<0m6{ATt1 zzw@g0|9bVy*f8y^;qh5pS6y>;RC<{3e$}(594X7v(-IyruJG!}Fx+fl$T&kH;-Q9y z%iP9e>%#cHB^_JmAlIOFfoB0%35&sIhJTF)hXWa0WM%fwS*xQH%Xnp($$vg3lbqhO zYu>Dx!zjhKjqhF9vS|!<<>lpy<>KaS>E?`W^<5#24h^eS1rqX7xmh~2v@*T5J(yOg zie6!yDl~W(6~%(-v3$e*bjWI z*NJ}of1}U8I?g;|FiGWX%se~*rS4xLc)d9&NA674e!RvXuv?^+S2JT0xwJ-p(3Rt2jZ zM@zAz+Mnv_yDxoTyW|+BL(AlqFC!*-{1x3ZJ!q2__y1jQ&7U5+e$1men}avTI+(R% z_6qCkXL`RTsNTxl_GZs#E6L?Wbs?V5A{KY8bM%-p_sG_z?$w@BwOU(r=IXONV2ss0 zwI?;=;?~Xwr~g?+xHz7WJH*SnZeeO*>V(IEEq(_NE-n0FQC0HS`lOsYkFl5Pt85u2 zyRey0qdx0Q5L)+V&5z!tL7}_sc5U0pXR$zDI*8*sugOJ;&!U!AR(BW9ulzFeaeLR{ z3rVw&t!L4gzjeDx#A6NZrG{m03qN}wJk!b-{pr5>0ky9@zWP&Zg+EQVcz8`lZg<|P zlSOYH*NQ|QUAg$eG(FDmZL2wtb8M9L{1kZOEY~6NFE>vPt{Au*U6P}sBWKMIa{wPVDt0Cp`CN*>G97xonj>*nK}7*_uNYr)KMBPMGvWXNAlOVH4Grp1YpTtoy;a?p>_+@$W*B%uBWFr)(CP@_*OzrgO=U z7Hr)z`SRyYdd=z;Z;x%bqwG`YQfYKy;*ELM9(J$Jx7|*^UHpVMz3j%x?eisl3NPH9 zaFy@!>{jD-?H>hPf_J1cK8g_1&3@=);p)@hta89??m8YrNd>8WFW#kWyuak*r_Tr8 z7^%JM2vPcUR<(BCmFwF|*cZo%&pHyL#=M(TN=sIEVfDT%GqT-&$` zKaS!;i6YihU85VjnosKOPd?vi3jT%y2&VSE611JFilW zG`_y?u|}%VGTW3_ZgiKwogLBAnqt{gy*I7wy57F-M9J-q*0c7Ctz(!V^Y^UI(fOP^ zSr_pA-Zt^O`Kl$08{S+gDV}Go+I@4QbGDx3qzTo>s;h24&wWta_a$zr;K_L7otZq_ zo*6iX-T9v4&!zQemCNgkhdq5*l9kxj9?(lTAk7~pG$o$%-m8;}D<+uU*wVxN#!LG4 zQO;dzJJn@^j@fBH7W-$k*Y#b8vntmdi4Q?qh0U+nuTC|#?OC{J%hWp$<#TA@GQf#VRx$!ZJV6D0Gxm~r_%LByz zZ~ZCZcT;N>*ZIPb4;NpwoSC=T`#jUa^QPaQFBRoW2zqrnsQ%=H`l~f_ZkKFw4?iON zd5`?e!hhCcCE<^mG}Bn_eyUxP(&t|Hvtz{(TOHY_&+WQiJ-eEkxKH6j?d_T7_iQE= zvHg^(iLTGw|9V~1oMkWam&Lzl`7~EF`Ni>qkMB=ZuDc*LOYD!GKz6H~;r=p{k}2)Q zTn5V4#>YPBzsoh9them!Yy+`VHLPEQL#)lNd@6a}eE-1C9XAc#)EXY{N`3HjW{$~{ zjvuX2Z9BpQ+WAiwSts6IOJP>71i5MY*&^u>i@+(aZa`T!6T=c z!|L*XMBKlYfh~mlid#S{>^ZezKoqZ=vy)@~#&L? znEKP#L^|=j+V15l`|Y1JM?Agz(nG!HM9V3bt`O_9H*z%?8}EGj-Rg9)#?#?R=^n42 z{r+~loMaSqB@}u08wMWe`}kCbB`WDu*7e5$D~dNa-hMOfsP^CYW$XL)Xe-w~|9LMn z>bdNaJ+IZ-EHC9G&7StoG-ks~vTByZ+r;;fpo>l^RB=~-5( zkAM03Sc{~wHrqYOy!+(lOPMUe6wgx=ZH1~ik5x@D<9}X%pR-YcyXRr+r_)Q5rF}T7 zs%q-4I5ci%-DtSt-sab*)K~BRyl2uSomO{e^N2Z#`d(9n47s{P#U}9Zv-|Jf-Y2+f zp`h0JC(Z9!?#ms#=jz_{ZIV)$TB=UbshZ*#r=z)(jz8dGNVct;eR(6F*xu>0#=hw_cMd<#5$rKYPi-szdwY{~;1<5lW&ACSS8VV8 zzOO%X+s`e*5E$wXv8rhePkI=6iOzJDnLH zTPCIQ)JVRy-Vh;Gc)}(9^S|B}qdy-P$2+cc&Mu5t!}#iLTKICd zZ_Dw%zx4Vx>zH3jF=_AQ-=4KHQQm90GuEZL>cwu?U6b$LOPBk$*5&$kxxiI(N;V(j zHxOV-uAi|`zOVD;2iu2^ikTWcL9J5r`x}eTZMO8#VxPrlU!^_U?ZWIBmXAL-H5s^+ zFTElqQyTp5-^}I7S2v&Qh+B7b{q}-|hYn_ba&25cDStv&>CRZn_Yu?k1$*D#<%r(zRrOPu^8xo{woOl7?yQ|yc;n=+f5LnA ztx0;`=F)v_O;n843t`Dw+7mZA8Pq%wuRIyTbXN8Ju7sx|^)GLWvTNB&p%`(W8NyQpmz=k9x<_JLJSfGkji1{`2yv_hxR@*BvIDW8YkVWLe1KTf6tJJ#t4R^Ge^; zERE7jIueIe{r+^k?-yfs-;$+LRbTWy^-}lT$hWuoyf&NOw-#RbYnuG(+D#cDf5If! zS>HF+;Zok9^}uZj!>SJ}??%p9aoN%2Zn>X>+Z5Z&B@JENI`@u0c%Ey=xz9)Dnd~;P zJas)ijmbKd2To64RDE%ZhQrG0yy&c)%blk(lX(=EeN?QtxNEV({^nqZQr9ouj-9?A zq-EGI*Yw9W#IyA;I;(qXy4k{uU$5PG#&Rn!=G5h5&$HC3jOHq^RC*tnYR`P?>thiY zo(2n6)f?$MZtX8KI^gnu+p>po#Ug#Lw>>s;+j99_ZcD#!gx>u3u{rTNp<+)s9)+q) zte7Uh=;QiJG3(=hGgy0w++Fj;Z|#!#LNl7r+!SwR8`YzYDPn@vl$jqN-!j1G?zh~}bS?GPK z&d&bplF&C#6CS55`sh(7vU3`rclGx0Gx=g0l-u_2uvrv1q3+F@3r>HtEi7Jrar+>Z zT{6q=#@mQ<{9m(^eRF>8YEJr?emP*#zRTY?M1Mbr&cK&;}7ka+V`Q@be_Rb|%+ za*B%CY8hJEw*9rv_xl^rY$q%7G`acM-M9T0b9MggIQvBI@@2V|N1seud5~@K@7$Gk zK3;{QW}DCc5jp>c$yjJu0==p@@pL3ax zGd9?7jd*m*|Kg?iE16j=wx1qnwA_x9yppzeau9Qv@OD=fp1jJm4U(&WwNCvOBOdYf zoR;v^2eQWn-EO7`tzZgJi#dCB>8@{gX6kV5EzJ0POw)B^VpO4t?CPtXfeNQKiLo5~ zc_EN-l3l|pgWL<9;ZvXHZ!lY%|JZZMkNG!?H!(Ht39a2aCm`i+*t^`RCH&e6Ei$QR zCrpxHdtQ55;o}mX0<~@5?|)i*LE`xiqXTZP)6CU-wl!^jF4A9k=kT{1RdQ4Mwf?1N zah+~-+;h)SXy<`1%9R%-g*05gRY!hqEmmHvsQqmf%cC7K2OCf3@3|aRzEl173|>3A zeaX!_d1mZa-tG9~So!U_-RGpw@Aj&8Y`1q&VArW!EPW$$!R{A9r#}Y07HHdSu)%IY zc3TAFt|RUTFDw*068kTjS@n$G!m7z?(PwAW=zhJF`f|FbtC;or7-n6Th=+-Mr%pak zduW~H^!(<$j%io=_*_+8=STN4D2n?!J5O}fuMVRNVI z=AQ?4%XH6In>4jtrIn}TWLhg%NhQlVb+Pi*a~H4`UF@p!F8dnmANadfZhQ8(j^wqw z_aFEb`Y}k=_hag&@51-mX%pOXvH2=RB{wp}~u3CBF^t zpYiB9EV;J7xnkDG9Tt@`62Z<+sO9r+wE~A6V{jDe|X@aKw!Y=@0w7 z&ui!hNU(56pJ#kh6Ja!~u4>EMsLuz4D!>0oE56`8QCGi5(Begb*BwuHwx6MA?UfJr z`>G57&32z0Kl4=9#;D({##3j?%@kJr(Xr;jst0*oZcE!z=H0worFHq_)_ymY@?&48 zUB6zND)!@CnErH*bN^hwehHXV_4K01y&%8t+5KPn1aDMN{L8fSdL-98ljIc*ywVve zi`2{WE3&6uJzQn{sC)4*DJO?0%U^NYi}@>5gQq@XoH@0gtIo@BGox|jY1if3=KT8q z=4FzQosHnnx%sNOd2)e9iqfS*e6!vpxIAaxlfz@g^*G;CA(ef}g9$%dr(F_yE!z0y z%F7dB9;fc@IN_BVdp=;f?cD4|cW-x=%-L#lu7!P5`ODmOT8}U5vu!)Gzij$e(XHqE z%S~P|L7lX>ZzrsMYPv&sy_VJk;%HR-0TCxW*ux$H+!YcbUiZ*?%4|G{vj$ zI<;$VkmcvA6_1k^6!N*fd*Ix(`IB@`mzUwO6p4jAy@rC_>v($Z*zYRxJ}9UewDj9$ zk>%p2ikf^nwyay^XQo{L!R1q>_5sVX#gl#FyX-t_zg{tA)iLjSYMH(wtxNHV)w+EC z(qE?zo_)UeS-_WMFFiH(;|Wjs^Tod?I`k>8I~~0zM?{P5_I>R=3pW_N|5I-;*I+jMY8fRW`R0TBhK7tdzOxMehd&)Ww}35CQoLqE$A!Oq{L!n+CB&;% z&bzoH|KGY?jgX6wSHWF zQSpb+H|gw;H%fMURmIn=7hu zw#T#;ccsqc)LY;uY`5X-z5g8{QxDX>S35pmd($P+r4dh#Napw~%WIgzedVF;#+s>% zc&!!T4DcN61SDLB5g~k{QVgs(j*s!9&|#0i-hSN0?|8pgg=%}%`V=W{rN$x?9)SY z%70E&;-BHh-0mJ#eb6lYBip%5W{WD{$#>EUKV`f+=xe2(KU<%xy6Cmyr?ndQxnkel z37Bl-<>$=HIC^8H-BC1 zYjpY3>rJ;eY!2SR!g5;gR$KC66N&yS&vyEW8^4!e&0D^G^YhD`yD~!L8!}AtyFbj! z-?gO6Yh&OWAIINeYtEJ%l$|}t)|1A+;EUM?g+FJ)FXUT2x7b#4^!Lq-IcI7l40y^L z9~Qk@=(5BhB+c-N#Vh|!oo|+iy!o}iKD1MRo#48Yb6z>ReRNYeb^ExiemVd0X7}T= zhPMO_R++IZIs2pGv18yP)o*T2Q-^4(gO(aqsC`!?A> z%ch*Py%ZN@)#p;)9QBgdN&I1a>fWH^hxWCDXpbT9M#EvC$)A-VgftXXK1Q)qv^cuOw zmgY=&#}-tgGojzJh2Od8(JHpN4AWk}uPWLuFCX5Mv@w6tHrcC@KR0}te{OE>Zd2Cv z3fwKCukJpTmfaSsc;=nX9~W1rl7_#EKSZ0uw<**y8xyUCjE~;)DIC>Pm>U0St?s=g6*+fy z7vz1{Gq*Ur|Al7S<&8(8o@hVyGF^US{$D#j^8$zVPVpVpuMhJ~+iUaf#<9s-%Syth z?-EwNy|P9nbJx*L8euF!mph}DI`^A*o&74{Q(=5Z;zQxb-ArGu?%Mfz@AW$-St&2~ ze|hfByY$E`xBdSbewn|0t0K#LfB9mLnpL-4nORPG7KkrRnI1RS_SZon_xC^Y*783L z3aETtEPnW$*Z0&9+G}J@ym~~hdB@-CjJ0F?Q&8vZw%|am0`I(CS3kMc`kpM}Rn0zZ z+xmENSNx{1+*HF}>3z@T6{hb`n6I(niHnY7qLKg$SHUK!!yR+xc($LvTcXC|*(`0o z>(*vF-l?h$A@M8zRk&VNk*QLSSwHDa&YrJ|mv>1d^gn$oswTg>OEqQtCgDe7(UQ?~ z^3u*4m)UIC6P-7A$tlJst#5TqrDjPTyTo)k@TB9M?#MazS3ikJ2`HC+=JKk$bBjqO zGRl$VYvYJL^n#6xUJEUba#z$JG=Qn;a2%O%W~}< zx(|LfTDxpwUv;8W%%KknSLVAH%nB*7l77|1^SyX|)|0*Og#Nm7?(UuVr)OpQ)Exr# zWxrWJ{^jIae#12;<7err_}%+oh}tjt)X8*&RkCnl(WWT}_Vz6IKik9ax~ui?jYUyat#XNs_FLa7n)4tUr zOGEB*@3SeNw$ki|iKO15?f+tn5B-?e_a?`-QEdM*-sA$w{4nk6XPe8SB}`Qo-3;O0 zs>P5{wKGh7nem*Y`Tu@zW}S5Fu|lb&daOW8w_;t3kE&4RE$67Mx0N=|?~eY|cCYGO z(}hQGr*>tgz6rKp_g-Dl@v7AQia_O>;N-|vzMtpr_W$+Vwsq;lzpENfZP1Ht@SbKb za`*Lv`x~co+bz=Q*=Y2eGkU`e-~Q>B@1-SPiqTlrRwdKMA^jvZd+p`fCm9rigHoR6 zE=$>c`R&`z+&B5v#+Tk3M=$>vu3yf7e0{dCKjQ}*p9A`;L2j%^+4wwI&c5*zn?fNqElqJ}CH{YdJ9eNyqD7 zI@4YE1zvRcX{s!elX>h|?X%jC`z4a*mF$_bXl{y=Pg&^u8$DZYq*X49HJGCH-uU=L zbGhf&o7DbArO+zHB% zF*f%LUd;QxVS@R*R@Uj$kN+&U;Q4THwnS6%H~l#d^$+8f_vo`7+Pv}7eC-5F*}Jc# z9D2Y0cipm1ZNck9FBmpR&6Kh5}R9a@XzXk6{VW8|B}j|ZnRhLvJWzGa%9zd`Kc@Vm6gfVnD!M~)|Vt~ zEGK5kr=jz!qwamN@i$#k z*T}Z{kZJz!vXf$db!{u6l5M7kZ+s-YekZ#?R(NWR<-av`=B7zHO|f(RR=S^W%(<=j zPW13RRo7cv%IEG_ab#bkeD>YV2Xod&USrukW7boSN0TB>zNnsX>a5-2`NyZ5-raNb zk0?*}qNUb}OmbV4Hn$wDdN---^b5cJh4ZwStc_Cnt0i3zhA~@bWpuo9@V?=+>U=Wu z_d`+a7gA2$Z+et5^=F*Br9V@?W%1VM!XlnuZ6>s&q`c(imb7~1#&m0!`=ONietU0g z+^Brs`lF|6y1EXBThbz_B{uS+ zxKt$b3B$)+QOEzTdsl1U`(s5($KCUfnRicAJbNK(e|OI@%kbP6r`~bsR%Z9cT5k@! z6Pg&oJ=v-xeuMY(iKp(|-q^Y-oJQwzK}Qc$hzr{g4Oa{)(0>dXl%;Z~OCS-KbgSyZo_(L+RtjqlaHrpZ}m-w14rl zMD>-WYs7{Bv@OrFq`v+rqd z{Sb~*QNFsjUMQ?*$rG>Ve6(lXYmMD@tv5|CY`%5(3X_P4g~#=ewHJyHs-B&^ZdJ$p zPd;qn%2%JBy16mb`u~(U$L?Ea$32;P>@NrB{2J$;e5nG)z3ic>{H@}`mojF~sEjq}1!bLhbd9a!WR=QviS#0&kHw+yKP>W!Y6XKvhx$gkS(bw~DaJ=f&g z?=1UtyA0EA=G>U@nZxl?sJp@!UV}?-FPH8z$YZrHF?zUl$N5*nv$(5vKP*|2_13;$ z`O{uo|9#JvTox`|z3lN6o^8Qu%Q9yy_+YlLLBT5Vz+5AJ+f{R7+YZ}>tm15R(022` zaeT$f+C&HC>%~)iW^S9QaO=$CNw&vsKf0sc7Ikou)LXslDPAkx_b@z}^nC5HrwTvc zs=t~gJojGV9FZ~`jbq_1Vr#riF8$v9$nYA=&nsIqo-ry%C7-{h(tXy$tiCc%WnpTs zd-H31J>8`0@68KdT@7*Ey)NbJf>w{I#~kLI**o7TaPzcxNBIv&3PgPTs;{)xBUSg} z?)n2QJ}w`Q`@_)z_&dBQIPr(H7j+ujBAbLQnwYfef?+p|pF+;IJ+c(!bj zYm4GuS5Ccs*XLW)gNDt^igJ}&cAmC+XYpl{T}q5asLtV;k@b>kS%Uws23p7ek?btr zs@xpELGR@8#~R=Nn5|L!`*5b}lJy5O_eEXWAF*-PLq(Hw-`d{CN%6h?dPC}=mo$6% zEd5=7CjXm#>~})Xb?u~Dsdsa_{cTS#^Hl%$W#^qB#*4be>np#RZO<3HDet~?uRWuT zw{hlsPY+ESHfH_RnX2ZqMMN32r-__7uanlJA$q$%s3C*hcmneUj{WX)qr|4K^mFo% zIs7>z`^^@mPkEEq@@y|w4^G#-7u#;)Mp=Q^m(?5lt>)7%*{+PWM#M6>s*i z<4xD&j|Jr2J)U{EbMAp8i)Wi%8Cy=7E!C>ke$03Ok)_W9kwXHB`EJVVioKeCu>Rhn zvhP>Agv*How_YuK@z|jBsog63&75x4xqAh#vYh!UzhTi8O3) zkIvpsTcuvE5As$}VV+Y_73NU!;|@#voWofk)|7B%`u<4^ z-sbNTW!Zars;c9MN%kUnLVZ6jim%r#;+Q1cksB_ndnuBA=FEe4FL|aioqRLDJPBx6d7$>c@Te*ynkz z0fslljefp1a`fQ%yqE8Y*XEUZtr1`AG*dUHUoX$hwAge#rc8;!>-(}x$CFfLt{j?g z6VrA;=j`(0gYN?uKeU|TVEazsa^y3|rXMFBE||Z{eQM_9vd$x$wAo@E-zkLfuU+zC zd-JsVSJBI!RcCB=Uv=jXYy#L&grOW7eQqSjY zcJZFOtwPzizBgUl+%oBe-@025;|!d53>G?w?a0tK%@>TDw}0msW+yqz)H8oAGyhKf z!NIPQ)f=m?I!m_SDCEaMACaY5mqdg$kH=ejo0|L+^~sK{UO6f5OL0Tn=GILzlkUH7 z*&mTKONcRlrRi_~S&HBGS?|5yKl`@4j_h0(XC1lh-M@HNhufVKoq0#_oq7h}Wz$5_ z)ekCtBVIaPZhaCFRaw!?^=eV@vWSPvyjLwbFkSUm)cx)4X?v^X`E|X{ac*C}bzT)F+Kjqi6d`~@kyV9uNUwAa3#^Vb;WYE_Kzmj%8Rs_Ck0H7Nbsqx->e#b z#@T~q@uS8K$7LQb-TziEI_gg8V!s%>d-oOoyOg=_dg=Uq%2xRsiz6+g=Wn%cw{}c$ zOA!-GO}{99J>7Piic?YDp~DHCZ=zk-zc7{f_oB_adtYP3+3CICW9{$lI_tN5V#YJq zpPifawy&Ge=UW!ItLO5%uBASo+qq{cHO0vDuQFXeb#c8oACuDG^Gy#jJak`PfAQys z?~8J7UuUbF#bQB=jrQMt|MT6Pgz8i0%_gbNmbtCj^l3%T>l*txiSpg?FO2s02fYqc zyMCwdvi)K8ZF)&ot2EE0-gvxytIeABT$lLWcZx5ZUUN|X4UcZ}jAYjUCx?5FHXLbg z7qFl3K~8vC>5h7?CLtqLQ+5rriLxax&18NzRk*D+jGVIdgV>K{HoNS0q}XLx1umC3 z^txlaf!Qldjoyl@@_SoS@Bi$s5oTfXW%DU&b$_h6yr znO|89+gD$8E)3dnbKARaj|PF&4?)d4~$0jJex>WCYmi@ct=*rJAUWsWt_~q73Em2FB@j4>Zdd%fXQ1wYYW7i_y zmUZviJd1Q1o@iI`$8KCvmgOb?pm}LF@7nFTjn&BkmmTiyczWf5jG)j~<=i9v*$QU0 zHS4PMKTbUOjqAlD26^|&qaHrpuiSK%7VHUbXv_%MQ?l*)b$-K-C(j+I|E#&R!Kv%H z)ODf5#itd#Gygt0WdES)=Bsn*VvlpGOSJgfSM?t--RwA3yYt1fH@|Y&u4`m+I!=*$ z`tOFk-J1Wm4ON+wd0VVyp0075b}Oo3!rm<9-%r0d)?JM4vm; zmhV9Uwk1x-*8Y4e`uj1ff{cz{)B2#Jl6$_hyPhul-nPBxyO0FWOymvd^_bZ+G6cI5iuB~hw5 zzMpo~=F}E5Yp*FU@hK3<GA( zoAxZwlRf!l0&mFf`R~joPh6>{`Ad`c&*SF>-dS&^|5Ca3ws$hi-~3yT12mm3TG>{G zduJZc&MowL*d>&%H8E;;&HjWEBlWQKOWNuI(H~3d%t{IclZ*4+(pK2|OD+`F+?gty zoVVfc>$i6LMZa2g^!|isg!kAV;7bi+n$2Jw`TqG6(Suw|yDc<#aq3UHyIpSn*2gZI|W{Of-CLg*4M z)dv@qH!@nypZh z6T=Tq9_7#Y4ZUjSTXeqcI(*-8wpf@A>mTW_Q$ISl=5cGT)n9)rth#|(T|MW*>7fRCSSeRkiX?u|CLQybv)@; zj=jDyoA(5NRLxb9x!>-rNcedBdV)pf{+suFzBF7c^_o6G;MvE=O#KD5FXV3@bvzmu z>TarS~Yq6ts;-O0P8Si-x0!^^H;BJnI*Vz#nT<;oIM4(_%w{PT8Z72nn) zhgy`bOcdC2ep~fBDc`^4Gjr6JURP!NJ8$wjt&lX=B0VAh{b{l@I`7@Kf3oq-oW(a< zmtHT8Q$2F_Xr+7lM9J5#Nzw{Pka2 z%p&E)(&w+me6KC|9{=;18y71l%b$mzG7MAfzxwe0XDQtK z;nyFd#dE~ZOpTAyn#r>&*)Y@j(86u;LCbQP4{wffb zgQw5WUvhuhljp4a4@oXuZ1RO=io&#a=aTeGg0A}g(=nS~z~#$(%j%~t8|%WQYfJVy z@6uYln?G#dU)3_7Db2!jq#JH{EnPnMa2SW&yx%X{Op?VNt5&CZm%LvjuYRIn>oNUh z7EQhaddnT>M5u@0bq|mPWj(;2OPg^v1wyS2lv-Irz{J&S7 zZ(E*yc=>0Oaf*6p!Rw%3deJBTsJ730zpwwUbi~9ny;~O^4S65YWp~73vE%v+|KEsx znPO3RbHSzuzg7wxr~4i7@8@WL_x7{+_lO6w5t;!HPG!IO8!@wH1IMGN&i@8n$rs&g z6YjQ2{yrYd@HAtghy8q2$9Y9jS-bz4aO%!rW%}N+dEeLK?d^B&dNx{rVOg%A9rIZy zBT1BePaZZ8XXi+m#S;cji%3fvaA2=i@Cl6s^;G%MdhGCHL+2|Ct95 z^IGf``OFpc;A{s=S8q*uNpf?{&H1+~ZM3$m*?mOi>a}=&@uQg@728+6J$I*iS&I4d zu9YG4C*56l@Y`j!XEl#S-fd=m8W7f{zQ1YbvblA!e>mQ}7Y*d&vA^<4Q&mAw{qgbo z`Np3fUYXHZcYv?UqG)0Ltz)6-d(?}SCW**YSs8SG{`2ifs?&7qEw`>@?GB#H{e2nd zWwRe`5wlV^Y^vx_c)BCM!sd02nu`05<@3MnS-f@2#M%EfzIvs_t@+PAajJmX=QH0X&olF^2ybaujF{r|;^v{nERGRA+Iwd-&A9eZYTq1t zv5#U&JM6ATeBe3p=auaAz;y{FHPS}|BOc2A=`B6?@7%56Pt{!ykE-7fU|90Ofxo3C zHMLLW(49GJd+yx#?`}F4IcLqraN#Xe*VU}s;Phv56yrwOqq?hWC;RQzog8}c$lXWh zR(S7SmA_UiK}6`xW8UzG8fmX9I9w}V@SiJc&guWav#4*LtL`rQZ2R!|&Yao0yDB#R z+Y>qOO^}WB=gwm$`z=i>SbNr<`&Qe(O42Fgq@ILpW}M6Cs@Rn`Z@kVc`nH?r`orDk zr&?GfmjCFU8m{x+^wG)(v*adR-Rs$>`Rs7W=}i&JXT_?0c08PAf4Tl8^Gp4%=$De` z>zYch{_B~sR{8hM2i|AOOFqk+w&-ZcW$A5+Y1TedvqZ$zbYHB}HYd@Nf2>i@#UI&O z*qqm#Zn@9#6_ah|3cI)?XRXSoui>{TWT_M^(S6af;oU z^{&}=*M+3@rUt#3#5_~l)!92h%wdz@_p;ZUmx!E>e!YA1yw`on@`pLMbzE6j8DPoZ zzV>?g7T;yNo~)Tr74$8@f{A76yd_Tq`V2$DpU>X@epaiA=iR?|(nK=%>qy&?MvC^OkN>nf-X;(t?SvMY&FCJ~lo*&659Wg#N-1 zy_M-b3%fU3uS?!k{#<(5gGoHSYu~@^z1wn6b5G3K`1|5pbJp-UO_iB$sO9vjtnA8b zk)A6jKO5-$*?%j0;Q}wN1kKv?7NO=3fp=85-P-%;@6#p9n)BZ|zRugFI=(hj8(hY`_T-c1BMcO0Y&T!iI^#>DNv{!!G=I5e)=SqxM z@RK)6Gc4DodA%&?mp`7XSgqvM&1UqwH7Gw=w)x6prQ`ooy=CvL%;iulygNhEtL%i( z;qvY2jqG=NOv@*CG-no0S5yeyTz_iw?(IVVOAIQG&)g>P?Y*If(bu?}YqA=hmYS~J ze3jcWu3bcPu6W4BmGKKEIoJoS{b$R1^y(tvlw~5mRVx-)sDk^-)H9cI{cu8Jq`tF0N`)EcB_FSaaaodbUmr>8sivu?C6@aNiUwv6l1L7kY4Wj0C6xHT=OY*q8k z-cjd!{<-;d^ESgr$3GW2u-9?R+gerqd-3<0>%-$tJ0@9Pep#ixukPFSu0*xD2kyV$ zZan3ozi--ncj>pr+}F5xpKJfv{d(26tOa-b+SA+X6`s4?cMVY7ss391X(>~-aAA*r zk63o<8I{=ICz^h#r|+--xG3M?PtUcFg11_^3%4I=67_xhb46d||CRIaUvB@j`0Cup z_j10jnYnJl=To2jli0r*-(YbPW}koA=JlHA!aE{LA4so?{8{RK?!bm8ySB};3jHLk zJ>~1Ro%eNr?evUw-sAOA?fSL~UjOg|HX;XR&(2um8~pj{#$RY-gxRaZ_D!M~j{7;I9RZ)7UQR$G`f%?(-X&PuKKCKCZs-Dr$D_+cLjL zLWd{6dw*_bQR~tJTPtMFKNAr)X#C0emG!FUgjR;Hf^x}S3H#l`W(e3BHnBG|+|?7< zE|wlJZwGr0w|>TlBZ|)$Q|>s_{Fm&`ZEw2hBQKmJ9F=YSF?jO*S`R+k;HIyVpZm*= zHwLC1n-b~p@3PpBX^lTVo4x2f{$^3r!_Nv&t6p7yxKZP3!=hg4=2wfJ{byEDWsJkJ zJ=Toi_ERsz*1h$D-hGPd$({*-m}@p#joz|`uZ<3GInoO>GfcJ)15t=g(FViW<7E4%(+8q z3>T(Mypa6-Q4;fpjRi_U!QM>`&l0TD)isL^0vHx>Z(+({ie-2s!@y@|R_2n`uw-+$ z`H6GK#CR5LUh-d^<3gdq_D#iGm>Emv$j-5Sqm#?%Bqt}AB$xM2N1RitQcgU$s`4x@606+5FXZbULod85~wvDEP$CbfCU7vU!dy;Q20pr|=Em z2l`SOnGe6Ne>sEU!T%_}XaBeA{LB7p&i(1v_M=TF&hc&7w3&rjr@^euuVc;sOTPC` z-jY1<`Td5eyHD2#)pPFr`;>jb@70R72e>l+iobpLU_sJ54weg^R@S?AG&d?VY}za; z@PuVTLD>c-kLt!ozc7c@{}-HThk#I@$gDrKiEa z?>zrJy{#jyqHkK>WH32cFKWsj`Pck|f7IDK@9vv_k=OdaQf8yWw zI{!cZw^UcSz@5>#W6y&eO^IKYdoB0qIPA*UCDT?|b;)OTVdLM+k6gYlRcyPvVC~eG z_beawiY4w-H#&JmocrP0&AvZpt8sm1QTTN5Mukr0l8;OeAD5phn%(f~Yx>uw<-0s4 zb7#mhxqFMgIK3jf;Mu974N`|K!pq)yZf(l$G-%VQUK5#FEzk4I?a`$>b0_QUHPlU; zcF@|WpnW4(?Jcu49}YQvDXf+>QnF9s{yAyZfh*fKyy-q2*W&o^+}uj*cPF*nH5Mx$ z*>HLF&KLWb^S5Z%t&Q7uVqeR&JX7mO-14<8miNEg>`hHrvA|nw)+?W>VJ(TjpK*kA zZYw=?{psU`Zl6UadKFVEj@d4EpHbB`b4P4*@0uOorg8Dtte*Gm5Q8&kQr}72xhAVp zw`KIX&AOhx__BwdX5GT0?>Q|$i@eRd{b0%0u4%d|VZZk}*iN3d{VM;t*UM@pdpW}E z=O~mMzP&`I#hCk1x5*9TpRN*496c$Mop&8Fzd7%t_LC>vYu9JYt4)3=lDl}u{gj-P zs%_a{MGu|0wrBCWIUf!kF0)SZ>rk-G3DlK;(VlisSxUugTJfWARyWe)Z$H%+mN>hp z!0X05UX6`~6VIzf@b3M~B_Y4ow9{%&f&;S`rEh2V-kK^k0&k6p-+2eotQB^_mSF?pX`>B#Bhi zX?AXCySVjte9EoUlegVXbQbCHUGH^7@0H!x+Sy!5hYvPi7{a-54KTdCBd9P}>&Xis<(OzyDqElw8#CYMM#;+!O4n_OBkC zk=`tQGv8h5T>pLLT_sa2Cs|w;w4Nk$IWyNcN3i(Zwq2o1g1Sz>wz1FnKSk@sm(Q21 z6lec9{N>3aeRUg7KY`pSZ`;qmkg}ORNpanb2?3@z=bTvhCu@1)EZx!t@||tk$tyM= z4*x5y-}m*(l|4GXMeS!#t|?_Y-jrdKxU#9NZBwMz8lixrZ{{Ywoql}RwR7Un!Z_oE zY?q(?x^eT)rpM{~^{1a*9=lMO`_Sr-g2%jKf6qve86srzY25 z2Mjq&lUu@$vz06tFP?foyk0YE>c_YDc+=JeD9hdYwwhyt_*(Yb<{p;(FSg7V&zdk~ zCRr(8l=^VByJr8))2i&fx_jdyroCP?MLoDuB=pTuzZH(`YI3ac-p8K)Stn>|UXmqU z$a63Gu)^cU%hid0Vx=C18@_cZ+;!KtLG1}g&_3qKJ@7*EzVAVq!=7cC zpSJo(XI`G(Y;CP*AUSRRp=CAuX<=d`h5z;kjQy#0-d#h|c_j~=Pd)p(LU;Q~A zcQ#Qa-S6FU$G*3_qf-2mKC=Be;BOaK5V7Z1;Cp$YgV)*OZ`lQ#&gV%NUM*K?fA8UI z!O)-;$F9Xny?g$t@^ERu23fJ`FI0podLtG-HxzluE>$tbq~B6IhCkGAd7#6E>}>-@M9)~cG{6C!@ODBL#tNZSLQ zcZC_O=Ci&`Y)U#Z>HVYfOH&yGmr>d#hU6I*6U$S^o&HN|&UWSim%PeOyQx+HBm6UsQ z{kMS3@J$M9Le43+O<#WHbm!JHVb=jg6C!9Z6M>)@i-*^@sW%yjizx zJtueI-n0X+lGj^!#phV`zUDT`x61jT^TWt|V^ZYr>=n=ZLwCK__x-kZM*y$)-!{7+ zrBb~2IDXy4tBFry4{UOux^0JMioW8(D7XFTv%DMa({khM z`?@WUmQ3tUp13PG(04&$(6znxQw#M!guRc}*|gx}iH$SLMDG9DOj_g%R2b_Kc1?|wwjds33I?#?}tOF`>?N~M=x zGW^WR$aVL8<+;rq7p>Tr#!g8tT9~J#^^77%u z)f{{gCCo|oTXJ8pf8d)i{mhq;6<izc^dXI^V`6C%5i4*74nB` z&*c<|J-YSQ^1`F=_>`YtjF{a%i$?05w5~Wjn`hSYFB(<>@ssj1UqmXu`Yd`T{;j%v z&6jy{p$*e`jJ=uyNF#Jey8$>okp?bfHMo;(eRu*E3vH^v#?ba9Ck+;^q33TP}0bW$x^V zI?7hRZ2ra2#_*#P<~-hJDH`!`yE9wA?T)*9IlNc! zY%17YT6_55rIcK@C0+?Hr`?;dV!8~=jexcj{X3YpE$(?!)2Lj`Z`*PA^_ndjH|kE- z{jy;n***5#?Be{eT|#KmwDr51t^X~UvFxk-$0y-#ciuYr&-9L-e)ww; z57z>ZttMIu*H?U;Wbwd8sOiu~8=hj%RRE(|vxT|-^C);45rfF<94ojVw zX6MsA^Z2}%+n-)HN)9;M_iOe3+-I6k%mSk~HO{))zDa1w58-=Nat2C`MsqHT{4uXH zuuC>rBGa+E)_d{X1DhY%|6n}&=#iIxuF0~mvm_U?>Y5xbV(H+o39<_nY{?J(uuo^w z2DN}kjg>MoDlb~!ci&=jSk5>nz~kgZ(MvyH|6Ltxpyk5HGgJQepVq*Fk}Ym)t%~=3 zJ#_5D(+C!h*hv;eQTduj6D)rxaB|*^_O-2E?Qvy|h_aJ?JKuX+}6Sdi8~TR{8KO`Pgy01jqG{e2>ONJz4XvbMIM^k7t%DS{qsD-?`ELqE*A?U+^>s z(XR`8%qNy^lQJ~;a^Y@~wB~Cwne$!08CN$e-+ghUkNvRE2bVi*>)s0;`m}vtlxFps zz7@s~Pi_}j5$;}i?rw$m!#4u641Sj?s%f7&nfpjMu+8qH&@E}Xra99Vzxq(H^VO0% zx&P*+x%*$rmi&D4X77~OCAPaN1a2>rTgJYma;8XS+w=rY=e!RRd!A~X{CHfV>#OkH zcb)}lKD!vN_U+U<_gipX&?33$2T!M%n}*eYJ;1+^EB9d9vD%Gh2i?E!R^&?hl_W~^VTRQXuFaG6freeQ*7I$7Hc6Ibp?4bQG$ z)z_H+x1%m5_*UuUtL%ro{Gaa9vF$q5qg&}9BfG2o14Gx;%aUo+O5-B9|FE`hGA#GJ zpd_O+_vYzsQ9{=C=2}6D3lH97|9iu@DVHxg@A1=|#iaq!Z~gdGY^S~0E&jPgcvtN@ z(~8!_V>k2@YG)>H2$XrQ&99o~ax0SeHV+ef!~8szRnFQf-3PjUFp{oUH> zFIaQ8t1h|d)m@u$Gx&kHq#sMLjCzur%TuF^UIK@dwg!8bJy;?TY``%^ol7ik=XV>= z<*!t?)E=$7ua&UKDQ?rrotbSvj*4B`RNNyOUFRdwRr@QhYr~2B#zKod8+LF!IK9Q< zTAoen8u`DrCpU|+_HH}ZR4yf>TQ2_VEAsN9md%q&o+*F7BUJ2S=|;sA!(W}=84v51JXq&ZcId%m z-jp5lTC?NKw)Jj#8b67(dA*VCt?60yS6r)ZCMEw8s4aLN<;{loS1uQ^UzZlHEO3l_EPL?hrZb&VaN#W%vcB+7Q(7XeJMYoN8{w+1hmL-dvC_U1ursPH zWKEx*)8{|Q^49H%NADR{KGT@8e{n72;nIaC0~fAUyH?Lys`QNe+>3QREAkV~=ltV3 zsds>}UjN6;;x`U|m7|isn(dvCrmd8&KWBBV)s^qUWnrG?dRa9N3o`Dk(ET3vry!-) z;97E~a&gDcyUhGApDMVXwie6LGL)M8Nd2eP?WmO;!mjJoZ!+$lHjRCu{LQWPS8{lh z*;np4*_|XHs#*SwnT&+qM|5VV;y5S$Y zbNj-B&z5G`hoxFqosP5HR2}hT@1=uZsyBXI-_d`3UDB(#NA7d)X2g{%2833W=04ha zS%>S7&9arHn~%QVwT>a#|8c*JxM_eDw|idY?bKa&ojy*l3|5a@?pkJHUaObS*k^o( z{X$*$ca`s3m4g<0pF1PHr{+qr&fYDSZW79dM+1H?o?@%^yE5|YIpwb&8gmGBC`u6IZqv5y-PzSNym8R zRGS?!Cd(&hmPczupY7jW$IO-@u_dL0%`HSc{eIz0^$#)%CTH_BpKVJ!F0rsX+T+UJ zQ2q7uO$*OBS){I?cHyz$@dLd3d?)JP|9qkQ|2Cb3*>aOwawmG*gnzhfJ$G8!W|cJFT)j<;VLjVp5;X6|WZ-R0%z7*nbd`_1lb{^G*vzu!8|vj~{5c;?w3 zo2=%CSJv3DhqzB`OZjj(Im@(Q(T{_1TRLYSe3-|6Yg7F68Lb;u{8)U#z31I&&AvKK z2Tu02N4$9cnJqlUG_iHXdF`oQUYrFb%*)F~0*n=Br`{`^w7_kB-N8R|zJKjJ>*W3; zZ-Vme_h*HBO;w~1%#*7=I9Q9c0g2Vrl#J@En%Cy(bTFp6xA&?q4D3a{H~(-Idw?MKWOvjWZp#=IOrqJ~ygX zwsv{p#ZdiQ6Qgd}_UB%o%YCMiPpq|8aK*tnmeEJvhZ!3G4q{k6FY)8L1)aB2)x2ge z_WwQmO2>q|AzGVHbUEMmY?piguTwhs(cWL*)qnks)86eWIDN*)!WF_Ut9lf#&M1Gw z=eH|Ybhi;#$8v7H9CqfKq?E!YNqgBRFJB#Py^(g8cSZ5ToaO6uALuxqE!fbIKQZIm z?;9KMzyH|&VCg+M=YqDpPm^|@=QzLiA(N`|B<`&yOr^gzM0v5VzE>4E%iy@hmmP)V%6R?i<5%{-N)dZdIP2jnjqtkx7VJmw z+>Us;H2k!Wg+qKqh>Y1E)r7qt-rkYfr`|fFOnXoBr^D__JT=ZiyVf3=BF(od*JUlI zL8nm3oYS{d^>@_YW9nHo_pix^Ub(F&ezmSTbC#`pj*OG^bsd#~?b=hGdY|ZDo~tSNxH9(C-<`#5&CmA#-{|J*$ztQ}?|(QX z*>OrtGuQi{OXgk-XW87gZ*`KeS;WJCRhqA*X1w!0uy?(1>Z3I;e`fDl_;JY-zY3>A zNz(J9UFOJH_lP@8d*8HB^?RDY)t~IydlmI7`&M2tjpvC?jPdzt;~|(|%V|^X#$GMp z)5;@YZMXSex++gz-tCjimVeQh(V4T%WB%fWtA$&{Ds1g5ibKn{-VW=jX?Boq-0Ax% zK$t(jeUnCAIFst^hMOgad3OJgVZSkVfBB7I-45l>11AKYOq*fP{+aK;{g&C+1LqlOoVooy&7~~FbjRtn&g?HI%!vK#I8pWQhjSmgFWVT{ZoM=o zVb7W;Cp(U~*{W*G*}M1Xm(BE8yd*HVaKRMg`j{>kizUiO*&1fPv(#Dic$U`P;2$+F z+tM}D^45mwtM@2=ZN8S%^!?5Q<0(u3J=^8`e9A2Yfv#^7 zuE)Kjouyf;m+aL~KlkkV%?Ee;Zpn(-v|pXMb;ex*`TI}3mMmCSc<%I!Q&Jng@4dgf zWQS$J^S6cjH*TwDH1>1^yl>E%riL9-kVoP1oLh&}GgwiTVp~pKh$)z~terKg}&Uxj*sb zhRg1|-(6kqbIe)EriO{}2WNZzl)6d(-{VK=^jb1 zaIqA&eYViu_qdtnLfft4y}WLJgY{XHMbkh1J$d7I+>Zk@d<7T3oV>m(-uvkhuP=|6 zP7O=6cxizb;tjN=&XSX@J^6j4=v42O7jbQET-W>OO^}MX2xvGZ_KWE&h`J7d%W>>}5 zH5_rl%PS&}vVMF}?&IG*d412;z>SNtjC*WPvCrJL+%{@^{qMf|BX3#je?IK|W_*b6 zmA~-mCn7tv*M2yw5v=2Wggau(WmysF^+9x#DT_`T>)Ww)6-S(Ao2x9pf5ViM3mydq_r2F_xKwYOw!BT~ zo}uS?t8D%y6Kl@2v$1#b6LPGqOJo{#TyR_)8`^BQ~AHw3?Q}P^jo%UNj+8}bL z)VOlqeqopd`z+0KS$Aj0OL`lBGMeF|+cWE@dY-}88#+?SQ;tSV ztmK<=@L(|Gm46=7&Rw4v^;yT_&35(XisRy7xPofLK2)yxgssX!c6wG$;>K=(7E0?&2{h5k0*9>OqJGEP^)H&cn zFGa4f?L?GXN&c?VwK2z@t-KJN`le@JxcUD#KED$(pZ0WQ+l$#A?p_R7UeXK^LJ()jIfim zo}yiRM``lCuUlLj1PYf3Pum)Cx%o%jyeqdI{95k(@)p>aqI*CpaPRc3VdtU}=U@Mv zz|r1oR=an`N{%ar3pYwH74yD+a8KgHKT;D`z0vZ^`=9>r(&YEg)~G)Zj6AcnTy#&C z=Y+m5?w|JV;7U#?-@SqRUZVAq&(1Q(-9we5TG^KAlktbAte;x*WnDt0Sl^l|mP21{A`bal{B|kmyWdk@IB(^x?W+oQaj#CO zC~15Bf8&nCeg9+wf4|dR=dKxHl{()=`Lwh3q{?Zw5=FhM|7Wjyuv+Zxi5Fo)Yh@Zv zSQvJiPg>OLbHjJjSD91pzjv0My1C8i)$u=Dm@;M>Ca*csqq6-?&Zo^bf~#&-&sg*7 zZL~b&-=!ZN>dsxsE>@Xz;K;{+Q-5=Z|6JbrT%jVE$>q_e0=upQ)+fBL^Q(yNQnUUu zzh!#5?;EDAEVI6M9zPtn=ib|JeO`g`2~ydYms+cdF1dY@ZTHIVz|xrv(X-rdZhrJt z8+vY9oUFlF)v-)g~;qga26VK(&T^gzDv-6wz}vwqDcD@%R$S}WdV>+8A}Uz0xIcu0HlC8;az_taAK z<_8L2%-;6ROa14A)N2}3yr2GI;?TUzI<-{1EHd`mTRXw@L!wL9mf5#lJ)+7c>+UzH z!t7LXJeybA($H_8p3Qo_R%Ks}@{S*m{MydOm-6ecJ~4gbrD-b<-lS)v7~RQT#?T5 zSg%u|0{mgeoIW~wmo{W=GKe>`uM$PRA?r(z{=s5mV*X?fZCM|CUef$6LXiQ`wcc?jLL6 z*l_4+%-;)DXV&Fj`E`AY&df_mlh5wEA;^iW3x@jh__CF7nrb1iSs+-FcC(pn2Kg+s9T9xNJ=e-j}tb2+NYbb7y^vRtm zxV2`n;!2k-r*k&&NFQ2g*T-cp?xl21d;U6;tAf2opOi%MxA&diS7o-Rq%_QDg6>x- zA6xx7{`I#SQm<^>`{S?32gl{lj2Jmm*ZW!W`~57<*u^Zq?q-gng+HIDn_K{=@m-re zrT_lP-Cxwx$}zcQNz%~+%9jp)aa^pm?BTq*Z^NS(yZm%wZd=Iq-y!5cNkv#gaaQlk zo_!T=%2V|37e6+h`7k%)dhB*rJ-$$-h@;Zk4=?UJ7~Hp~b@mKXiPD>%@lUH3Fj@ao znC0k@T|C)Ze{{fJ9m8w)jn(Tcbic{^Pl3rKaGxwb1%9T z3ry*}J%9a?*n965^X+Ckb#~J3yPt0;Mm}~*o<8+tl!M?YVY{hmeRF^CpBIw9lEfy zva*A#*nUIZu_owu=@_{?hkqiCdp! zWGyl=Uba+gncgMYmwf(?y5U9pbI;ncl-4$I9-pdMB6CS~lB*?$&1Ko`skeBoTqHL< z`B2g$a_QYNjpUbUyA)SnJ1o5I+6|?)4bMNG=-et?srjz=q{xLopATC0^T#G{x4&-n z`Pav&n~$O|F0ym>6%I+}b1if_8`b@s^X8NQhNy&g{r!{P{QTtLe{F+RnvY&)iR6hJ zZ?cZb9LrUawal)1fS^k8vnj6!s{}%6(Wz2Usp@5jL7@TPU^kg z<*U0&L#;hJ>1gk+;A80;sqOD&HvV_Bd&vH$@Q7vzt9rtoXT&Gt1qDK0jXz70ul2+4ZmS zsNst*SKXhxpE+%`VE2>$4PVx;Wmj20uU$Fg`4LUk)!J#*=PZH*7FHad`hMBrCDQLK z-)iNTWcPn~eDb=~{9BvfPkSqJr$l{oWSHeu-)*^b_;XE}cgX~Q56E0z$!@s*g7U}f zB@gX{9_@@Vyt(StvEFYB)Ml>q;p+~Fy`FsgqF|`T^PthjHczh7caoPMe8#q34xpU&^AH}Dqo z6EIa2_@AQi`|0#OPmi@1SoNl`p46O_zD>%@+Hd`}i<4vT@S99uSzB#h)oeVy&*;Gc zX;Zz`4u=CbUv}ML?%~bk5%#dSa^q7rZl?#bZ|YxjWbkikXup)*_9ou%?UH5RogX`y z?pW0J_<{C)OZ}DAe{x0N)h_*UE8DN#pt1aCF-}uhkBOF^lpXYErQIa<`vfKZ! z+|f^a9xv6)`SLdNh4G=dINzM9a3orIy6xfrtXt~ktyz{Qf6-2!b?(1=P5P^{o6ebUw(of$ ztDbV8|Ng;K>-ruhs#zFD^;B->`Xf@fbp9!`g^7B?(mOsH8mk3em)ZRyUG8*twT2%r z@6ni_`SaiM|6aR7Y4OX4Sry50izdqY++OJ2?On6_%CxBrMb1f^p0j)S-t-Q-C9rLE zNz2yDpW93vXSAydMEA3ZSu?NrX*A)p*`?$_`};;m^}jy3rv3Gy^wi+gi+n5BePK+w zJ3Ex;@UHF~=lIvJ;FdpMIls5&D(k8e@50;9XZ20kFB85h!*Au31KR>w`NNJHKiMf! z{G)nd?3dr`&3G%Obuy)HxXw1M?pOQS&e%Kq7r%+UyRXFS%6ylW%IO-H42*VO60DWu zPt9GukwJSF&ur})t+cd#wSZScwe0rUmF`w!b zzvp4RA7WYsS_MAs=Q;Ri?~kcRKmFU-_%@-YVN1bD#kkaE?w#+yr|;AF{B1dqwZM1HlwC*fOPyPIr{rZ= z`sZy++1@ogxtDTF=;m_UWIMeblXyP7R)2klZS$EEy-U{wJ*t+-Y3>S|@L=b$A9Q&1Sshv#Qyn z?}r4u4z{&>Jr_zle9a^)zBK5@CGqUay9N@wM7MHQYecv{SRG>*TvInw+0Ac>@fC%Q zZhcBR2jn+f?m6aAHm8-@H&5l_6svB{4Qz$aL|aqjN`MM!#L?ig}C?>m8ew- ziL0|awF+D|KCO8ga%Xq#1?3%G=bh}hu2k{t-WRR**>;o4Uf101dnD#cXVip!xu7o? zmMFI3*cAQ52PT`g3-=j%wN0D%v03`W@4W(xtma7Vx6rUkol*E{?j?rP`W^R~bq-n| zOTJm>xHF1H_;J+3KNUAJx1Y~?sjv8CO}OlGj-)s?frZol%rmtJ?_#cAb5eX?lI$a~ zY5GRzH6QQbx>&Yo{qv`*ELSAG_Pg@o!2g~F2}x05=PfR`?B6A7TI5`IYJE(Y#xARH z70YAN!V~)T_O|mk8%R5uG+z35Z*JkLLoZgf1~w(GS#@Edw8@g7ty&Q#JIzihsx^l^ zW;Pa^93>}NP;s?lzv9#2>CCC?>|=iX4l8SW8{Bi^KV#b_->+P$c`3yuMX8CoAXa`- z7MFW2e7H`}%W0Hgkt6lP{t7SU|nu(x^nX*DH%D$-(Ebm)uLA(pl>H5MbG|1#T)3!nX3 ze(TDOli%uhEmkb}xjr@dNBrp*`>)k+_LKX+?ZpBKNlqV~-dK(vpR>Ae7rgl2ZtiJq zT+OttzTG!Q_TS`R>=QoQ|KQO0_i)0b14pjBnV%IdEp6!>9n8d)SRKtCE*`AT6j?1C ztZvPuS{?1Y`+tb!t*BcS|NdY5o8P*m`=PxJ$E}(F56c|h?>y~X(lohcYFyLw{s-iy zWqjs${ol2E_P=VqP0Q4#t=snBF8>$5{C}S-NA8_F_PKujpXI&vu^#&BN=sB0y8Vr3 z{G+X#m7bHIl$q|g;LRug>1}>$|9SstuT9AKng8_<`w2qdNEG_y3u%-?)16tmB$em3PcxYE`RX!PorvYt0rt-O$?k z@1p6oX0EVCYo2#G3k2WaySna)v-ZTqJ(_1uUMb;8YdyGP-`bNNRwuXI z)a{HmimhHHxx~FY6Dr?vm6BxbRH9JM@bpU&vC;8!L=&f8N)kVbE!H)M3>>oBd&B zGHa%9I96;^aAEIikM?Iy$Lu(mPxI_P_vXvNTxUt22IWfg%fH*E1$NGH=3cROyUE`o z&nk%knOE-=N-m4pB>lN0X>?7ef5~Ni#?!(7>bMOo7(U&&*!Eyr%gnVi#C*y>RK;0v zDt^=`Phg$6I6Kx8<+|Blw@$0-Tif*}Lq<%TRd>P9N#ZB6V&62*k#&>$edNNX zOC<|u*scw8`u%vCVez_{HPbh)ahwwR%&9tT^S`6ki{E8_I{rkerPlO2>%ntvh6`e* ztq|+zi)^-uoFO~^gZ|O5Md#mq(fhvR)83#DlQNFI?7Ed6HF@TQbuZNdRZggI#al&4 zI&V01%1Tyz{@I^=x<(J@DVCq_d$)Y;V!kJ`7O5SFSE?KR-TmuS@(bIx9cS4RrdKqt z*3cADjSLn$+!rN#p1;w)aOqdZ^YP1rX7-=D85v^mRQkw0-Xk+P#69*$2i$LtJK9y{ zb!BIFLFy}iA%P#+&x0J;JZzghLaiPsWQfgd+qKNlQ!UGC#|_P==j&&zX<}G*r(aMm zSMAsKEsq#Q=fytEF<(Ea^wymETN>6|-*t4XF6-LhHL+!|SwtFJ`&A*oY(U~&q zV_c!Z!te#nHtX`TXTBF}aSgRy{g-W**f%Zv?d;aQ%3GKMPv33dnd5Hu+*(X?VZr4* zrahCG*D8JHys)*3l-R@>k69vAR(r?^lOl{} zAK5o^&m1E`W;^YrZiZ=ZUK?z$G-6j>yJ-6wpBG^VCAk`{HwAcJF6+x*l3Tp)%~tN; z7WyksJ-3}u_qX?7QJYt0qk~Y9#w8Z>6_}7YI$WmiOe22zfTQ{DaSL z>EN^LYjmcczF+@7c!Tj$G0DcF9U`|66|6S%%4l(%`E>Cym%XJeadT6;yPHg=}S7n=SKcNX4R#U4z)9OH!iOG zI&YFshM{g-g|TcVQ>*8SM<4H8|D91{XBYnKu%m*~3JtIM#~QBadEVgXTdpj2Oj0j? z<6V<=3>vm%lz zlEsy)zQ=P+dby!c=xfu%SkLqiV%_QXKD&Jclmjl<&Psm&i*LgVNB4Q$p>54|3rfum zCSR2Jl=yfy$Gf+j*ZaI){?HM>xI#zg>0VclaAhn6_+Jo~*xnLGtI! z>|h-&3N4Y1RUNmG28H_>{sRB2gmE`rkq@v z_e=!8q1gxC^_sTBB(eR|7 zpwXsThCgKI_bS~H{X3T}_}Su@8kJAFYLqlQZr{1XGvS7=Z%$uz!qXY%yH;_q2{2Y% zn&XlEP+RBWrO$``da@Z`nsiqt{HhIePnzKsePpfP^6BNal{d_SVtdlguD!YC`n#S| zt3C6qm#x=cdQWG?ubn*Bc{?(XvTf}@$2hrGYxUDv!oSX!RH(1!T(ZM7meJ|+SJCqV zrH44IFKFD#jINiGHsdqv_Wc+3_=V6Z>yvAinkpR$;F-Q_xsAD{Vfh1N?U#q2FW78z zO!jY*efetUU4}-x*M9u%mBOH;wIFueVyFCGx2eAZ63!X&qLhqvKcr}7p0>-K-yx>U4IH645UTfW~<`*}s;#jaDOJnw6+UWzoi z_dz%-Z&QBOldSu1e-+KqX2^ZN;{dDU+;uKLls*{R^2;9QWxSOnaWDDBZT1T@D;BQd z;5(e&pDZ~;t#Fp~UvV4LrMLK^J0wF(Z4YfR3|_L8_qWP=7ROsMZ9Ot~eFeX_3b~us zZr`-~klOWNPiC1*j8W-lE#uxi9t$Mv?t@yKmzLq?O(7!sLA0%EAXOwyy>hQyEgMWs= z!sw!vs%-OK-s;>GVtGI5#b>ECy(_*Y_I+P^Zz0!l!+P&K-4~SGb6Mk$8T(62cToJ% z!DY22_uQ_V+9jg5_KE5yQe=1NJVU^ zTo%rF`lvzU(&|Nei(B-v>fQye%8*IeVByXckAS$eK{LJ?4Au#IMeeygiA*FRC?cN%MhuOo|B> zA72FODtJC^-901P?})ppyyDTN0qe5Zuk-zG7PytL|8e1}IW1rQYG!_ow(q^pcImRx z!$8}L@Pjry>*o{(Th+1bbvW*}#(#H=29N))gvCD%r)x#;Vq z^ap%PuKk>^(mCJk`;E=^95KENFTZ!+7n9>=Zmgf;Enpj(GxNYqDK`aHMw>%Z)<3(M zxu>Q7iIPS7>rc%~FZ4|eGzt8(D(fQaqss?#A05B6pnJ`}pouY2*OM=`cI(V6nY6mW ztU1uM^>CT=#ff)5PT!NN{*FPB=l%+thp$`~a5ucsKKo$a;r5J`M|1W*y~B8P>ZHH+ zYo~l)w#)Rc%n?-zS>ZCL^s0&S41vD$ zx-&j_&5;bWIjOn!_~ID>lh(Xju;BeNo?97(+EcFEazEB65#|3O7IQ`PP~Ph0OZL?1 z%;Sx|dT(C-2C=WsQN~MCBwDpk=hSkqPG&#ncT#q<*Qe(e8P#INNr$roV`rNjzgulk zlCsBLU{$r3@rk3-|F%9n7id-4b90;Kd}VF7%~hFs_d>kaPx#8K8FZDg*0-xSg7X*? zi(20AX^U!_>xE?mA|I$cmsrELJTE=L;NzrayL=V2j(gT^Wtp?$?THeub@O=pZwSw? z|5N(PinEyE&CSKKE4TC?$x~q8zH;`(`8)pV9olJebL}CE)7SP}n(TGEe=zKF8t-8y zb?u_Fe{|pNxvCeuqbx`E_q=dKW?u1vL*7I zFrtCKC2+eg!SULJdc@jwHJ!obvWu; zf4|I*{`x~|RnIB;sdvn4U!8ixsw>#!tF#P9#^SL)&$tzR?ht$!2wAfwd#$!n?mGdC{W*M8cOPbBHqdF87! z3TMyD!9+x|zNkkoo89Dv@$){b(8I~<^=nUGdSvZj zkZAblwnzl;)uhuc)i19GFN}fHS{_s4vx5Ia*pHFTUO)jjQd?=2&quSR#vaNf@oGSfo-_@)5PRgYUoSAz* zK4_(d-x}H3R_;kTMq<53zqIzwQ7>>|)NQFbmS~%GT|6uBPi^kMV#YICGHF+H&s{vG zkaFQU_kybQBR5=6naAktT9E&>X72vI`x{tG4*81wDXqMeFH+w8T%6KomXu_XwSElGN+&iUte9c95=}9}y&iS4rI(ud@gJdkvcHn3mY6R_n;-}*;ajpJTsK08-v zd9~nK;+}p5o{1OE??0id{kBbhda1OpN#n#WndaRuQjW+e%s8-_4VYa`nT*QpG0nYE6jYlV^&`2_VqCj zGdoI;&Nq=aDpwXX{d*DvtrQRXj|l{hUfzM;l^(bAyK z5AW;eOuEKv6@I}>HS=KDWRcCc<4$$2_-G^Ux89E7XG>xauc7FhomNlHyK>aEe`K+0 zEY8WY;?t{^ytqS~W&cwF!vwZh-F83TW!+rttbEygO73MhrK{!t=jl2=6JH%Ckv?t8 z(@Qccvwp|L>?q;Qyq9#QSHXYA(v}x#{`UkGUS3=-R`+oA&X$D>{CR|5PWPu(Z?{du*{?BLc#Z41BW1*By?HL9QO zxY+(|W;e%?x}UFX3@(N@S0w2D6uppeZMwig*G;=vbYWuUvF%0;);-( zD?BYy%ekamwodiea@g9fo7fmrzU<@l=qWNPxi6FoO;203WuNX4UuE!wcZq%6?=|YT zJ-(IhymC6bW#_%}#G|S`kJFeGuJc%YIy7Z|{bF0eJ{iGx_ja$=doSC#=PI?!7<%dd4`8O?`1Qz8H<=4S4?f+UN^{HTz{ik{uoYdE_eY&dpdI+rJl<%9n7 z9IiVGKZsA;cJH8A!-|#BD=H=%uxOS&R!*C~wdLo{%RkyT>+DyRmb?7_!O>@V-{%$b zcIyW@Pdqkz>Dz_xAG}|FapjZdkaM5bZ8#~oI-_InU4uHBo5-v;9uvtQ-|F&b!%sisnI_A{AdIlxhAF!-}Y#nd*#dCzFRnGqDlA{eeUGetB1umm;TY6VZBqN{cd-E;imP|ADl=H zNSbf&d#dM_@eh-OA2r{LwpC7vO6};FajLO9xB23UAUg%#d1u;c;?iuQA6C8LKdRvD zyR|3#i9c8V%&8gq0%<{F79uOAEx5ycNZ@6h)^f`@;f1YN?b3fVFK@l_GmXdbWa}I& zcHT_uAX)FO+keA~=Nwm+LL|ze5V~=hZDtZPwiQ-y=hYXld|thqNXALj_s<>PJKLerfSXNDD&?VglBO2 zZSb*cQrLI*w911!y1eE)gv6RlSL~^q^5y&=hyQ%xi7aPWe>_j!&GG794>o+|z9yw4lz8t`HvdwuiQ-G^esUrb%~(y7>xb&6Z!&lUStZjF0# z#b_pvZA62@EZuVNp+^E`m|JLbc;vdUz++=p}>ooe`=O{ksljVc|+W*3KW-wo} z4SS}M7-pu(uXXhCsqL>mv#B*LF=3eZ_e)fF&b^JM$*{g~=JYom8sR%Tt!GVLwSUp^UMp5P zxp$2p4_qjA43|G_@oSQbk=w(#p6_mpGu?}R@!l(_7PL!x_K$s%v;2$Q_05ix+fshd zbCgzkV$8hHd#Pnl{JOrwYgQbXIptNeYSf>rJ2ti-5PuXrf5+0ZpKkPWbPDfzDkRc3 zQQN*QgIoF9%k|G<_a{4Tx_a7_A;0&tgm#|%@yWIqA5GeO{Ijv{?-$E2+4rutIQ%T{ zmX^tjzKOmYw@f~^v$Cp6^g8#azd{?oeS52=p6gV2P~G3qcduCeibacyv(w(C3B8K3 z`C>aeyP+x!%`fF}_+6gqktyrmuP~YB-SNBSR;rM$(JskLi*{Z57+sW5 zl2Ej?eu~o;rftT(iVLK9HfrH^*ZOnLeDXI{Qt1uz4URm+UuAS z-G_~NmsX!Po!Q&A!6v8L>L`y9+wJR{j$3oyoi6!WG^PG!)it{bGA|#+o6j^p=iRu! z?t5U}3+C8Q)BFDm?Ec5Jb45}9sV?tU2k(|0F>`h)%r!pyAmPJy`-k$0x$=iPj!ZTz za=W^DsrZi2zE%C6i|tr`RflHW)ry$2NScZ1V`NS>TMWC6bM9K@pa+(c%3Tws!`E7z z&k>mUDSGO+gAx%}RvlJ-vTdQu@4Srq6~|u|K3j1AfOyH*2_zr*Yl?K3Y%@y;(yG4ZGrL*E|&5a6Bp?mE=qDWnB0?jKO*_`dE-oB z)A*~uuDsIf3_23{dG+_-+}Hn}`&M-{@lP1n)OSs;qQC5y=VvJV6aBwCR*?HqV&~Pq z6IENKx(-;GCOg|oA4!_~>iuF)hlo_Aw||qjcdj?$zOql6=k9hUp96JP#y$>NRlJk8 z_@A5m=}(GoOT&V)b-8J`93^(1eJS23^=2E>rx|NnznODKaBV*ybmiEl0}M5`8T$h{ zBkP?TOjiUgE?>%IEw!zC%9lJD=MM?$igK1_XOlX(%`Rq6mzG{R@7&ZRA-OsRlr#8)9ekO=#+vUG^+cd3Lop9Ovq?6Evu@L)Y- z=RM}5BJ(>my4Ez_?Fs+5NU!hcp5sn+T=%^%ZJM~hPOx*O;mkF+r61WDzUUX1mytd@ zK_+gE$4|?@ich%$}>> zcXdw7;TE&|%R4hpZ;XHPYtuia+bbL|&&hnTRyS-JL#?^r{E}8(gACcIbj5 z!)KVCIquj!29B?jG*-aG$gM$D~5&zt{Zy~L!t_>-(w7T=!lA8p%l_3^&hN?X6q z{lF}DDRaL4%OJm)IZ836(+jUhlqqiGa)^0&?2i2HE6=W$8$ErNo_nfbudU5_|CENO zlk<1f-sZlsvqSE(+o=cBrgEE}4tzTG{+H* z;+WLeNk&X>)uZ*wf1K~X*%G(g^7Xs5+x5bqa`PG-{^`h^suR4XS!Vg9$Jt*GG9`qt zS}VO_3Spk#YcAX<_qgGi->zNZT(%SE%O<(LIdu3!dF|FMFYlKJFW;qjd1_JR)rG~Y zWLKQ!{BXG>J>&8=L7$hc5+-5`RN2@rnr`Gc!ppgyMV&>kZ|K}TGE>$&9iJ$aDQ|ndnrlb!Gc3*ltFR<;$qMhtBqRaYDq)nDx!S!q2 zrXc%R9rw9YTCQY-GN(u_+tPc*Ur>DO`gz><)@pyeX;?IC+m+d~`X-&JoLExx)+>72 zk)!o8n-;RldK_i!Z{pJs<>~I>i{10Ctf9T&{h_~h-Kv^@ZY^NpU!9icvHc&EofpNprjX z&p&eAIN!-nH$d7!=1-?oO2+(5hIE;g9~#uk@j_cv*eLQz|(O>;(j^f5Qso<8wOLA5Y?b(@cX8YQhvM57@l=%>+ZEn!efZ;k>2-&OTVGeM`?A>A zw=Ypn=f}Q`?k2-#`}H-mC#VM7ndXYR?B`QsJGezHSGJ4K(ZOiZ!K8h?4@%D@UDZ30 z`_%vRnywF1a)hdq*B;+{Pay2QN>*WM4a><3XLQy~tK!MrKd)0)b(XpCRSs7}?jNl} zMb})_EOkoff4;>%b9XPR*r`8hyZkG5$W?6ezQ0BzdBL_PyX`N&+17Wm+0jEW{5pYury|3g+=MI;SKT9qsusW9KRR_shQ= zJQlqq{qx0zPuGTKe>pBz$igUgKJe8W>HA{LZmidCK3aRickS*VCi^7AF9mTQa{H%F z3rsh4yTS1$?|0gU6%1}&EZH9;zH1dl1+jO&sJE(OR8#tW zM5RZzy;o6SCF8ZMFZ;66pFiu|`*Zr;>Cu(z?ageaw>>!-nBmScQ}fz-|D)6IxCEN7 z;h)CQ?3%e{dd0igz+8qD2HiWQ@|zELMZ8+_$#(VMzU9ZRUN4S!-d(cjhuXGJaqqro zH{a>=@;;e*>&~^qQ$&yHR2IDO+PeF~x(6q(bvGOF2F2WUI`+8b@(HcH11+@$e{**% z%ieLIzH{r9wX3DhZ=2!d_i<&Y$7ZL;?AIo0Fg=giuH>;%?bZyf4eeG}x=!8SGiN#D zM@zn^lhP*t5Mf-PZnpHf;o%9Y5fk)Pt`>6EUHf!eX>~EPbMz!wvLO<)pxzy+0sdBW`re?D4RYx0p{U)P(oy7tfJ^Wp@0N*^?;&IpW>?p-&n zQ?!NA&7j0-+lx1@hI83Jb!6Yu;Iqt%(|Z1()LZpIcs7$<{D&$5RR@oWx@YzMd9`_RefWI+_$ki3A^JjFzPX%dTAE@c z<=diuRce#)siy`Ht;7$j+Dlj|$uDYOQ7fU$)q=?72utX#VH#hxODCI&Nv1o2SgBsG$;9xBKtf?Y|v$-tKa9 zn^5-Q;`spakZonVH(j(6n(r}xN}eNQvBFJNli;9@+kY9}YSellvhKy^6}Edq?z%*t zJM;HePOyeBYsAcLn|L!ycfBhrlFR-od-$|xI(J!BeaFG$fqD7Hv9njRC`>x6Q@G+2 zkLZoJ8@W!-cwG5HO-g3=>BFs4S*2DTytg-DO2IlG>C?)2O$^xRa`!xIuOFeSWE+Ae&r>_}wNS4$F|Lop_^wyZ(H}vkCvs`pg$kIpg{6 z#*xZt4gITP9!|>??fEuW%{P)^_Sc@;=NtT$HR{7On}g(LXLE1dBeyG-eT8{K=hrE* zCHrSh3~^CC=&E|+TE>n^Cxw`t9!u?hA)KJY^kKp4Kb60i@ACGQlx%OAb@Y%@3X@;T zbw!o6d6j?H%j7<2Tl!ZsRX@2@^-+zGu!ho6t>cIH#Iuxamq~aV81vZ9O7kLz$7-`} zVu{Pozkk*DuuOBxtIOp%^L-{{WEHhpY~Pqv`@!N6udv~V!_4>F-#h(ZCcL6wa<@xw zT>WXWzxUMVoL%bqBH_@Lhdbu@YPVf=o}1(J`q#%hM`pIIOkXvBWz^$fhEsF@%r7{l zI^*=C{+1*QuUju0nRctsP38TtC8qo+!+gi&B~oAZJ2fp&Sg11N=7N2tbuaVc^h0JX zYh{a7n7&B!jz6zfJ?oP@Q|0$I{5QydRWem}ImdJP19^rmX)AIVtTB~L5EIZx)`OnqDH8IcU3CYWq2E6h2IWD=fW=ZUdWzA2Q z9_f2?r!_3eAfj_ ztj{@Sp8r|1-0S5@pYW|h*DIKMOF3Vvxm}164OqYEGLOc(${W#48*DUp*DRAc@Vw#1 zt5fMB54T#ry&XIC%*M#RI}4>0d&NYxwUY*67Pj&%*)F?*6Js@(Ir{5IJpX zv?tfmDm!!Wf;F3UeKuAcP6`ey6sZVkz0y4sucv|n9alyF2bcJgBW#hJggC+2&E&4_%Uz2(D_k~&egpAjpS7#Q^A zP4B6T&iu0IMdi%s@RWT9*K2>S{TIe}eWCnO$<4>&D(+05SjX{9UUyeT?2_BJJincr zX*=8D&+`B3ZgY0O<((08de_!(O!x2IGq(M$zVF2hRgb-O*A{OTyK*_iH2?8U+v&3$ z+KVO3_zer%T1t*AS+K{i@6Vf6a@FBQ5t#?~e|z(aZVr`xDF}dKRR*gIyeXt=ed&jYm4bca>Zp)fxsp=&C3UU*=@4M~gk+ySY ziOZFwr*8~8-oVE5{?n$%6=9Fxos?SQ`M@c`Z1b~SyL}RUFMeS=@_*H=YbyWRasnH# zb?uNi*QcwirsX?Fovk9FplPLgAG2=VL>qbGjGce^{ZAUU{<=Q*($~EvjX_5WUY+}J z`10v>g02Uaif~Q+`1umU8@Iy++_MBVk8YBf5|O%B=o<%<%%`YirBsu5oHys>-45$B zea7GYFULl1wa1Fz$C=#bZcFb~Hhp`yp;?)0{~~7%_K2piVEyZ<_e!l4SPZak}n4sZ#+Q%s;rkt_MUCy$t zL%C?tq_2b?5rfOvuzQ+ z?snwy{HLsWe{QTb`@_FJ zTQBl)Cw~ijV$X zkhb`ms+AcKtW0hWFYO+Zq1J-zTM%X?%J7z|E{qqjtZ;;qA+7n4@N@ z%z5gyCw@!i$+i5enaaZ^35&+G&RFcp`Xk79?`EeO3AWp134+sW9ADESK^H1-V$X8L>-OCbf&oXh} zeiXFCe%j8)53jvEq#O^u*w*PDdvUdOY1{AFC#$x+o@Ki@peu&+gk`oY^Su_0w%duJ zYfkIz;7&GQbKU=3>XkU5JGZVcdouazy*}To6SODX=q_}+?!==veaFvN-)DaB=6Y^6 z{iDl6H^!q6AK%+pk+M-^hQzUFp!vfS&ku&})?M2-pMUiBOP{RO z)+>D1+*}g2d)kD`dZ?6snAN$Z&U+@St@>^)hwJ{ES`_b_+5Y6^-dt&EvR_=MbJh&0 ztU13QM^2kw|1RI!#I^O3{}Csa{mR*XdAGJKGMZJsk@qxPK8G0(bJYEAgY}EnwTaam zEzDZuyn0i`wCu;Jd_{@tvdTrA5>pg*&qxzLrEJTm|9pOg%0oMWW}ThEv1tNx_lbA4 zYnU}E|GmW-5uJZKqW^MPvDbodbNklBg-Hvw|2}%6^J`0tm#5fWxmWjR@J~4y*Bo<$ z;ew%ij_0}48|N~HNWIFdF-k}>u#=87~MR&GC~BwypLw5vCO*S~9L;S1}i?fX`Il9)L6+A851K7;r#ZpS-{ zURyn>-1xLCv7GJVOx-yQ#oL~@&WlWY+qUxCCu_L_i*J-K3k)f_dcjFDM=xPcLEi5b z#uw68C}=kCu!{5h-=iA$pI2HseD?}2HNgM{PuA6UXY8B5(=hD%E+JjbMTZ`)dGN^X z-p8oC$Cqw4Z_W~oI&)4ocmI|8V9RfkFD@7D<}K5jUi-Jtas6dQ<+N+xTU}@Ed2O1o ziTBVx-M-rWH^uoDbbS)@)LgOtQBpU{ga0{M;!-tyY_e5_x~Pf9-RF0B z{mi07wq&z7?GGuwyEi8yC}rvD6|E7ni*AYD$na=?I_s3N!s|WZ?p3D}e>AL#kDjuz zK63Ypdpx$vmG`etb<*l#$WKkHSRSfsAhgFYMC9AC?V5%;d0W3bO^G?lCv#Hi)t2uw zE4jZm>pWqP{wKGf!|U7sf9(#6OA=nhE80c@!8d`*U+G0t_0_yGr<}!Roqj~ElXK1_94h6!r{%8$Zsp!RTtbe zsFJTYWwNgSvPb`#s(-~E;R%vLjmtM3Rn(DL!E|rx%1tJV?%s7;SH@ZO%qn2l!F3+1 zPx;ll-B_pf___S<`Fqx`Q53%x%K1oA<#;`-7F&i!8`C5c4~Uws!w{gE_4fQ@OmTNtEPiJAW%^o< z(szgL6hB`{2(Gh~I>&!jTrn$>r{Kw7IqsF~(vla4u3j0^vj5sX{iv2K7e4n3Syvi1 z9_V}PS&|j|*&sJYaP72fi%M+&e&*V*d#yq4?U`QD3!fF{*}h=P&oKY36{nvitao2C zNypW?^v3E*cTVecGi+yh&zV{_`PT$zg{Rjpott?yz2j})rEiy(pR^79sDJCxxl4aj zXBaJTeG6G+A!#T*kVA9vXWBx(bCnjt%@>>0T`y-3hW{JhxJ%`Gd$b|mlJ85>` zQ0d8Y<5bJ+SDkwR6eN^X8WXX6yO?oy=1okz~73@_bsC6mx6hYl>W)_{ z`J}TCUlLAayV~XVOLlYeJf6e@{y$qTs=s5Y$ro0=pTm{p#c|Vg_F0V#)y=6YQ4Kqd zS3F;tx9sSK-9P`m{Pgpfu0>h)j$1nNa^+Hs2`u92)QT^2R442|??_ z<+i28n^;mVuxehsFVcH3?Cj+5QGD@k z|0Jz4U`@-8J^5qp`-LLG>$>X>zn7e~%E|A#yV9drzb}vLJbJifmRYpK^QTuUnpZerG?$@VQH@y)*xvLX>w3kIzE&KhZDV zKG;5OTS$FR9z6=SO`RJwK=X3iHpL~+2ar;Zy%?IRJ-E(J-%=WPB{&KZ`%^#ZjFZ4?*zwVr}H2a}$OpJ7z^%k{{J0EXz znRvB$;gr)>uR66({5RMov&*fmJb>?8*4%>NSv(s(-kol*c%8JL^Q=sMPk-nBKbvP1 znH-8)GC%Vw&yH)FCm(iC-2KB+&c)WgaX%l!VgEUMMK?b$(awt$nzyAs$^OkF5kW>t zjR29Cx)#~y{xicluCy2G{n_{6nrOhY6N_XcpYD?2E<51vTYXjg`O{0{nnf+)ZnN&E zZ#=Ag^mmoy>MP%`OfQ>x^+DsJT>)}J>{IPR8(wQ~?&GWZDdfC!C;y^TE=I~B#{Yh? zT&P?0Z_kH*x5SkE50?rgw_TW=;%9N~@X~KZY^?@uyq`)|{MjtuGaX%7gIVOJ zCK;Qm?@Ye)m*;S9aV$r>Us>-8gN`fRty0Imy`*Ki_dJz&H%XyPN;`KSQ&WOKTwI*W zl5=ZoS2&j^d#QfEyzB3CnKK5}YWA^fEN!fPTO?%LYS zcz%KDAZYmKn90> z>4_V=cGU7+>9ph9bVG`5dS-wM1OM~&?-TSNls;dim#|g+!;2H~*Jmt$va++MDk56t zSjJP0SBDmE-p`=<%--2%XM03tOd?;7%PW~P7mqv&KH0W1F~!R7iuEEn_b=P410=V+ zcjIK~ubis#fZO((kNo}YMbA&&b{EL*KPBoJw{c}S*T-%AV(G4jLKAv2mZ`@+d;4bF zODCDPGSl5x&)Oaqo|dG0)BE*8zhpMQ^ZpUCE6djFi^}?)u}x>&$7< zM+!1Nyt#64|GH@(bkk&)e&6AH$AfPzqwUkb2htc7Ocv?gj^lWGaN!T%k6h_BkIQYQ ze*T(zzdm>F-?c}bKJ}Q{n_qdMaB6FEC0F!3_CJDWZY*_<@(>i&IT)39?@p9P=#7v$ zzkY4jvhoPGS!(f~yYK9!8w+3WaHyP;JD<1A>~`U?Rjw0QH}XD{@$3t1=zVEFZyg6` zmf_ixir$XPVD&(9xCN^g~1H56Dit@B2=26xJG9XW?fOPU&{PvT${6<=1l zS;cWem&(0)oyn6gaP)84{%5miz2uwMPr4l)W)uX5KYzA4!*#Rk3)xBHnbUhdS}V%! z@HBWS@Uf{@ea?2-2HjmNA6!Yglsack>dqxuDoYym7_did}Oj2(r$9@Y&OC!&HNL zA5I>>oo{;T+2yBB<&RH$-f8gF*dr`_baz$jrmuO5f9C(#lV?#HAv3n!&dc7N*fvg@PLq@;?I`7vQHj-@1?sLiTw>K&W9aJ zZt4_=AF2Kv*`W8w&Lr!;>tvXA@8rDUzxM6=>COR>CEg-IiY-j*=WH~5|52*4ch3nXYqp z(Q}7Ggp>7{V2*C(rkfYeh^)KGa^aNDmkC7%zdoOvKRNhqUcAPtM(ykDW-+b)?JZot zwzM%Uex~+9*tJAAw7_2LzmWL4?*~_?CgyTZI-qkebA@m(SCwI(xa*e856VC1=I+0G z}9|T(}%qKzxFYHn(V#g|CZ1L*AJTcgc&8M&OYd?p;X#i{IOI`@}-IYEbnO-!dDvy z-3aZSwZM$^O2Rp|MHlAAI6Jbx*jn@B#}wX#$UTwr$+OiB>~a%SvUG2|tPge)KmKu3 z^3SiW4N4vhx&1%aEVtFK@%aBNVA4)&62FK-V*y_4u z9-e$`l0bxD;ip^ypYv6{{3f-v3hav631P~?8LD@pZ~kMx^!jA3c8TqyS`(q@?Y_L!;h(-rWxR{#{Oxn~g4C(2 zCX*k}`?NBK^NnuDl*Qjpn=^jg{lxylJ;PON)~d%lCKSd_-McT$EG(uVXp73071#GD zmi%ON5aVK)yrO{BIcR$0120RXZRvg$FC~}$`4)U_o%*3y_vY6d+8=QU-t$`i)Jk5f zAIsxU8Z{WDzuB~BihP$x+@!}*8z)@aeUWYZ4T-~B%A3-Z4Lx)XB|i29EIP&Ad1s#Q zbmva46YF_X=gu`PnsuXIug*jARS|ryRb--gW!#&RiUVPeS66LNnLAJOu7UN|^tKhDH^0jtGIl!Ikg@Z5 zS3&~M!KFocN}OvlIdi+>9!pO;zsz>Wn&ueI#C@F!+YUAhJ1LZ=FQ2MD`}pZ7^{;k$JE9m5!BiFXfe>r7$s|QQUk>)o4e-|xxY-LVb-Mzex9D+;ui1D zKG`Qe_|JPbBQC9&XU??cHmDcgG<$to<-*|BVC;_82WiqV-h{jP0{(TX3ty-)b;4S2G9+Hc29 z_k~Ly)xK@3Q`nJw_1YBinTk`EifPQ?YdXx-!4=rOp>3gF!Jm}NHKB!nZzQ~5{L7wk zm$>VTx+Hhy)gO7ag%VA)ewIF$-^+X@t?hxNsKlvWv%cLbjUgvDKDyd9H!AV6TKg9r zJ*!FkG_qe?ZsBu!lId8Uq^+pbS8mn(;rOq;=WMoq&hTi6yUX_^_U$4+{fSGsbbMHw z&#rp;D#M#+M^4z@oAX|8omTkvz3taaSM%N^FP|?L=%#*9V#6Mu6B&0HCKQ*=S{GC; zHuc2aw@Gp{r`*qF3F3OQ*3@^4L&=(!9ZyxS{jqQqJlL{v`t~aVy*tWIZmXMI(4+Tx zTl(DQ((6-y1S+tr$_5`ulCsx3CeqV$bG?|L_HIX!l`F5#oG|s@vCNl+lU|-*d`{)Z z;+MgvlMH{b{_tVze=@t!@TSH4Eh>NH&Lx`g{NTCny^F#3*HnflGZmEt)07{*n|1X4 zU7r(oGdM0*yVd-X;{BPk)A7p&)7Y23#|{=gsA;>qM*p7d#b;7V1&ECM3-<*A6uV9UxOOpz-pLu-#4yhwED<0jt zdfrrS&THwM1wN~0<-6s+sR~>W(R=LkWx*x-s_cqZV*h)pleYz=^>&}xX(ZFD+vSj( z_}g5OUy}L2#(k4MNOw*-X;=Piv2vz+WTerQsV!1dHCE|gv)EmGI{N>K9p+(N?tjCY z=e#zWT^D71Wxbf6=%34KhvGLB`)!&t{kuYz)r`iM$uoWR*YUjgTB3b*-`|tsYR7kN z_&kR>{HEWOHJ(0bwFCfFzQ(a;-t$vwRc*Xci;69R z%CmJ|9Sq|4aAwQs-*!D}^RH+=&F>u#d1hs5ymz<0dhEx_#>cH&W|s$A$TRQP`|;p( z{6lurrAd3s*Q!sJYnWyRfb3FK_yk>Gx;ku7yvFnd{yG86jF}ZdrM}XM9d2Zehxc+XO z)G@vGSWokbQyDXZ?taybuZt$RT{Bl!mi@oX}u=uX*^GNmrWBZWW5mi z#mwsLpQIe~o$ou@o@i~UGQ3`}L}0TPm;a4(9an!n?vD9$sf&#>qqLx&v1HNd#%WvY zp8s{S2x-4pwJ=IS$G?Q}dcOwmj@|rKPZoY^wqM)f>!|a6&gRo>drn@xa-Z>%=bPJy zef}t#M>O%KuDR1x8oqLY-&TvY&rbLr{mXFXVJ6d}erBE%EJ_@ydor)jV+`1MXpzkG zQ0CbhA0wBnyfJUn8@qW&Bdy9b>Z49;zN^{#?p^T;uGm+p^Sko4fBJuY@5j4g)1-JU zKA$~Ov$SbtcS7R!xZl6SrX6Y68+;_yYEsyz;N}m~@>Qwjb4?GnpNaC6y{D7kC7^Hh z?}E`3A9ghlo+GmYVwrjmbre30cXRQ3T*lB{>^uigIgAp3sHp{KDiz8Wr9 zuAjA?vd&X|*O#-;&xp+UslN8%)o_QWE_0^jZ##eL!K1%>ggZ?-HK(vVc=%Llm$d5) z$EP*V{+EUo`>@XJt`;ku!(3)lC$YsYaG|Nj#6<1|8=AIf1ve%wDQM zmQPnWUq0sdbb?3qb_=ihj4x%bx#@|<^Iq2Ho8J}ngt736e&5{CrW<=oZ#^zL!?#Po z=%uz$VBY!9GRut=w>_CrK5s!?%)|A1m6>bVmY({;Z}>amNvwyg`1Hg2%n=%Aa=drt z@G1#KXE3N$DfeG_xclJY)pqh4?>m!P@0?oy<7UL3zfXRy7Cv$FqMg9p|C_I{N8Fq| z<5Sg(RX^6qz25WdQ;Xt5vC1!EF^6Bie!$?j@<3YAIZKvJmVuf_Yu{9_>OZNgDE`Rh ze#uYI*+FTyY>$Q&)GYC^eA=I)zSUm3p4Tw7!Rnc^X;5!>S21J2-?T3!uA3w}dkT*p zFHFlx(*2itR!WG;<+oaK`npR|@6|aQ6nHjX|N2Jza<1A2iJaL6y&ITP1H5{5&z#e6 zci7UD%W|Ui;jt&bPOsY7Xu7~9?#RhstHaWH7w?#6n=n^w=VR%McKq+GEKjx7$CxWF zIB#-x)6VD5+twMMxlzb3v5(!HrT^phuS@n6-m`N$Auf^=-}i*~xYWt#q4zT49+z%& zIwZ8}fBa5Quc@gPIi#gXc`#Y|vr`Rzr;*@+J#Wwv7 zOXuR-$J^NS4!=L}d}8y7Tj6KJxn1hF>ULe)JmdQbzY7`D)pTTSwyfOj#5g%pa$ch5 zq?X_!cW!6FMfxU}#HtH+6)#XVc)(L-XuXVk`oH>1H6bUmM1ntMKU_EU?B(taC!%^5 zpZ1tL_w7&pR~x&d|4(9#*vGwjwmk3M=zRUQc73+2c&!iDcW>lyng8HNs`z}b`HzxK z53cE4_4~!T&2JTSaxWiZVJ;Wsxg$MUIOm4#z7w~uWzAd1t6{P0U0U)ja#Q>8r6--Cog; zi{89>an&)`>DeRu-8H7^#`h+?z9~O%W{(+mi@e?)u`ctpt!uK)BvaHf|0>iy-zy7(>Udd{V?&dFDf*ar2f@@agzK3h-i=HE39 zX9ae=sr$&W?*4(Kt;l=wE!|EiOiIjq z;<9|^9vkDeO!oh}?)=M0h}oc?60Eg;x7nJcHr0wtYAh?R&OGQ5_5XHZhH=BYLX#75 z3WZa)*2u>0a(4Dmykp|Hb;}EFCB8#l(&g6=6z1EQuMyZ-d_?A+etpiIiJWzr>uY3E zQxs<{n6JOBz?W_AWoc(t-!F&rpT7H8!pXvT&ijbwvZafB*5qce9c6xPCa_05>6O~6 zJuJo2vBz$Sd9;{ab+QTko^V7fwJBVu>o1$p{H+oq?{0oBI#wq=N&1h)$z-hvj_LpI z-zk1xp(`|fQ?{S?B9*zDCO$b_6rtOx-kYrBRaF1w!3n*cA6D#cEMxXMX#TxbCt)2sc^rzyckC`VHx&PkT=RQCA&&~kR%l7ZKcU^Lku$$K9CLo&d;O0M# z)wS~(^1>f@Ilcd@^+$OzLlZ0Kf<5=w^3VDpxMto)r}e?k0a8Jx^B!3po5Q{GfNY@9 zzwZ{^2YfaPMcLODX$dFqVGNr0UF+1QH`B^Lo(r?C%8TlI;reh|nBZf5*_7BF9|}{e zmWiFUOJ|ro$4PlYfmOwls2vxcsW}@=xRb`*w)4$r{bIi_tV>pK?&{4G<9oX@-8}MK z$bCh*lG~rd?q@#x&~R*in$Dg+hJL5RUvkd2{TC1tdUpL4&;6Yt8>D=d3U|t`^{G** z`~B=zi6!5Z;>XUP()a9(kH7Nf{E=ca(cFgn5vO|9C2lCcxl+}Vz*C!V-LdR|{KWNw z=aT9Q_Gv`qC4C-!{E-`amsUb}ID z&y3#>vqKd&KiToK@58H%7lLIG=>hL~E$vMoKV9(fs>r&tU%tGuH#1tcd7b}+#oCW6 z_NY7)x?R0N?PT#1dqbad9D#ppR>q&j-Q?WUeUv3e=wVi=I zM8|JN_7&~>t_IU?1nyPQ^44(Q6a4p6L_x;$y?4$V&fx6k-t*~irq2AcV#$)H^6pKz zRkg98D`oeqTMds@I}3y&*4+0G*nM{Py^JtZr7O=Ks+)OA%q|ZxovD1Ys zvI5RO%w-XYyOpL8#j0ky$HA*N@T%8*iQWsHw*}dpFMFR<>*j1)S6zJV(6#&f1lu;b zm@g}I+3EC6{EcqsS*iS>g!t;i`Kj^FVe3KPn1}rXpX`PO&GcTl>x80j>a>nd=ZI~x>m40N*FY%dSEAQUl z9VT=B5`SfqHkWt)(P$<;vm>@OhgbuiJ=;I`liAg~%T>1IHuIicDv(?{t+&SQSpLbE z8IAKSS!F&~cKywMha+BflT*}kNoK})P8(p6P3HHLk0OlVNHtLf!uMHUf#shziT-7lz|@e|Kd zuCsZ(RkP-hXq<{DyT;ZHit8*iXHVeLnK!xHv3ude>Z^wrUfk1oK5J=&t^XP>!(XXi zTFo@(-g+0hBDSQcK)B*=Kv2qzx#gN&$?SsL18@6m(kkDiUBzpD!>zdWw)LxO>il#Q-f?wHP@vy*>9d|iaY7{qDUA(FT4b~Q*U$TU zwAHX*seajtZ5({|ZE=o~nFmyJGgaC@9JyWO9X`b?vuowD9ZQ-v{^ncv_$L2ur2Aw2t?TY*dUlA;EH%vy%qW~^tfO`O z@uN5|JIVP8iwcF@nSSk?Q$OL-s#WLO-_Jg_Zq@>xdf9(U+$^`ID=Nz_Y^a*FsYGS@ zwIAjt^0k&<^)+70v}?-*KQ*~!ep^VZSm8TIL!mYIf!3(sr^3r0Z+<7xH6!WU>Hw$z zdhZ<)P0e{GXz^wHNo;luy~DZV%j#>}wG(kapALlXl8L=__E)snIiv| zNTj`6o^oKl(kA+{GqkQlR`qJ{wu`ft-MGaN(agS) zMRM`2%azZTX^UOVna}oMrik+7hdnlHHm1i`o$Sr6Z)M*9>$&o6?Tgz5L$+$LsypAz zl6B*(TPCUXwC%cAW$V6L@!!@#Eq8m**iGzsEYtJYf5SudDYlxGZa-=dpEdUU>0-{w zJn^#F(tkXwH$|mx@lr`-w|3)Peob56IcEMboo$*O>uMa#SIa!q`g+9n$83S{&yG9z z#M9GvZ#^ujy{b(1+VVi5YhE)_LLc3!zBbAJ$0^n)kD^)2IuRx=3XxDUsP+oSbD;#6D-n9E9Hg60xcFvdX+Fn+_(Q8``_gM$%IzdB@?gn z9Jwv@=&ODDq{Ymwa}GIl7ynGp-Wa!}!K+7i+Z@HHlZ7 ztSlefJa>9Mj>Fvoa1UYk6$DysQzyB z`+C*%)06s|j##({9`cNpGVnbVdG%b;Idct@@6Y+JK3ezUR`7&rH_w_^KDJ)ImSsur z=LU(B<+V=bciSW?_k2*ByTZ6APkTM*4quh^GJNaq>}Wl^LhR|ruFEGRgN!~M_vf4X z{-MU*9N9(n29p$JKP$5)#d1~tce^jn=kPgWvy+OL>(%{*UTa;H4qceAPGyC!;7#`j zWwGrqvN*5UKDfN-ub58C44b`%6Zx+^TI})j@0w+C#|r*Dw%@nm=!d;dyB!;Bzt1@E zI%XNm&0s#qzp;DI{|ec7;Md`vYajW~G)jg{-^lLn&GDGGLNev|-eqiV9uXXk()QV@ zR+@2-ycS9uFN<+~JS8Sjy23%LU+`GYC25|;|FV|VcxXq~D?Q)w=gtM;3lmPUOb=SemqVwoFa2z4%~po9J_Io(BB2iA7r|FaOQVLT`bqS!SSkg@@reCo9c-RzFMSZtPU^v6nSf+ z$+1bCFCRXV<<+!O-0Ru5xp_%`y0+-5-J4R3pMTc8vY;XB%2ij}h3D%$TCaWywD>Y- zd5MHV!K`CH<}8(482EUh#lhz>ZYTS8?h<~w+(zAeGT)>?z89@tv5(ta)?cYN`c+fc zdrzs@{NApvcPDapyi@jX*(&nf%UyIj$j zztR8ShO;MA_@%_&>NlpoeYi35()TKv9f#Zx&5NJEDeS#r>O$RJiX3a}bet+#r+i$I z#HD1#{p;0h?ug3x9j#L~Z*(zEt(tAz>+e;YL&|4w6ra37i;ug$NYu|`zrnvNdu+G=5u0rN!%6sG;f1>A zURrP8Ug~|hCq6UGFTZz@&6_1jwaLcsb0Y5j|29`V_wmUk327g`-`-?=>fZOJxl1%Q zR&UeJ+7fk;qdjDYoWk$bDxw84dB%SiTsd)ccl!&2q`!gQGm_OsCj534c&erOB5JoV z;{`>T$O@SXkME0}O9MZ(cysCchUu)Cn0Rf;j+ShJ+7`ORo=>Mc|9@gf(eY31@#uuqByQ|3b#Xp11_#a!D=Mj#Rk4_xb4t%KW zm?*c#xqo$};+3_nx4Rp=nCfNq4ZBv=Ii+=J$p4#BuYF?8Mcx|?E2pHDOxN0Xc29{@ z-{o}=TdhZ~z3C>SW@CuMQj*uc&+HdHV-GK6uA6by}w%*xRqPM8X$Z3n(8~T zJ3BK9%FD~k_a8WVms8-*-MhLK1?A=2ALt$Aw5z=T`~K`-%a`q1m3{hF>9x4@^3v}M zRi>6~C=dN!#Ing?gMra!rYkC;q7e}@XEL7Y$>EqXCFz`laQKAgy*oO!Cx|a#HDO=D zD9fm`reVK;7>ifKjONADjZa)UCF+pt_Ss)xL1uOm-zH{DW)s;Q**lJDVGMQU<>iUx z;^uDY=8nhqyJk5k9JtEGv4PAUMo-T4dtu20SW6o2{)=zQaI^Zsv>5R8amc&1<+ z-k^CwD5d|v7yY{_Z**lC=KSZIz1#Ai`q$|bPRG|VyxK2yiQ!D6SpCJkZQHuk${ZNB z&S;*yc((Qh$psG*_)501uduo?^TvPn)Fk#zUw{37^p9Qfan`4BcERe?`%fAEw`M7t z$WqC4cB!eaxQQ zD6{L8#)=ac|CTfS^Yp$k+j2(p8(qe%b@f|K3eEoKKbXH|6X%Qjmp{uJ{hz7EaQgpO zQJ(U21?e2Ww@)ACO&PVW7`H|l2W4~^dr{41Xw&u=esmSF{-^mu$8utVvO$tJ#tqmp0_pxN2 zQyym`aeZ9`Zt@US&26qZz{-L z=_1D^zk1diuLDMEGppu)>U&z>tyI=^)hM)nhuNw{ca}WKH`@82rN~!gb!1V0hwSNF z2MpIqm(N}&X!UDPp^Irf$4kF0e=erBq#kj4_Q|yH`ouTW`dvOf7FGMYVZUmcyB7bx zNY(=v%_R6-(`T*I+8v*qep_RD$3@o^mmlsE@BZugkz@MK-R$qjyOKv(-P?@%@@7N} zNlpnnaV*Vbz4ZN+n|0sF>t-(At~zf*EdToa<$E^N%Oy{fW^om^`ZCj3f5xBZ%a7{2 zS|5|zzA9MmTH(xMgSub4uAEq&R>$LdD0hDJ)Z_Ke{0kY6p0vL3VTL02jSDP|lT19< z3fC6Dl-X_kuC1s}^V`Ju+iMPrtbF@9@S{`G-fEx5ivoN6=QjSh!hEZ~BlKbHWR7`G zA3k>`O6sg#viXYtmR6M_lg29b6Y}COdOBXeW}G+0?4kK&ofrS+O`J4)rB~&@raXZf z&xy91&x!i-TGT4bCtY)HnG_-EBYHKr@!mRH`8%8BH{JQSRP)-_to3pymTP)H=XveE z!rvoSaQAoXe>--~>)6t^qU4%u%SOSVj(t%_Zzr#86$jv`=!;E{=&Wy`9EQDixYFB^!2OX}5Xa$GOgicdpiO zH9vmSsi$Kx>33Oq$*G!Exu10^n$B`~>oG5zvvzXNal@rY_yw=M7XExtl)38Dr*r$i ztzWh9o&=9j(?`d6C$~r*|Kji;SJ(Y1`*~|kcl)QKm+#H?Sk^k}sl)NC{`(7!IWsT* zoc3yotnjPM@~n4@0yDqG%nfBb?Kx|;^y%>R@#hUg#eAl{5@S5)JvYEPMa+E4!n8=u z%NurHsC(7Ov9at}`M*gSF7KI6Zf*E@@q6Qzl3(+>brbeq{hPDv)#Mv4abM2_Pj_>u z2>aH}HqCxl@WG!)C-}6O@`Wn8ZB;wIY(=43P3zt>i?=N`w>T%57b2+LD-;}&I+^=j z>O$teBE@h&^E1283)|^ky;OWhvi*0?p+|QU7VYjmG{@lGviGd#eg5-YTYb^?V(t9m zFE6<@Pt98>c>7(Bznk+(MHANBPtxZ1p5p!UM_}H$v{Qw#q78f}7w+_~-6-Y!bLqj8 ziOZh_R-Ad*o*fYTXvdzgXU7c#y**ESdd++J^2Vm1PLU~x&3kj)_B7P(yxp~F!Tq~S z;&i9;&zkn}o|%*H&N-)Tysx!hy`%Kt;rfjd7M5>W&iKB)nz)B?L!^zlx@RWOye$j& z9?~nm6ImR`kP+>xfB0;y$EBHz(zeaEk9!z%_(uAHvM1s~vYM^;ytn;2@^PNMakhx@ z>VV60@7G?v(sT2I;-sf#mXaCoWaH)52PtgWHPyWNY|QKc`^O(We_fe0`M_M3{XgGw z<>b9>Up`;gwK+d~-eMQtq=>zI&GtOuvEPg|-tAnu>NbyE*wIkK%-^R1121LF4L$H^ zfAyUF&AA`)IPT5vn;ki6VZ(8k+bgZt{Mes1LEAZYcIa*irPimpXAjKYEhBVan5Al+ zr&6uH&k^C@Gd`<5%dJ}Bw8Jv}gk~?x_D?~%2J4mwDl>6!yY4TUvSUxof=|w>vIZ^X z{~H>3TMRRvI4o;;oRcUxc|y%yv9mQXoaSM6_X63uF1-@XYt|Hc_Rit{DO>H6i*Ebx zy7%XedFTA<$fNo$+MjKc5*{qx+iZOL_?|f*^jvkkUItC+kAJ7W;6&q^jJ&y?Z!X=7 zna!Xc7s;V0pfOQCfYs6ESADDu>$>Si-}IMBdewdR`1Zg@=5OO3m6K0WC+}eB@>#L> z__u`B(=>Qwgz9$(r)>E?b-!1R*Wv#)`}wMyDS5mM+bk3IZfuiq{w>oqaUVrY+et7fR?bQpmo_c@tK+|0z9pw(jtM=FS*M8>vwv|m` z`jSrHcPBP0C4ciYy48Dh`w#VIF zT82Fr2t2zyo+bW7y70LlOzsZ?1*WoVYv;a;c^@kBvnrA&D4VbQ2v5+J-z!ox{uHp3 z^C`@62;Wq@o%x?`)%w<`jY&Q4SGzP;P7OTzY|GJ8E3|85)=EE5y!7^xHUD*4QSlYh zN}F3{^$zBi9o!bTX)eD=(cDO>Z+2%R|w4r-@54X;(1o~>TZQo%?kEke;(U8#V|;BhW2Fs;4jJbE*Cf- zU#_crD(fu6IK!;2&#(1P{wtPu2~%c1o5kJpm`z~n{HGl373tsh2gIayM7yPVeyToa ze|XFJmy@n0?zwOH`}$Jry*GY|mQ8ey?tP}P|H6m2GxhY>=qPkwT~sp9{I!MFa{a7e z_rxiz=OQEXbKX9B($sXa{@%mWEA4W0uH!;cY4jE=FIt=pvy{YwvzyeL2C#>sCmZ zVZhb<&sv^~G3mZubclaN_ubq1OATFim6$7C54|JnzOjIXuj{srYO-$ql53xK?Ram( z&wpsj{ZqM9lHwK1V{Ibs3qBps+&Xc4|GR}v{&5F($0>Q`zb#%LwP=FQD#u&N84q~W z_gy#@v-)WK`|k_W=H1=2n^E?|yJe!QGF5Em-3y(yqWVVCw#LazG`q^o92O=m-w-D- z_jS4T2^OdK+{-;4&Yg0|YEDgfYN{_kL#EVE#m&xZIE>r5HJ;8%j$QMjW#%r?Z5kUs zRUcKnX|N;e(%ixqDJODf1oH;arGv$H-kWg5d(Poc692xuGu~G4KATxnPWax{bd8HsPHxsS zaI8MMwqQl|Q{`W+Wi?_gmAXkeFMgE2)W6$e+pp8GWcH;cj%z!==>6tn+q6NjUtVun zhnN6w-NVa{=eKjrKH7OW(R;IJm=WWWOaTGC%0FM8#B8+7e3!m|@!82{5%!LX`{Tpz zcOF=1#Zx(Pj`$qGkDHl3b^qPz#p=iRSwA*#hDp5ZllAchC;t>JvQ}BubEj3%`gyVZ z{7-M6Dc!f7Yrt^RD>?F4sr2MC*QSe}=RLA!VukGYnEAcmTh%{ta-TJ6Yx|HoEeJu6Gf-r~T z^-G%H$n%sRo%cgIUT;m*rRND%#b3g_7hcyCGwzqF64gmmISiwk(X> z-*7aeN5Dd9(hU*Lz>^$Pjf^$Fzgt#4-$zbKZ{hU$uXWvfugP(K$-naA`K}q#p0$&jy~^f76R!99s1M{T1o^%NT{`$i6x0H~rv&qh@v0+qXPj?DHe%_A3p`x_^b= zJlqcS>7=y2aG!bc-OG8;<=-T?|M>oUR!02W)G0P>?K4tsi`cSkZi|@x1p;qwo(&zj07v4Mj zFX>>4Tx$1ypW|QE{^V?3@b{{2<=g#B3`MJ~v`Wf8O}o_6`tqQ*_`Ry`$@zSXV_o`u z7OK5n`JQ`ojdZS{`JJq;&8BI&{nJ;d9;r%nR|{MFJofvo65e}>4m(PEc%uKX`b__) z_4W0%Ll*JgQ{w0QY?`&Xq;2hK=HFtEf2n;bJ-^;a``c=Jwy3|1JQw?vUKFg~yCS+@ zdz$EjE$^il?lyXRta9bJiFk{Cu!BZc^h+c^E0gVOY7a;PLy@JuXM32EBM)b z%J$gpuwXA2ONq%(WqWUU89mIrn)u(>=r-fT;O9}BFUr44f2(@v)!(m5xuNXAc?RNM z?5<5kOx7QcoP4~9`+EfQX|XPW_a2p7{=HQG5+rmi>ft$!T@EWY3Y#B`D4)l|zG;v2 z)x$!MtNng#@_PTFp+oK5uFZDub6K5kPr4oUYeneq1ryDW%X4jJIh|EB{qCi>ubc9k z4n9*5UsWpiMY)r6a;{Znj!W)RJChPw3=mnLhWcVEOSLYvFm~~lZ`6S5$7bdn`$<|wAe%82H=-szd{+Wk% zt1$@OTmIP7c<(*C#5v1O`&S;2Kcw6*`ZTMqxG3j`CBqiBFImFZ=j?O+%;Nime08$zrslPbmHMp>$4A*WgDGYn8tW~W$v!M9%UZU8*JCg zHZNewXTMc3kMGa%d)F$Xzep{844CwyDQXO$r3 zn>;Iw_Zae!i@b6#FqzcBBEw|P%&RNj1bn|{^A+Eb`i;~oue(8;nJhZiU(Edx_<x;9G^Ht;Ggqu3zD~kWbgiG%{5WHZe z*3u=e&1Ua@XH2Rq{?5!cQ|H`P}_7`&LJs!9rEH_r-?=RsUI){fp=L{gyhKXS*`5S;uGnH-T3j zjYqhPx6Db5;#+I==o}xW@sHCrcX)Tz2 zrJcv&?Q$nAwg-+U#Lhmv5&X_U^zBAL&v|8;$xrtlemlW^lW*vb4U5-Q=W_);*e3JK zw6`g>G&R5|QuX{x)@7%btjPaXQg(Yq`Uy_oG`BrifAv}vwId=rd%>4T#hmjWAN>p4zj8-e()9&TCa0);G!zb*erVp4 zV;1dJ`Cc!S9FAV$h(Ayu-UJ0 z_sw}dPA9@;xEF@bUoUv7=l<`r$Gv3bg^GVE=)aY6mwvDL;NK17@0Lp6Kiz(-^5}Q( zj8)HMDy>%w;Q)i+i`~9 z;Z)aiO!}Owh>T7PLzk9W| z37yLjo>}IZqG{PDnb^+#wzNfT@7tJ!i1451Z&XyTSs%?^uv1e^SZm&|M@M2(k~8CK zru+^x(DVxLKDJ%1arZwH%lTG!!-O_jPENS8F5_+Hiz7QaggNd#fBdrUqwc!G*|Xj> zF>SG5SF3e&Z9!j=viGy&$>+*sj9>X)*v`UOv!d2i(c5bXW8R3 zyWd!{$F5hrrf+8Oi21X7%FPcs#+x!aPVCu|z_&qEHfriImbfmzg@=m1^4mR^?BbU_ zY<^_s-bwd^Gf(#OW-h<8>N2w+^8u&zo0o-_sGRCHxFWuU%k;6JZ1nY$QaxJ=w<~=V zcTF=i56|A%84%#A^mY9-#m`B+74@(9zRU3x{;o<1o4i9-=jv|x?$lmOJL`*1H$^9~ zNU#ZuCminRPI~11?6rWJw0c2srOMF@?{d>l1Z|n6yx-#B6i(kg%YUxjRAVT9g87zQ z&!=@tXg9oHeN;XG&3k&X=UA-=wZQV!l%k3AFZWI|gE*05wb8mIypP!W* z{!B`_x0a*sSZv-e8&0;)h{Ox$M32tPjJ=^Paat;gJ8j*8NZE_o@1p{q?^#`*FJlnXU#h7*WKl?P(iB6zn$!e4RI+od~~O_||-eD>!no4&r)T5EaupNPhu z=jFDGvb9fZ>Uw@w-*sr};Uw zRZT`r=O>tKe72-$gMYeli^X()pZ`A-ZnjNVFX!AJBJ{<&FF7NA$MV8Eoaa1)um^6KX{gn^C>MQ1ZKJ;!l{H=n;dkIJM?EMbgPdlI9&OArz z;L?p{dBX8$KW=*8Te|vT-rV#To`0JkC+6>8owTC<(T~slmz%$(B>5aj;*QM>P@j0@ z>fiJ13j0G-HyrrsRulj4=ezKS*L}r~Ud!rji(llrR(^NSg{Qu2a_bFb=R9CsBO2GU zv*=}*UYKBa#mm0Qhi3n6vtL>xkmvZ1iT&$`V(+^jydFgt-pO=WtoW;Fb#TKty0EZ7vndqkHjX-n28 z3D4J6x zsm0N^qOYgjNfFBP%B|L(*}QiDwu;oJyj)VZX6E0#`s8(7>FH%#JY(X|)rX4k8(GCY zmtL`VljmQyfLprnRy2HSUtF7d%l+@ld3T?`l~j-0wA?yuQth4Or85<;v0Y{ltG_m> z>T28Bv@bW~HPYo1`95qu_F>)x{;Xs9EcqM`Z1~*T$XX+wcp9uGPCOuWBou-F#GI6<1b3MBzHWe2sZ}j)lwinlssGaq@PwQ*w90A>9p`KHhb6S+YcB)}?&j^qcSQ@^vy7Z2WcnlNGgBx#vDMmwvZY z{;4aEXZ$W_NhZnFF}fXTX@=44i+{`#XWcimVMSSeU)uHbz%4E&&jrF~7?rv4>4|fn zefg_;j^`jmAGfT!Q+`WvMw0fbuS-67 z@BRF#P4HOLlP&M68M*Y!ciy-zc4FJy2@|!>TwlYtjZ@3;=Y7r#tXFt`&8&W)>~rLo z>J<}9|ED*--qxMT+j2oa!okUSLo-vPf9v7(_XO^7wja?e{r~%o1XHTN=(&5MS3~b9 zeGXag5LNlyt@s}Iha2(2v*MD9HVeO*opjJ`!Rb>KD!Ci$FoClJO&#zzbb#cIyb?(cWm-AnjcMY;yv5lv6h2^$uDYZY%-^E36pL$@N zFlTad{GKyMV^`}sewu1}u5LtQ zbU|Xzz0T<9NwFNIN>6D4yQG=|WtvMv(ZJF82R z*F8)8w_42j`$6Lwej-l)Ik*3G3KN)ke7%gPJNNvZe@wkuqih|ypCs}mnB22#b+qSh z?Dbnbq0*sR**kyH=}!H_7Xq!9PU|T9$$sISrJ$dkw~fpi8w1x9ZB5IvWdArbyO&RR zzD)eqG7E-dryP0m>h7%BFh9{XzqtN)Q%j2W!hn9Gwe25v->wLHrd_OP|MT7Uwd$q! zIMQD3W-SceR@2z^jBDS$HEf|DzE1Y}D0!+oC*rwb--XZZb7p><`#0+1kK6CUf4x)4 z^VaF!7S~tgzN1$q;YuDI;j%b`UN zq~*1LPvd#HBiwmv_PwuNOLm`?+EOs>>h{G~xR!13^N6bZ^|vCgDPrkz`97wzeHp)X z9;J6|;*L?fzar%1*%Pb6*zz?G6-jT{a`UDo$ER7wc2@Id^@LuV5H9hPE#bCk`m=kd z;#>^5Axk;LM>h0()!~^F!=I<#vHBe~Q8voVbMh`}v-XS?-^BuhS_8Wt zvP`mPJ85%dBTH1lnQn#`Te4K|mM!4X7j#%QN8IODK*sR{y;bEpKXyDXHvZ1CdPnaE z`Ro&mnJ1c5xU1-Xmcz-W&3_DV4Iyry&vJZEsP7^yd z-(#bmZ25V4`;A_TbuB9rcC~K{3AuUV?ev9R*LOy}PF|lCJGaGQ;^k<|_(fZ$RyaBT zQeEWTw{g+7Uv?|rzu!FxEyCt9=i2(L%Z*Dnr#Zp`^UEANZzsfAv9j>|{-ZsXeH zmM9r1K7EBuRY|6@vQqKqqEEBS#I_ZiCv1sKdmwDgb}EpA%j{Xq3%~2fH|+{=ZRI*T z-&a+S`=Ak@O|(PW|Bm?+E*_lV6~PsM`Dm>ThwMR~imU6Nirkp`BB{R7=H<;D{Y=x8 zv`+G?vdiD;Db#h5p7YZqZSlu)HmwI|j`uQdJbbpjRor!L#o>oh_aakv-8JoU@DK?- z(WcIKwMEar_l#xMX6Nj)&i6K+k}=;`KE0#GF-E86w26P2$(zOnXObHaea@cxw|btq z)@AK7_JD*JW&yiDY+tvT=ij+|J@a?yH*PHm^euBcqnrE4wTE%xlv&58wI0{{>2XB1 zWnX#uBBbGV&z0wFPyUqlZ>{%<2vu1MUiSO^Ap3F*CB7gw)i{c|K9WbOKtp#iOiNWW>xUd(A+*p zvwKQQcuL=a$R4fb;nr^q#C@wLA6Y1{NzniDOzpbKON@0DcDNa;@ITMr_V&cp8P_uG z@>RZtF4O#*G9zNkTZO`>M}*hJ%(*ChddAb;j|2-g%BRF1G)Sql`mtvHr-FD>k)skb zzwgbFe;pI6w(YUBJ-SWu>aDj*LN~V?&8w2ydiIv>(9xMb?X<+hieq za*mtMd-JWC)h5k*XNv^-geC6kzp7_=@2r2}bUkabopEqy>%u9f z0+H{W`wluRerr?z+hbnT3mrX;(wUCwsSY1R0#|aop3|1<%bYQl|E&#gg@e=HuaBmS zvd+Ee-=L(s$tV57;f?v4`zr&wyYI@Bni^T}{wXl!T=9e*CuDE^u9^46B# zPCMKEMZ5KSx1T-{y7?-DUXRbtsOI}!JCpV1$bMxL>|r|jcbUCm);HH#H%g~Go>42` zx4&C)-^>j^`kR|>9t%^ul&+@bB5&KtbpFcMGe#ys7pCb+Zhl&JrOl$lO;C4-GpkNc zjmfHIJcchB4Pm(pGIyP<2cNW!T=&?@NCjqfp!T^m>GFaO)5U$TXDl1ZD8-9aAf%jGgfJ+GO)7oYgC z{jqr6$Mc}Z;A@t$G^CKDoDtoJ<0ko1ULb$$Pr$l~qq)ucCGu|6*Pvmwv)e0HN*9TliS3(pV*=;%Qr5F|ylL09?`S^DzR{x+ZnE#b z!R&jN0^f4gR5ETpbzz$jZ(6>$yWU$a-C~*3XVedH_38W7KUc4VPTVM*5i;% zZ+E(V-7cim#U%Lie#(Qqk{{Xj`y{W`bXQFIm?3v%!BeGN&WxNV#}-ZIes%9^-_F9f z9;Tl&C(OTnWxnF!+I}%vTfMBAeyi{4S*+T-V(yxNBd>(Q4ex8K-|2Oote|?9CE3w` z^G}-@@kcoBNc)Q4&-qjPy;weDY z=W46v{0LnR$$n1TS9KphrW7|G^glPDyZDky*;E((E$?5I?P-6{9CuJTRcFujS(84- z6dG;3*&{W3?&9BVMqd3{FW0g9O!3X;ax`5$@gVb-o)6KSj@`xAW4&`Hz0Tr2RjXyZ zusb0`Yu8Hm;)ib{4rVMLfNkji^CRJzxma(=h(wHoxz{{%N&<4|6rEN zoqzW0qbU`4{$6?36{7g%;wWw7i#^~StkXC8XJT5>9B_5zpB z_cmTG+i7uhQg}!1_U-d3{o4B0opO@M485rIs^+3~v8TZP!nVSmlv&>Q#I`&9xNtxJ z&>H6xyWRekoImt%$~o1Q>sFOoL)6VjkMk-?uZWB<1n0v}qaX3&VJu8gC`0)U7hy zbLw^7Y{|`QHZ}P#KiAEYqQD>78*YAj>b~IZK9}ku7JgaFbLegV9g5&mn|l+ZNlOQLN^t*hgXX|TGo?}xleB#+IZmn(x;U>-~T?{7ccwc_@a2ZFEe)(t~xE)dc^GL;_Y1fU36`C zR=S>d@#ZvG>gQHh{eJJ_0}D3P7;Mb0a}Eyqp|^4AG@tkGS4E_6mN{*IRKauZjYgUs zQ|ax^4cz4qR?l4-`}F8Rr(mhj;-H=N5zbMwEIcx&T~3vC2@J3O_MG*}w)^)x*mssa zFN}MxxT4}_g6>@tF&;}UwOnzX(>(u$kDC0Fb6>i1HTQkvrcX(iw&%0{TopEDL#i#q zYPR=+PG&C)W~3y0Ys^2WQ^Oi`!A#YDhtG<`OQZG~$iB7w`Q6D^a)0johFd*-wT8E| zS*jf$N$IYXp7vkx_~Y#%@+UNe6M0kqy;Mtge)XW8@6Vza?RvTyCTe~^c{IKhJl%F)^p)KkLmi9zhWvAXlsori z1|Kix^;qaVv#D+t)0)Q-t5)sXbZ_l~Cf*nBp(T%IAMGpgo)K{?(c?R3(RJo0TRV6+ z1hG$$Kd`glNfgufC!D`q_uuQ{F@2rtYP-un;jD?H=2Yv|qQ3u~=KVjvTFt)nM$7$< z*w|TWee<6`?Qv@Qe{zY?1@%L(Hf`LfvA_G~p<~|~FBqLQ@sEF^^-cPw#N#gh8&=Dc zeq9UkZ2tN8>h4<>e-)OQRB=r$xRb{3^ml0vmz}oG_Gw$hW^6Y3#3nLDBVRYl=2Wpp za*S%r=0MhUmi1|}x?k3Bjlb{K_x!Ql8U87@y7y_tkEuI6mRas^d&73KYwhGl;Y&HZ@05P4i)=`d3=eqH zwK`|#X8%1e#a}MiCta^H?faisZ|Bw&bw3qeTl`{6<`uimcoh5f=B^duy-%NiVt0}$a^ji$N^o_J?hkb(!vlvs+d{qvY+7S-=(|Lq z<=R7qv76L?_MBTkUBIh#)_;LHMsu&s4rD9hDXm?sVZ0#f`>jnA%Ntfyt$2uG*jRkP^?vrOld86RW0ySnbShCOzGMBp?N9Z?q(VDS zgxar*n|LYFaA{^J*FUGpMYBHG9@klSXU(nhSz5LENhWLWFECe1$VmPcw)Il^_L~#e zta9luj;yrr*Rko5blE;ZJ7U876W^G6>y|$K@nlgL`)_Z4(YH_Pb}H}BohO;8n9)*u z;H6$}m2@OaeNJeQk4&w`ro6>sHb=}DV~Y1&z2Ft>w|k|P(5$ZqZ2QGlF8dQJyHQ(* zQ|_YM8Mff+2M=dG_+HF>&-rd}diiR`a*129%xbsd;&r1dPls4oh+L3-)gjf+|Lg6y zGXMVAvj^%uKlkpxeOZ!ka@PIzwd#yV5--pHrpV?ZxnAg+`@}g4sT%p;6>?P#vX11d zPU!lT8@@FEpvw&8wg7 zFfqisF~z{d*o@eXDdnjFvS&8wzT-Q{Da~}SY4`5k?ALoY zZ|vR8$}b1now8&1?%ml1dFRUCS#FQJy87qky;Y@WUzz?**Ep&2#v#G9yjsE7)|gqC z-yzh=b>7U$t=tEW9O!cK)O^KZ!W4b0@kq}B2e}5d3nB}+wy+y)W{8+EW5z@c#zke{ z-t|p;CYHdkmGi82|sQx;bLJr zAm-38b1AQY!m1TZRM#qSE|?Y)!0y51=-{p_-7snM#@?lz4(Beha1=3JVmR|ghSBW5 zAA?$%Lh$MO%%Y?p?hGebUvT`>K6B>cIWYzOb!s{bS1e!?5Kj#eW|e64VJr%&zwMZy zK5u`{g3iTn_b>a+#_->Kli{!Ylt1@h><@L{UhmH1apnv|u(z!we_TbsR`Wajz3wd4pn2hq{_UH`+zy@)<5(cJb@SG8HfCAIPi4y- z+yxwtp1a2JMSj}EwM%<{|DXPSKTqa{i}CU;j?e1nCjT-|d8v~4lFcM^6U+atx6Yh+ zw%+ysgINda_jlV|xN_;{xBGt&?63P%8yIXoq4)RyxS!=c^?E5+riBJh4qEX0J=33H zG4`1^W=1ugVO;fKf1H%%tbgJ^maj=k`T73s&;A+zbA%gy{x7Oj-mrM7v_pI6!}!++ zzpVc}-{bxN2qmSmym?>F%*kP>3QN;tFxHk7>Hf@qw;9`Aj+O*0b&Bp;p`ZZ6=WJcV%#oN76aI;A@`=lio7a#JvTIbIA z?m}pSPbACpI0kR%17nJ{L{pwq35@OEWZ`iue{Di4YRe{c` z?JFPNmh{UJJN|vre8bbZ$9xOZUOo_M_j|rd=xiC6{#FG%9rfY0=D+zV z?6ag1Z>7s8Ba^DmhQ&gmrfj_xbDk_VwY=e!|EcZp-QVvO>mC_~7Ek^=H-zK$+wgvl zrEOyO{bw_?UuDqDpIj?;=Dp)a0p))wiU;JA@7`}}XPbZO%HD61iJ^;fZl96V+A8{7 z>%-^M(R|!;{~!GM5$Jay^MJ|PuBRejyW_O8Kc=mUTA~n?Qs!)Uy5ggV_qsh*49Cs} zYW>)_YVM6&A5KhdnkJAcbn3iAg-?)y{F|`YuWtJCh97=TdfCI8Bsb#|=Za$H1#0`g zObp&O>5-%YH(!^WN4813t^G`ks|V*S`m|ZS=0&K)?Cwbms`5km>K!I~d7b&aEmZyW zC++DzG7`7;A6*}DO=hCSI`;QDt5pw(%V+*Q6nbet`vV&pA0M0Ac%Azil2N~>GF?)s zyT+`j7Sis%EauRyzmsm}YEO_;>5UJZ(fUAg;mp;q56aB>Xq7LU7uan&+bdq5$xBix zB5HnDX+TOi%;D76Y+H4R;ettc`Py8q9apn=bL?5n|OW2J%-lWTVDkkpIzeT zTNW-8VO0Hi@B4>w?8l~g>`Isz?_wX89`QM&(|y?`mw7BHVXIwNJwNqmm-*%9t3mUO zSy+}EhWS`ujhwQo<={(C!)Z0^Qr^WKGGzRj%)4sY7qc%R7xZ|205vo%`;pK_}?Gpu9UoT@V`qP3`K(Y^~T1=slgEZln2T4QEq zhjH1i_}$_e&Y8CT*DaRR@a?|d9dOxjcFg(IzdiXMME+;#??_;tDp%L`V8%5!-;dU9 zK`}+ITuv(d5}et!BB$S}xT|KF)|49t6KbAUWjLo~ZJ72>fOn^sM&KDqr$>yxjQLzN z(j_>fl@2~&n;KnkLI3O~EsoryqRcSmWB0TYa~I zZEM1hA8#VUtCNhvuwW8+Rle*Sj!$<}v8y7z^` zt(!h4WtaY*mc%Nseo4UrMd^QrN^8W{2&TVYX20O^l4*h8jZT$lfByb&W>t8rcH-pkA??*~0yf)uJAF_-Q5WS~kmn_| zSNHH*o91m(tz;|~7@cyA4m`6~=`cp+@tVgn$z+FyOhspm-NjpIC*7S zuzOwL%L#oB7L(O@PTzkKnliaQ*w?@mMdr?)t?k^1rs8yurB8=p)l=-bGhDW3&W{ zJeKsn`<|p)%h9=%-SLUd=J`!>mw%}rbgHQmK3_D~`u@Y)OK*I!dMhBdsg7?Q%N?=Z zry?vm(@eh|3)NkD;pKbXi-C$sdRLF{D@^zKteQo zT(5m=_Ac>Xh8IevEqqhUWqjt;DQo}TJg<8dSA8h_pvIV3HJh`(Yrb32vKi}t7tBrC zb*mtG)4RU<8wbAgUs?UU_^ZGD(zExLw7+kddU?VcS;Iw*k6I#CwBLlw#B|M?q7kyn zzj~hl6KBul{&T(sYg!L3SZ}N-w`OVjwCt0g>ecTUyClWBTw1w>wWdQsMO{kqvFaRy zgf%9uXSnXAnrun`ysQ7bf#Dur>p55I!p$Z(c;A$BIDPe??RxWb_uiL^@bvFDDQV-q z*M21X_Z?E2ejGF03ilnXTpQ1GI^*NCKOV&|qjDn}uFbx1uu^X0uQ|`2=dVplztX>@vdKv- zA*M2^#pZI3m_pKtEcu^yvF-|7#%Y3OQ$45KP1$?)K(?&9*zN@kz3bnaIlL07pQjer zt?^6J>ygUb%r_!$RV%;GjlKS8g2noaC6deJxkLB$YA;q;eB*E^x1f08v<_Y^%S$@@ z?#XV|y;UELfj82M_(g4qJxKbtqS zu9#ch-KuagZKL*=l@5(TU;fr)-N^dOAKVoGwrT3QwCR2Iwg(gWMW!8EzfE0mB1g(w z(YxE3jrGhl_Z#khaLCs8c7sFgaHmbCrZrPBeoR{e;c zvDb;;QC6K%>o??@AIGwhWI<<~}KilFtQIXxX89_zdy6RqMv)<1#Yazo-3q&sybHH|6KSJ`mIrZO*&*ugt@ zS#Fg3bB#~Nxo6g0kPE*W;Ia6h^_h0vz-jxg%+``%GQW3izT11>@Sv4T{CmZA?)d%V z#!)95YmEMvY{=;P}rQX|0i%G7)P z-U-P+t}K68suMi(v)MjjX8pg9YUj%BT=xH8np6FSvU5QTZO_Kp78tz$^6uiPj~^HI zr?m5Pi3|1C-!wR?s4lLwZi-Kou5Bczt9AP0bH6g5r2kVm`XGOG$2v9kivk-trA*&9 z1t)j-Jo$S3mfsa$p8pCBYnIAiwEXaMORVa5o*nbHExQvSEUWaUyW{H7;(4j{>rLBZ zJ$_u?75V&=tE<@^$7iqoC-+|48J!@gldYO2rpE36_9nOAoPzol3)N1)Wf4)V?FgJ2 z9mE(Nc;d?9K#eVtzfOY-nvL046rmL>W^y^fy zTz<|+)HL|f`hY{S>(({Oyt3H2hov*Fq{Ai4tZGWU{JYHE%dY1Cn%I4o&9kb#ze>!^ zZhx8Ojcex1d^$hs{8p({|1v}O#NW+Vx2~V!Rjga`EatC|E5{uzV}V0wG*XMMxlEd1 zWb*C2waX%%TZ$i&79ZPrS#Y_=9=rD0>0!_Qsp!2BF3ib#dco-I&r7loTK`P;N_j7B zmi#a*;doY?PX9Mup5BTzN8EG^r|2~3xpCYRyVUug8i-sy^AhDzvWm)N@(Q-{Pq7G$6}2bzcKNPvg~sp5}iKr(W|hw2EtyUU^x5 zt}E*c!Snm{H|ts3T7<8;xh?Wc{K8qXcDF6r&ev-jFJ6D`@L68P-Fk|X^QGtZz4jMO zYkBJu{h=bo_`#WVuG|?xhdyyFw3d2cy{47#@>NfRciud@j#-kQHd+bRznU8vGhJGD z!WVB*>qSA+>o@eAnD^|xP@L)FxFuKK&a3gR(V2DGT*5bS%14L(IKdY$)L%rNkvSJ7 zef2@ue0^7N zX3tT(iIN-vYF}P+>j+GCc5Jph_BbepC;q<3rN}b>&sH3z9~MOOJ(~3SaP}#YnSa(z ztUdZRfrWX=A=SHiM`R|REJ^Tqnth|V#X#oxxiZG@e+Ah)9eR&mC|;%DaHzJ{*!--4 zyQrLF|E=z4x8Jm+woGi(XZh&2t@%WE^z4|P*@x5nlOqH@^lO^=Is9`4dP8*dE$`|q zdEe8$rKjy|=^CmU^KWDnLgdZvm zoHEbV=>(JW>sy+eJq|3MS~flH-p~FAop&x=e&XQtldn2hYFo=M<&Uvx0!uF&@i5q* z?6i?>lBtQanEyhYy}fOsjq90`iERBlb>455@=vg=-J*LyR_FKQ>r!U|y3)gwBX8-x z%AELH#VAB|-|R=z59zPhd{f?^Smp4ixVZ0CY}4z<9evXs7xVHr?-u91WZWyyl(;8< zzuUY`z1y9@ zjk2fPXn&lzGm-kw80qZE^KX={eYIjr zQ<(E~E+@%Gv#`^PIhlC*%N~gsEy}H*_uPNg-g1$YdVc#m>)(Aa+sX7aV%zIYH}-GY zC-}W8EWy1{pNlhoky%c2rX#X(=E(#=KJB@CUYjlub%MNa$kAn+}&jx)A{?>AGjl4 zE6eru<$C)=CEX2ESC;hZonp;dP;$TLbD2&1p10YnRa~XdKmRp5Qp(Tx%2M^^w~IJt zuf2OG^Y$espFf)Ioh)Jdx2DgqJF)BByt>=_pW5B}V4Hlp-(vZLxz`toO5QQzx~39g z*RtyQ=Ky;l+vHES85@5nUR5?eT)lR7?TeyKYpx0Vf2cY?HAM4kQb>fZS)cEsyUV?4X)wlYWmqwkY!zH<6!T{Zf9Q0K)q z|Kl2UcfMRx$^GDSo2&Fo_^nfK4`zPd^-K6iY+cC$*5tOg(q#+n&()sqUb9KZyiRiB z|BBo5?%(|wq+B<5soDPZW!Gj{u1fs6ir>-Sb%8^<{SSkKKMmKUDtT{Uyl;5KG|c3? zwU_Ru>HX>zW+JW!W4_&crpBE2`fbQk-vFbG9>?0h2ZWb?F!;_c=UyuH^6a*<*VjLu z2r9A^F|Thq@lJ7DiZ@?m%I7_nd0nqR&@c#&rr<&=)5nhO^Ee< zmZ+41^))FJ^D1tSm2)37H{~m0`GW zzpGKFR7BD58iU?$X0F-4XC@z-=+!F|dq%C;M(3PbXrI>uC98efVFLZ#*?X1l*S1(& z9zW9>5|goP?hYQY;tX$Bv-?z#dwlwWL zKTppm^irGiInjcfjw?=UE59gdcyZCm$~eoQzv23ypMQ*GULX9g^6vA2)mDpwx5^#M zI4@p)U16=++h_7`_TE0L88kOi$Gu?JS@xf+V<$=|%&WS-vD`J&=l$flM%zPzw68_I zGTL!nyJL?_%)~YPjI%2_XBE^n&&v+m{>0(orDongch~oP+<5bO#=iI!n}rXRuPFR+ zZ}yI-r9sbp9_CnHd2;3Pr_NPBHX zjI#BiZVYse5$Jyg}S$SyuDP-s~L0Sha-D?UZ>ELxbIw%aVk5D5`UcH-)_BMbm>%< z>jy&}S-kVtC98Gn#@=m_F`In-eU7KWM$ee*UmVvjf3o527jCnbFVa&U@-JDWd!Nhx zaK6`+-$H6`K^&8=oP6anzjpc@+ZSB_vpO7{;Yedbj?Yn9HUqbz=zX5N^%jC7u{fXOj^79=n z6+iTt2z@(a_rkw^e#5U7k=)h0FQrvR=ilW(UyJ};a zv3&cDJ-b?J%v$^3T-kCaoXIq9=7eGyRT~+>e<$6mz6WbLO5c5QdGG6Tmsg#aANw+1 zP1zGDaXire?Ia~(y=JCc^Xg(Y|6mBp=e4`Y&G&;XW_?JG?Y1P-g{`Gu9O{mJ^veEI z78mS#LgdmS{lDfWt(*}HPsM2X#(fg^*Eo86VXW73<;R_TA$3RgcufB5mZK(p=!Ec( za|vrSSAU%s{yk4EaHqU|`_shCBT_7d{CkqGKKAlp{cdm}cH4`0Q|ErFv|%pUKhrec z{GVp5`+MhKQC5O2=Z-lD6*o)jF5V*Nw`u~Xw)LKEyn8OmuCNeEwRzpIa->tf;fC17 zb?X`BuIWxWdNJ2w$~QGBd(E|NQSEYp0*j7Js@r$O&Dd9#GdO-hgM7n%0R`92f?Z9| zZ71r6-Z433{by2I+`+9OS1lMO2Q5GRZIQ7(&*e$_Ict=cIj)?lcu%GAHy6=z+ZwtT{+%qp zI&<|2@4OuAOW)HE`FV66IV&%oC@^KRo%_mplME$0<<&TM%y_LRqoX$2er5c^2M_X9 zggzWK4qCHfuE(x*3m&^KJ@ePjPX0pQ$C-*Ie=PD&UOBWzM*N{-;AwNcOg_8E5y6*F zz8Bu-v`|aDwcyB-bMmLS?yvTeJ)1GzMQc*swP%@;uF1Q1-w>1Pvb9btJQvNb`uvLu zTgcJUf}#`r`m@*Dg@k_ob?3UqiL9K@Gr51SGcNuT7_R?yLXFdxPwUrS+AR~Jo0xaw zbJaB`W!w7Of?0QucupykIOD(n+ou!9U%krM?Dxhq&c}Prr^#2N7JhEkC^nLq^jB)- z#Kqdx*Ly@Ib+s)dt-~Q_{;0Ea9uegu;)1U;o}>s zew<9QKK=UOk*!}|DGSUvws+s$z0*`)sjl5y+q!s{^NlwPuWc&L*16Pv+v@Nx*-a7F zKRoxRO1t#_DV58f?p=0OX5-x_tB<8U50UEEpWJfA+w)y@!*=F(^6l9@0*|#`|JEwA zwpZWzisSvRw4%rJ%{KkoZ!d!O`RjzZPK`qT;M zUo1;qY3H>xcSW8_Yag4L=*Zxib>ou{8u{YPxGhQMZ@8K<CPJ3Z^E10Wy$(*U0caLhcbZd51 z^N1gv&9{wpPL$)TJ?8O`i!^4L<@|r*FrVLW@fu&w(uU`&&q^PTvGpmQ{epML+@A_)h~UVvHIEffNsayyj1=I$zbvC zD|>}iq%JLA_ELY>pIcA0f?g(zclmgE)Y)%l_PPCYZql^_PoG36wkvL0yYSoA`a8`D ztrvC`&hI@Dc;j9{_=fDI0l%|yoRdr6XVxvLoqwULF3I~)Wc)_1hjSlID{H@|Ep=P% z=4tu5a|u$x&xH)d16%XjmLHFan;)`kmy6nL z<|;QAOt#-(BK>M}-V9adofp|w?Gk($y;pnsRh6#2d>vu+{XgbU_F<}AK8dg6fQuFT z#ILJOtb6*(mt9?BvF)(s8|T1Mx4?D1VK=1I97Xm8bBfBBKjv(6{>A!RU+0yoO(oau zCtperYIXcLb6Vx7_{xud(?4<*xk+=scyV=AT~%o$bHKdCn^i7-v7GSA|1Ptd>7f_% zyeflaO%#9LYFB!`=CW*ir*_X|#d%>Fe%Dlfd+|J*!+U2=o#9Lqshty=+gq-F@7#Bl z+mKtp>V2rN@N3KMt0T-WYMxG?;$pJu?Ea&VZ9W8PJ-c=IyNuzIH`RgNU*B#P%$B9(jaiE?cupu!>(s zC#Z43<<``*&R?3m{q)T>=jX3Va`Tt#GAeOhx1RB<>z;U_zDKRU=kE89p3z({C?IS7 zK5d_@b>-13%8$Ryyy%wdx*&dn@AoSW=T1E>x%h6m#XS4DGORAbMScS>WYO;q zRr@mwT7N&B{x~@x?C5T%jOg3GX7yg_`%81IeC3v0uIeqAQXV^f)}y2sv!1S$^JLX_k>^RUtc5~c%oEq zKI2xozPoa#)mVG}8o9rTulSj;rK0Zq{inRw_UrARoMFSRmbI@$NxGS>cKVbhw`?@y zZgr}v?(SIDR zGvQF>Y)!FJt@-m;hRv;>Q~7YUluad{{FX|!)J3kBWm?Zhw?RjzQ{i)S?8S>pVw&xCiIe*Q*a&KXJmVBFZ zTTH|>f5R`g|GweMJ5gl(&*GK!?->#Q9{)etETL8sy!y?AoYbOFu9Tv3HMXgq#**gm zG;AJ=C9QnpcWloUbtaXw_j?duL4iY*f4yc>6H zMc=$Smb>-wUYkN^g`MtMz|6iW=a; z*&n`UxpU3Kl|}deKBzjXK1otXF-n`Qef7iJl3hOR#amPL_gPtff2RMNC*OxPE>1z? zN3wYTLyeC&rc}wM&N^wdwyo=-`uq$%{+08klO4a5-OtI1H>fPuQO%8;-OFG7w@W;A zgN)Sa##t@5c>i|a*U=WZDH9oKB(m49@au1lrL40V7VWyowD6Egg~)f4RVrt`Z8uSJ zI%aKT$?;_!>uK31dY^QxL)yhUeYBeHuHEX**(h}BbzuD$maEBy1n1#qKKSx8F9cRMfrLRL3&W^2CG43Ej6t?*#lZaGAzkxjNS?XwK5I<+W1; zH?MEaEbQP2opX6X<$Lzmx2^S8{b$@a^+J_%Tchc$OF{DA_A1<~lSy{!IKt%5_&9Hh z$}jGMT)SMI-Vg>c>bjB&NYo9B`Ha#7Jn`d_|_ItT&Oy&rmz0E?(2U2 zOFqG`4HM#}`demg{xQi-ebF+P{+P}q!u0Op4b9&(H*1+ReLB7NQ2L}* ziViH&v&^|{o#qJac;C^!vdy;P&uP=`f%>rz*4^v$Wz0U=_2`=1+qWLiF1*j}=_!cY zrhF@8;leqS82>&?+4y)aw^x_ax+9Nu8^n%=UfDlU>gd$-if=y~FSa_#wR&3W1^(FI zmWyJ4hJE~fC~8(o&Qtxz@{y_c0lM<(HbLmQ^uWxD>?sRMD{i7^pAEhYCvn+Mpl5T-O z%S+vN^ADe{xz2D$$+}8?$=>Jes*?X^bO!w~bnoIlU>Rt!c^9MZ<`s*wt+HNhU+B}q zI``ezWRLuly4z(vUT@-5cQ+F(4dB1CTw&(?Iw^Ub4X1Bv#(#=txPLe~qbjOq)#s&= z?<<7!WR1jliZwc(PhL^hc;@cgl2oNW`RW4#=f9f1P5dCb{`!ssn;xe$uAc4Sklpo$ zC0SY9>1!5|9=zOZCKRscS3K)hKTv+;?tn$$IzKORp7X#m!f{UKM5iJEPh5zKyB3(#4XWKhG}~ zJmROMGWCJ|sn9DQuU`8KLou(4z-lWxVB_`!~-P>-_8Fd{Cr#)OP=@_|vQH8;$FW+XZ`0F|I@fYs+ z4=yGFyk2WkT|R6U+E`=Qw&o3=mExpn>%VcOpHPar^5A8`$z4;oy}G%^)?4ZO#>E$v zb{&6N-dHk2^2=WKjSJtjU0uEXVY=N0`Sa`llo&ppHIZjq>HREO4r%?GN6Y^+p1&nA z0n5rs6RayI&0%XLjTDRwEG#TwTw?_T7*oN>(8SDC0R#x2>7BDPc!HkKHr=RgZ-0f| z+?IPAj^ehi3VZqIZf)6n3-i1ur;nUCW9WYFM2*L#_@r-TdRp`Nmi27uDdCA>NHt8A zbYt@iV_=pw=FwcaVe-m_-Anh*?O52YDeiFh3d@3=R}2X$Oa_Jq28SjvwY-(JnX7YF zH-zv}Vlt_n4vQ z?OPw6|3^>Ge0QJa%^jb)G5-|Po~7h-PY?|i6q!6dn6ZQF@@fudp0_>>MneC6wig#Z z`^BD{^(N=@`d1kYdjGfP@chq~{CoXZ{lim5h{#})~ zXWlU8{O6p#!|IR!D|x4L|35GX{8_B1df>>FH}YFn_x8?NxK^{l>BhZl2d^Hz!l{s* zpY$q)Jz$&Rmf!9F{y*T!)y=i}UqA7`xZ=yCAN@j2WzYU+xS#ese(2l$4NEuASlYg_ zvuWvR`=;5FxBe(!+5h;}vj3K{k-@^=;kW; zT{wF367zzy4&T?SCH}bnL*Dy)eV~)mH#yL)v^)$^X=-c?%G}o64U=0>e*eEP`^~E- zDOt}y<=_0j@@f5_`t6ffu54dvc;?xxy@ur-p;gflOXp{NbP~1rdT36g)>kRz55IEm z?={=>w4=52-$~tblezpFt!4hzED(Hu@a(=P!P*lO_h{a^`NikVdXBrMbG8RP(kkA+ z>+b%p*7v=FRpkj;H?|!sO87ppUvFmgY)7sTW1X9o;iW-+PxqX7)MLmd8r%H9qncCt zw0_y6DZ8F%L`K~&Smu6Zs|UB(Lf3M)Kl$ym6&|u4WH0!>JMj~Un3$r z=ePFUE&M_%Cl_wfcn~u$;cr>SB~8JX9WDh^Dj5ZjrKOo@LEE2r+f#IHIxlV%y7H`A6|zv)ORSswgx7W2W1fJs_)2VdEqa@f0ClWFo4qvwha z`(70XpN!L~U40_5if5BoTXp9t@7=b==PKJIIr)O$L~XgQnsBH%Wc8;@dm@S?lfGM; zWZ5-GcA1=;%2~GO-rkQ!&x5SWTTX6Nb(YHRcw4-6!kzm&Ok^MC{zF8~sNFQ5{ z!IIf3t7`Y(*~l{^K|K<)63=xyQ{mOxZe8JJmfmZ0bW7-%Yu{62CUe7 zI3zni>h8Z)Qzrz9KN3Dze_uyHhAZ=a^SA#TT3aueeP6IC=H)}}?iPRkf9w8vP3@d9 zrE=fBotvU0)<0Uh|G=%MJDftMYhOyc{QGm*9FJ$EFAVyYRwqn*T=l8@>$EQ=XfGQw0w($-930 zv*y76BLdUkth`zKMBtj*O0h|-d&_zwOxl#g~XiEi)qNxSGJ(eq&QM&An?k4|>wpVoTh z?!}WaPp+uVb9!-8Ol74^na(2#mx4=Ad9wtal2l@6$7P0zAA9MjcKK}EgnGGH)&TV> zt2u1KUMBx|vDUYR$*KOz&FlIKcdP`PzDc~_eQ$zewt#+r1>MoUA4H!0J@y*8Pm~({8QKT~Kkp=uhy3@5>o= za{d_Ys?V7(`Gz%kdg*uO#^il`xl`x5l(p6tEid?SAx-Go(of%~%sDRlG3t(?+PTnz z-%=l>-hBDz6j!oSHR;%a>|2VdY=-%d(yAEzuiw5OHFdU=`o)GF*Bv*@^SrmSfA;?N zx$?;Ac~dS#x?g`9n)l^tOljb;%3VBR4==YGpN?=8nBiFA+wOapOeD&b_$xR7VTJ>fno_ThKJC*DK@GnSU=E4J<5=eo^m9_OS_ z?>YHkq_;SWC>Ev$MiO)DZkwST!v{~Mc=rI#1@_sw|p z@sTr2ox5>-_?wlbeO2ZK^SxGj{a7oyVcY9f=k6_?^T(H^(wY0A(}bI?KjmViPBDu} zw6~NgUntIRiT*O@Yf0zt1NHk~Z@E)@RIlRNwDhYxTKAj%nt6t4a>~kAZ-p;DdfR^C z;qJ&ZCzGm2TV_exi#nyt+v_IZWSpJc?fi0qY11+tHa$U$s@S+?vENsj=->ZoJ^Agl zIsM0?BZ?}SN?z7%h;;7!q!;^7blrs2yFyZD+*c|}*6Mn8bjh`(+O_wz`XZ&duQ@Hc zIngsrc>achxs3l#huwd^ylLJd!Q#~|o7bdFDBH9zDVX7}xa$_%hf7an^;zNW!*gs0;*%Hb zl$;v>U_l5U)2i)(NvEF(?s#J7cdh8XvDKC-`}bzK8mv4jd14AnzTXM|`>oCCH)7&_ z8kRB!2Cut$^Y<)iE=Hf84lDmwGGq z)ZxjbT)rcl+A3cLo6qIDo|WX@(CWc);_Q)QYtIEgoLhOb^sIz|azgK$Ba@O3`OWWO z&Ut%jx`*r%u{lXK8s}7_QcSiSStwEQ$E9|Wb9TST6Qz`0Jm)f!}n#*6wfJ((hJk2QNm|Cyk zr;&=boqMKSdUSU8Kx$&$VYp=hEYt)G*)<5q~P5U9FYWhOSG4|T> z^a8G?oVdwUMqftW70)>eVmU zrU%V`q_>+d+49EoNjARvo*OiEH|zeCnZHJ337_7cxVW2vsVuC||J^z6IQ!Shbd5Vv zPd=^n%#y#xHo3FA_Edeg0cTT>On-gZp;wz{%D?D$`?D6Q?+^y!;bra?Y69 zY-8b#o9li(Gwa&BSFZPK-pVJhZpR)7f01bum+_Ou<tml<&uH5+H!b+3x%tC8 z^EokJq<*CFpKjRDA*g8D!X3|IvDjdONQV%6+6E=>vVc2BGX-6hG@Z)D+8O9a~+w*-E9S-YyA8(<$Bzc|ssd=wz%YJ07o1?^i zbu-h(8DDq*W|Yoe`b$X3H~GH!fjVFI>dy4NGj2DT8H*iM`BHcLTlp!;%9Pl74|W=F zKQ}$fqGjXz_U2MC^ZgU=sKAW%RepsdhFV>thA) zySHw>uD_*k!%mY8c@=7HX(3tXxH~tvU;FL#LV2;ws*sLCwujDp1>&Uc`t7xJf7qz& z;eEHYQ%Yp#kz1_KHz*1|7I*$G@SXALp>^&4m!0lR6#rG=B)_&&=hlbNnehP$x0-%G zV|gl6UYmKX2E0>py&0!yhE`;>YW6`BgqaGZlN>MQzQ$ zldCOPmL+tq{w06LvtBc9HSf;}?=n+&{{PGocqt}iNW(p%(c8`La#&Zf=o$@4Q06vH_W zwywV`{P1^ez~5tzDOca#P&%}6d365Oq^-fT_4b!eKeH*OLu_Wd+Wn|DHOaTqI*Y{K z-(I&kXa?tcg%dH8)tAUD*><5UX68NS5{U?dz?$VNxgY)IyPIIJD`ozk7K@x`+p|1- zIp1zeWnMhj-s$h7o=LT5Gj>GiYJZAOTl>1k>Gia*jdrQbxlI##%%8{c@qUop+IHVb zUD`wUOr-z4+JnW1FUppCt=_S0CL2fKWMg3;{}Veqir)7nOY`oW-KrfRU{o~Wj^bVG zNsW@tjzOjQE7tm?CQ9;dSyn0?x@B&(>wBXg%Q`mZ8+IORf2iN}=Bnx>v+{dgpQZAq zM~d!QGl%E-)UAP{yTy!NOi6vy9{Q)J&vE;!P$9+7%6?Pszg=pl)AZ}`u?fE%- zeY|6)(ZcT^4i#3sNV=dQA8LEGnKkY}{JiHU!xl+o+KZ<7oJG3^n=&T)VZwbtGRNwmcpL}>tAYbjClMr*hz+G ziTJryN7fr_7lb}`3iy3BsWRAZ=eHB@?VOIQeE;|1iNxEBa}NcsZE}vTJ-{$s?asdU zGkRs7?>TQXcMG@c>HrHDQI{o`oL9zgS|hFFz}fl!e3Ig<``5OOy-|TyW0cQt?54>G_lEv{IPP z?Rljo?N-+lv1e<-`kDJ1C52yoF%Mf%xMIQ`p7&e3FHNvDO%SXssgs^qv7(tnCu7n@ zi7tZ|=DWX7`nHXIx01sJj_n4gEv;i@T;IPEj#ue1QadH_aGu6#1M4EiUu=zQWtK{8 zX`1)rr{Rmxi*Ih(C|Nz*5fOgk;-`wO8|ozguB!b$(|J?xcfoJDYDe2`gnpR_iT0gH2{>qd*hp|rRIH8w*P5``=gk5;_B^|9p8lYfTQlVFmzouV<}ydPd3JAHuf=mB zsCMCoH**n2OdDtcLF3e-a)@N^aXAz>smM`=v4VzKb^ zuib*Luj=2csnz;E#pulK3d8Rq;SnlDyFRI<-dgx{QL+62MjtIM{ay8eR&O7Lo8Rx? zT(x~}L_&V$!5iC{V*k2^Oup6JGO1zeE1}gg2VPb)9Dj0fh4j3YwrUES;tq*d3yZ(V z;j`{Kydm#Ls?Rmi8yt)Gz6_jjRyBC%riAdVhjQ1&X*nKNZJedIEp_@Gk>f6Zf>->0 zw$A8VNL9*vC4;Luop+fv3bJZLWtq6{ssH_?+QC>|P@r^qsgo|((M8XnNOINPDoC=| zSHAN`skYkAc8oM$51)&;7~s^_iE%Hty7U+3>a5>95j0_Xv*n zAvp=J*yp_v7T2@gk^bktXGO-v8)o4PmDZSsrN~@kj-34Mlf~6N;!_G#b}jOFq1Ar; zw@vG`%Js)JGK^0ztL6WUa>>sXGEwCR_>X>O=d7*x9bO){&exfpU!c{d<>Q{L9Upwo zXu4`HxEkHv7GU+ ziLu$&c0BU2_1RC6tCQZgJZ=@K`LW?o?B~9y%*^?*_GTyi@~2yu76(=H=}OGua?`qX z`8MyRy-O?(&Y5GnIqYEBVVlPny{A18nXfU)Ic8Iha@X8Ad&@<4IX`Om$#08X(0k2+ zY2ATok#d$$_>ywX z;aP?Mio;EZuQELS=k71^hP(6Ox}paQH@OGKt|RMgS!f2g>FM7+XR=R7 z>CI+X`dB$))rnFIiKc5jJoPqnO%{Ju-65Hyq=zt z6ulXl$wklax4Q3pmL-|)`A*Yd(Z6no-t<*RIF?7bzImML6m380^~0|V)zlX#KiglV zx@U=_XTFubX-w;`Sfd#MN=a`vZ$2n^YF@{bQzmyp4s4w8=Sg>LF|SAAZhp0nW6!S0 zYp>oh-}AiW@vhZp#Z6pAp4Z2=?%#3s=o@+E3XSLD-y&=7Ty5R-Gpzs4odaGr(_1?O z@9Dh@miZr&`SSdH_k(;1yX_q!G>$u&2)oT6}Q#(s;wk6 zoL92?|HwU6(3QE^F#m+iZYq=LAs)Re9>GgjU7dg?95ksz)5jv?u==;qnix$3(&eR=6A z?DtjcB)5l7L+_rncDtFzmwOJblAP{wK*U+^LlgTN8NUw~+`q^^{+@hi$)1+WZ>D8V z)d|mF+xJRz;}WCEnnyAulBHDU-K;gAcidlRb}irfkAYloKGbNZyx^DiwEp!R*^C8l-(oN58_8#V3b*_nwJbN?FyuPVTb`IR z6WaE!HM0*q^P6Gv2g^^h5-X~%trk9%4QFgbRIMPjxKmKjEh&=yy z>LmB{L^+xEcRwrl8J@Xi(0SXoY>vOV)RpwW&;Kqx<;}bm+2J5j^=^iW(zzdTyA;n{ zzr1_BIls**rdwB+IBEQ@NS>&dy!5$vl;?bh)A^UQ6XGQoEO)$MKkc&ljyi64_PsS? zYhs&~T8?DiZ@>KD=r!$^r^8;bP5#uVx_M?t(%QKiC5zv_S-q=|ee;!n!M`uB;IP?P zAa(CyzvYY@E2h+m#2N}WT(MQpVC#S9aQMKHwuRSZ)rBf84{Z|-h`0aKUHNsJ(T}Nj z^Bvq?uV8y&A;L42Q>W`hTAJ^wGd;1l`x+Of1YOQ&oXWQA#?h~-6%VUg=DjxaWpC{f z<<*+JwI}e$ipE^cz7)O48vzrNPRj8`KkiNbsZzjn!EDA2J~7XGGoLv2 z+h*@5blj@MfBAL$-@bEi{M%I#m*Xn;b@`^vs%N&eU4Q%TY|aX%)Lov3y1u%+PAES1 z?bG|NZU6Lof<$*FehIU^8CR`&c(cF_(bxmwn?;-t6c)POd9W#^Ki_xy|H~?TKQttq zJ#Q9=$M1cz`c=t|e@(7Amu`LG*}4Crb(ff%ILFMFTf|#~-FX-*%Vmo8vMcpZe6nrv z8IH5}f3k2pEeQNCyKAc1?T@*7*{-vemTlVVyx^+%9(h?04$NA%B*(VnqNFNU*O@DJ>Ro%MNe2nNo`2~lL#^=P`F*UmNt3Q^ ze(|JetK-a7C0>R86An%7F59yFhp5BT)}GuQ7TN!~bR*mfX2x|EKl;9AUgy;rb3F`0 z4t9Ow%sb5RMsrEh3ui|bRk5!JeLsGklf3xI<}ZJpf3N&F`HWugbNverjaHZ6e)3xS z@WU!UU$!-mx1_ zO^f!;`u3paUBS=N=I!lu0*oz7&c~beOZ}~uwtHSZC-7b4%a4mA-dNiQojUv{f~hR2 zCA>H@M*7XeX&i@`BC{_%=+L=VyZ%G&h56pxe?F~V$|3wku;y4&%cm7@&T98R4e!_K zvJ~AGdZ78A@zz@nk!O$Y$>7Vd$n925oI8DrM%0%6nUzsR4Er4tlAT|v9=7+rkl>iF zvEkauDvRch^E>t^T$d_%RL{B0A)5QQ_p*StIrh^x`km<$>Ii@ES|_CO-L+}qv0b}D z>Iz$m|4dIloUCzgdh@H)(v#XxZ|Iy{xVFS+UgDytsq8DY1*Xl`IP^m-?DDKUR=2}i zLIw7`6YuMOIpJRYZ|%2LG1d~3=P!vjFjkviQarP9`Rp?ju7%7!+IM{V6Y-^rujkx1 zj&b%Z(m338Rr~naYkzJWWqmH$v9#Fpe(AZMbz5R2CN8@$>C5%-;0qpe&L3_~F#SJ& zq0WNs+jrmmB^|N#t$j_jhZ6s0W3A^YuM;IIOTDig@p{^G`p}u+fW3FP!feDcleyLQ zL`rhI^4>UGe2kBM$L%xxbrRWozCW6}8x+$-WTvEijFw+p z{bN@4{FBYeTx?G^$9HSCJYO(bTK#}~a0B1gsjqW$HJ{|YekF3x$>QAGt>@K0r)`Zt zvp(&$$5vUNDNJk6oOX*pcRVS!erosgIl*bNl3ZOc{kqp#w9lTZ3*|N(jCLlrRmuu$aE9M6LM>%TjYYr&Q zTK1#PPf}+3_Q@%Swf+@qhi`KJdOUZAftOsP=iJ+BQ#*Y!;x3(d;2E@+mGfI&&VJ@X z8>MI8xy4T&NH~&j`)*pE#>@j#BFtjbe$?A{KTOYGP zGESmw(N}$6xx9^$<-AMp>=e^J_42B~%@?iHzMY1ZWVhnvdR^1hhK!?KY1vu>H+ zzkNO1CUO7%+0}MWB=g+N*L`J8I}fj_`_g;zRrpP=Upp&HHs8I&ayGPl#m$ML6Lfx0 z`8QQYlE=I8vTA_M_q4dhn)@yUc5PeoIzeyV9zkc@ZQIu8$uC-Ct6%-!W7=|ij?a<# zEf1acFy3oOZNGH$ZPfq5>plP49n7~2o>BVUa#<+PNlJC{&mZgyH?z3xX%}getbd)l z!TGrR%CoDZ4>XmYeb{#I{RyKP8kGyPQhzNhpHk6yomam8cg_)+fLb?;uKHk?UNgxx zMwKVogEE=YRvwd$zhshBHuFH-LEGYpZ_R(D?urF3Haa%3?`F!PBHm}5?6;Kq)+Rr- zZoVa=s<|t+-;meo@3H&o&%T*inq7MwU~;oIL%Pk9+i)-c#S5yFzIeL^Pd%{t8Mj^M zD)9ui(0LseGwlV-W<=y=>Ad6r)_%VzEhXf!)1$>wi!wMj|8_I~uv=;Mx5f7k?v9cd zZ`-!qVYbPvwOpZ6OXrF@cKnEK-r_b@va;=0;m${Aoac5fHh3}jqP&Yihb7zm=yFwO zpY(0UOjCsxoJg_=zEoqXTKZtI#-Uuw(itP7Vt&Fk{|QJwcn)g@9jX&%Na zHov^~YvtVD)FA#F=N}3Ou3c8By~_B%CO^-NGtFz)7nL1I>^#%o!>4E}R(|$+e5Jyq zh>vye<~Hq^K1=lL?A6WtR_J6q9=5ye@W@s|M#Q46;PJD{rTs^{*jb(^J&pC13Us#i z^<2$c%)0DHxN!HHWWiPmvlqQnWWTo-tIfUtqCu3~r9iYOEp=tybwlqD0>5tWI=Pl< zy67>1r{M*i@%j;d60Wzrei^L$9iN(V_IY~9{iI{l*w@-dzj~RF+FP%#ozB_tdurv1 z2)0Ls6Bq8vme&&b7sz0>_~l6%iv>rejo2-_zc-t2>T`VVUSaS{dFA}s(Gj;j->Q18 z;@NPrapw8yx0(ecD+K0Ga!dJnSniv<*x9qUUM0^9_T9GmmEj)aF9#g^AII>nUjD^z z&$rlvi)X}6`xVeM>v8jo-(mfZZ9xx(6jK&hoHZ}&zWZE;bI*ZpHi@fOZ{7h+21BVo%cw9=R=RJ>3{B7g11G_U)=sL|Ik*8BKPmi2j|TE z{-dIQ?ry<(mpTppZw+F88*=2E_PeSRB|8sh=PVGLko0=Xw3MwgN)xs3eV@X;fW2_e zy$kFA{Bw%#c~I?jL$l4Iq&e}9n&PW}$0l7>{+({^vP5=Is#@Ihz=Mke7fY|y`OlN~ zcixBoJdyV)1{VaYtxiAn=6jxqqw^yL9OMPwJ`VEElP|% z&i|YX+UNdebFQ+k`15(`X4UBWg*)rTPA)b$-X8byZ^Y&*zdy2d|Ft}sWjD9KTvJgv zh3m}zfAbs6X2%J%?C^8;5xy4A<+LOzcxK$f!umaRf7$vqlq@6Mhw50dq<&TCJMB{(47W%D3fZtGeu#z51oSM8@u{>V)UQ_txnank>Ai)^wl1y9C|T+Avq$7vexyNO z?}2?>8FLsvO|M>L=f2^25uZ)%i#toM%`=qf>O6l`e#P5mKl`g6C8uaD5j=Zqk0bZJ zLu}d0nS#9(B}M*BDEjZEB^Mnx-SK-pfVP~-cu zwM;C(eP?z%+AraBTDRo1pQlHz->V6gjz04K&pC~ke*?R&0g)i9NYVB zm2lC{*rQ=TQh)EA)4|g<)pC~q$>#SnzGuJPAA0okPiyT*DOpdJt3GW=-h6j!m*Ne! z+UbA4Zw(i|u;FX-=?^!aP7#u9d?4lIGWWSy{re*B1SRi3-x8kjhwR_lCdVUR`hCNk zoA>Wt*|vLAu}zRMR~hFq2Ue5%D_0bRFMg6OZQUSu)hc0OAybY{L(Q~V%!$&=G?nYN z<+OaM*Ew4?`D9YdTAdpayBB|Y-Bm8sFz4^AG>^1j6W&%i$lvFgF?Eji(-hT`ih4Ky zyz;lVeII%2SDlU$^O<(|OLpbbOA{=Er%d_1;7i+?xzo9fd#B32dTg(Exb=dyo+?N1 z=jXfBxpJJ=UwP#A*Sd9U?51MI4NK>WO`5&W`FPYjd$~oYs+b#J%HO*1*ilVW=|{)6 zWtVjB?tErBW4|QRZ62lDwH2#RN?s~E#~D+tKGvDkxe;?m}- z%4pv!JL`_?u5EvQgr!08p|913L?eO71M^>K&HM9lYxvEVk25$e|2F1Nl`uEc=U>_W zQ(`A$*N+b8qi5b8O3iq?iuXBJe8P6QMp3Q0FFeaGoh{biS0~%2AgWqD;p{OI7}v?2WILQTei-QS&A<}`10SpDVkpQ$r;O7@iqOg6V$ z#b6mCz3x`;Z4E)Sqx&!ap4VAhB46))p(1ReP0{wo#q86>^KLCnO;5~@ukem2houAY9xdct4t#Xp{O%zyO$?tayX`Pes9=!<-qxcKOQuji@Z`b zn0qfx?A-;Hoo5ezcyPWX_079m#y3nPlW)|Uy6?5|H8?5BIfX6wq1CyJ@R?Cbvva(X zGs0)&?f$D&dCjeVSHQv@Rnjdd6(?Bgrv`OL-`5VfYapj*r&;33(Uo}eo#cb%&wpM} z(0|Wq?xO6;kZdP*`&jG*?s=K}3cjcvUNBMBU1h;a{XMtSe#|qv)>&gKuNSdqdI z+WiVSPa7R{`!jj*k@J&Yea+nTy!hpo3zoSb_RQ{eKjpCL?N6pHUY8fga~9?Jof5tI z_*1pt?`^8f?3FK??>N9`z52w@=-#;p*S)h?{^N%5Wx?9X4O&raINI)RiF%~aDEMcg zOyAS3z1mZP`er^^>yq{&%kp;Xk2#*sdT|d=f2ecryXSm!yL;{XhH{ZruXnss(`3zC zv+(5gTb<^m=4-w#*1rDeW=DXzaL^PPMi%)?l`4k0=53;Kn1Ckz-xU#o{?oQU zUD zR6MoTbHA$~^A{@lEFMNp39 z?c!_tAGQZcuW&fTsXk+2^2f|b?WN`dS0m>g|Iu>wk&TGc$%$!^3nvy$F~05B`lc;W zYysnVfmgnvY|f4}f1>v2O`?37R=o7pEz_w`AnuJkizx;D@8;Hw_aWqUvs5pEW(!l=&>wh2`EZ(>p1S1vbmQY0o%j_en@(C~uU&SCkJZIqWq#A+j>Ktqr1!+#JpCc2 z^{lz^$4&*!UCwb6PX_6x8$18Hxu(K0_hIEzb%B>VdsGhi(3q*`Yl?ev$=47kAlGeea~O{ z@R_}R|BySmQtei|vU<3@fO5wNG1vN?tF9~To67yp*ItfIZ=!Q_J$GG>V(W~m+gi8y zUS@}!>0p2T_etB6vo4X`k^465PL-*6p1lh3^zt5zTDnflxy zxM_ig-O8NBy-d}wS|_LU#;mzie&Vk7b}sH+ZY$qTig-G$XV>hqP|5R=^GiiH=PZ6C z&NMS)z46u`JC|+KzMSbe=a)rR?%kd1J7$DUP~DN!-Ei&kn@w+(zBcW>bS^X`>S2hd z@}CD^K3@9KS9SOAo7)Yp^J~58(w8<|T~HXDY7u=gywWl0m2KJKGs%vc6&tTN3di64 zwqnWhZuy9*Zl5E#Sk_!?@6DD9dU@QZ>8pYL$5S)J*cSi1s^zI?u;PV@%ht>1)i1w& zFTF0XL9T{(UU>MT<+oGJ*kzJJKMK|5)if#GT9BgmQ+-oz=>eIumg*OkpC6d+`2Nqg z>dKnpPZw`)cepcA{k*c^tet#~4pFE6Mr&Ptp8G&_Q@YXu&QQC4|7EvK7|V9%1vOZ{ z`ESi)nlLfI|NNPp&ROrKmhL|kY`630&(eoGwfEiE{PMIx=bVD6#WcB}t$s6VxHopI zGRFV>y5^$3R^2m;ini%$hgy6x%PW7fylee(tAlOT9L|O3toN@dQ0bmr5x`WwWg*l1 zFLvvGC0OjfT9p&HGNXI`Y@_AeJEf1-KYGxV(v@wq@u$qsshP_~X0qsg_Hw-)ZydR0 z>fx03J=33-eV>!f5Fz2r_qzPOX`<%E%?nrGJor3tw)NgGa}?itCr@9uxiz*(>CC*x z!HZ8itoLf=;99e-QKT#MWuJM~-3cX}#jdQkG>wf)+*%|<-$VrLD_LS#xY2Wcp`%q{ z)-oZT)rEDN4UHDQ;Fr*O5d5@k*3Zm-y(EK}Ur7>uB4V#ue#rQ0>++laShDch^~$*O zIrn$fW*t@AboZ$K)HSJclh>U5c;^I9Xn9}sd#<%i-^696x&1emTUR>EXMx;?i?e>j zxrqJYW!>0&@XXAI3STVMB3I#ZAXQ&Y7^i)79Hpt1V_d z!&Ivt=^uX|txGC7GGVGVi@fuXH+;{YBqu$-_(A4;f2rnfjSt>TvY+mrTYb_?fc0?2 z7gxvXMHg0@PgIw5|Mb-KEc3-bEB$|(>hQ};87Y`v-ejve$Tf#by~eE_h)9&K7H}t9In=E z&KmKbO$T~s2bp!>VhfkD6&BOq{&&Xx)r`;N4;4OgHdyZ-ks5a2U$e^SLT~Cq>(9b( z`d7yPKBbtge>=Ts{l4`wQFZIiy!m`tS)%FSmX_T%556wY-5+tI@}Ad&idbnI_L)=m zFMRu6`~Av$FK7O$$+Vt(d#=Bv@y>j+?nJ*&`Kd1j(`U0bJXtChZ6$a$I-G;|#f&%0 zxo0>o%S&4jJ|Vqsm(T{bL@ic{yn~4;^~bMBv2hr4avxP@lr?`2HAg(( ztn&Rc$@RsdqbpW=>q)4{-H