From 8ddb0ed05269ede22fc65905781e524901b057f1 Mon Sep 17 00:00:00 2001 From: Samuel Hammersberg Date: Mon, 8 May 2023 20:54:02 +0200 Subject: [PATCH] We can now print strings :) --- src/Codegen/Auxillary.hs | 1 + src/Codegen/Codegen.hs | 6 +++- src/Codegen/CompilerState.hs | 4 +-- src/Codegen/Emits.hs | 58 ++++++++++++++++++++++-------------- src/Codegen/LlvmIr.hs | 4 +++ src/Main.hs | 6 +++- 6 files changed, 52 insertions(+), 27 deletions(-) diff --git a/src/Codegen/Auxillary.hs b/src/Codegen/Auxillary.hs index af31504..1636736 100644 --- a/src/Codegen/Auxillary.hs +++ b/src/Codegen/Auxillary.hs @@ -10,6 +10,7 @@ type2LlvmType (MIR.TLit id@(TIR.Ident name)) = case name of "Int" -> I64 "Char" -> I8 "Bool" -> I1 + "Unit" -> I16 _ -> CustomType id type2LlvmType (MIR.TFun t xs) = do let (t', xs') = function2LLVMType xs [type2LlvmType t] diff --git a/src/Codegen/Codegen.hs b/src/Codegen/Codegen.hs index 6f66c36..17ecc07 100644 --- a/src/Codegen/Codegen.hs +++ b/src/Codegen/Codegen.hs @@ -38,6 +38,7 @@ generateCode (MIR.Program scs) addGc = do detectPrelude :: Def -> Bool detectPrelude (DData (Data (TLit (Ident "Bool")) _)) = True +detectPrelude (DData (Data (TLit (Ident "Unit")) _)) = True detectPrelude (DBind (Bind (Ident ('l' : 't' : '$' : _), _) _ _)) = True detectPrelude _ = False @@ -50,8 +51,11 @@ defaultStart :: [LLVMIr] defaultStart = [ UnsafeRaw "target triple = \"x86_64-pc-linux-gnu\"\n" , UnsafeRaw "target datalayout = \"e-m:o-i64:64-f80:128-n8:16:32:64-S128\"\n" - , UnsafeRaw "@.str = private unnamed_addr constant [3 x i8] c\"%i\n\", align 1\n" + , UnsafeRaw "@.str = private unnamed_addr constant [2 x i8] c\"%i\", align 1\n" + , UnsafeRaw "@.new_line = private unnamed_addr constant [1 x i8] c\"\n\", align 1\n" , UnsafeRaw "@.non_exhaustive_patterns = private unnamed_addr constant [41 x i8] c\"Non-exhaustive patterns in case at %i:%i\n\"\n" + , UnsafeRaw "@.char_print = private unnamed_addr constant [2 x i8] c\"%c\"\n" + , UnsafeRaw "@.char_print_no_nl = private unnamed_addr constant [3 x i8] c\"%c\0\"\n" , UnsafeRaw "declare i32 @printf(ptr noalias nocapture, ...)\n" , UnsafeRaw "declare i32 @exit(i32 noundef)\n" , UnsafeRaw "declare ptr @malloc(i32 noundef)\n" diff --git a/src/Codegen/CompilerState.hs b/src/Codegen/CompilerState.hs index b455712..d238262 100644 --- a/src/Codegen/CompilerState.hs +++ b/src/Codegen/CompilerState.hs @@ -174,9 +174,7 @@ getTypes bs = Map.fromList $ go bs getGlobals :: [MIR.Def] -> Map Ident (LLVMType, LLVMValue) getGlobals scs = Map.fromList [ go b | MIR.DBind b <- scs ] where - go bind | x == "main" = let typ = Function I64 [] - in (x, (typ, VFunction x Global typ)) - | otherwise = (x, (typ, VFunction x Global typ)) + go bind = (x, (typ, VFunction x Global typ)) where typ = Function tr $ Ptr : ts Function tr ts = type2LlvmType' t diff --git a/src/Codegen/Emits.hs b/src/Codegen/Emits.hs index 1545a6c..4a2f794 100644 --- a/src/Codegen/Emits.hs +++ b/src/Codegen/Emits.hs @@ -22,6 +22,8 @@ import Data.Maybe (fromJust, fromMaybe, isNothing) import Data.Tuple.Extra (second) import Grammar.Print (printTree) import Monomorphizer.MonomorphizerIr +import Debug.Trace (traceShow) +import Data.List (isPrefixOf) compileScs :: [Def] -> CompilerState () @@ -111,7 +113,7 @@ compileScs (DBind bind : xs) = do let args' = zip (mkCxtName : map fst args) t_args - emit $ Define FastCC t_return name args' + emit $ Define FastCC (if isMain then I64 else t_return) name args' modify $ \s -> s { locals = foldr insertArg s.locals args' } -- Dereference ptr arguments @@ -133,10 +135,23 @@ compileScs (DBind bind : xs) = do result <- exprToValue exp + when isMain $ case t_return of + I64 -> do + emit . UnsafeRaw $ + "call i32 (ptr, ...) @printf(ptr noundef @.str, i64 noundef " <> toIr result <> ")\n" + I8 -> do + emit . UnsafeRaw $ + "call i32 (ptr, ...) @printf(ptr noundef @.char_print, i8 noundef " <> toIr result <> ")\n" + _ -> do + emit $ Comment "TODO" if isMain - then mapM_ emit $ lastMainContent gcEnabled result + then do + emit $ UnsafeRaw "call i32 (ptr, ...) @printf(ptr noundef @.new_line)\n" + mapM_ emit $ lastMainContent gcEnabled + emit $ Ret I64 (VInteger 0) else emit $ Ret t_return result + emit DefineEnd -- Reset variable count and empty locals modify $ \s -> s { variableCount = 0, locals = mempty } @@ -189,18 +204,9 @@ firstMainContent True = ] firstMainContent False = [] -lastMainContent :: Bool -> LLVMValue -> [LLVMIr] -lastMainContent True var = - [ UnsafeRaw $ - "call i32 (ptr, ...) @printf(ptr noundef @.str, i64 noundef " <> toIr var <> ")\n" - , UnsafeRaw "call void @cheap_dispose()\n" - , Ret I64 (VInteger 0) - ] -lastMainContent False var = - [ UnsafeRaw $ - "call i32 (ptr, ...) @printf(ptr noundef @.str, i64 noundef " <> toIr var <> ")\n" - , Ret I64 (VInteger 0) - ] +lastMainContent :: Bool -> [LLVMIr] +lastMainContent True = [UnsafeRaw "call void @cheap_dispose()\n"] +lastMainContent False =[] compileExp :: T Exp -> CompilerState () compileExp (ELit lit, _t) = emitLit lit @@ -322,6 +328,8 @@ emitECased t e cases = do emitCases rt ty label stackPtr vs (Branch (PLit $ LInt 1, t) exp) emitCases rt ty label stackPtr vs (Branch (PEnum (Ident "False$Bool"), t) exp) = do emitCases rt ty label stackPtr vs (Branch (PLit (LInt 0), t) exp) + emitCases rt ty label stackPtr vs (Branch (PEnum (Ident "Unit$Unit"), t) exp) = do + emitCases rt ty label stackPtr vs (Branch (PLit (LInt 0), t) exp) emitCases rt ty label stackPtr vs br@(Branch (PEnum consId, _) exp) = do emit $ Comment "Penum" cons <- gets constructors @@ -356,6 +364,16 @@ emitECased t e cases = do lbl_failPos <- (\x -> Ident $ "failed_" <> show x) <$> getNewLabel emit $ Label lbl_failPos +preludeFuns :: LLVMIr -> Ident -> LLVMValue -> LLVMValue -> CompilerState LLVMIr +preludeFuns def (Ident xs) arg1 arg2 + | "$langle$$langle$" `isPrefixOf` xs = pure $ Icmp LLSlt I8 arg1 arg2 + | "$langle$" `isPrefixOf` xs = pure $ Icmp LLSlt I8 arg1 arg2 + | "$minus$" `isPrefixOf` xs = pure $ Sub I64 arg1 arg2 + | "printChar$" `isPrefixOf` xs = pure . UnsafeRaw $ + "call i32 (ptr, ...) @printf(ptr noundef @.char_print_no_nl, i8 noundef " <> toIr arg1 <> ")\n" + --char_print_no_nl + | otherwise = pure def + emitApp :: Type -> T Exp -> T Exp -> CompilerState () emitApp rt e1 e2 = do ((EVar name, t), args) <- go (EApp e1 e2, rt) @@ -367,14 +385,7 @@ emitApp rt e1 e2 = do Global <$ Map.lookup name consts <|> Global <$ Map.lookup (name, t) funcs -- this piece of code could probably be improved, i.e remove the double `const Global` - call <- case name of - Ident ('$' : 'l' : 'a' : 'n' : 'g' : 'l' : 'e' : '$' : _) -> - pure $ Icmp LLSlt I64 (snd (head args)) (snd (args !! 1)) - Ident ('$' : 'm' : 'i' : 'n' : 'u' : 's' : '$' : '$' : _) -> - pure $ Sub I64 (snd (head args)) (snd (args !! 1)) - - -- FIXME - _ -> do + call <- do let closure_call LocalElem { typ = Ptr, val } = (mkDerefName name, (Ptr, val) : args) (name, args) <- gets $ maybe (name, (Ptr, VNull) : args) closure_call @@ -382,6 +393,8 @@ emitApp rt e1 e2 = do . locals pure $ Call FastCC (type2LlvmType rt) visibility name args + + call <- preludeFuns call name (snd (head args)) (snd (args !! 1)) emit $ Comment $ show (type2LlvmType rt) emit $ SetVariable vs call @@ -433,6 +446,7 @@ exprToValue et@(e, t) = case e of EVar "True$Bool" -> pure $ VInteger 1 EVar "False$Bool" -> pure $ VInteger 0 + EVar "Unit$Unit" -> pure $ VInteger 0 EVar name -> gets (Map.lookup name . globals) >>= \case Just (typ@(Function _ ts), val) | length ts > 1 -> do diff --git a/src/Codegen/LlvmIr.hs b/src/Codegen/LlvmIr.hs index 0e0a6ce..07b9892 100644 --- a/src/Codegen/LlvmIr.hs +++ b/src/Codegen/LlvmIr.hs @@ -29,6 +29,8 @@ data LLVMType | I8 | I32 | I64 + | I16 + | Void | Ptr | Ref LLVMType | Function LLVMType [LLVMType] @@ -47,9 +49,11 @@ instance ToIr LLVMType where toIr = \case I1 -> "i1" I8 -> "i8" + I16 -> "i16" I32 -> "i32" I64 -> "i64" Ptr -> "ptr" + Void -> "void" Ref ty -> toIr ty <> "*" Function t xs -> toIr t <> " (" <> intercalate ", " (map toIr xs) <> ")*" Array n ty -> concat ["[", show n, " x ", toIr ty, "]"] diff --git a/src/Main.hs b/src/Main.hs index fba8d40..75aad28 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -205,5 +205,9 @@ prelude = , "\n" , "printStr xs = case xs of" , " Nil => Nil" - , " Cons x xs => Cons (print x) (printStr xs)" + , " Cons x xs => Cons (printChar x) (printStr xs)" + , "\n" + , "data List a where" + , " Cons : a -> List a -> List a" + , " Nil : List a" ]