git.iko.soy/Idris-dev
on master help sign in
Idris-dev/src/IRTS/Lang.hs
482 lines 19 kB history raw
1{-|
2Module : IRTS.Lang
3Description : Internal representation of Idris' constructs.
5License : BSD3
6Maintainer : The Idris Community.
7-}
8{-# LANGUAGE DeriveDataTypeable, DeriveFunctor, DeriveGeneric, FlexibleContexts,
9 PatternGuards #-}
11module IRTS.Lang where
13import Idris.Core.CaseTree
14import Idris.Core.TT
16import Control.Monad.State hiding (lift)
17import Data.Data (Data)
18import Data.List
19import qualified Data.Map.Strict as Map
20import Data.Typeable (Typeable)
21import GHC.Generics (Generic)
23data Endianness = Native | BE | LE deriving (Show, Eq)
25data LVar = Loc Int | Glob Name
26 deriving (Show, Eq)
28-- ASSUMPTION: All variable bindings have unique names here
29-- Constructors commented as lifted are not present in the LIR provided to the different backends.
30data LExp = LV Name
31 | LApp Bool LExp [LExp] -- True = tail call
32 | LLazyApp Name [LExp] -- True = tail call
33 | LLazyExp LExp -- lifted out before compiling
34 | LForce LExp -- make sure Exp is evaluted
35 | LLet Name LExp LExp -- name just for pretty printing
36 | LLam [Name] LExp -- lambda, lifted out before compiling
37 | LProj LExp Int -- projection
38 | LCon (Maybe Name) -- Location to reallocate, if available
39 Int Name [LExp]
40 | LCase CaseType LExp [LAlt]
41 | LConst Const
42 | LForeign FDesc -- Function descriptor (usually name as string)
43 FDesc -- Return type descriptor
44 [(FDesc, LExp)] -- first LExp is the FFI type description
45 | LOp PrimFn [LExp]
46 | LNothing
47 | LError String
48 deriving (Eq, Ord)
50data FDesc = FCon Name
51 | FStr String
52 | FUnknown
53 | FIO FDesc
54 | FApp Name [FDesc]
55 deriving (Show, Eq, Ord)
57data Export = ExportData FDesc -- Exported data descriptor (usually string)
58 | ExportFun Name -- Idris name
59 FDesc -- Exported function descriptor
60 FDesc -- Return type descriptor
61 [FDesc] -- Argument types
62 deriving (Show, Eq, Ord)
64data ExportIFace = Export Name -- FFI descriptor
65 String -- interface file
66 [Export]
67 deriving (Show, Eq, Ord)
69-- Primitive operators. Backends are not *required* to implement all
70-- of these, but should report an error if they are unable
72data PrimFn = LPlus ArithTy | LMinus ArithTy | LTimes ArithTy
73 | LUDiv IntTy | LSDiv ArithTy | LURem IntTy | LSRem ArithTy
74 | LAnd IntTy | LOr IntTy | LXOr IntTy | LCompl IntTy
75 | LSHL IntTy | LLSHR IntTy | LASHR IntTy
76 | LEq ArithTy | LLt IntTy | LLe IntTy | LGt IntTy | LGe IntTy
77 | LSLt ArithTy | LSLe ArithTy | LSGt ArithTy | LSGe ArithTy
78 | LSExt IntTy IntTy | LZExt IntTy IntTy | LTrunc IntTy IntTy
79 | LStrConcat | LStrLt | LStrEq | LStrLen
80 | LIntFloat IntTy | LFloatInt IntTy | LIntStr IntTy | LStrInt IntTy
81 | LFloatStr | LStrFloat | LChInt IntTy | LIntCh IntTy
82 | LBitCast ArithTy ArithTy -- Only for values of equal width
84 | LFExp | LFLog | LFSin | LFCos | LFTan | LFASin | LFACos | LFATan
85 | LFATan2 | LFSqrt | LFFloor | LFCeil | LFNegate
87 | LStrHead | LStrTail | LStrCons | LStrIndex | LStrRev | LStrSubstr
88 | LReadStr | LWriteStr
90 -- system info
91 | LSystemInfo
93 | LFork
94 | LPar -- evaluate argument anywhere, possibly on another
95 -- core or another machine. 'id' is a valid implementation
96 | LExternal Name
97 | LCrash
99 | LNoOp
100 deriving (Show, Eq, Ord, Generic)
102-- Supported target languages for foreign calls
104data FCallType = FStatic | FObject | FConstructor
105 deriving (Show, Eq, Ord)
107data FType = FArith ArithTy
108 | FFunction
109 | FFunctionIO
110 | FString
111 | FUnit
112 | FPtr
113 | FManagedPtr
114 | FCData
115 | FAny
116 deriving (Show, Eq, Ord)
118-- FIXME: Why not use this for all the IRs now?
119data LAlt' e = LConCase Int Name [Name] e
120 | LConstCase Const e
121 | LDefaultCase e
122 deriving (Show, Eq, Ord, Functor, Data, Typeable)
124type LAlt = LAlt' LExp
126data LDecl = LFun [LOpt] Name [Name] LExp -- options, name, arg names, def
127 | LConstructor Name Int Int -- constructor name, tag, arity
128 deriving (Show, Eq, Ord)
130type LDefs = Ctxt LDecl
132data LOpt = Inline | NoInline
133 deriving (Show, Eq, Ord)
135addTags :: Int -> [(Name, LDecl)] -> (Int, [(Name, LDecl)])
136addTags i ds = tag i ds []
137 where tag i ((n, LConstructor n' (-1) a) : as) acc
138 = tag (i + 1) as ((n, LConstructor n' i a) : acc)
139 tag i ((n, LConstructor n' t a) : as) acc
140 = tag i as ((n, LConstructor n' t a) : acc)
141 tag i (x : as) acc = tag i as (x : acc)
142 tag i [] acc = (i, reverse acc)
144data LiftState = LS (Maybe Name) Int [(Name, LDecl)]
145 (Map.Map ([Name], LExp) Name) -- map from args/expressions
146 -- to names, so we don't create the same function
147 -- multiple times
149setBaseName :: Name -> State LiftState ()
150setBaseName n
151 = do LS _ i ds done <- get
152 put (LS (Just n) i ds done)
154lname (NS n x) i = NS (lname n i) x
155lname (UN n) i = MN i n
156lname x i = sMN i (showCG x ++ "_lam")
158getNextName :: State LiftState Name
159getNextName
160 = do LS mn i ds done <- get
161 let newn = case mn of
162 Nothing -> lname (sUN "_") i
163 Just n -> lname n i
164 put (LS mn (i + 1) ds done)
165 return newn
167renameArgs :: [Name] -> LExp -> ([Name], LExp)
168renameArgs args e
169 = let newargNames = map (\i -> sMN i "lift") [0..]
170 newargs = zip args newargNames in
171 (map snd newargs, rename newargs e)
173addFn :: Name -> LDecl -> State LiftState ()
174addFn fn d
175 = do LS n i ds done <- get
176 put (LS n i ((fn, d) : ds) done)
178makeFn :: [Name] -> LExp -> State LiftState Name
179makeFn args exp
180 = do fn <- getNextName
181 let (args', exp') = renameArgs args exp
182 LS n i ds done <- get
183 case Map.lookup (args', exp') done of
184 Just fn -> return fn
185 Nothing ->
186 do addFn fn (LFun [Inline] fn args' exp')
187 LS n i ds done <- get
188 put (LS n i ds (Map.insert (args', exp') fn done))
189 return fn
191liftAll :: [(Name, LDecl)] -> [(Name, LDecl)]
192liftAll xs =
193 let (LS _ _ decls _) = execState (mapM_ liftDef xs) (LS Nothing 0 [] Map.empty) in
194 decls
196liftDef :: (Name, LDecl) -> State LiftState ()
197liftDef (n, LFun opts _ args e) =
198 do setBaseName n
199 e' <- lift args e
200 addFn n (LFun opts n args e')
201liftDef (n, x) = addFn n x
203lift :: [Name] -> LExp -> State LiftState LExp
204lift env (LV v) = return (LV v) -- Lifting happens before these can exist...
205lift env (LApp tc (LV n) args) = do args' <- mapM (lift env) args
206 return (LApp tc (LV n) args')
207lift env (LApp tc f args) = do f' <- lift env f
208 fn <- makeFn env f'
209 args' <- mapM (lift env) args
210 return (LApp tc (LV fn) (map LV env ++ args'))
211lift env (LLazyApp n args) = do args' <- mapM (lift env) args
212 return (LLazyApp n args')
213lift env (LLazyExp (LConst c)) = return (LConst c)
214-- lift env (LLazyExp (LApp tc (LV (Glob f)) args))
215-- = lift env (LLazyApp f args)
216lift env (LLazyExp e) = do e' <- lift env e
217 let usedArgs = nub $ usedIn env e'
218 fn <- makeFn usedArgs e'
219 return (LLazyApp fn (map LV usedArgs))
220lift env (LForce e) = do e' <- lift env e
221 return (LForce e')
222lift env (LLet n v e) = do v' <- lift env v
223 e' <- lift (env ++ [n]) e
224 return (LLet n v' e')
225lift env (LLam args (LLam args' e)) = lift env (LLam (args ++ args') e)
226lift env (LLam args e) = do e' <- lift (env ++ args) e
227 let usedArgs = nub $ usedIn env e'
228 fn <- makeFn (usedArgs ++ args) e'
229 return (LApp False (LV fn) (map LV usedArgs))
230lift env (LProj t i) = do t' <- lift env t
231 return (LProj t' i)
232lift env (LCon loc i n args) = do args' <- mapM (lift env) args
233 return (LCon loc i n args')
234lift env (LCase up e alts) = do alts' <- mapM liftA alts
235 e' <- lift env e
236 return (LCase up e' alts')
237 where
238 liftA (LConCase i n args e) = do e' <- lift (env ++ args) e
239 return (LConCase i n args e')
240 liftA (LConstCase c e) = do e' <- lift env e
241 return (LConstCase c e')
242 liftA (LDefaultCase e) = do e' <- lift env e
243 return (LDefaultCase e')
244lift env (LConst c) = return (LConst c)
245lift env (LForeign t s args) = do args' <- mapM (liftF env) args
246 return (LForeign t s args')
247 where
248 liftF env (t, e) = do e' <- lift env e
249 return (t, e')
250lift env (LOp f args) = do args' <- mapM (lift env) args
251 return (LOp f args')
252lift env (LError str) = return $ LError str
253lift env LNothing = return LNothing
255allocUnique :: LDefs -> (Name, LDecl) -> (Name, LDecl)
256allocUnique defs p@(n, LConstructor _ _ _) = p
257allocUnique defs (n, LFun opts fn args e)
258 = let e' = evalState (findUp e) [] in
259 (n, LFun opts fn args e')
260 where
261 -- Keep track of 'updatable' names in the state, i.e. names whose heap
262 -- entry may be reused, along with the arity which was there
263 findUp :: LExp -> State [(Name, Int)] LExp
264 findUp (LApp t (LV n) as)
265 | Just (LConstructor _ i ar) <- lookupCtxtExact n defs,
266 ar == length as
267 = findUp (LCon Nothing i n as)
268 findUp (LV n)
269 | Just (LConstructor _ i 0) <- lookupCtxtExact n defs
270 = return $ LCon Nothing i n [] -- nullary cons are global, no need to update
271 findUp (LApp t f as) = LApp t <$> findUp f <*> mapM findUp as
272 findUp (LLazyApp n as) = LLazyApp n <$> mapM findUp as
273 findUp (LLazyExp e) = LLazyExp <$> findUp e
274 findUp (LForce e) = LForce <$> findUp e
275 -- use assumption that names are unique!
276 findUp (LLet n val sc) = LLet n <$> findUp val <*> findUp sc
277 findUp (LLam ns sc) = LLam ns <$> findUp sc
278 findUp (LProj e i) = LProj <$> findUp e <*> return i
279 findUp (LCon (Just l) i n es) = LCon (Just l) i n <$> mapM findUp es
280 findUp (LCon Nothing i n es)
281 = do avail <- get
282 v <- findVar [] avail (length es)
283 LCon v i n <$> mapM findUp es
284 findUp (LForeign t s es)
285 = LForeign t s <$> mapM (\ (t, e) -> do e' <- findUp e
286 return (t, e')) es
287 findUp (LOp o es) = LOp o <$> mapM findUp es
288 findUp (LCase Updatable e@(LV n) as)
289 = LCase Updatable e <$> mapM (doUpAlt n) as
290 findUp (LCase t e as)
291 = LCase t <$> findUp e <*> mapM findUpAlt as
292 findUp t = return t
294 findUpAlt (LConCase i t args rhs) = do avail <- get
295 rhs' <- findUp rhs
296 put avail
297 return $ LConCase i t args rhs'
298 findUpAlt (LConstCase i rhs) = LConstCase i <$> findUp rhs
299 findUpAlt (LDefaultCase rhs) = LDefaultCase <$> findUp rhs
301 doUpAlt n (LConCase i t args rhs)
302 = do avail <- get
303 put ((n, length args) : avail)
304 rhs' <- findUp rhs
305 put avail
306 return $ LConCase i t args rhs'
307 doUpAlt n (LConstCase i rhs) = LConstCase i <$> findUp rhs
308 doUpAlt n (LDefaultCase rhs) = LDefaultCase <$> findUp rhs
310 findVar _ [] i = return Nothing
311 findVar acc ((n, l) : ns) i | l == i = do put (reverse acc ++ ns)
312 return (Just n)
313 findVar acc (n : ns) i = findVar (n : acc) ns i
316-- Return variables in list which are used in the expression
318usedArg env n | n `elem` env = [n]
319 | otherwise = []
321usedIn :: [Name] -> LExp -> [Name]
322usedIn env (LV n) = usedArg env n
323usedIn env (LApp _ e args) = usedIn env e ++ concatMap (usedIn env) args
324usedIn env (LLazyApp n args) = concatMap (usedIn env) args ++ usedArg env n
325usedIn env (LLazyExp e) = usedIn env e
326usedIn env (LForce e) = usedIn env e
327usedIn env (LLet n v e) = usedIn env v ++ usedIn (env \\ [n]) e
328usedIn env (LLam ns e) = usedIn (env \\ ns) e
329usedIn env (LCon v i n args) = let rest = concatMap (usedIn env) args in
330 case v of
331 Nothing -> rest
332 Just n -> usedArg env n ++ rest
333usedIn env (LProj t i) = usedIn env t
334usedIn env (LCase up e alts) = usedIn env e ++ concatMap (usedInA env) alts
335 where usedInA env (LConCase i n ns e) = usedIn env e
336 usedInA env (LConstCase c e) = usedIn env e
337 usedInA env (LDefaultCase e) = usedIn env e
338usedIn env (LForeign _ _ args) = concatMap (usedIn env) (map snd args)
339usedIn env (LOp f args) = concatMap (usedIn env) args
340usedIn env _ = []
342lsubst :: Name -> LExp -> LExp -> LExp
343lsubst n new (LV x) | n == x = new
344lsubst n new (LApp t e args) = let e' = lsubst n new e
345 args' = map (lsubst n new) args in
346 LApp t e' args'
347lsubst n new (LLazyApp fn args) = let args' = map (lsubst n new) args in
348 LLazyApp fn args'
349lsubst n new (LLazyExp e) = LLazyExp (lsubst n new e)
350lsubst n new (LForce e) = LForce (lsubst n new e)
351lsubst n new (LLet v val sc) = LLet v (lsubst n new val) (lsubst n new sc)
352lsubst n new (LLam ns sc) = LLam ns (lsubst n new sc)
353lsubst n new (LProj e i) = LProj (lsubst n new e) i
354lsubst n new (LCon lv t cn args) = let args' = map (lsubst n new) args in
355 LCon lv t cn args'
356lsubst n new (LOp op args) = let args' = map (lsubst n new) args in
357 LOp op args'
358lsubst n new (LForeign fd rd args)
359 = let args' = map (\(d, a) -> (d, lsubst n new a)) args in
360 LForeign fd rd args'
361lsubst n new (LCase t e alts) = let e' = lsubst n new e
362 alts' = map (fmap (lsubst n new)) alts in
363 LCase t e' alts'
364lsubst n new tm = tm
366rename :: [(Name, Name)] -> LExp -> LExp
367rename ns tm@(LV x)
368 = case lookup x ns of
369 Just n -> LV n
370 _ -> tm
371rename ns (LApp t e args)
372 = let e' = rename ns e
373 args' = map (rename ns) args in
374 LApp t e' args'
375rename ns (LLazyApp fn args)
376 = let args' = map (rename ns) args in
377 LLazyApp fn args'
378rename ns (LLazyExp e) = LLazyExp (rename ns e)
379rename ns (LForce e) = LForce (rename ns e)
380rename ns (LLet v val sc) = LLet v (rename ns val) (rename ns sc)
381rename ns (LLam args sc) = LLam args (rename ns sc)
382rename ns (LProj e i) = LProj (rename ns e) i
383rename ns (LCon lv t cn args) = let args' = map (rename ns) args in
384 LCon lv t cn args'
385rename ns (LOp op args) = let args' = map (rename ns) args in
386 LOp op args'
387rename ns (LForeign fd rd args)
388 = let args' = map (\(d, a) -> (d, rename ns a)) args in
389 LForeign fd rd args'
390rename ns (LCase t e alts) = let e' = rename ns e
391 alts' = map (fmap (rename ns)) alts in
392 LCase t e' alts'
393rename ns tm = tm
395instance Show LExp where
396 show e = show' [] "" e where
397 show' env ind (LV n) = show n
399 show' env ind (LLazyApp e args)
400 = show e ++ "|(" ++ showSep ", " (map (show' env ind) args) ++")"
402 show' env ind (LApp _ e args)
403 = show' env ind e ++ "(" ++ showSep ", " (map (show' env ind) args) ++")"
405 show' env ind (LLazyExp e) = "lazy{ " ++ show' env ind e ++ " }"
406 show' env ind (LForce e) = "force{ " ++ show' env ind e ++ " }"
407 show' env ind (LLet n v e)
408 = "let " ++ show n ++ " = " ++ show' env ind v
409 ++ " in " ++ show' (env ++ [show n]) ind e
411 show' env ind (LLam args e)
412 = "(\\ " ++ showSep "," (map show args)
413 ++ " => " ++ show' (env ++ (map show args)) ind e ++ ") "
415 show' env ind (LProj t i) = show t ++ "!" ++ show i
417 show' env ind (LCon loc i n args)
418 = atloc loc ++ show n ++ "(" ++ showSep ", " (map (show' env ind) args) ++ ")"
419 where atloc Nothing = ""
420 atloc (Just l) = "@" ++ show (LV l) ++ ":"
422 show' env ind (LCase up e alts)
423 = "case" ++ update ++ "(" ++ show' env ind e ++ ") of \n" ++ fmt alts
424 where
425 update = case up of
426 Shared -> " "
427 Updatable -> "! "
428 fmt [] = ""
429 fmt [alt]
430 = "\t" ++ ind ++ "| " ++ showAlt env (ind ++ " ") alt
431 fmt (alt:as)
432 = "\t" ++ ind ++ "| " ++ showAlt env (ind ++ ". ") alt
433 ++ "\n" ++ fmt as
435 show' env ind (LConst c) = show c
437 show' env ind (LForeign ty n args) = concat
438 [ "foreign{ "
439 , show n ++ "("
440 , showSep ", " (map (\(ty,x) -> show' env ind x ++ " : " ++ show ty) args)
441 , ") : "
442 , show ty
443 , " }"
444 ]
446 show' env ind (LOp f args)
447 = show f ++ "(" ++ showSep ", " (map (show' env ind) args) ++ ")"
449 show' env ind (LError str) = "error " ++ show str
450 show' env ind LNothing = "____"
452 showAlt env ind (LConCase _ n args e)
453 = show n ++ "(" ++ showSep ", " (map show args) ++ ") => "
454 ++ show' env ind e
456 showAlt env ind (LConstCase c e) = show c ++ " => " ++ show' env ind e
457 showAlt env ind (LDefaultCase e) = "_ => " ++ show' env ind e
459occName :: Name -> LExp -> Int
460occName n (LV x) = if n == x then 1 else 0
461occName n (LApp t e es) = occName n e + sum (map (occName n) es)
462occName n (LLazyApp x es)
463 = if n == x then 1 + sum (map (occName n) es)
464 else sum (map (occName n) es)
465occName n (LForce e) = occName n e
466occName n (LLet x v sc)
467 = if n == x then occName n v
468 else occName n v + occName n sc
469occName n (LLam ns sc)
470 = if n `elem` ns then 0 else occName n sc
471occName n (LProj e i) = occName n e
472occName n (LCon _ _ _ es) = sum (map (occName n) es)
473occName n (LCase t e alts) = occName n e + maximum (map occAlt alts)
474 where
475 occAlt (LConCase _ _ ns e)
476 = if n `elem` ns then 0 else occName n e
477 occAlt (LConstCase _ e) = occName n e
478 occAlt (LDefaultCase e) = occName n e
479occName n (LForeign _ _ es) = sum (map (occName n . snd) es)
480occName n (LOp _ es) = sum (map (occName n) es)
481occName n _ = 0