-
Notifications
You must be signed in to change notification settings - Fork 130
/
Emit.hs
104 lines (88 loc) · 2.65 KB
/
Emit.hs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
{-# LANGUAGE OverloadedStrings #-}
module Emit where
import LLVM.Module
import LLVM.Context
import qualified LLVM.AST as AST
import qualified LLVM.AST.Constant as C
import qualified LLVM.AST.Float as F
import qualified LLVM.AST.FloatingPointPredicate as FP
import Data.Word
import Data.Int
import Control.Monad.Except
import Control.Applicative
import qualified Data.Map as Map
import Codegen
import qualified Syntax as S
toSig :: [String] -> [(AST.Type, AST.Name)]
toSig = map (\x -> (double, AST.Name x))
codegenTop :: S.Expr -> LLVM ()
codegenTop (S.Function name args body) = do
define double name fnargs bls
where
fnargs = toSig args
bls = createBlocks $ execCodegen $ do
entry <- addBlock entryBlockName
setBlock entry
forM args $ \a -> do
var <- alloca double
store var (local (AST.Name a))
assign a var
cgen body >>= ret
codegenTop (S.Extern name args) = do
external double name fnargs
where fnargs = toSig args
codegenTop exp = do
define double "main" [] blks
where
blks = createBlocks $ execCodegen $ do
entry <- addBlock entryBlockName
setBlock entry
cgen exp >>= ret
-------------------------------------------------------------------------------
-- Operations
-------------------------------------------------------------------------------
lt :: AST.Operand -> AST.Operand -> Codegen AST.Operand
lt a b = do
test <- fcmp FP.ULT a b
uitofp double test
binops = Map.fromList [
("+", fadd)
, ("-", fsub)
, ("*", fmul)
, ("/", fdiv)
, ("<", lt)
]
cgen :: S.Expr -> Codegen AST.Operand
cgen (S.UnaryOp op a) = do
cgen $ S.Call ("unary" ++ op) [a]
cgen (S.BinaryOp "=" (S.Var var) val) = do
a <- getvar var
cval <- cgen val
store a cval
return cval
cgen (S.BinaryOp op a b) = do
case Map.lookup op binops of
Just f -> do
ca <- cgen a
cb <- cgen b
f ca cb
Nothing -> error "No such operator"
cgen (S.Var x) = getvar x >>= load
cgen (S.Float n) = return $ cons $ C.Float (F.Double n)
cgen (S.Call fn args) = do
largs <- mapM cgen args
call (externf (AST.Name fn)) largs
-------------------------------------------------------------------------------
-- Compilation
-------------------------------------------------------------------------------
liftError :: ExceptT String IO a -> IO a
liftError = runExceptT >=> either fail return
codegen :: AST.Module -> [S.Expr] -> IO AST.Module
codegen mod fns = withContext $ \context ->
liftError $ withModuleFromAST context newast $ \m -> do
llstr <- moduleLLVMAssembly m
putStrLn llstr
return newast
where
modn = mapM codegenTop fns
newast = runLLVM mod modn