From 7e246a94e51d8e67f6e6445b59dc616ee85913df Mon Sep 17 00:00:00 2001 From: Samuel Hammersberg Date: Fri, 24 Mar 2023 19:57:49 +0100 Subject: [PATCH] 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