git.iko.soy/Idris-dev
on f151dee help sign in
Idris-dev/src/IRTS/Lang.hs
239 lines 11 kB history raw
1module IRTS.Lang where
3import Core.TT
4import Control.Monad.State hiding(lift)
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 | LMinus | LTimes | LDiv | LMod
32 | LAnd | LOr | LXOr | LCompl | LSHL| LSHR
33 | LEq | LLt | LLe | LGt | LGe
34 | LFPlus | LFMinus | LFTimes | LFDiv
35 | LFEq | LFLt | LFLe | LFGt | LFGe
36 | LBPlus | LBMinus | LBDec | LBTimes | LBDiv | LBMod
37 | LBEq | LBLt | LBLe | LBGt | LBGe
38 | LStrConcat | LStrLt | LStrEq | LStrLen
39 | LIntFloat | LFloatInt | LIntStr | LStrInt | LFloatStr | LStrFloat
40 | LIntBig | LBigInt | LStrBig | LBigStr | LChInt | LIntCh
41 | LPrintNum | LPrintStr | LReadStr
43 | LB8Lt | LB8Lte | LB8Eq | LB8Gt | LB8Gte
44 | LB8Plus | LB8Minus | LB8Times | LB8UDiv | LB8SDiv | LB8URem | LB8SRem
45 | LB8Shl | LB8LShr | LB8AShr | LB8And | LB8Or | LB8Xor | LB8Compl
46 | LB8Z16 | LB8Z32 | LB8Z64 | LB8S16 | LB8S32 | LB8S64 -- Zero/Sign extension
47 | LB16Lt | LB16Lte | LB16Eq | LB16Gt | LB16Gte
48 | LB16Plus | LB16Minus | LB16Times | LB16UDiv | LB16SDiv | LB16URem | LB16SRem
49 | LB16Shl | LB16LShr | LB16AShr | LB16And | LB16Or | LB16Xor | LB16Compl
50 | LB16Z32 | LB16Z64 | LB16S32 | LB16S64 | LB16T8 -- and Truncation
51 | LB32Lt | LB32Lte | LB32Eq | LB32Gt | LB32Gte
52 | LB32Plus | LB32Minus | LB32Times | LB32UDiv | LB32SDiv | LB32URem | LB32SRem
53 | LB32Shl | LB32LShr | LB32AShr | LB32And | LB32Or | LB32Xor | LB32Compl
54 | LB32Z64 | LB32S64 | LB32T8 | LB32T16
55 | LB64Lt | LB64Lte | LB64Eq | LB64Gt | LB64Gte
56 | LB64Plus | LB64Minus | LB64Times | LB64UDiv | LB64SDiv | LB64URem | LB64SRem
57 | LB64Shl | LB64LShr | LB64AShr | LB64And | LB64Or | LB64Xor | LB64Compl
58 | LB64T8 | LB64T16 | LB64T32
59 | LIntB8 | LIntB16 | LIntB32 | LIntB64 | LB32Int
61 | LFExp | LFLog | LFSin | LFCos | LFTan | LFASin | LFACos | LFATan
62 | LFSqrt | LFFloor | LFCeil
64 | LStrHead | LStrTail | LStrCons | LStrIndex | LStrRev
65 | LStdIn | LStdOut | LStdErr
67 | LFork
68 | LPar -- evaluate argument anywhere, possibly on another
69 -- core or another machine. 'id' is a valid implementation
70 | LVMPtr
71 | LNoOp
72 deriving (Show, Eq)
74-- Supported target languages for foreign calls
76data FLang = LANG_C
77 deriving (Show, Eq)
79data FType = FInt | FChar | FString | FUnit | FPtr | FDouble | FAny
80 deriving (Show, Eq)
82data LAlt = LConCase Int Name [Name] LExp
83 | LConstCase Const LExp
84 | LDefaultCase LExp
85 deriving (Show, Eq)
87data LDecl = LFun [LOpt] Name [Name] LExp -- options, name, arg names, def
88 | LConstructor Name Int Int -- constructor name, tag, arity
89 deriving (Show, Eq)
91type LDefs = Ctxt LDecl
93data LOpt = Inline | NoInline
94 deriving (Show, Eq)
96addTags :: Int -> [(Name, LDecl)] -> (Int, [(Name, LDecl)])
97addTags i ds = tag i ds []
98 where tag i ((n, LConstructor n' (-1) a) : as) acc
99 = tag (i + 1) as ((n, LConstructor n' i a) : acc)
100 tag i ((n, LConstructor n' t a) : as) acc
101 = tag i as ((n, LConstructor n' t a) : acc)
102 tag i (x : as) acc = tag i as (x : acc)
103 tag i [] acc = (i, reverse acc)
105data LiftState = LS Name Int [(Name, LDecl)]
107lname (NS n x) i = NS (lname n i) x
108lname (UN n) i = MN i n
109lname x i = MN i (show x)
111liftAll :: [(Name, LDecl)] -> [(Name, LDecl)]
112liftAll xs = concatMap (\ (x, d) -> lambdaLift x d) xs
114lambdaLift :: Name -> LDecl -> [(Name, LDecl)]
115lambdaLift n (LFun _ _ args e)
116 = let (e', (LS _ _ decls)) = runState (lift args e) (LS n 0 []) in
117 (n, LFun [] n args e') : decls
118lambdaLift n x = [(n, x)]
120getNextName :: State LiftState Name
121getNextName = do LS n i ds <- get
122 put (LS n (i + 1) ds)
123 return (lname n i)
125addFn :: Name -> LDecl -> State LiftState ()
126addFn fn d = do LS n i ds <- get
127 put (LS n i ((fn, d) : ds))
129lift :: [Name] -> LExp -> State LiftState LExp
130lift env (LV v) = return (LV v) -- Lifting happens before these can exist...
131lift env (LApp tc (LV (Glob n)) args) = do args' <- mapM (lift env) args
132 return (LApp tc (LV (Glob n)) args')
133lift env (LApp tc f args) = do f' <- lift env f
134 fn <- getNextName
135 addFn fn (LFun [Inline] fn env f')
136 args' <- mapM (lift env) args
137 return (LApp tc (LV (Glob fn)) (map (LV . Glob) env ++ args'))
138lift env (LLazyApp n args) = do args' <- mapM (lift env) args
139 return (LLazyApp n args')
140lift env (LLazyExp (LConst c)) = return (LConst c)
141-- lift env (LLazyExp (LApp tc (LV (Glob f)) args))
142-- = lift env (LLazyApp f args)
143lift env (LLazyExp e) = do e' <- lift env e
144 let usedArgs = nub $ usedIn env e'
145 fn <- getNextName
146 addFn fn (LFun [NoInline] fn usedArgs e')
147 return (LLazyApp fn (map (LV . Glob) usedArgs))
148lift env (LForce e) = do e' <- lift env e
149 return (LForce e')
150lift env (LLet n v e) = do v' <- lift env v
151 e' <- lift (env ++ [n]) e
152 return (LLet n v' e')
153lift env (LLam args e) = do e' <- lift (env ++ args) e
154 let usedArgs = nub $ usedIn env e'
155 fn <- getNextName
156 addFn fn (LFun [Inline] fn (usedArgs ++ args) e')
157 return (LApp False (LV (Glob fn)) (map (LV . Glob) usedArgs))
158lift env (LProj t i) = do t' <- lift env t
159 return (LProj t' i)
160lift env (LCon i n args) = do args' <- mapM (lift env) args
161 return (LCon i n args')
162lift env (LCase e alts) = do alts' <- mapM liftA alts
163 e' <- lift env e
164 return (LCase e' alts')
165 where
166 liftA (LConCase i n args e) = do e' <- lift (env ++ args) e
167 return (LConCase i n args e')
168 liftA (LConstCase c e) = do e' <- lift env e
169 return (LConstCase c e')
170 liftA (LDefaultCase e) = do e' <- lift env e
171 return (LDefaultCase e')
172lift env (LConst c) = return (LConst c)
173lift env (LForeign l t s args) = do args' <- mapM (liftF env) args
174 return (LForeign l t s args')
175 where
176 liftF env (t, e) = do e' <- lift env e
177 return (t, e')
178lift env (LOp f args) = do args' <- mapM (lift env) args
179 return (LOp f args')
180lift env (LError str) = return $ LError str
181lift env LNothing = return $ LNothing
183-- Return variables in list which are used in the expression
185usedArg env n | n `elem` env = [n]
186 | otherwise = []
188usedIn :: [Name] -> LExp -> [Name]
189usedIn env (LV (Glob n)) = usedArg env n
190usedIn env (LApp _ e args) = usedIn env e ++ concatMap (usedIn env) args
191usedIn env (LLazyApp n args) = concatMap (usedIn env) args ++ usedArg env n
192usedIn env (LLazyExp e) = usedIn env e
193usedIn env (LForce e) = usedIn env e
194usedIn env (LLet n v e) = usedIn env v ++ usedIn (env \\ [n]) e
195usedIn env (LLam ns e) = usedIn (env \\ ns) e
196usedIn env (LCon i n args) = concatMap (usedIn env) args
197usedIn env (LProj t i) = usedIn env t
198usedIn env (LCase e alts) = usedIn env e ++ concatMap (usedInA env) alts
199 where usedInA env (LConCase i n ns e) = usedIn env e
200 usedInA env (LConstCase c e) = usedIn env e
201 usedInA env (LDefaultCase e) = usedIn env e
202usedIn env (LForeign _ _ _ args) = concatMap (usedIn env) (map snd args)
203usedIn env (LOp f args) = concatMap (usedIn env) args
204usedIn env _ = []
206instance Show LExp where
207 show e = show' [] e where
208 show' env (LV (Loc i)) = env!!i
209 show' env (LV (Glob n)) = show n
210 show' env (LLazyApp e args) = show e ++ "|(" ++
211 showSep ", " (map (show' env) args) ++")"
212 show' env (LApp _ e args) = show' env e ++ "(" ++
213 showSep ", " (map (show' env) args) ++")"
214 show' env (LLazyExp e) = "%lazy(" ++ show' env e ++ ")"
215 show' env (LForce e) = "%force(" ++ show' env e ++ ")"
216 show' env (LLet n v e) = "let " ++ show n ++ " = " ++ show' env v ++ " in " ++
217 show' (env ++ [show n]) e
218 show' env (LLam args e) = "\\ " ++ showSep "," (map show args) ++ " => " ++
219 show' (env ++ (map show args)) e
220 show' env (LProj t i) = show t ++ "!" ++ show i
221 show' env (LCon i n args) = show n ++ ")" ++ showSep ", " (map (show' env) args) ++ ")"
222 show' env (LCase e alts) = "case " ++ show' env e ++ " of {\n\t" ++
223 showSep "\n\t| " (map (showAlt env) alts)
224 show' env (LConst c) = show c
225 show' env (LForeign lang ty n args)
226 = "foreign " ++ n ++ "(" ++ showSep ", " (map (show' env) (map snd args)) ++ ")"
227 show' env (LOp f args) = show f ++ "(" ++ showSep ", " (map (show' env) args) ++ ")"
228 show' env (LError str) = "error " ++ show str
229 show' env LNothing = "____"
231 showAlt env (LConCase _ n args e)
232 = show n ++ "(" ++ showSep ", " (map show args) ++ ") => "
233 ++ show' env e
234 showAlt env (LConstCase c e) = show c ++ " => " ++ show' env e
235 showAlt env (LDefaultCase e) = "_ => " ++ show' env e