git.iko.soy/Idris-dev
on ed85b4e help sign in
Idris-dev/src/IRTS/Compiler.hs
325 lines 13 kB history raw
1{-# LANGUAGE PatternGuards #-}
3module IRTS.Compiler where
5import IRTS.Lang
6import IRTS.Defunctionalise
7import IRTS.Simplified
8import IRTS.CodegenCommon
9import IRTS.CodegenC
10import IRTS.CodegenJava
11import IRTS.DumpBC
12import IRTS.Inliner
14import Idris.AbsSyntax
15import Idris.UnusedArgs
17import Core.TT
18import Core.Evaluate
19import Core.CaseTree
21import Control.Monad.State
22import Data.List
23import System.Process
24import System.IO
25import System.Directory
26import System.Environment
27import System.FilePath ((</>), addTrailingPathSeparator)
29import Paths_idris
31compile :: Target -> FilePath -> Term -> Idris ()
32compile target f tm
33 = do checkMVs
34 let tmnames = namesUsed (STerm tm)
35 usedIn <- mapM (allNames []) tmnames
36 let used = [UN "prim__subBigInt", UN "prim__addBigInt"] : usedIn
37 defsIn <- mkDecls tm (concat used)
38 findUnusedArgs (concat used)
39 maindef <- irMain tm
40 objs <- getObjectFiles
41 libs <- getLibs
42 hdrs <- getHdrs
43 let defs = defsIn ++ [(MN 0 "runMain", maindef)]
44 -- iputStrLn $ showSep "\n" (map show defs)
45 let (nexttag, tagged) = addTags 65536 (liftAll defs)
46 let ctxtIn = addAlist tagged emptyContext
47 iLOG "Defunctionalising"
48 let defuns_in = defunctionalise nexttag ctxtIn
49 logLvl 5 $ show defuns_in
50 iLOG "Inlining"
51 let defuns = inline defuns_in
52 logLvl 5 $ show defuns
53 iLOG "Resolving variables for CG"
54 -- iputStrLn $ showSep "\n" (map show (toAlist defuns))
55 let checked = checkDefs defuns (toAlist defuns)
56 outty <- outputTy
57 dumpCases <- getDumpCases
58 dumpDefun <- getDumpDefun
59 case dumpCases of
60 Nothing -> return ()
61 Just f -> liftIO $ writeFile f (showCaseTrees tagged)
62 case dumpDefun of
63 Nothing -> return ()
64 Just f -> liftIO $ writeFile f (dumpDefuns defuns)
65 iLOG "Building output"
66 case checked of
67 OK c -> case target of
68 ViaC -> liftIO $ codegenC c f outty hdrs
69 (concatMap mkObj objs)
70 (concatMap mkLib libs) NONE
71 ViaJava -> liftIO $ codegenJava c f outty
72 Bytecode -> liftIO $ dumpBC c f
73 Error e -> fail $ show e
74 where checkMVs = do i <- get
75 case idris_metavars i \\ primDefs of
76 [] -> return ()
77 ms -> fail $ "There are undefined metavariables: " ++ show ms
78 inDir d h = do let f = d </> h
79 ex <- doesFileExist f
80 if ex then return f else return h
81 mkObj f = f ++ " "
82 mkLib l = "-l" ++ l ++ " "
86irMain :: TT Name -> Idris LDecl
87irMain tm = do i <- ir tm
88 return $ LFun (MN 0 "runMain") [] (LForce i)
90allNames :: [Name] -> Name -> Idris [Name]
91allNames ns n | n `elem` ns = return []
92allNames ns n = do i <- get
93 case lookupCtxt Nothing n (idris_callgraph i) of
94 [ns'] -> do more <- mapM (allNames (n:ns)) (map fst (calls ns'))
95 return (nub (n : concat more))
96 _ -> return [n]
98mkDecls :: Term -> [Name] -> Idris [(Name, LDecl)]
99mkDecls t used
100 = do i <- getIState
101 let ds = filter (\ (n, d) -> n `elem` used || isCon d) $ ctxtAlist (tt_ctxt i)
102 mapM traceUnused used
103 decls <- mapM build ds
104 return decls
106showCaseTrees :: [(Name, LDecl)] -> String
107showCaseTrees ds = showSep "\n\n" (map showCT ds)
108 where
109 showCT (n, LFun f args lexp)
110 = show n ++ " " ++ showSep " " (map show args) ++ " =\n\t "
111 ++ show lexp
112 showCT (n, LConstructor c t a) = "data " ++ show n ++ " " ++ show a
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 -- TMP HACK - until we get inlining.
151 | (P _ (UN "replace") _, [_, _, _, _, _, arg]) <- unApply tm
152 = ir' env arg
153 | (P _ (UN "lazy") _, [_, arg]) <- unApply tm
154 = do arg' <- ir' env arg
155 return $ LLazyExp arg'
156 | (P _ (UN "par") _, [_, arg]) <- unApply tm
157 = do arg' <- ir' env arg
158 return $ LOp LPar [LLazyExp arg']
159 | (P _ (UN "fork") _, [arg]) <- unApply tm
160 = do arg' <- ir' env arg
161 return $ LOp LFork [LLazyExp arg']
162 | (P _ (UN "prim__IO") _, [v]) <- unApply tm
163 = do v' <- ir' env v
164 return v'
165 | (P _ (UN "io_bind") _, [_,_,v,k]) <- unApply tm
166 = do v' <- ir' env v
167 k' <- ir' env k
168 return (LApp False k' [LForce v'])
169 | (P _ (UN "malloc") _, [_,size,t]) <- unApply tm
170 = do size' <- ir' env size
171 t' <- ir' env t
172 return t' -- TODO $ malloc_ size' t'
173 | (P _ (UN "trace_malloc") _, [_,t]) <- unApply tm
174 = do t' <- ir' env t
175 return t' -- TODO
176-- | (P _ (NS (UN "S") ["Nat", "Prelude"]) _, [k]) <- unApply tm
177-- = do k' <- ir' env k
178-- return (LOp LBPlus [k', LConst (BI 1)])
179 | (P (DCon t a) n _, args) <- unApply tm
180 = irCon env t a n args
181 | (P _ n _, args) <- unApply tm
182 = do i <- get
183 let collapse = case lookupCtxt Nothing n (idris_optimisation i) of
184 [oi] -> collapsible oi
185 _ -> False
186 let unused = case lookupCtxt Nothing n (idris_callgraph i) of
187 [CGInfo _ _ _ _ unusedpos] -> unusedpos
188 _ -> []
189 args' <- mapM (ir' env) args
190 if collapse then return LNothing
191 else return (LApp False (LV (Glob n))
192 (mkUnused unused 0 args'))
193 | (f, args) <- unApply tm
194 = do f' <- ir' env f
195 args' <- mapM (ir' env) args
196 return (LApp False f' args')
197 where mkUnused u i [] = []
198 mkUnused u i (x : xs) | i `elem` u = LNothing : mkUnused u (i + 1) xs
199 | otherwise = x : mkUnused u (i + 1) xs
200-- ir' env (P _ (NS (UN "O") ["Nat", "Prelude"]) _)
201-- = return $ LConst (BI 0)
202 ir' env (P _ n _) = return $ LV (Glob n)
203 ir' env (V i) | i < length env = return $ LV (Glob (env!!i))
204 | otherwise = error $ "IR fail " ++ show i ++ " " ++ show tm
205 ir' env (Bind n (Lam _) sc)
206 = do let n' = uniqueName n env
207 sc' <- ir' (n' : env) sc
208 return $ LLam [n'] sc'
209 ir' env (Bind n (Let _ v) sc)
210 = do sc' <- ir' (n : env) sc
211 v' <- ir' env v
212 return $ LLet n v' sc'
213 ir' env (Bind _ _ _) = return $ LNothing
214 ir' env (Proj t i) = do t' <- ir' env t
215 return $ LProj t' i
216 ir' env (Constant c) = return $ LConst c
217 ir' env (Set _) = return $ LNothing
218 ir' env Erased = return $ LNothing
219 ir' env Impossible = return $ LNothing
220-- ir' env _ = return $ LError "Impossible"
222 irCon env t arity n args
223 | length args == arity = buildApp env (LV (Glob n)) args
224 | otherwise = let extra = satArgs (arity - length args) in
225 do sc' <- irCon env t arity n
226 (args ++ map (\n -> P Bound n undefined) extra)
227 return $ LLam extra sc'
229 satArgs n = map (\i -> MN i "sat") [1..n]
231 buildApp env e [] = return e
232 buildApp env e xs = do xs' <- mapM (ir' env) xs
233 return $ LApp False e xs'
235 doForeign :: [Name] -> [TT Name] -> Idris LExp
236 doForeign env (_ : fgn : args)
237 | (_, (Constant (Str fgnName) : fgnArgTys : ret : [])) <- unApply fgn
238 = let tys = getFTypes fgnArgTys
239 rty = mkIty' ret in
240 do args' <- mapM (ir' env) args
241 -- wrap it in a prim__IO
242 -- return $ con_ 0 @@ impossible @@
243 return $ LLazyExp $
244 LForeign LANG_C rty fgnName (zip tys args')
245 | otherwise = fail "Badly formed foreign function call"
247getFTypes :: TT Name -> [FType]
248getFTypes tm = case unApply tm of
249 (nil, []) -> []
250 (cons, [ty, xs]) ->
251 let rest = getFTypes xs in
252 mkIty' ty : rest
254mkIty' (P _ (UN ty) _) = mkIty ty
255mkIty' _ = FAny
257mkIty "FInt" = FInt
258mkIty "FFloat" = FDouble
259mkIty "FChar" = FChar
260mkIty "FString" = FString
261mkIty "FPtr" = FPtr
262mkIty "FUnit" = FUnit
264zname = NS (UN "O") ["Nat","Prelude"]
265sname = NS (UN "S") ["Nat","Prelude"]
267instance ToIR ([Name], SC) where
268 ir (args, tree) = do logLvl 3 $ "Compiling " ++ show args ++ "\n" ++ show tree
269 tree' <- ir tree
270 return $ LLam args tree'
272instance ToIR SC where
273 ir t = ir' t where
275 ir' (STerm t) = ir t
276 ir' (UnmatchedCase str) = return $ LError str
277 ir' (ProjCase tm alts) = do alts' <- mapM (mkIRAlt tm) alts
278 tm' <- ir tm
279 return $ LCase tm' alts'
280 ir' (Case n alts) = do alts' <- mapM (mkIRAlt (P Bound n Erased)) alts
281 return $ LCase (LV (Glob n)) alts'
282 ir' ImpossibleCase = return LNothing
284 -- special cases for O and S
285 -- Needs rethink: projections make this fail
286-- mkIRAlt n (ConCase z _ [] rhs) | z == zname
287-- = mkIRAlt n (ConstCase (BI 0) rhs)
288-- mkIRAlt n (ConCase s _ [arg] rhs) | s == sname
289-- = do n' <- ir n
290-- rhs' <- ir rhs
291-- return $ LDefaultCase
292-- (LLet arg (LOp LBMinus [n', LConst (BI 1)])
293-- rhs')
294 mkIRAlt _ (ConCase n t args rhs)
295 = do rhs' <- ir rhs
296 return $ LConCase (-1) n args rhs'
297 mkIRAlt _ (ConstCase x rhs)
298 | matchable x
299 = do rhs' <- ir rhs
300 return $ LConstCase x rhs'
301 | matchableTy x
302 = do rhs' <- ir rhs
303 return $ LDefaultCase rhs'
304 mkIRAlt _ (ConstCase c rhs)
305 = fail $ "Can't match on (" ++ show c ++ ")"
306 mkIRAlt _ (DefaultCase rhs)
307 = do rhs' <- ir rhs
308 return $ LDefaultCase rhs'
310 matchable (I _) = True
311 matchable (BI _) = True
312 matchable (Ch _) = True
313 matchable (Str _) = True
314 matchable _ = False
316 matchableTy IType = True
317 matchableTy BIType = True
318 matchableTy ChType = True
319 matchableTy StrType = True
321 matchableTy W8Type = True
322 matchableTy W16Type = True
324 matchableTy _ = False