diff --git a/Justfile b/Justfile index 6c7fcaa..cd5b955 100644 --- a/Justfile +++ b/Justfile @@ -22,6 +22,12 @@ hm FILE: bi FILE: cabal run language -- -t bi {{FILE}} +hml FILE: + cabal run language -- -l -t hm {{FILE}} + +bil FILE: + cabal run language -- -l -t bi {{FILE}} + hmd FILE: cabal run language -- -d -t hm {{FILE}} diff --git a/language.cabal b/language.cabal index e299f24..23aa5dd 100644 --- a/language.cabal +++ b/language.cabal @@ -55,6 +55,7 @@ executable language Codegen.Emits Compiler Renamer.Renamer + ReportForall TreeConverter Desugar.Desugar diff --git a/sample-programs/PriorityQueue.crf b/sample-programs/PriorityQueue.crf index cd8487d..b288a62 100644 --- a/sample-programs/PriorityQueue.crf +++ b/sample-programs/PriorityQueue.crf @@ -6,13 +6,6 @@ data Maybe a where Nothing : Maybe a Just : a -> Maybe a -data Pair a b where - Pair : a -> b -> Pair a b - -data List a where - Nil : List a - Cons : a -> List a -> List a - empty = Empty singleton x = Node Empty x Empty @@ -35,7 +28,3 @@ merge tree1 tree2 = case tree1 of Empty => tree2 insert x tree = merge (singleton x) tree - -main = case peek (insert 1 (insert 2 (insert 3 (singleton 4)))) of - Nothing => (0 - 1) - Just x => x diff --git a/sample-programs/Quicksort.crf b/sample-programs/Quicksort.crf index c037aeb..fa7a32b 100644 --- a/sample-programs/Quicksort.crf +++ b/sample-programs/Quicksort.crf @@ -42,13 +42,3 @@ descList from to = case to < from of main = let list = (5 :: (2 :: (8 :: (9 :: (6 :: (0 :: (1 :: Nil))))))) in printStr (toStr (quicksort list)) - -{- - --- Program output -- -0125689 -In dispose -Out dispose -ExitSuccess - --} diff --git a/src/Auxiliary.hs b/src/Auxiliary.hs index 6a1a073..d595c1a 100644 --- a/src/Auxiliary.hs +++ b/src/Auxiliary.hs @@ -53,7 +53,9 @@ liftMM2 f m1 m2 = do typeof :: Lit -> Type typeof (LInt _) = int typeof (LChar _) = char +typeof (LString _) = string +string = TLit "String" int = TLit "Int" char = TLit "Char" diff --git a/src/Codegen/LlvmIr.hs b/src/Codegen/LlvmIr.hs index 07b9892..a9661c1 100644 --- a/src/Codegen/LlvmIr.hs +++ b/src/Codegen/LlvmIr.hs @@ -161,6 +161,7 @@ typeOf = \case Store t _ _ _ -> t Type x _ -> CustomType x SetVariable _ ir -> typeOf ir + x -> error $ "\n -- MARTIN HJÄLP! -- \nType of: '" ++ show x ++ "' not found" diff --git a/src/Compiler.hs b/src/Compiler.hs index 3fb1fe1..6f7fb24 100644 --- a/src/Compiler.hs +++ b/src/Compiler.hs @@ -28,7 +28,8 @@ 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++" + -- , "-Wall -Wextra -g -std=gnu++20 -stdlib=libstdc++" + , "-w -g -std=gnu++20 -stdlib=libstdc++" , "-O3" --, "-tailcallopt" , "-Isrc/GC/include" diff --git a/src/Main.hs b/src/Main.hs index 7c42d54..2260b7b 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -51,14 +51,15 @@ parseArgs argv = case getOpt RequireOrder flags argv of hPutStrLn stderr (concat errs ++ usageInfo header flags) exitWith (ExitFailure 1) where - header = "Usage: language [--help] [-d|--debug] [-m|--disable-gc] [-t|--type-checker bi/hm] [-p|--disable-prelude] \n" + header = "Usage: language [--help] [-l|--log-intermediate] [-d|--debug] [-m|--disable-gc] [-t|--type-checker bi/hm] [-p|--disable-prelude] \n" flags :: [OptDescr (Options -> Options)] flags = - [ Option ['d'] ["debug"] (NoArg enableDebug) "Print debug messages." + [ Option ['d'] ["debug"] (NoArg $ enableDebug . logIntermediate) "Print debug messages. --debug implies --log-intermediate" , 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 ['p'] ["disable-prelude"] (NoArg disablePrelude) "Do not include the prelude" + , Option ['l'] ["log-intermediate"] (NoArg logIntermediate) "Log intermediate languages" , Option [] ["help"] (NoArg enableHelp) "Print this help message" ] @@ -70,6 +71,7 @@ initOpts = , gc = True , typechecker = Nothing , preludeOpt = False + , logIL = False } enableHelp :: Options -> Options @@ -84,6 +86,10 @@ disableGC opts = opts{gc = False} disablePrelude :: Options -> Options disablePrelude opts = opts{preludeOpt = True} +logIntermediate :: Options -> Options +logIntermediate opts = opts{logIL = True} + + chooseTypechecker :: String -> Options -> Options chooseTypechecker s options = options{typechecker = tc} where @@ -98,6 +104,7 @@ data Options = Options , gc :: Bool , typechecker :: Maybe TypeChecker , preludeOpt :: Bool + , logIL :: Bool } main' :: Options -> String -> IO () @@ -109,33 +116,33 @@ main' opts s = do file <- readFile s - printToErr "-- Parse Tree -- " + let file' = if opts.preludeOpt then file else file ++ prelude parsed <- fromErr . pProgram . resolveLayout True $ myLexer file' - log parsed + when opts.logIL (printToErr "-- Parse Tree -- " >> log parsed) - printToErr "-- Desugar --" + let desugared = desugar parsed - log desugared + when opts.logIL (printToErr "-- Desugar --" >> log desugared) - printToErr "\n-- Renamer --" + _ <- fromErr $ reportForall (fromJust opts.typechecker) desugared renamed <- fromErr $ (rename <=< annotateForall) desugared - log renamed + when opts.logIL (printToErr "\n-- Renamer --" >> log renamed) - printToErr "\n-- TypeChecker --" + typechecked <- fromErr $ typecheck (fromJust opts.typechecker) (orderDefs renamed) - log typechecked + when opts.logIL (printToErr "\n-- TypeChecker --" >> log typechecked) - printToErr "\n-- Lambda Lifter --" + let lifted = lambdaLift typechecked - log lifted + when opts.logIL (printToErr "\n-- Lambda Lifter --" >> log lifted) - printToErr "\n -- Monomorphizer --" + let monomorphized = monomorphize lifted - log monomorphized + when opts.logIL (printToErr "\n -- Monomorphizer --" >> log monomorphized) - printToErr "\n -- Compiler --" + generatedCode <- fromErr $ generateCode monomorphized (gc opts) -- generatedCode <- fromErr $ generateCode monomorphized False @@ -144,6 +151,7 @@ main' opts s = createDirectory "output" createDirectory "output/logs" when opts.debug $ do + printToErr "\n -- Compiler --" writeFile "output/llvm.ll" generatedCode debugDotViz diff --git a/src/Monomorphizer/Monomorphizer.hs b/src/Monomorphizer/Monomorphizer.hs index 99925cc..47ddbcc 100644 --- a/src/Monomorphizer/Monomorphizer.hs +++ b/src/Monomorphizer/Monomorphizer.hs @@ -345,7 +345,6 @@ morphPattern p expectedType = case p of return $ Just ((M.PEnum newIdent, expectedType), Set.empty) L.PInj ident pts -> do let newIdent = newName expectedType ident ts' <- mapM (getMonoFromPoly . snd) pts - trace ("Constructor: " ++ show ident ++ "expected: " ++ show expectedType ++ "\nTS': " ++ show ts' ++ "\n\n\n") pure () morphCons (convertConsTypeToDataType expectedType (reverse ts')) ident newIdent let pts' = zip (map fst pts) ts' psSets <- mapM (uncurry morphPattern) pts' diff --git a/src/TypeChecker/TypeCheckerBidir.hs b/src/TypeChecker/TypeCheckerBidir.hs index ddd2f5c..93334dc 100644 --- a/src/TypeChecker/TypeCheckerBidir.hs +++ b/src/TypeChecker/TypeCheckerBidir.hs @@ -2,7 +2,7 @@ {-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternSynonyms #-} -{-# OPTIONS_GHC -Wno-incomplete-patterns #-} +-- {-# OPTIONS_GHC -Wno-incomplete-patterns #-} module TypeChecker.TypeCheckerBidir (typecheck) where @@ -248,6 +248,7 @@ checkPattern PCatch a = apply (T.PCatch, a) -- ------------------------- PLit -- Γ ⊢ lit ↑ A ⊣ Γ checkPattern (PLit lit) a | a == typeof lit = apply (T.PLit lit, a) +checkPattern (PLit lit) a = error $ "\n -- MARTIN HJÄLP!! --\nUnimplemented match for: '" ++ printTree a ++ "' == '" ++ printTree (typeof lit) ++ "'" -- Γ ∋ (K : T) Γ ⊢ A <: B ⊣ Δ -- ---------------------------