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