git.iko.soy/Idris-dev
on 46b7a4e help sign in
Idris-dev/src/Idris/Compiler.hs
240 lines 8.9 kB history raw
1{-# LANGUAGE PatternGuards #-}
3module Idris.Compiler where
5import Idris.AbsSyntax
6import Idris.Transforms
8import Core.TT
9import Core.Evaluate
10import Core.CaseTree
12import Control.Monad.State
13import Data.List
14import System.Process
15import System.IO
16import System.Directory
17import System.Environment
19import Paths_idris
21import Epic.Epic hiding (Term, Type, Name, fn, compile)
22import qualified Epic.Epic as E
24primDefs = [UN "mkForeign", UN "FalseElim"]
26compile :: FilePath -> Term -> Idris ()
27compile f tm
28 = do checkMVs
29 let tmnames = namesUsed (STerm tm)
30 used <- mapM (allNames []) tmnames
31 ds <- mkDecls tm (concat used)
32 objs <- getObjectFiles
33 libs <- getLibs
34 hdrs <- getHdrs
35 ddir <- liftIO $ getDataDir
36 -- if any includes exist in the data directory, use that
37 hdrs' <- liftIO $ mapM (inDir ddir) hdrs
38 let incs = map Include hdrs'
39 so <- getSO
40 let ilib = ddir ++ "/libidris.a"
41 case so of
42 Nothing ->
43 do m <- epicMain tm
44 let mainval = EpicFn (name "main") m
45 liftIO $ compileObjWith []
46 (mkProgram (incs ++ mainval : ds)) (f ++ ".o")
47 liftIO $ link ((f ++ ".o") : ilib : objs ++ (map ("-l"++) libs)) f
48 where checkMVs = do i <- get
49 case idris_metavars i \\ primDefs of
50 [] -> return ()
51 ms -> fail $ "There are undefined metavariables: " ++ show ms
52 inDir d h = do let f = d ++ "/" ++ h
53 ex <- doesFileExist f
54 if ex then return f else return h
57allNames :: [Name] -> Name -> Idris [Name]
58allNames ns n | n `elem` ns = return []
59allNames ns n = do i <- get
60 case lookupCtxt Nothing n (idris_callgraph i) of
61 [ns'] -> do more <- mapM (allNames (n:ns)) ns'
62 return (nub (n : concat more))
63 _ -> return [n]
65mkDecls :: Term -> [Name] -> Idris [EpicDecl]
66mkDecls t used
67 = do i <- getIState
68 let ds = filter (\ (n, d) -> n `elem` used) $ ctxtAlist (tt_ctxt i)
69 decls <- mapM build ds
70 return $ basic_defs ++ decls
72-- EpicFn (name "main") epicMain : decls
74ename x = name ("idris_" ++ show x)
75aname x = name ("a_" ++ show x)
77epicMain tm = do e <- epic tm
78 return $ effect_ e
80-- epicMain = effect_ $ -- ref (ename (UN "run__IO")) @@
81-- ref (ename (NS (UN "main") ["main"]))
83class ToEpic a where
84 epic :: a -> Idris E.Term
86build :: (Name, Def) -> Idris EpicDecl
87build (n, d) = do i <- getIState
88 case lookup n (idris_prims i) of
89 Just opDef -> return $ EpicFn (ename n) opDef
90 _ -> do def <- epic d
91 logLvl 3 $ "Compiled " ++ show n ++ " =\n\t" ++ show def
92 return $ EpicFn (ename n) def
94impossible = int 42424242
96instance ToEpic Def where
97 epic (Function tm _) = epic tm
98 epic (CaseOp _ _ pats _ _ args sc) = epic (args, sc) -- optimised version
99 epic _ = return impossible
101instance ToEpic (TT Name) where
102 epic tm = epic' [] tm where
103 epic' env tm@(App f a)
104 | (P _ (UN "mkForeign") _, args) <- unApply tm
105 = doForeign args
106 | (P _ (UN "lazy") _, [_,arg]) <- unApply tm
107 = do arg' <- epic' env arg
108 return $ lazy_ arg'
109 | (P _ (UN "prim__IO") _, [v]) <- unApply tm
110 = do v' <- epic' env v
111 return (effect_ v')
112 | (P _ (UN "io_bind") _, [_,_,v,k]) <- unApply tm
113 = do v' <- epic' env v
114 k' <- epic' env k
115 return (effect_ (k' @@ (effect_ v')))
116 | (P _ (UN "malloc") _, [_,size,t]) <- unApply tm
117 = do size' <- epic' env size
118 t' <- epic' env t
119 return $ malloc_ size' t'
120 | (P _ (UN "trace_malloc") _, [_,t]) <- unApply tm
121 = do t' <- epic' env t
122 return $ mallocTrace_ t'
123 | (P (DCon t a) n _, args) <- unApply tm
124 = epicCon env t a n args
125 epic' env (P (DCon t a) n _) = return $ con_ t
126 epic' env (P (TCon t a) n _) = return $ con_ t
127 epic' env (P _ n _) = return $ ref (ename n)
128 epic' env (V i) = return $ ref (env!!i)
129 epic' env (Bind n (Lam _) sc)
130 = do sc' <- epic' (aname n : env) sc
131 return $ term ([aname n], sc')
132 epic' env (Bind n (Let _ v) sc)
133 = do sc' <- epic' (aname n : env) sc
134 v' <- epic' env v
135 return $ let_ v' (aname n, sc')
136 epic' env (Bind _ _ _) = return impossible
137 epic' env (App f a) = do f' <- epic' env f
138 a' <- epic' env a
139 return (f' @@ a')
140 epic' env (Constant c) = epic c
141 epic' env Erased = return impossible
142 epic' env (Set _) = return impossible
144 epicCon env t arity n args
145 | length args == arity = buildApp env (con_ t) args
146 | otherwise = let extra = satArgs (arity - length args) in
147 do sc' <- epicCon env t arity n
148 (args ++ map (\n -> P Bound n undefined) extra)
149 return $ term (map ename extra, sc')
151 satArgs n = map (\i -> MN i "sat") [1..n]
153 buildApp env e [] = return e
154 buildApp env e (x:xs) = do x' <- epic' env x
155 buildApp env (e @@ x') xs
158doForeign :: [TT Name] -> Idris E.Term
159doForeign (_ : fgn : args)
160 | (_, (Constant (Str fgnName) : fgnArgTys : ret : [])) <- unApply fgn
161 = let tys = getFTypes fgnArgTys
162 rty = mkEty' ret in
163 do args' <- mapM epic args
164 -- wrap it in a prim__IO
165 -- return $ con_ 0 @@ impossible @@
166 return $ lazy_ $ foreign_ rty fgnName (zip args' tys)
167 | otherwise = fail "Badly formed foreign function call"
169getFTypes :: TT Name -> [E.Type]
170getFTypes tm = case unApply tm of
171 (nil, []) -> []
172 (cons, [ty, xs]) ->
173 let rest = getFTypes xs in
174 mkEty' ty : rest
176mkEty' (P _ (UN ty) _) = mkEty ty
177mkEty' _ = tyAny
179mkEty "FInt" = tyInt
180mkEty "FFloat" = tyFloat
181mkEty "FChar" = tyChar
182mkEty "FString" = tyString
183mkEty "FPtr" = tyPtr
184mkEty "FUnit" = tyUnit
186instance ToEpic Const where
187 epic (I i) = return (int i)
188 epic (BI i) = return (bigint i)
189 epic (Fl f) = return (float f)
190 epic (Str s) = return (str s)
191 epic (Ch c) = return (char c)
192 epic IType = return $ con_ 1
193 epic FlType = return $ con_ 2
194 epic ChType = return $ con_ 3
195 epic StrType = return $ con_ 4
196 epic PtrType = return $ con_ 5
197 epic BIType = return $ con_ 6
199instance ToEpic ([Name], SC) where
200 epic (args, tree) = do logLvl 3 $ "Compiling " ++ show args ++ "\n" ++ show tree
201 tree' <- epic tree
202 return $ term (map ename args, tree')
204instance ToEpic SC where
205 epic (Case n [ConCase _ i ns sc])
206 = epicLet n ns 0 sc
207 where
208 epicLet x [] _ sc = epic sc
209 epicLet x (n:ns) i sc
210 = do sc' <- epicLet x ns (i+1) sc
211 return $ let_ (ref (ename x) !. i) (ename n, sc')
213 epic (STerm t) = epic t
214 epic (UnmatchedCase str) = return $ error_ str
215 epic (Case n alts) = do alts' <- mapM mkEpicAlt alts
216 return $ case_ (ref (ename n)) alts'
217 where
218 mkEpicAlt (ConCase n t args rhs) = do rhs' <- epic rhs
219 return $ con t (map ename args, rhs')
220 mkEpicAlt (ConstCase (I i) rhs) = do rhs' <- epic rhs
221 return $ constcase i rhs'
222 mkEpicAlt (ConstCase IType rhs) = do rhs' <- epic rhs
223 return $ defaultcase rhs'
224 mkEpicAlt (ConstCase c rhs)
225 = fail $ "Can only pattern match on integer constants (" ++ show c ++ ")"
226 mkEpicAlt (DefaultCase rhs) = do rhs' <- epic rhs
227 return $ defaultcase rhs'
229tempfile :: IO (FilePath, Handle)
230tempfile = do env <- environment "TMPDIR"
231 let dir = case env of
232 Nothing -> "/tmp"
233 (Just d) -> d
234 openTempFile dir "esc"
236environment :: String -> IO (Maybe String)
237environment x = catch (do e <- getEnv x
238 return (Just e))
239 (\_ -> return Nothing)