Fixed a segfault.
This commit is contained in:
Samuel Hammersberg
parent
f531afb3ab
commit
7e246a94e5
5 changed files with 82 additions and 76 deletions
|
|
@ -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;
|
||||
};
|
||||
|
|
@ -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
|
||||
|
|
|
|||
57
src/Main.hs
57
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")
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue