git.iko.soy/Idris-dev
on edbb52f help sign in
Idris-dev/src/IRTS/Lang.hs
235 lines 9.9 kB history raw
1module IRTS.Lang where
3import Control.Monad.State hiding (lift)
4import Core.TT
5import Data.List
6import Debug.Trace
8data LVar = Loc Int | Glob Name
9 deriving (Show, Eq)
11data LExp = LV LVar
12 | LApp Bool LExp [LExp] -- True = tail call
13 | LLazyApp Name [LExp] -- True = tail call
14 | LLazyExp LExp
15 | LForce LExp -- make sure Exp is evaluted
16 | LLet Name LExp LExp -- name just for pretty printing
17 | LLam [Name] LExp -- lambda, lifted out before compiling
18 | LProj LExp Int -- projection
19 | LCon Int Name [LExp]
20 | LCase LExp [LAlt]
21 | LConst Const
22 | LForeign FLang FType String [(FType, LExp)]
23 | LOp PrimFn [LExp]
24 | LNothing
25 | LError String
26 deriving Eq
28-- Primitive operators. Backends are not *required* to implement all
29-- of these, but should report an error if they are unable
31data PrimFn = LPlus ArithTy | LMinus ArithTy | LTimes ArithTy
32 | LUDiv IntTy | LSDiv ArithTy | LURem IntTy | LSRem ArithTy
33 | LAnd IntTy | LOr IntTy | LXOr IntTy | LCompl IntTy
34 | LSHL IntTy | LLSHR IntTy | LASHR IntTy
35 | LEq ArithTy | LLt IntTy | LLe IntTy | LGt IntTy | LGe IntTy
36 | LSLt ArithTy | LSLe ArithTy | LSGt ArithTy | LSGe ArithTy
37 | LSExt IntTy IntTy | LZExt IntTy IntTy | LTrunc IntTy IntTy
38 | LStrConcat | LStrLt | LStrEq | LStrLen
39 | LIntFloat IntTy | LFloatInt IntTy | LIntStr IntTy | LStrInt IntTy
40 | LFloatStr | LStrFloat | LChInt IntTy | LIntCh IntTy
41 | LPrintNum | LPrintStr | LReadStr
42 | LBitCast ArithTy ArithTy -- Only for values of equal width
44 | LFExp | LFLog | LFSin | LFCos | LFTan | LFASin | LFACos | LFATan
45 | LFSqrt | LFFloor | LFCeil
47 -- construction element extraction element insertion
48 | LMkVec NativeTy Int | LIdxVec NativeTy Int | LUpdateVec NativeTy Int
50 | LStrHead | LStrTail | LStrCons | LStrIndex | LStrRev
51 | LStdIn | LStdOut | LStdErr
53 | LFork
54 | LPar -- evaluate argument anywhere, possibly on another
55 -- core or another machine. 'id' is a valid implementation
56 | LVMPtr
57 | LNullPtr
58 | LNoOp
59 deriving (Show, Eq)
61-- Supported target languages for foreign calls
63data FCallType = FStatic | FObject | FConstructor
64 deriving (Show, Eq)
66data FLang = LANG_C | LANG_JAVA FCallType
67 deriving (Show, Eq)
69data FType = FArith ArithTy
70 | FFunction
71 | FFunctionIO
72 | FString
73 | FUnit
74 | FPtr
75 | FAny
76 deriving (Show, Eq)
78data LAlt = LConCase Int Name [Name] LExp
79 | LConstCase Const LExp
80 | LDefaultCase LExp
81 deriving (Show, Eq)
83data LDecl = LFun [LOpt] Name [Name] LExp -- options, name, arg names, def
84 | LConstructor Name Int Int -- constructor name, tag, arity
85 deriving (Show, Eq)
87type LDefs = Ctxt LDecl
89data LOpt = Inline | NoInline
90 deriving (Show, Eq)
92addTags :: Int -> [(Name, LDecl)] -> (Int, [(Name, LDecl)])
93addTags i ds = tag i ds []
94 where tag i ((n, LConstructor n' (-1) a) : as) acc
95 = tag (i + 1) as ((n, LConstructor n' i a) : acc)
96 tag i ((n, LConstructor n' t a) : as) acc
97 = tag i as ((n, LConstructor n' t a) : acc)
98 tag i (x : as) acc = tag i as (x : acc)
99 tag i [] acc = (i, reverse acc)
101data LiftState = LS Name Int [(Name, LDecl)]
103lname (NS n x) i = NS (lname n i) x
104lname (UN n) i = MN i n
105lname x i = MN i (show x)
107liftAll :: [(Name, LDecl)] -> [(Name, LDecl)]
108liftAll xs = concatMap (\ (x, d) -> lambdaLift x d) xs
110lambdaLift :: Name -> LDecl -> [(Name, LDecl)]
111lambdaLift n (LFun _ _ args e)
112 = let (e', (LS _ _ decls)) = runState (lift args e) (LS n 0 []) in
113 (n, LFun [] n args e') : decls
114lambdaLift n x = [(n, x)]
116getNextName :: State LiftState Name
117getNextName = do LS n i ds <- get
118 put (LS n (i + 1) ds)
119 return (lname n i)
121addFn :: Name -> LDecl -> State LiftState ()
122addFn fn d = do LS n i ds <- get
123 put (LS n i ((fn, d) : ds))
125lift :: [Name] -> LExp -> State LiftState LExp
126lift env (LV v) = return (LV v) -- Lifting happens before these can exist...
127lift env (LApp tc (LV (Glob n)) args) = do args' <- mapM (lift env) args
128 return (LApp tc (LV (Glob n)) args')
129lift env (LApp tc f args) = do f' <- lift env f
130 fn <- getNextName
131 addFn fn (LFun [Inline] fn env f')
132 args' <- mapM (lift env) args
133 return (LApp tc (LV (Glob fn)) (map (LV . Glob) env ++ args'))
134lift env (LLazyApp n args) = do args' <- mapM (lift env) args
135 return (LLazyApp n args')
136lift env (LLazyExp (LConst c)) = return (LConst c)
137-- lift env (LLazyExp (LApp tc (LV (Glob f)) args))
138-- = lift env (LLazyApp f args)
139lift env (LLazyExp e) = do e' <- lift env e
140 let usedArgs = nub $ usedIn env e'
141 fn <- getNextName
142 addFn fn (LFun [NoInline] fn usedArgs e')
143 return (LLazyApp fn (map (LV . Glob) usedArgs))
144lift env (LForce e) = do e' <- lift env e
145 return (LForce e')
146lift env (LLet n v e) = do v' <- lift env v
147 e' <- lift (env ++ [n]) e
148 return (LLet n v' e')
149lift env (LLam args e) = do e' <- lift (env ++ args) e
150 let usedArgs = nub $ usedIn env e'
151 fn <- getNextName
152 addFn fn (LFun [Inline] fn (usedArgs ++ args) e')
153 return (LApp False (LV (Glob fn)) (map (LV . Glob) usedArgs))
154lift env (LProj t i) = do t' <- lift env t
155 return (LProj t' i)
156lift env (LCon i n args) = do args' <- mapM (lift env) args
157 return (LCon i n args')
158lift env (LCase e alts) = do alts' <- mapM liftA alts
159 e' <- lift env e
160 return (LCase e' alts')
161 where
162 liftA (LConCase i n args e) = do e' <- lift (env ++ args) e
163 return (LConCase i n args e')
164 liftA (LConstCase c e) = do e' <- lift env e
165 return (LConstCase c e')
166 liftA (LDefaultCase e) = do e' <- lift env e
167 return (LDefaultCase e')
168lift env (LConst c) = return (LConst c)
169lift env (LForeign l t s args) = do args' <- mapM (liftF env) args
170 return (LForeign l t s args')
171 where
172 liftF env (t, e) = do e' <- lift env e
173 return (t, e')
174lift env (LOp f args) = do args' <- mapM (lift env) args
175 return (LOp f args')
176lift env (LError str) = return $ LError str
177lift env LNothing = return $ LNothing
179-- Return variables in list which are used in the expression
181usedArg env n | n `elem` env = [n]
182 | otherwise = []
184usedIn :: [Name] -> LExp -> [Name]
185usedIn env (LV (Glob n)) = usedArg env n
186usedIn env (LApp _ e args) = usedIn env e ++ concatMap (usedIn env) args
187usedIn env (LLazyApp n args) = concatMap (usedIn env) args ++ usedArg env n
188usedIn env (LLazyExp e) = usedIn env e
189usedIn env (LForce e) = usedIn env e
190usedIn env (LLet n v e) = usedIn env v ++ usedIn (env \\ [n]) e
191usedIn env (LLam ns e) = usedIn (env \\ ns) e
192usedIn env (LCon i n args) = concatMap (usedIn env) args
193usedIn env (LProj t i) = usedIn env t
194usedIn env (LCase e alts) = usedIn env e ++ concatMap (usedInA env) alts
195 where usedInA env (LConCase i n ns e) = usedIn env e
196 usedInA env (LConstCase c e) = usedIn env e
197 usedInA env (LDefaultCase e) = usedIn env e
198usedIn env (LForeign _ _ _ args) = concatMap (usedIn env) (map snd args)
199usedIn env (LOp f args) = concatMap (usedIn env) args
200usedIn env _ = []
202instance Show LExp where
203 show e = show' [] e where
204 show' env (LV (Loc i)) = env!!i
205 show' env (LV (Glob n)) = show n
206 show' env (LLazyApp e args) = show e ++ "|(" ++
207 showSep ", " (map (show' env) args) ++")"
208 show' env (LApp _ e args) = show' env e ++ "(" ++
209 showSep ", " (map (show' env) args) ++")"
210 show' env (LLazyExp e) = "%lazy(" ++ show' env e ++ ")"
211 show' env (LForce e) = "%force(" ++ show' env e ++ ")"
212 show' env (LLet n v e) = "let " ++ show n ++ " = " ++ show' env v ++ " in " ++
213 show' (env ++ [show n]) e
214 show' env (LLam args e) = "\\ " ++ showSep "," (map show args) ++ " => " ++
215 show' (env ++ (map show args)) e
216 show' env (LProj t i) = show t ++ "!" ++ show i
217 show' env (LCon i n args) = show n ++ ")" ++ showSep ", " (map (show' env) args) ++ ")"
218 show' env (LCase e alts) = "case " ++ show' env e ++ " of {\n\t" ++
219 showSep "\n\t| " (map (showAlt env) alts)
220 show' env (LConst c) = show c
221 show' env (LForeign lang ty n args)
222 = "foreign " ++ n ++ "(" ++ showSep ", " (map (show' env) (map snd args)) ++ ")"
223 show' env (LOp f args) = show f ++ "(" ++ showSep ", " (map (show' env) args) ++ ")"
224 show' env (LError str) = "error " ++ show str
225 show' env LNothing = "____"
227 showAlt env (LConCase _ n args e)
228 = show n ++ "(" ++ showSep ", " (map show args) ++ ") => "
229 ++ show' env e
230 showAlt env (LConstCase c e) = show c ++ " => " ++ show' env e
231 showAlt env (LDefaultCase e) = "_ => " ++ show' env e