git.iko.soy/Idris-dev
on 1865526 help sign in
Idris-dev/src/IRTS/Compiler.hs
264 lines 9.9 kB history raw
1{-# LANGUAGE PatternGuards #-}
3module IRTS.Compiler where
5import IRTS.Lang
6import IRTS.Defunctionalise
7import IRTS.Simplified
8import IRTS.CodegenC
9import IRTS.CodegenJava
10import IRTS.Inliner
12import Idris.AbsSyntax
13import Idris.UnusedArgs
15import Core.TT
16import Core.Evaluate
17import Core.CaseTree
19import Control.Monad.State
20import Data.List
21import System.Process
22import System.IO
23import System.Directory
24import System.Environment
26import Paths_idris
28compile :: Target -> FilePath -> Term -> Idris ()
29compile target f tm
30 = do checkMVs
31 let tmnames = namesUsed (STerm tm)
32 used <- mapM (allNames []) tmnames
33 defsIn <- mkDecls tm (concat used)
34 findUnusedArgs (concat used)
35 maindef <- irMain tm
36 objs <- getObjectFiles
37 libs <- getLibs
38 hdrs <- getHdrs
39 let defs = defsIn ++ [(MN 0 "runMain", maindef)]
40 -- iputStrLn $ showSep "\n" (map show defs)
41 let (nexttag, tagged) = addTags 65536 (liftAll defs)
42 let ctxtIn = addAlist tagged emptyContext
43 iLOG "Defunctionalising"
44 let defuns_in = defunctionalise nexttag ctxtIn
45 logLvl 5 $ show defuns_in
46 iLOG "Inlining"
47 let defuns = inline defuns_in
48 logLvl 5 $ show defuns
49 iLOG "Resolving variables for CG"
50 -- iputStrLn $ showSep "\n" (map show (toAlist defuns))
51 let checked = checkDefs defuns (toAlist defuns)
52 dumpC <- getDumpC
53 dumpCases <- getDumpCases
54 dumpDefun <- getDumpDefun
55 case dumpCases of
56 Nothing -> return ()
57 Just f -> do cs <- getCaseTrees (concat used)
58 liftIO $ writeFile f (showCaseTrees cs)
59 case dumpDefun of
60 Nothing -> return ()
61 Just f -> liftIO $ writeFile f (dumpDefuns defuns)
62 iLOG "Building output"
63 case checked of
64 OK c -> case target of
65 ViaC -> liftIO $ codegenC dumpC c f True hdrs
66 (concatMap mkObj objs)
67 (concatMap mkLib libs) NONE
68 ViaJava -> liftIO $ codegenJava c f
69 Error e -> fail $ show e
70 where checkMVs = do i <- get
71 case idris_metavars i \\ primDefs of
72 [] -> return ()
73 ms -> fail $ "There are undefined metavariables: " ++ show ms
74 inDir d h = do let f = d ++ "/" ++ h
75 ex <- doesFileExist f
76 if ex then return f else return h
77 mkObj f = f ++ " "
78 mkLib l = "-l" ++ l ++ " "
82irMain :: TT Name -> Idris LDecl
83irMain tm = do i <- ir tm
84 return $ LFun (MN 0 "runMain") [] (LForce i)
86allNames :: [Name] -> Name -> Idris [Name]
87allNames ns n | n `elem` ns = return []
88allNames ns n = do i <- get
89 case lookupCtxt Nothing n (idris_callgraph i) of
90 [ns'] -> do more <- mapM (allNames (n:ns)) (map fst (calls ns'))
91 return (nub (n : concat more))
92 _ -> return [n]
94mkDecls :: Term -> [Name] -> Idris [(Name, LDecl)]
95mkDecls t used
96 = do i <- getIState
97 let ds = filter (\ (n, d) -> n `elem` used || isCon d) $ ctxtAlist (tt_ctxt i)
98 decls <- mapM build ds
99 return decls
101getCaseTrees :: [Name] -> Idris [(Name, Def)]
102getCaseTrees used
103 = do i <- getIState
104 let ds = filter (\ (n, d) -> n `elem` used || isCon d) $ ctxtAlist (tt_ctxt i)
105 return ds
107showCaseTrees :: [(Name, Def)] -> String
108showCaseTrees ds = showSep "\n\n" (map showCT ds)
109 where
110 showCT (n, CaseOp _ _ _ _ _ args sc)
111 = show n ++ " " ++ showSep " " (map show args) ++ " = " ++ show sc
112 showCT (n, _) = ""
114isCon (TyDecl _ _) = True
115isCon _ = False
117class ToIR a where
118 ir :: a -> Idris LExp
120build :: (Name, Def) -> Idris (Name, LDecl)
121build (n, d)
122 = do i <- getIState
123 case lookup n (idris_scprims i) of
124 Just (ar, op) ->
125 let args = map (\x -> MN x "op") [0..] in
126 return (n, (LFun n (take ar args)
127 (LOp op (map (LV . Glob) (take ar args)))))
128 _ -> do def <- mkLDecl n d
129 logLvl 3 $ "Compiled " ++ show n ++ " =\n\t" ++ show def
130 return (n, def)
132declArgs args n (LLam xs x) = declArgs (args ++ xs) n x
133declArgs args n x = LFun n args x
135mkLDecl n (Function tm _) = do e <- ir tm
136 return (declArgs [] n e)
137mkLDecl n (CaseOp _ _ pats _ _ args sc) = do e <- ir (args, sc)
138 return (declArgs [] n e)
139mkLDecl n (TyDecl (DCon t a) _) = return $ LConstructor n t a
140mkLDecl n (TyDecl (TCon t a) _) = return $ LConstructor n (-1) a
141mkLDecl n _ = return (LFun n [] (LError ("Impossible declaration " ++ show n)))
143instance ToIR (TT Name) where
144 ir tm = ir' [] tm where
145 ir' env tm@(App f a)
146 | (P _ (UN "mkForeign") _, args) <- unApply tm
147 = doForeign env args
148 | (P _ (UN "unsafePerformIO") _, [_, arg]) <- unApply tm
149 = ir' env arg
150 | (P _ (UN "lazy") _, [_, arg]) <- unApply tm
151 = do arg' <- ir' env arg
152 return $ LLazyExp arg'
153 | (P _ (UN "fork") _, [arg]) <- unApply tm
154 = do arg' <- ir' env arg
155 return $ LOp LFork [LLazyExp arg']
156 | (P _ (UN "prim__IO") _, [v]) <- unApply tm
157 = do v' <- ir' env v
158 return v'
159 | (P _ (UN "io_bind") _, [_,_,v,k]) <- unApply tm
160 = do v' <- ir' env v
161 k' <- ir' env k
162 return (LApp False k' [LForce v'])
163 | (P _ (UN "malloc") _, [_,size,t]) <- unApply tm
164 = do size' <- ir' env size
165 t' <- ir' env t
166 return t' -- TODO $ malloc_ size' t'
167 | (P _ (UN "trace_malloc") _, [_,t]) <- unApply tm
168 = do t' <- ir' env t
169 return t' -- TODO
170 | (P (DCon t a) n _, args) <- unApply tm
171 = irCon env t a n args
172 | (f, args) <- unApply tm
173 = do f' <- ir' env f
174 args' <- mapM (ir' env) args
175 return (LApp False f' args')
176 ir' env (P _ n _) = return $ LV (Glob n)
177 ir' env (V i) | i < length env = return $ LV (Glob (env!!i))
178 | otherwise = error $ "IR fail " ++ show i ++ " " ++ show tm
179 ir' env (Bind n (Lam _) sc)
180 = do let n' = uniqueName n env
181 sc' <- ir' (n' : env) sc
182 return $ LLam [n'] sc'
183 ir' env (Bind n (Let _ v) sc)
184 = do sc' <- ir' (n : env) sc
185 v' <- ir' env v
186 return $ LLet n v' sc'
187 ir' env (Bind _ _ _) = return $ LConst (I 424242)
188 ir' env (Proj t i) = do t' <- ir' env t
189 return $ LProj t' i
190 ir' env (Constant c) = return $ LConst c
191 ir' env _ = return $ LError "Impossible"
193 irCon env t arity n args
194 | length args == arity = buildApp env (LV (Glob n)) args
195 | otherwise = let extra = satArgs (arity - length args) in
196 do sc' <- irCon env t arity n
197 (args ++ map (\n -> P Bound n undefined) extra)
198 return $ LLam extra sc'
200 satArgs n = map (\i -> MN i "sat") [1..n]
202 buildApp env e [] = return e
203 buildApp env e xs = do xs' <- mapM (ir' env) xs
204 return $ LApp False e xs'
206 doForeign :: [Name] -> [TT Name] -> Idris LExp
207 doForeign env (_ : fgn : args)
208 | (_, (Constant (Str fgnName) : fgnArgTys : ret : [])) <- unApply fgn
209 = let tys = getFTypes fgnArgTys
210 rty = mkIty' ret in
211 do args' <- mapM (ir' env) args
212 -- wrap it in a prim__IO
213 -- return $ con_ 0 @@ impossible @@
214 return $ LLazyExp $ LForeign LANG_C rty fgnName (zip tys args')
215 | otherwise = fail "Badly formed foreign function call"
217getFTypes :: TT Name -> [FType]
218getFTypes tm = case unApply tm of
219 (nil, []) -> []
220 (cons, [ty, xs]) ->
221 let rest = getFTypes xs in
222 mkIty' ty : rest
224mkIty' (P _ (UN ty) _) = mkIty ty
225mkIty' _ = FAny
227mkIty "FInt" = FInt
228mkIty "FFloat" = FDouble
229mkIty "FChar" = FChar
230mkIty "FString" = FString
231mkIty "FPtr" = FPtr
232mkIty "FUnit" = FUnit
234instance ToIR ([Name], SC) where
235 ir (args, tree) = do logLvl 3 $ "Compiling " ++ show args ++ "\n" ++ show tree
236 tree' <- ir tree
237 return $ LLam args tree'
239instance ToIR SC where
240 ir t = ir' t where
242 ir' (STerm t) = ir t
243 ir' (UnmatchedCase str) = return $ LError str
244 ir' (ProjCase tm alts) = do alts' <- mapM mkIRAlt alts
245 tm' <- ir tm
246 return $ LCase tm' alts'
247 ir' (Case n alts) = do alts' <- mapM mkIRAlt alts
248 return $ LCase (LV (Glob n)) alts'
250 mkIRAlt (ConCase n t args rhs)
251 = do rhs' <- ir rhs
252 return $ LConCase (-1) n args rhs'
253 mkIRAlt (ConstCase (I i) rhs)
254 = do rhs' <- ir rhs
255 return $ LConstCase (I i) rhs'
256 mkIRAlt (ConstCase IType rhs)
257 = do rhs' <- ir rhs
258 return $ LDefaultCase rhs'
259 mkIRAlt (ConstCase c rhs)
260 = fail $ "Can only pattern match on integer constants (" ++ show c ++ ")"
261 mkIRAlt (DefaultCase rhs)
262 = do rhs' <- ir rhs
263 return $ LDefaultCase rhs'