Rakarake/churf
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Fixed a segfault.

Browse source
This commit is contained in:
Samuel Hammersberg 2023-03-24 19:57:49 +01:00
parent f531afb3ab
commit 7e246a94e5
5 changed files with 82 additions and 76 deletions
Download patch file Download diff file Expand all files Collapse all files

15
sample-programs/basic-1
View file

@ -1,8 +1,9 @@
add : Int ; data True() where {
add = 4; True: True()
main : Int ;
main = case add of {
5 => 0;
_ => 1;
}; };
main: Int;
main =
case True of {
True => 1;
_ => 0;
};

41
src/Codegen/Codegen.hs
View file

@ -102,7 +102,7 @@ getConstructors bs = Map.fromList $ go bs
let (GA.Ident n) = extractTypeName t let (GA.Ident n) = extractTypeName t
fst fst
( foldl ( foldl
( \(acc, i) (Constructor (GA.UIdent id) xs) -> ( \(acc, i) (Constructor (GA.Ident id) xs) ->
( ( (GA.Ident (n <> "_" <> id), MIR.TLit (coerce n)) ( ( (GA.Ident (n <> "_" <> id), MIR.TLit (coerce n))
, ConstructorInfo , ConstructorInfo
{ numArgsCI = length xs { numArgsCI = length xs
@ -215,6 +215,7 @@ compileScs [] = do
-- emit $ UnsafeRaw "\n" -- emit $ UnsafeRaw "\n"
-- warning this segfaults!!
enumerateOneM_ enumerateOneM_
( \i (GA.Ident arg_n, arg_t) -> do ( \i (GA.Ident arg_n, arg_t) -> do
let arg_t' = type2LlvmType arg_t let arg_t' = type2LlvmType arg_t
@ -262,10 +263,10 @@ compileScs (MIR.DBind (MIR.Bind (name, _t) args exp) : xs) = do
compileScs xs compileScs xs
compileScs (MIR.DData (MIR.Data typ ts) : xs) = do compileScs (MIR.DData (MIR.Data typ ts) : xs) = do
let (Ident outer_id) = extractTypeName typ let (Ident outer_id) = extractTypeName typ
let biggestVariant = maximum $ sum <$> (\(Constructor _ t) -> typeByteSize . type2LlvmType . snd <$> t) <$> ts let biggestVariant = 1--maximum (sum . (\(Constructor _ t) -> typeByteSize . type2LlvmType . snd <$> t) <$> ts)
emit $ LIR.Type (coerce outer_id) [I8, Array biggestVariant I8] emit $ LIR.Type (Ident outer_id) [I8, Array biggestVariant I8]
mapM_ 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)) emit $ LIR.Type (GA.Ident $ outer_id <> "_" <> inner_id) (I8 : map type2LlvmType (snd <$> fi))
) )
ts ts
@ -274,6 +275,18 @@ compileScs (MIR.DData (MIR.Data typ ts) : xs) = do
mainContent :: LLVMValue -> [LLVMIr] mainContent :: LLVMValue -> [LLVMIr]
mainContent var = mainContent var =
[ UnsafeRaw $ [ 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" <> -- "%2 = alloca %Craig\n" <>
-- " store %Craig %1, ptr %2\n" <> -- " store %Craig %1, ptr %2\n" <>
-- " %3 = bitcast %Craig* %2 to i72*\n" <> -- " %3 = bitcast %Craig* %2 to i72*\n" <>
@ -394,16 +407,16 @@ emitECased t e cases = do
emit $ Store ty val Ptr stackPtr emit $ Store ty val Ptr stackPtr
emit $ Br label emit $ Br label
emit $ Label lbl_failPos emit $ Label lbl_failPos
-- emitCases rt ty label stackPtr vs (Injection (MIR.CIdent id) exp) = do emitCases rt ty label stackPtr vs (Branch (MIR.PVar (id,_), _) exp) = do
-- -- //TODO this is pretty disgusting and would heavily benefit from a rewrite -- //TODO this is pretty disgusting and would heavily benefit from a rewrite
-- valPtr <- getNewVar valPtr <- getNewVar
-- emit $ SetVariable valPtr (Alloca rt) emit $ SetVariable valPtr (Alloca rt)
-- emit $ Store rt vs Ptr valPtr emit $ Store rt vs Ptr valPtr
-- emit $ SetVariable id (Load rt Ptr valPtr) emit $ SetVariable id (Load rt Ptr valPtr)
-- increaseVarCount increaseVarCount
-- val <- exprToValue (fst exp) val <- exprToValue exp
-- emit $ Store ty val Ptr stackPtr emit $ Store ty val Ptr stackPtr
-- emit $ Br label emit $ Br label
emitCases _ ty label stackPtr _ (Branch (MIR.PCatch, _) exp) = do emitCases _ ty label stackPtr _ (Branch (MIR.PCatch, _) exp) = do
val <- exprToValue exp val <- exprToValue exp
emit $ Store ty val Ptr stackPtr emit $ Store ty val Ptr stackPtr

57
src/Main.hs
View file

@ -2,41 +2,31 @@
module Main where module Main where
import Codegen.Codegen (generateCode) import Codegen.Codegen (generateCode)
import Data.Bool (bool) import Data.Bool (bool)
import GHC.IO.Handle.Text (hPutStrLn) import GHC.IO.Handle.Text (hPutStrLn)
import Grammar.ErrM (Err) import Grammar.ErrM (Err)
import Grammar.Par (myLexer, pProgram) import Grammar.Par (myLexer, pProgram)
import Grammar.Print (printTree) import Grammar.Print (printTree)
import Monomorphizer.Monomorphizer (monomorphize) import Monomorphizer.Monomorphizer (monomorphize)
import Control.Monad (when) import Control.Monad (when)
import Data.List.Extra (isSuffixOf) import Data.List.Extra (isSuffixOf)
import Compiler (compile) import Compiler (compile)
import Renamer.Renamer (rename) import Renamer.Renamer (rename)
import System.Directory ( import System.Directory (createDirectory, doesPathExist,
createDirectory, getDirectoryContents,
doesPathExist, removeDirectoryRecursive,
getDirectoryContents, setCurrentDirectory)
removeDirectoryRecursive, import System.Environment (getArgs)
setCurrentDirectory, import System.Exit (ExitCode, exitFailure,
) exitSuccess)
import System.Environment (getArgs) import System.IO (stderr)
import System.Exit ( import System.Process.Extra (readCreateProcess, shell,
ExitCode, spawnCommand, waitForProcess)
exitFailure, import TypeChecker.TypeChecker (typecheck)
exitSuccess,
)
import System.IO (stderr)
import System.Process.Extra (
readCreateProcess,
shell,
spawnCommand,
waitForProcess,
)
import TypeChecker.TypeChecker (typecheck)
main :: IO () main :: IO ()
main = main =
@ -67,8 +57,7 @@ main' debug s = do
-- --
printToErr "\n -- Compiler --" printToErr "\n -- Compiler --"
generatedCode <- fromCompilerErr $ generateCode (monomorphize typechecked) generatedCode <- fromCompilerErr $ generateCode (monomorphize typechecked)
putStrLn "Generation of code successful" putStrLn generatedCode
-- putStrLn generatedCode
check <- doesPathExist "output" check <- doesPathExist "output"
when check (removeDirectoryRecursive "output") when check (removeDirectoryRecursive "output")

43
src/Monomorphizer/Monomorphizer.hs
View file

@ -1,15 +1,14 @@
{-# LANGUAGE LambdaCase #-} {-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
module Monomorphizer.Monomorphizer (monomorphize) where module Monomorphizer.Monomorphizer (monomorphize) where
import Data.Coerce (coerce) import Data.Coerce (coerce)
import Grammar.Abs (Constructor (..), Ident (..)) import Grammar.Abs (Constructor (..), Ident (..))
import Unsafe.Coerce (unsafeCoerce)
import Grammar.Abs qualified as GA import qualified Grammar.Abs as GA
import Monomorphizer.MonomorphizerIr qualified as M import qualified Monomorphizer.MonomorphizerIr as M
import TypeChecker.TypeCheckerIr qualified as T import qualified TypeChecker.TypeCheckerIr as T
monomorphize :: T.Program -> M.Program monomorphize :: T.Program -> M.Program
monomorphize (T.Program ds) = M.Program $ monoDefs ds monomorphize (T.Program ds) = M.Program $ monoDefs ds
@ -19,11 +18,14 @@ monoDefs = map monoDef
monoDef :: T.Def -> M.Def monoDef :: T.Def -> M.Def
monoDef (T.DBind bind) = M.DBind $ monoBind bind 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 -> M.Bind
monoBind (T.Bind name args (e, t)) = M.Bind (monoId name) (map monoId args) (monoExpr e, monoType t) 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 :: T.Exp -> M.Exp
monoExpr = \case monoExpr = \case
T.EId (T.Ident i) -> M.EId (Ident i) 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) T.ECase expt injs -> M.ECase (monoexpt expt) (monoInjs injs)
monoAbsType :: GA.Type -> M.Type monoAbsType :: GA.Type -> M.Type
monoAbsType (GA.TLit u) = M.TLit (coerce u) monoAbsType (GA.TLit u) = M.TLit (coerce u)
monoAbsType (GA.TVar _v) = M.TLit "Int" monoAbsType (GA.TVar _v) = M.TLit "Int"
monoAbsType (GA.TAll _v _t) = error "NOT ALL TYPES" 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.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.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.TVar (T.MkTVar i)) = M.TLit "Int"
monoType (T.TLit (T.Ident i)) = M.TLit (Ident i) monoType (T.TLit (T.Ident i)) = M.TLit (Ident i)
monoType (T.TFun t1 t2) = M.TFun (monoType t1) (monoType t2) 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.TData (T.Ident n) t) = M.TLit (Ident (n ++ concatMap show t))
monoexpt :: T.ExpT -> M.ExpT monoexpt :: T.ExpT -> M.ExpT
@ -56,7 +58,7 @@ monoId :: T.Id -> M.Id
monoId (n, t) = (coerce n, monoType t) monoId (n, t) = (coerce n, monoType t)
monoLit :: T.Lit -> M.Lit 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 monoLit (T.LChar c) = M.LChar c
monoInjs :: [T.Branch] -> [M.Branch] 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) monoInj (T.Branch (init, t) expt) = M.Branch (monoInit init, monoType t) (monoexpt expt)
monoInit :: T.Pattern -> M.Pattern 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.PLit (lit, t)) = M.PLit (monoLit lit, monoType t)
monoInit (T.PInj id ps) = M.PInj (coerce id) (monoInit <$> ps) monoInit (T.PInj id ps) = M.PInj (coerce id) (monoInit <$> ps)
monoInit T.PCatch = M.PCatch monoInit (T.PEnum id) = undefined
monoInit T.PCatch = M.PCatch

2
src/Monomorphizer/MonomorphizerIr.hs
View file

@ -35,7 +35,7 @@ data Branch = Branch (Pattern, Type) ExpT
type ExpT = (Exp, Type) type ExpT = (Exp, Type)
data Constructor = Constructor UIdent [(UIdent, Type)] data Constructor = Constructor Ident [(Ident, Type)]
deriving (Show, Ord, Eq) deriving (Show, Ord, Eq)
data Lit data Lit