We can now print strings :)
This commit is contained in:
Samuel Hammersberg
parent
3755d41b59
commit
8ddb0ed052
6 changed files with 52 additions and 27 deletions
|
|
@ -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]
|
||||
|
|
|
|||
|
|
@ -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"
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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, "]"]
|
||||
|
|
|
|||
|
|
@ -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"
|
||||
]
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue