git.iko.soy/Idris-dev
on 7afa310 help sign in
Idris-dev/src/IRTS/Lang.hs
352 lines 14 kB history raw
1{-# LANGUAGE PatternGuards, DeriveFunctor #-}
3module IRTS.Lang where
5import Control.Monad.State hiding (lift)
6import Control.Applicative hiding (Const)
8import Idris.Core.TT
9import Idris.Core.CaseTree
11import Data.List
12import Debug.Trace
14data Endianness = Native | BE | LE deriving (Show, Eq)
16data LVar = Loc Int | Glob Name
17 deriving (Show, Eq)
19-- ASSUMPTION: All variable bindings have unique names here
20data LExp = LV LVar
21 | LApp Bool LExp [LExp] -- True = tail call
22 | LLazyApp Name [LExp] -- True = tail call
23 | LLazyExp LExp
24 | LForce LExp -- make sure Exp is evaluted
25 | LLet Name LExp LExp -- name just for pretty printing
26 | LLam [Name] LExp -- lambda, lifted out before compiling
27 | LProj LExp Int -- projection
28 | LCon (Maybe LVar) -- Location to reallocate, if available
29 Int Name [LExp]
30 | LCase CaseType LExp [LAlt]
31 | LConst Const
32 | LForeign FLang FType String [(FType, LExp)]
33 | LOp PrimFn [LExp]
34 | LNothing
35 | LError String
36 deriving Eq
38-- Primitive operators. Backends are not *required* to implement all
39-- of these, but should report an error if they are unable
41data PrimFn = LPlus ArithTy | LMinus ArithTy | LTimes ArithTy
42 | LUDiv IntTy | LSDiv ArithTy | LURem IntTy | LSRem ArithTy
43 | LAnd IntTy | LOr IntTy | LXOr IntTy | LCompl IntTy
44 | LSHL IntTy | LLSHR IntTy | LASHR IntTy
45 | LEq ArithTy | LLt IntTy | LLe IntTy | LGt IntTy | LGe IntTy
46 | LSLt ArithTy | LSLe ArithTy | LSGt ArithTy | LSGe ArithTy
47 | LSExt IntTy IntTy | LZExt IntTy IntTy | LTrunc IntTy IntTy
48 | LStrConcat | LStrLt | LStrEq | LStrLen
49 | LIntFloat IntTy | LFloatInt IntTy | LIntStr IntTy | LStrInt IntTy
50 | LFloatStr | LStrFloat | LChInt IntTy | LIntCh IntTy
51 | LPrintNum | LPrintStr | LReadStr
52 | LBitCast ArithTy ArithTy -- Only for values of equal width
54 | LFExp | LFLog | LFSin | LFCos | LFTan | LFASin | LFACos | LFATan
55 | LFSqrt | LFFloor | LFCeil | LFNegate
57 -- construction element extraction element insertion
58 | LMkVec NativeTy Int | LIdxVec NativeTy Int | LUpdateVec NativeTy Int
60 | LStrHead | LStrTail | LStrCons | LStrIndex | LStrRev
61 | LStdIn | LStdOut | LStdErr
63 -- Buffers
64 | LAllocate
65 | LAppendBuffer
66 -- system info
67 | LSystemInfo
68 -- Note that for Bits8 only Native endianness is actually used
69 -- and the user-exposed interface for Bits8 doesn't mention
70 -- endianness
71 | LAppend IntTy Endianness
72 | LPeek IntTy Endianness
74 | LFork
75 | LPar -- evaluate argument anywhere, possibly on another
76 -- core or another machine. 'id' is a valid implementation
77 | LVMPtr
78 | LNullPtr
79 | LRegisterPtr
80 | LNoOp
81 deriving (Show, Eq)
83-- Supported target languages for foreign calls
85data FCallType = FStatic | FObject | FConstructor
86 deriving (Show, Eq)
88data FLang = LANG_C | LANG_JAVA FCallType
89 deriving (Show, Eq)
91data FType = FArith ArithTy
92 | FFunction
93 | FFunctionIO
94 | FString
95 | FUnit
96 | FPtr
97 | FManagedPtr
98 | FAny
99 deriving (Show, Eq)
101-- FIXME: Why not use this for all the IRs now?
102data LAlt' e = LConCase Int Name [Name] e
103 | LConstCase Const e
104 | LDefaultCase e
105 deriving (Show, Eq, Functor)
107type LAlt = LAlt' LExp
109data LDecl = LFun [LOpt] Name [Name] LExp -- options, name, arg names, def
110 | LConstructor Name Int Int -- constructor name, tag, arity
111 deriving (Show, Eq)
113type LDefs = Ctxt LDecl
115data LOpt = Inline | NoInline
116 deriving (Show, Eq)
118addTags :: Int -> [(Name, LDecl)] -> (Int, [(Name, LDecl)])
119addTags i ds = tag i ds []
120 where tag i ((n, LConstructor n' (-1) a) : as) acc
121 = tag (i + 1) as ((n, LConstructor n' i a) : acc)
122 tag i ((n, LConstructor n' t a) : as) acc
123 = tag i as ((n, LConstructor n' t a) : acc)
124 tag i (x : as) acc = tag i as (x : acc)
125 tag i [] acc = (i, reverse acc)
127data LiftState = LS Name Int [(Name, LDecl)]
129lname (NS n x) i = NS (lname n i) x
130lname (UN n) i = MN i n
131lname x i = sMN i (show x)
133liftAll :: [(Name, LDecl)] -> [(Name, LDecl)]
134liftAll xs = concatMap (\ (x, d) -> lambdaLift x d) xs
136lambdaLift :: Name -> LDecl -> [(Name, LDecl)]
137lambdaLift n (LFun opts _ args e)
138 = let (e', (LS _ _ decls)) = runState (lift args e) (LS n 0 []) in
139 (n, LFun opts n args e') : decls
140lambdaLift n x = [(n, x)]
142getNextName :: State LiftState Name
143getNextName = do LS n i ds <- get
144 put (LS n (i + 1) ds)
145 return (lname n i)
147addFn :: Name -> LDecl -> State LiftState ()
148addFn fn d = do LS n i ds <- get
149 put (LS n i ((fn, d) : ds))
151lift :: [Name] -> LExp -> State LiftState LExp
152lift env (LV v) = return (LV v) -- Lifting happens before these can exist...
153lift env (LApp tc (LV (Glob n)) args) = do args' <- mapM (lift env) args
154 return (LApp tc (LV (Glob n)) args')
155lift env (LApp tc f args) = do f' <- lift env f
156 fn <- getNextName
157 addFn fn (LFun [Inline] fn env f')
158 args' <- mapM (lift env) args
159 return (LApp tc (LV (Glob fn)) (map (LV . Glob) env ++ args'))
160lift env (LLazyApp n args) = do args' <- mapM (lift env) args
161 return (LLazyApp n args')
162lift env (LLazyExp (LConst c)) = return (LConst c)
163-- lift env (LLazyExp (LApp tc (LV (Glob f)) args))
164-- = lift env (LLazyApp f args)
165lift env (LLazyExp e) = do e' <- lift env e
166 let usedArgs = nub $ usedIn env e'
167 fn <- getNextName
168 addFn fn (LFun [NoInline] fn usedArgs e')
169 return (LLazyApp fn (map (LV . Glob) usedArgs))
170lift env (LForce e) = do e' <- lift env e
171 return (LForce e')
172lift env (LLet n v e) = do v' <- lift env v
173 e' <- lift (env ++ [n]) e
174 return (LLet n v' e')
175lift env (LLam args e) = do e' <- lift (env ++ args) e
176 let usedArgs = nub $ usedIn env e'
177 fn <- getNextName
178 addFn fn (LFun [Inline] fn (usedArgs ++ args) e')
179 return (LApp False (LV (Glob fn)) (map (LV . Glob) usedArgs))
180lift env (LProj t i) = do t' <- lift env t
181 return (LProj t' i)
182lift env (LCon loc i n args) = do args' <- mapM (lift env) args
183 return (LCon loc i n args')
184lift env (LCase up e alts) = do alts' <- mapM liftA alts
185 e' <- lift env e
186 return (LCase up e' alts')
187 where
188 liftA (LConCase i n args e) = do e' <- lift (env ++ args) e
189 return (LConCase i n args e')
190 liftA (LConstCase c e) = do e' <- lift env e
191 return (LConstCase c e')
192 liftA (LDefaultCase e) = do e' <- lift env e
193 return (LDefaultCase e')
194lift env (LConst c) = return (LConst c)
195lift env (LForeign l t s args) = do args' <- mapM (liftF env) args
196 return (LForeign l t s args')
197 where
198 liftF env (t, e) = do e' <- lift env e
199 return (t, e')
200lift env (LOp f args) = do args' <- mapM (lift env) args
201 return (LOp f args')
202lift env (LError str) = return $ LError str
203lift env LNothing = return $ LNothing
205allocUnique :: LDefs -> (Name, LDecl) -> (Name, LDecl)
206allocUnique defs p@(n, LConstructor _ _ _) = p
207allocUnique defs (n, LFun opts fn args e)
208 = let e' = evalState (findUp e) [] in
209 (n, LFun opts fn args e')
210 where
211 -- Keep track of 'updatable' names in the state, i.e. names whose heap
212 -- entry may be reused, along with the arity which was there
213 findUp :: LExp -> State [(Name, Int)] LExp
214 findUp (LApp t (LV (Glob n)) as)
215 | Just (LConstructor _ i ar) <- lookupCtxtExact n defs,
216 ar == length as
217 = findUp (LCon Nothing i n as)
218 findUp (LV (Glob n))
219 | Just (LConstructor _ i 0) <- lookupCtxtExact n defs
220 = return $ LCon Nothing i n [] -- nullary cons are global, no need to update
221 findUp (LApp t f as) = LApp t <$> findUp f <*> mapM findUp as
222 findUp (LLazyApp n as) = LLazyApp n <$> mapM findUp as
223 findUp (LLazyExp e) = LLazyExp <$> findUp e
224 findUp (LForce e) = LForce <$> findUp e
225 -- use assumption that names are unique!
226 findUp (LLet n val sc) = LLet n <$> findUp val <*> findUp sc
227 findUp (LLam ns sc) = LLam ns <$> findUp sc
228 findUp (LProj e i) = LProj <$> findUp e <*> return i
229 findUp (LCon (Just l) i n es) = LCon (Just l) i n <$> mapM findUp es
230 findUp (LCon Nothing i n es)
231 = do avail <- get
232 v <- findVar [] avail (length es)
233 LCon v i n <$> mapM findUp es
234 findUp (LForeign l t s es)
235 = LForeign l t s <$> mapM (\ (t, e) -> do e' <- findUp e
236 return (t, e')) es
237 findUp (LOp o es) = LOp o <$> mapM findUp es
238 findUp (LCase Updatable e@(LV (Glob n)) as)
239 = LCase Updatable e <$> mapM (doUpAlt n) as
240 findUp (LCase t e as)
241 = LCase t <$> findUp e <*> mapM findUpAlt as
242 findUp t = return t
244 findUpAlt (LConCase i t args rhs) = do avail <- get
245 rhs' <- findUp rhs
246 put avail
247 return $ LConCase i t args rhs'
248 findUpAlt (LConstCase i rhs) = LConstCase i <$> findUp rhs
249 findUpAlt (LDefaultCase rhs) = LDefaultCase <$> findUp rhs
251 doUpAlt n (LConCase i t args rhs)
252 = do avail <- get
253 put ((n, length args) : avail)
254 rhs' <- findUp rhs
255 put avail
256 return $ LConCase i t args rhs'
257 doUpAlt n (LConstCase i rhs) = LConstCase i <$> findUp rhs
258 doUpAlt n (LDefaultCase rhs) = LDefaultCase <$> findUp rhs
260 findVar _ [] i = return Nothing
261 findVar acc ((n, l) : ns) i | l == i = do put (reverse acc ++ ns)
262 return (Just (Glob n))
263 findVar acc (n : ns) i = findVar (n : acc) ns i
266-- Return variables in list which are used in the expression
268usedArg env n | n `elem` env = [n]
269 | otherwise = []
271usedIn :: [Name] -> LExp -> [Name]
272usedIn env (LV (Glob n)) = usedArg env n
273usedIn env (LApp _ e args) = usedIn env e ++ concatMap (usedIn env) args
274usedIn env (LLazyApp n args) = concatMap (usedIn env) args ++ usedArg env n
275usedIn env (LLazyExp e) = usedIn env e
276usedIn env (LForce e) = usedIn env e
277usedIn env (LLet n v e) = usedIn env v ++ usedIn (env \\ [n]) e
278usedIn env (LLam ns e) = usedIn (env \\ ns) e
279usedIn env (LCon loc i n args) = concatMap (usedIn env) args
280usedIn env (LProj t i) = usedIn env t
281usedIn env (LCase up e alts) = usedIn env e ++ concatMap (usedInA env) alts
282 where usedInA env (LConCase i n ns e) = usedIn env e
283 usedInA env (LConstCase c e) = usedIn env e
284 usedInA env (LDefaultCase e) = usedIn env e
285usedIn env (LForeign _ _ _ args) = concatMap (usedIn env) (map snd args)
286usedIn env (LOp f args) = concatMap (usedIn env) args
287usedIn env _ = []
289instance Show LExp where
290 show e = show' [] "" e where
291 show' env ind (LV (Loc i)) = env!!i
292 show' env ind (LV (Glob n)) = show n
294 show' env ind (LLazyApp e args)
295 = show e ++ "|(" ++ showSep ", " (map (show' env ind) args) ++")"
297 show' env ind (LApp _ e args)
298 = show' env ind e ++ "(" ++ showSep ", " (map (show' env ind) args) ++")"
300 show' env ind (LLazyExp e) = "lazy{ " ++ show' env ind e ++ " }"
301 show' env ind (LForce e) = "force{ " ++ show' env ind e ++ " }"
302 show' env ind (LLet n v e)
303 = "let " ++ show n ++ " = " ++ show' env ind v
304 ++ " in " ++ show' (env ++ [show n]) ind e
306 show' env ind (LLam args e)
307 = "\\ " ++ showSep "," (map show args)
308 ++ " => " ++ show' (env ++ (map show args)) ind e
310 show' env ind (LProj t i) = show t ++ "!" ++ show i
312 show' env ind (LCon loc i n args)
313 = atloc loc ++ show n ++ "(" ++ showSep ", " (map (show' env ind) args) ++ ")"
314 where atloc Nothing = ""
315 atloc (Just l) = "@" ++ show (LV l) ++ ":"
317 show' env ind (LCase up e alts)
318 = "case" ++ update ++ show' env ind e ++ " of \n" ++ fmt alts
319 where
320 update = case up of
321 Shared -> " "
322 Updatable -> "! "
323 fmt [] = ""
324 fmt [alt]
325 = "\t" ++ ind ++ "| " ++ showAlt env (ind ++ " ") alt
326 fmt (alt:as)
327 = "\t" ++ ind ++ "| " ++ showAlt env (ind ++ ". ") alt
328 ++ "\n" ++ fmt as
330 show' env ind (LConst c) = show c
332 show' env ind (LForeign lang ty n args) = concat
333 [ "foreign{ "
334 , n ++ "("
335 , showSep ", " (map (\(ty,x) -> show' env ind x ++ " : " ++ show ty) args)
336 , ") : "
337 , show ty
338 , " }"
339 ]
341 show' env ind (LOp f args)
342 = show f ++ "(" ++ showSep ", " (map (show' env ind) args) ++ ")"
344 show' env ind (LError str) = "error " ++ show str
345 show' env ind LNothing = "____"
347 showAlt env ind (LConCase _ n args e)
348 = show n ++ "(" ++ showSep ", " (map show args) ++ ") => "
349 ++ show' env ind e
351 showAlt env ind (LConstCase c e) = show c ++ " => " ++ show' env ind e
352 showAlt env ind (LDefaultCase e) = "_ => " ++ show' env ind e