/
Compiler.hs
143 lines (120 loc) · 5.25 KB
/
Compiler.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
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
{-# LANGUAGE PatternGuards #-}
module Idris.Compiler where
import Idris.AbsSyntax
import Core.TT
import Core.Evaluate
import Core.CaseTree
import Control.Monad.State
import Epic.Epic hiding (Term, Type, Name, fn, compile)
import qualified Epic.Epic as E
primDefs = [UN "mkForeign", UN "FalseElim", UN "believe_me"]
compile :: FilePath -> Idris ()
compile f = do ds <- mkDecls
objs <- getObjectFiles
libs <- getLibs
hdrs <- getHdrs
let incs = map Include hdrs
lift $ compileObjWith [Debug] (mkProgram (incs ++ ds)) (f ++ ".o")
lift $ link ((f ++ ".o") : objs ++ (map ("-l"++) libs)) f
mkDecls :: Idris [EpicDecl]
mkDecls = do i <- getIState
decls <- mapM build (ctxtAlist (tt_ctxt i))
return $ basic_defs ++ EpicFn (name "main") epicMain : decls
ename x = name ("idris_" ++ show x)
aname x = name ("a_" ++ show x)
epicMain = effect_ $ ref (ename (UN "run__IO")) @@
ref (ename (NS (UN "main") ["main"]))
class ToEpic a where
epic :: a -> Idris E.Term
build :: (Name, Def) -> Idris EpicDecl
build (n, d) = do i <- getIState
case lookup n (idris_prims i) of
Just opDef -> return $ EpicFn (ename n) opDef
_ -> do def <- epic d
logLvl 3 $ "Compiled " ++ show n ++ " =\n\t" ++ show def
return $ EpicFn (ename n) def
impossible = int 42424242
instance ToEpic Def where
epic (Function tm _) = epic tm
epic (CaseOp _ _ pats args sc) = epic (args, sc) -- TODO: redo case comp after optimising
epic _ = return impossible
instance ToEpic (TT Name) where
epic tm = epic' [] tm where
epic' env tm@(App f a)
| (P _ (UN "mkForeign") _, args) <- unApply tm
= doForeign args
| (P _ (UN "lazy") _, [_, arg]) <- unApply tm
= do arg' <- epic' env arg
return $ lazy_ arg'
| (P _ (UN "believe_me") _, [_, _, arg]) <- unApply tm
= epic' env arg
epic' env (P (DCon t a) n _) = return $ con_ t
epic' env (P (TCon t a) n _) = return $ con_ t
epic' env (P _ n _) = return $ ref (ename n)
epic' env (V i) = return $ ref (env!!i)
epic' env (Bind n (Lam _) sc)
= do sc' <- epic' (aname n : env) sc
return $ term ([aname n], sc')
epic' env (Bind n (Let _ v) sc)
= do sc' <- epic' (aname n : env) sc
v' <- epic' env v
return $ let_ v' (aname n, sc')
epic' env (Bind _ _ _) = return impossible
epic' env (App f a) = do f' <- epic' env f
a' <- epic' env a
return (f' @@ a')
epic' env (Constant c) = epic c
epic' env (Set _) = return impossible
doForeign :: [TT Name] -> Idris E.Term
doForeign (_ : fgn : args)
| (_, (Constant (Str fgnName) : fgnArgTys : P _ (UN ret) _ : [])) <- unApply fgn
= let tys = getFTypes fgnArgTys
rty = mkEty ret in
do args' <- mapM epic args
-- wrap it in a prim__IO
return $ con_ 0 @@ impossible @@ foreign_ rty fgnName (zip args' tys)
| otherwise = fail "Badly formed foreign function call"
getFTypes :: TT Name -> [E.Type]
getFTypes tm = case unApply tm of
(nil, [arg]) -> []
(cons, [a, (P _ (UN ty) _), xs]) ->
let rest = getFTypes xs in
mkEty ty : rest
mkEty "FInt" = tyInt
mkEty "FFloat" = tyFloat
mkEty "FChar" = tyChar
mkEty "FString" = tyString
mkEty "FPtr" = tyPtr
mkEty "FUnit" = tyUnit
instance ToEpic Const where
epic (I i) = return (int i)
epic (BI i) = return (bigint i)
epic (Fl f) = return (float f)
epic (Str s) = return (str s)
epic (Ch c) = return (char c)
epic IType = return $ con_ 1
epic FlType = return $ con_ 2
epic ChType = return $ con_ 3
epic StrType = return $ con_ 4
epic PtrType = return $ con_ 5
epic BIType = return $ con_ 6
instance ToEpic ([Name], SC) where
epic (args, tree) = do logLvl 3 $ "Compiling " ++ show args ++ "\n" ++ show tree
tree' <- epic tree
return $ term (map ename args, tree')
instance ToEpic SC where
epic (STerm t) = epic t
epic (UnmatchedCase str) = return $ error_ str
epic (Case n alts) = do alts' <- mapM mkEpicAlt alts
return $ case_ (ref (ename n)) alts'
where
mkEpicAlt (ConCase n t args rhs) = do rhs' <- epic rhs
return $ con t (map ename args, rhs')
mkEpicAlt (ConstCase (I i) rhs) = do rhs' <- epic rhs
return $ constcase i rhs'
mkEpicAlt (ConstCase IType rhs) = do rhs' <- epic rhs
return $ defaultcase rhs'
mkEpicAlt (ConstCase c rhs)
= fail $ "Can only pattern match on integer constants (" ++ show c ++ ")"
mkEpicAlt (DefaultCase rhs) = do rhs' <- epic rhs
return $ defaultcase rhs'