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

Almost got a lot of bugs fixed.

Browse source
This commit is contained in:
Samuel Hammersberg 2023-03-26 22:21:44 +02:00
parent 9952eb0279
commit 91cfb21a35
4 changed files with 114 additions and 123 deletions
Download patch file Download diff file Expand all files Collapse all files

94
src/Codegen/Codegen.hs
View file

@ -14,6 +14,7 @@ import Data.Map (Map)
import qualified Data.Map as Map import qualified Data.Map as Map
import Data.Maybe (fromJust, fromMaybe) import Data.Maybe (fromJust, fromMaybe)
import Data.Tuple.Extra (dupe, first, second) import Data.Tuple.Extra (dupe, first, second)
import Debug.Trace (trace)
import qualified Grammar.Abs as GA import qualified Grammar.Abs as GA
import Grammar.ErrM (Err) import Grammar.ErrM (Err)
import Monomorphizer.MonomorphizerIr as MIR import Monomorphizer.MonomorphizerIr as MIR
@ -22,7 +23,7 @@ import Monomorphizer.MonomorphizerIr as MIR
data CodeGenerator = CodeGenerator data CodeGenerator = CodeGenerator
{ instructions :: [LLVMIr] { instructions :: [LLVMIr]
, functions :: Map MIR.Id FunctionInfo , functions :: Map MIR.Id FunctionInfo
, constructors :: Map MIR.Id ConstructorInfo , constructors :: Map GA.Ident ConstructorInfo
, variableCount :: Integer , variableCount :: Integer
, labelCount :: Integer , labelCount :: Integer
} }
@ -39,6 +40,7 @@ data ConstructorInfo = ConstructorInfo
{ numArgsCI :: Int { numArgsCI :: Int
, argumentsCI :: [Id] , argumentsCI :: [Id]
, numCI :: Integer , numCI :: Integer
, returnTypeCI :: MIR.Type
} }
deriving (Show) deriving (Show)
@ -56,7 +58,7 @@ getVarCount = gets variableCount
-- | Increases the variable count and returns it from the CodeGenerator state -- | Increases the variable count and returns it from the CodeGenerator state
getNewVar :: CompilerState GA.Ident 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 -- | Increses the label count and returns a label from the CodeGenerator state
getNewLabel :: CompilerState Integer getNewLabel :: CompilerState Integer
@ -74,18 +76,7 @@ getFunctions bs = Map.fromList $ go bs
go (MIR.DBind (MIR.Bind id args _) : xs) = go (MIR.DBind (MIR.Bind id args _) : xs) =
(id, FunctionInfo{numArgs = length args, arguments = args}) (id, FunctionInfo{numArgs = length args, arguments = args})
: go xs : go xs
go (MIR.DData (MIR.Data n cons) : xs) = go (_ : xs) = go xs
do map
( \(Constructor id xs) ->
( (coerce id, MIR.TLit (extractTypeName n))
, FunctionInfo
{ numArgs = length (flattenType xs)
, arguments = createArgs (flattenType xs)
}
)
)
cons
<> go xs
createArgs :: [MIR.Type] -> [Id] 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 ++ [(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, {- | Produces a map of functions infos from a list of binds,
which contains useful data for code generation. 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 getConstructors bs = Map.fromList $ go bs
where where
go [] = [] go [] = []
go (MIR.DData (MIR.Data t cons) : xs) = go (MIR.DData (MIR.Data t cons) : xs) =
do
let (GA.Ident n) = extractTypeName t
fst fst
( foldl ( foldl
( \(acc, i) (Constructor (GA.Ident id) xs) -> ( \(acc, i) (Constructor id xs) ->
( ( (GA.Ident (n <> "_" <> id), MIR.TLit (coerce n)) ( ( id
, ConstructorInfo , ConstructorInfo
{ numArgsCI = length (flattenType xs) { numArgsCI = length (init . flattenType $ xs)
, argumentsCI = createArgs (flattenType xs) , argumentsCI = createArgs (init . flattenType $ xs)
, numCI = i , numCI = i
, returnTypeCI = t --last . flattenType $ xs
} }
) )
: acc : acc
@ -183,11 +173,13 @@ generateCode (MIR.Program scs) = do
compileScs :: [MIR.Def] -> CompilerState () compileScs :: [MIR.Def] -> CompilerState ()
compileScs [] = do compileScs [] = do
emit $ UnsafeRaw "\n"
-- as a last step create all the constructors -- as a last step create all the constructors
-- //TODO maybe merge this with the data type match? -- //TODO maybe merge this with the data type match?
c <- gets (Map.toList . constructors) c <- gets (Map.toList . constructors)
mapM_ mapM_
( \((id, t), ci) -> do ( \(id, ci) -> do
let t = returnTypeCI ci
let t' = type2LlvmType t let t' = type2LlvmType t
let x = BI.second type2LlvmType <$> argumentsCI ci let x = BI.second type2LlvmType <$> argumentsCI ci
emit $ Define FastCC t' id x emit $ Define FastCC t' id x
@ -213,9 +205,6 @@ compileScs [] = do
ptr' <- getNewVar ptr' <- getNewVar
emit $ SetVariable ptr' (Bitcast (Ref t') (VIdent top Ptr) (Ref $ CustomType id)) emit $ SetVariable ptr' (Bitcast (Ref t') (VIdent top Ptr) (Ref $ CustomType id))
-- 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
@ -237,14 +226,13 @@ compileScs [] = do
) )
(argumentsCI ci) (argumentsCI ci)
-- emit $ UnsafeRaw "\n"
-- load and return the constructed value -- load and return the constructed value
emit $ Comment "Return the newly constructed value" emit $ Comment "Return the newly constructed value"
load <- getNewVar load <- getNewVar
emit $ SetVariable load (Load t' Ptr top) emit $ SetVariable load (Load t' Ptr top)
emit $ Ret t' (VIdent load t') emit $ Ret t' (VIdent load t')
emit DefineEnd emit DefineEnd
emit $ UnsafeRaw "\n"
modify $ \s -> s{variableCount = 0} modify $ \s -> s{variableCount = 0}
) )
@ -263,11 +251,12 @@ 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 = 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] emit $ LIR.Type (Ident outer_id) [I8, Array biggestVariant I8]
mapM_ mapM_
( \(Constructor (GA.Ident inner_id) fi) -> do ( \(Constructor inner_id fi) -> do
emit $ LIR.Type (GA.Ident $ outer_id <> "_" <> inner_id) (I8 : map type2LlvmType (flattenType fi)) emit $ LIR.Type inner_id (I8 : variantTypes fi)
) )
ts ts
compileScs xs compileScs xs
@ -348,7 +337,7 @@ emitECased t e cases = do
emitCases :: LLVMType -> LLVMType -> GA.Ident -> GA.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 emitCases rt ty label stackPtr vs (Branch (MIR.PInj consId cs, t) exp) = do
cons <- gets constructors 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_failPos <- (\x -> GA.Ident $ "failed_" <> show x) <$> getNewLabel
lbl_succPos <- (\x -> GA.Ident $ "success_" <> show x) <$> getNewLabel lbl_succPos <- (\x -> GA.Ident $ "success_" <> show x) <$> getNewLabel
@ -362,17 +351,23 @@ emitECased t e cases = do
emit $ Label lbl_succPos emit $ Label lbl_succPos
castPtr <- getNewVar castPtr <- getNewVar
castedPtr <- getNewVar
casted <- getNewVar casted <- getNewVar
emit $ SetVariable castPtr (Alloca rt) emit $ SetVariable castPtr (Alloca rt)
emit $ Store rt vs Ptr castPtr emit $ Store rt vs Ptr castPtr
emit $ SetVariable castedPtr (Bitcast Ptr (VIdent castPtr Ptr) Ptr) emit $ SetVariable casted (Load (CustomType (coerce consId)) Ptr castPtr)
emit $ SetVariable casted (Load (CustomType (coerce consId)) Ptr castedPtr)
val <- exprToValue exp val <- exprToValue exp
-- enumerateOneM_ enumerateOneM_
-- (\i c -> do (\i c -> do
-- case c of 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 -- CIdent x -> do
-- emit . Comment $ "ident " <> show x -- emit . Comment $ "ident " <> show x
-- emit $ SetVariable x (ExtractValue (CustomType (fst consId)) (VIdent casted Ptr) i) -- emit $ SetVariable x (ExtractValue (CustomType (fst consId)) (VIdent casted Ptr) i)
@ -385,12 +380,9 @@ emitECased t e cases = do
-- 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) -- LChar c -> emit $ Icmp LLEq I8 (VIdent testVar Ptr) (VChar c)
-- CCatch -> emit . Comment $ "Catch all" -- CCatch -> emit . Comment $ "Catch all"
-- emit . Comment $ "return this " <> toIr val )
-- emit . Comment . show $ c cs
-- emit . Comment . show $ i emit $ Store ty val Ptr stackPtr
-- )
-- cs
-- 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 (Branch (MIR.PLit i, _) exp) = do emitCases rt ty label stackPtr vs (Branch (MIR.PLit i, _) exp) = do
@ -417,6 +409,10 @@ emitECased t e cases = do
val <- exprToValue exp val <- exprToValue exp
emit $ Store ty val Ptr stackPtr emit $ Store ty val Ptr stackPtr
emit $ Br label 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 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
@ -435,13 +431,13 @@ emitLet xs e = do
] ]
emitApp :: MIR.Type -> ExpT -> ExpT -> CompilerState () emitApp :: MIR.Type -> ExpT -> ExpT -> CompilerState ()
emitApp t e1 e2 = appEmitter e1 e2 [] emitApp rt e1 e2 = appEmitter e1 e2 []
where where
appEmitter :: ExpT -> ExpT -> [ExpT] -> CompilerState () appEmitter :: ExpT -> ExpT -> [ExpT] -> CompilerState ()
appEmitter e1 e2 stack = do appEmitter e1 e2 stack = do
let newStack = e2 : stack let newStack = e2 : stack
case e1 of 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 (MIR.EId name, t) -> do
args <- traverse exprToValue newStack args <- traverse exprToValue newStack
vs <- getNewVar vs <- getNewVar
@ -449,11 +445,13 @@ emitApp t e1 e2 = appEmitter e1 e2 []
consts <- gets constructors consts <- gets constructors
let visibility = let visibility =
fromMaybe Local $ fromMaybe Local $
Global <$ Map.lookup (name, t) consts 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` -- this piece of code could probably be improved, i.e remove the double `const Global`
args' = map (first valueGetType . dupe) args 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 emit $ SetVariable vs call
x -> error $ "The unspeakable happened: " <> show x x -> error $ "The unspeakable happened: " <> show x

8
src/Codegen/LlvmIr.hs
View file

@ -14,7 +14,7 @@ module Codegen.LlvmIr (
import Data.List (intercalate) import Data.List (intercalate)
import Grammar.Abs (Ident (..)) import Grammar.Abs (Ident (..))
data CallingConvention = TailCC | FastCC | CCC | ColdCC data CallingConvention = TailCC | FastCC | CCC | ColdCC deriving Show
instance ToIr CallingConvention where instance ToIr CallingConvention where
toIr :: CallingConvention -> String toIr :: CallingConvention -> String
toIr TailCC = "tailcc" toIr TailCC = "tailcc"
@ -33,6 +33,7 @@ data LLVMType
| Function LLVMType [LLVMType] | Function LLVMType [LLVMType]
| Array Integer LLVMType | Array Integer LLVMType
| CustomType Ident | CustomType Ident
deriving Show
class ToIr a where class ToIr a where
toIr :: a -> String toIr :: a -> String
@ -61,6 +62,7 @@ data LLVMComp
| LLSge | LLSge
| LLSlt | LLSlt
| LLSle | LLSle
deriving Show
instance ToIr LLVMComp where instance ToIr LLVMComp where
toIr :: LLVMComp -> String toIr :: LLVMComp -> String
toIr = \case toIr = \case
@ -75,7 +77,7 @@ instance ToIr LLVMComp where
LLSlt -> "slt" LLSlt -> "slt"
LLSle -> "sle" LLSle -> "sle"
data Visibility = Local | Global data Visibility = Local | Global deriving Show
instance ToIr Visibility where instance ToIr Visibility where
toIr :: Visibility -> String toIr :: Visibility -> String
toIr Local = "%" toIr Local = "%"
@ -89,6 +91,7 @@ data LLVMValue
| VIdent Ident LLVMType | VIdent Ident LLVMType
| VConstant String | VConstant String
| VFunction Ident Visibility LLVMType | VFunction Ident Visibility LLVMType
deriving Show
instance ToIr LLVMValue where instance ToIr LLVMValue where
toIr :: LLVMValue -> String toIr :: LLVMValue -> String
@ -132,6 +135,7 @@ data LLVMIr
| Comment String | Comment String
| UnsafeRaw String -- This should generally be avoided, and proper | UnsafeRaw String -- This should generally be avoided, and proper
-- instructions should be used in its place -- instructions should be used in its place
deriving Show
-- | Converts a list of LLVMIr instructions to a string -- | Converts a list of LLVMIr instructions to a string
llvmIrToString :: [LLVMIr] -> String llvmIrToString :: [LLVMIr] -> String

28
src/Main.hs
View file

@ -16,26 +16,16 @@ 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,
doesPathExist,
getDirectoryContents, getDirectoryContents,
removeDirectoryRecursive, removeDirectoryRecursive,
setCurrentDirectory, setCurrentDirectory)
)
import System.Environment (getArgs) import System.Environment (getArgs)
import System.Exit ( import System.Exit (ExitCode, exitFailure,
ExitCode, exitSuccess)
exitFailure,
exitSuccess,
)
import System.IO (stderr) import System.IO (stderr)
import System.Process.Extra ( import System.Process.Extra (readCreateProcess, shell,
readCreateProcess, spawnCommand, waitForProcess)
shell,
spawnCommand,
waitForProcess,
)
import TypeChecker.TypeChecker (typecheck) import TypeChecker.TypeChecker (typecheck)
main :: IO () main :: IO ()
@ -70,15 +60,15 @@ main' debug s = do
-- let lifted = lambdaLift typechecked -- let lifted = lambdaLift typechecked
-- printToErr $ printTree lifted -- printToErr $ printTree lifted
-- --
printToErr "\n -- Compiler --" --printToErr "\n -- Compiler --"
generatedCode <- fromCompilerErr $ generateCode (monomorphize typechecked) generatedCode <- fromCompilerErr $ generateCode (monomorphize typechecked)
putStrLn generatedCode --putStrLn generatedCode
check <- doesPathExist "output" check <- doesPathExist "output"
when check (removeDirectoryRecursive "output") when check (removeDirectoryRecursive "output")
createDirectory "output" createDirectory "output"
when debug $ do when debug $ do
writeFile "output/llvm.ll" generatedCode _ <- writeFile "output/llvm.ll" generatedCode
debugDotViz debugDotViz
compile generatedCode compile generatedCode

45
test_program.crf
View file

@ -1,28 +1,27 @@
data Maybe () where { data Maybe () where {
Nothing : Maybe Nothing : Maybe ()
Just : Int -> Maybe Just : Int -> Maybe ()
}; };
fmap : (Int -> Int) -> Maybe -> Maybe ; -- fmap : (Int -> Int) -> Maybe () -> Maybe () ;
fmap f ma = case ma of { -- fmap f ma = case ma of {
Nothing => Nothing ; -- Nothing => Nothing ;
Just a => Just (f a) ; -- Just a => Just (f a) ;
-- };
main = case (Just 5) of {
Just a => a ;
Nothing => 1 ;
_ => 66 ;
}; };
pure : Int -> Maybe ; -- pure : Int -> Maybe () ;
pure x = Just x ; -- pure x = Just x ;
--
ap mf ma = case mf of { -- return = pure;
Just f => case ma of { --
Nothing => Nothing; -- bind : Maybe () -> (Int -> Maybe ()) -> Maybe () ;
Just a => Just (f a); -- bind ma f = case ma of {
}; -- Nothing => Nothing ;
Nothing => Nothing; -- Just a => f a ;
}; -- };
return = pure;
bind ma f = case ma of {
Nothing => Nothing ;
Just a => f a ;
};