git.iko.soy/Idris-dev
on d3fa352 help sign in
Idris-dev/src/IRTS/Lang.hs
394 lines 16 kB history raw
1{-|
2Module : IRTS.Lang
3Description : Internal representation of Idris' constructs.
4Copyright :
5License : BSD3
6Maintainer : The Idris Community.
7-}
8{-# LANGUAGE DeriveFunctor, DeriveGeneric, PatternGuards #-}
10module IRTS.Lang where
12import Idris.Core.CaseTree
13import Idris.Core.TT
15import Control.Applicative hiding (Const)
16import Control.Monad.State hiding (lift)
17import Data.List
18import Debug.Trace
19import GHC.Generics (Generic)
21data Endianness = Native | BE | LE deriving (Show, Eq)
23data LVar = Loc Int | Glob Name
24 deriving (Show, Eq)
26-- ASSUMPTION: All variable bindings have unique names here
27-- Constructors commented as lifted are not present in the LIR provided to the different backends.
28data LExp = LV LVar
29 | LApp Bool LExp [LExp] -- True = tail call
30 | LLazyApp Name [LExp] -- True = tail call
31 | LLazyExp LExp -- lifted out before compiling
32 | LForce LExp -- make sure Exp is evaluted
33 | LLet Name LExp LExp -- name just for pretty printing
34 | LLam [Name] LExp -- lambda, lifted out before compiling
35 | LProj LExp Int -- projection
36 | LCon (Maybe LVar) -- Location to reallocate, if available
37 Int Name [LExp]
38 | LCase CaseType LExp [LAlt]
39 | LConst Const
40 | LForeign FDesc -- Function descriptor (usually name as string)
41 FDesc -- Return type descriptor
42 [(FDesc, LExp)] -- first LExp is the FFI type description
43 | LOp PrimFn [LExp]
44 | LNothing
45 | LError String
46 deriving Eq
48data FDesc = FCon Name
49 | FStr String
50 | FUnknown
51 | FIO FDesc
52 | FApp Name [FDesc]
53 deriving (Show, Eq)
55data Export = ExportData FDesc -- Exported data descriptor (usually string)
56 | ExportFun Name -- Idris name
57 FDesc -- Exported function descriptor
58 FDesc -- Return type descriptor
59 [FDesc] -- Argument types
60 deriving (Show, Eq)
62data ExportIFace = Export Name -- FFI descriptor
63 String -- interface file
64 [Export]
65 deriving (Show, Eq)
67-- Primitive operators. Backends are not *required* to implement all
68-- of these, but should report an error if they are unable
70data PrimFn = LPlus ArithTy | LMinus ArithTy | LTimes ArithTy
71 | LUDiv IntTy | LSDiv ArithTy | LURem IntTy | LSRem ArithTy
72 | LAnd IntTy | LOr IntTy | LXOr IntTy | LCompl IntTy
73 | LSHL IntTy | LLSHR IntTy | LASHR IntTy
74 | LEq ArithTy | LLt IntTy | LLe IntTy | LGt IntTy | LGe IntTy
75 | LSLt ArithTy | LSLe ArithTy | LSGt ArithTy | LSGe ArithTy
76 | LSExt IntTy IntTy | LZExt IntTy IntTy | LTrunc IntTy IntTy
77 | LStrConcat | LStrLt | LStrEq | LStrLen
78 | LIntFloat IntTy | LFloatInt IntTy | LIntStr IntTy | LStrInt IntTy
79 | LFloatStr | LStrFloat | LChInt IntTy | LIntCh IntTy
80 | LBitCast ArithTy ArithTy -- Only for values of equal width
82 | LFExp | LFLog | LFSin | LFCos | LFTan | LFASin | LFACos | LFATan
83 | LFSqrt | LFFloor | LFCeil | LFNegate
85 | LStrHead | LStrTail | LStrCons | LStrIndex | LStrRev | LStrSubstr
86 | LReadStr | LWriteStr
88 -- system info
89 | LSystemInfo
91 | LFork
92 | LPar -- evaluate argument anywhere, possibly on another
93 -- core or another machine. 'id' is a valid implementation
94 | LExternal Name
95 | LCrash
97 | LNoOp
98 deriving (Show, Eq, Generic)
100-- Supported target languages for foreign calls
102data FCallType = FStatic | FObject | FConstructor
103 deriving (Show, Eq)
105data FType = FArith ArithTy
106 | FFunction
107 | FFunctionIO
108 | FString
109 | FUnit
110 | FPtr
111 | FManagedPtr
112 | FCData
113 | FAny
114 deriving (Show, Eq)
116-- FIXME: Why not use this for all the IRs now?
117data LAlt' e = LConCase Int Name [Name] e
118 | LConstCase Const e
119 | LDefaultCase e
120 deriving (Show, Eq, Functor)
122type LAlt = LAlt' LExp
124data LDecl = LFun [LOpt] Name [Name] LExp -- options, name, arg names, def
125 | LConstructor Name Int Int -- constructor name, tag, arity
126 deriving (Show, Eq)
128type LDefs = Ctxt LDecl
130data LOpt = Inline | NoInline
131 deriving (Show, Eq)
133addTags :: Int -> [(Name, LDecl)] -> (Int, [(Name, LDecl)])
134addTags i ds = tag i ds []
135 where tag i ((n, LConstructor n' (-1) a) : as) acc
136 = tag (i + 1) as ((n, LConstructor n' i a) : acc)
137 tag i ((n, LConstructor n' t a) : as) acc
138 = tag i as ((n, LConstructor n' t a) : acc)
139 tag i (x : as) acc = tag i as (x : acc)
140 tag i [] acc = (i, reverse acc)
142data LiftState = LS Name Int [(Name, LDecl)]
144lname (NS n x) i = NS (lname n i) x
145lname (UN n) i = MN i n
146lname x i = sMN i (showCG x ++ "_lam")
148liftAll :: [(Name, LDecl)] -> [(Name, LDecl)]
149liftAll xs = concatMap (\ (x, d) -> lambdaLift x d) xs
151lambdaLift :: Name -> LDecl -> [(Name, LDecl)]
152lambdaLift n (LFun opts _ args e)
153 = let (e', (LS _ _ decls)) = runState (lift args e) (LS n 0 []) in
154 (n, LFun opts n args e') : decls
155lambdaLift n x = [(n, x)]
157getNextName :: State LiftState Name
158getNextName = do LS n i ds <- get
159 put (LS n (i + 1) ds)
160 return (lname n i)
162addFn :: Name -> LDecl -> State LiftState ()
163addFn fn d = do LS n i ds <- get
164 put (LS n i ((fn, d) : ds))
166lift :: [Name] -> LExp -> State LiftState LExp
167lift env (LV v) = return (LV v) -- Lifting happens before these can exist...
168lift env (LApp tc (LV (Glob n)) args) = do args' <- mapM (lift env) args
169 return (LApp tc (LV (Glob n)) args')
170lift env (LApp tc f args) = do f' <- lift env f
171 fn <- getNextName
172 addFn fn (LFun [Inline] fn env f')
173 args' <- mapM (lift env) args
174 return (LApp tc (LV (Glob fn)) (map (LV . Glob) env ++ args'))
175lift env (LLazyApp n args) = do args' <- mapM (lift env) args
176 return (LLazyApp n args')
177lift env (LLazyExp (LConst c)) = return (LConst c)
178-- lift env (LLazyExp (LApp tc (LV (Glob f)) args))
179-- = lift env (LLazyApp f args)
180lift env (LLazyExp e) = do e' <- lift env e
181 let usedArgs = nub $ usedIn env e'
182 fn <- getNextName
183 addFn fn (LFun [NoInline] fn usedArgs e')
184 return (LLazyApp fn (map (LV . Glob) usedArgs))
185lift env (LForce e) = do e' <- lift env e
186 return (LForce e')
187lift env (LLet n v e) = do v' <- lift env v
188 e' <- lift (env ++ [n]) e
189 return (LLet n v' e')
190lift env (LLam args e) = do e' <- lift (env ++ args) e
191 let usedArgs = nub $ usedIn env e'
192 fn <- getNextName
193 addFn fn (LFun [Inline] fn (usedArgs ++ args) e')
194 return (LApp False (LV (Glob fn)) (map (LV . Glob) usedArgs))
195lift env (LProj t i) = do t' <- lift env t
196 return (LProj t' i)
197lift env (LCon loc i n args) = do args' <- mapM (lift env) args
198 return (LCon loc i n args')
199lift env (LCase up e alts) = do alts' <- mapM liftA alts
200 e' <- lift env e
201 return (LCase up e' alts')
202 where
203 liftA (LConCase i n args e) = do e' <- lift (env ++ args) e
204 return (LConCase i n args e')
205 liftA (LConstCase c e) = do e' <- lift env e
206 return (LConstCase c e')
207 liftA (LDefaultCase e) = do e' <- lift env e
208 return (LDefaultCase e')
209lift env (LConst c) = return (LConst c)
210lift env (LForeign t s args) = do args' <- mapM (liftF env) args
211 return (LForeign t s args')
212 where
213 liftF env (t, e) = do e' <- lift env e
214 return (t, e')
215lift env (LOp f args) = do args' <- mapM (lift env) args
216 return (LOp f args')
217lift env (LError str) = return $ LError str
218lift env LNothing = return LNothing
220allocUnique :: LDefs -> (Name, LDecl) -> (Name, LDecl)
221allocUnique defs p@(n, LConstructor _ _ _) = p
222allocUnique defs (n, LFun opts fn args e)
223 = let e' = evalState (findUp e) [] in
224 (n, LFun opts fn args e')
225 where
226 -- Keep track of 'updatable' names in the state, i.e. names whose heap
227 -- entry may be reused, along with the arity which was there
228 findUp :: LExp -> State [(Name, Int)] LExp
229 findUp (LApp t (LV (Glob n)) as)
230 | Just (LConstructor _ i ar) <- lookupCtxtExact n defs,
231 ar == length as
232 = findUp (LCon Nothing i n as)
233 findUp (LV (Glob n))
234 | Just (LConstructor _ i 0) <- lookupCtxtExact n defs
235 = return $ LCon Nothing i n [] -- nullary cons are global, no need to update
236 findUp (LApp t f as) = LApp t <$> findUp f <*> mapM findUp as
237 findUp (LLazyApp n as) = LLazyApp n <$> mapM findUp as
238 findUp (LLazyExp e) = LLazyExp <$> findUp e
239 findUp (LForce e) = LForce <$> findUp e
240 -- use assumption that names are unique!
241 findUp (LLet n val sc) = LLet n <$> findUp val <*> findUp sc
242 findUp (LLam ns sc) = LLam ns <$> findUp sc
243 findUp (LProj e i) = LProj <$> findUp e <*> return i
244 findUp (LCon (Just l) i n es) = LCon (Just l) i n <$> mapM findUp es
245 findUp (LCon Nothing i n es)
246 = do avail <- get
247 v <- findVar [] avail (length es)
248 LCon v i n <$> mapM findUp es
249 findUp (LForeign t s es)
250 = LForeign t s <$> mapM (\ (t, e) -> do e' <- findUp e
251 return (t, e')) es
252 findUp (LOp o es) = LOp o <$> mapM findUp es
253 findUp (LCase Updatable e@(LV (Glob n)) as)
254 = LCase Updatable e <$> mapM (doUpAlt n) as
255 findUp (LCase t e as)
256 = LCase t <$> findUp e <*> mapM findUpAlt as
257 findUp t = return t
259 findUpAlt (LConCase i t args rhs) = do avail <- get
260 rhs' <- findUp rhs
261 put avail
262 return $ LConCase i t args rhs'
263 findUpAlt (LConstCase i rhs) = LConstCase i <$> findUp rhs
264 findUpAlt (LDefaultCase rhs) = LDefaultCase <$> findUp rhs
266 doUpAlt n (LConCase i t args rhs)
267 = do avail <- get
268 put ((n, length args) : avail)
269 rhs' <- findUp rhs
270 put avail
271 return $ LConCase i t args rhs'
272 doUpAlt n (LConstCase i rhs) = LConstCase i <$> findUp rhs
273 doUpAlt n (LDefaultCase rhs) = LDefaultCase <$> findUp rhs
275 findVar _ [] i = return Nothing
276 findVar acc ((n, l) : ns) i | l == i = do put (reverse acc ++ ns)
277 return (Just (Glob n))
278 findVar acc (n : ns) i = findVar (n : acc) ns i
281-- Return variables in list which are used in the expression
283usedArg env n | n `elem` env = [n]
284 | otherwise = []
286usedIn :: [Name] -> LExp -> [Name]
287usedIn env (LV (Glob n)) = usedArg env n
288usedIn env (LApp _ e args) = usedIn env e ++ concatMap (usedIn env) args
289usedIn env (LLazyApp n args) = concatMap (usedIn env) args ++ usedArg env n
290usedIn env (LLazyExp e) = usedIn env e
291usedIn env (LForce e) = usedIn env e
292usedIn env (LLet n v e) = usedIn env v ++ usedIn (env \\ [n]) e
293usedIn env (LLam ns e) = usedIn (env \\ ns) e
294usedIn env (LCon v i n args) = let rest = concatMap (usedIn env) args in
295 case v of
296 Nothing -> rest
297 Just (Glob n) -> usedArg env n ++ rest
298usedIn env (LProj t i) = usedIn env t
299usedIn env (LCase up e alts) = usedIn env e ++ concatMap (usedInA env) alts
300 where usedInA env (LConCase i n ns e) = usedIn env e
301 usedInA env (LConstCase c e) = usedIn env e
302 usedInA env (LDefaultCase e) = usedIn env e
303usedIn env (LForeign _ _ args) = concatMap (usedIn env) (map snd args)
304usedIn env (LOp f args) = concatMap (usedIn env) args
305usedIn env _ = []
307lsubst :: Name -> LExp -> LExp -> LExp
308lsubst n new (LV (Glob x)) | n == x = new
309lsubst n new (LApp t e args) = let e' = lsubst n new e
310 args' = map (lsubst n new) args in
311 LApp t e' args'
312lsubst n new (LLazyApp fn args) = let args' = map (lsubst n new) args in
313 LLazyApp fn args'
314lsubst n new (LLazyExp e) = LLazyExp (lsubst n new e)
315lsubst n new (LForce e) = LForce (lsubst n new e)
316lsubst n new (LLet v val sc) = LLet v (lsubst n new val) (lsubst n new sc)
317lsubst n new (LLam ns sc) = LLam ns (lsubst n new sc)
318lsubst n new (LProj e i) = LProj (lsubst n new e) i
319lsubst n new (LCon lv t cn args) = let args' = map (lsubst n new) args in
320 LCon lv t cn args'
321lsubst n new (LOp op args) = let args' = map (lsubst n new) args in
322 LOp op args'
323lsubst n new (LForeign fd rd args)
324 = let args' = map (\(d, a) -> (d, lsubst n new a)) args in
325 LForeign fd rd args'
326lsubst n new (LCase t e alts) = let e' = lsubst n new e
327 alts' = map (fmap (lsubst n new)) alts in
328 LCase t e' alts'
329lsubst n new tm = tm
331instance Show LExp where
332 show e = show' [] "" e where
333 show' env ind (LV (Loc i)) = env!!i
334 show' env ind (LV (Glob n)) = show n
336 show' env ind (LLazyApp e args)
337 = show e ++ "|(" ++ showSep ", " (map (show' env ind) args) ++")"
339 show' env ind (LApp _ e args)
340 = show' env ind e ++ "(" ++ showSep ", " (map (show' env ind) args) ++")"
342 show' env ind (LLazyExp e) = "lazy{ " ++ show' env ind e ++ " }"
343 show' env ind (LForce e) = "force{ " ++ show' env ind e ++ " }"
344 show' env ind (LLet n v e)
345 = "let " ++ show n ++ " = " ++ show' env ind v
346 ++ " in " ++ show' (env ++ [show n]) ind e
348 show' env ind (LLam args e)
349 = "\\ " ++ showSep "," (map show args)
350 ++ " => " ++ show' (env ++ (map show args)) ind e
352 show' env ind (LProj t i) = show t ++ "!" ++ show i
354 show' env ind (LCon loc i n args)
355 = atloc loc ++ show n ++ "(" ++ showSep ", " (map (show' env ind) args) ++ ")"
356 where atloc Nothing = ""
357 atloc (Just l) = "@" ++ show (LV l) ++ ":"
359 show' env ind (LCase up e alts)
360 = "case" ++ update ++ show' env ind e ++ " of \n" ++ fmt alts
361 where
362 update = case up of
363 Shared -> " "
364 Updatable -> "! "
365 fmt [] = ""
366 fmt [alt]
367 = "\t" ++ ind ++ "| " ++ showAlt env (ind ++ " ") alt
368 fmt (alt:as)
369 = "\t" ++ ind ++ "| " ++ showAlt env (ind ++ ". ") alt
370 ++ "\n" ++ fmt as
372 show' env ind (LConst c) = show c
374 show' env ind (LForeign ty n args) = concat
375 [ "foreign{ "
376 , show n ++ "("
377 , showSep ", " (map (\(ty,x) -> show' env ind x ++ " : " ++ show ty) args)
378 , ") : "
379 , show ty
380 , " }"
381 ]
383 show' env ind (LOp f args)
384 = show f ++ "(" ++ showSep ", " (map (show' env ind) args) ++ ")"
386 show' env ind (LError str) = "error " ++ show str
387 show' env ind LNothing = "____"
389 showAlt env ind (LConCase _ n args e)
390 = show n ++ "(" ++ showSep ", " (map show args) ++ ") => "
391 ++ show' env ind e
393 showAlt env ind (LConstCase c e) = show c ++ " => " ++ show' env ind e
394 showAlt env ind (LDefaultCase e) = "_ => " ++ show' env ind e