git.iko.soy/Idris-dev
on aa8aefd help sign in
Idris-dev/src/RTS/SC.hs
249 lines 9.4 kB history raw
1{-# LANGUAGE PatternGuards #-}
3module RTS.SC where
5import Core.TT
6import Core.Evaluate
7import Core.CaseTree
9import Control.Monad.State
11type CType = Maybe Const
12type Tag = Int
13type Arity = Int
15data SCDef = SCDef { sc_args :: [(Name, CType)],
16 sc_locals :: Int,
17 sc_def :: SCExp }
18 deriving Show
20data SCExp = SRef Name
21 | SLoc Int -- de Bruijn level
22 | SApp SCExp [SCExp]
23 | SLazyApp Name [SCExp]
24 | SLet Name SCExp SCExp
25 | SFCall String CType [(SCExp, CType)] -- foreign call with types
26 | SCon Tag [SCExp] -- constructor, assume saturated (forcing does this)
27 | SConst Const
28 | SError String
29 | SCase SCExp [SAlt]
30 | SPrimOp SPrim [SCExp]
31 deriving Show
33data SPrim = AddI | SubI | MulI | DivI
34 | EqI | LtI | LteI | GtI | GteI
35 | EqC | LtC | LteC | GtC | GteC
36 | AddBI | SubBI | MulBI | DivBI
37 | EqBI | LtBI | LteBI | GtBI | GteBI
38 | AddF | SubF | MulF | DivF
39 | EqF | LtF | LteF | GtF | GteF
40 | ConcatS | EqS | LtS
41 | StoI | ItoS
42 | CtoI | ItoC
43 | ItoBI | BItoI
44 | StoBI | BItoS
45 | StoF | FtoS
46 | ItoF | FtoI
47 | ExpF | LogF | SinF | CosF | TanF
48 | ASinF | ACosF | ATanF | SqrtF | FloorF | CeilF
49 | HeadS | TailS | ConsS | IndexS | RevS
50 | BelieveMe
51 deriving Show
53data SAlt = SConCase Tag [Name] SCExp
54 | SConstCase Const SCExp
55 | SDefaultCase SCExp
56 deriving Show
58type Prims = [(Name, ([CType], CType, SPrim))]
60sInt, sFloat, sChar, sString, sPtr, sBigInt :: CType
61sInt = Just IType
62sFloat = Just FlType
63sChar = Just ChType
64sString = Just StrType
65sPtr = Just PtrType
66sBigInt = Just BIType
68type SCState = ([(Name, SCDef)], Name)
70toSC :: Prims -> (Name, Def) -> [(Name, SCDef)]
71toSC prims (n, d)
72 = case lookup n prims of
73 Nothing -> sclift (n, d)
74 Just (args, rt, op) ->
75 let anames = zipWith mkA args [0..] in
76 [(n, SCDef anames (length anames)
77 (SPrimOp op (take (length anames)
78 (map SLoc [0..]))))]
79 where mkA t i = (MN i "primArg", t)
81sclift :: (Name, Def) -> [(Name, SCDef)]
82sclift (n, d) = fst (execState (sc [] d) ([], n))
84add (n, SCDef args _ def)
85 = do (xs, b) <- get
86 let (def', maxloc) = dbl (map fst args) def
87 put ((n, SCDef args maxloc def') : xs, b)
89nextSC :: State SCState Name
90nextSC = do (xs, n) <- get
91 let n' = getNext n
92 put (xs, n')
93 return n'
94 where getNext (UN n) = MN 0 n
95 getNext (MN i n) = MN (i+1) n
96 getNext (NS n ns) = NS (getNext n) ns
98sname :: State SCState Name
99sname = do (xs, n) <- get
100 return n
102class Lift s t | s -> t where
103 sc :: [Name] -> s -> State SCState t
105instance Lift Def () where
106 sc env (Function ty tm) = do n <- sname
107 tm' <- sc env tm
108 add (n, SCDef (zip env (repeat Nothing)) 0 tm')
109 sc env (TyDecl _ _) = do n <- sname
110 add (n, SCDef (zip env (repeat Nothing)) 0
111 (SError $ "undefined " ++ show n))
112 sc env (Operator _ _ _) = return ()
113 sc env (CaseOp _ _ _ _ _ args cases)
114 = do n <- sname
115 cases' <- sc (env ++ args) cases
116 add (n, SCDef (zip (env ++ args) (repeat Nothing)) 0 cases')
118instance Lift (TT Name) SCExp where
119 sc env (P (DCon t a) _ _) = return $ SCon t []
120 sc env (P (TCon t a) _ _) = return $ SCon t []
121 sc env (P _ n _) = return $ SRef n
122 sc env (V i) = return $ SRef (env!!i)
123 sc env fn@(App _ _)
124 = do let (f, args) = unApply fn
125 prim <- sPrim env f args
126 case prim of
127 Just t -> return t
128 Nothing -> do args' <- mapM (sc env) args
129 case f of
130 (P (DCon t a) _ _) -> return $ SCon t args'
131 (P (TCon t a) _ _) -> return $ SCon t args'
132 _ -> do f' <- sc env f
133 return $ SApp f' args'
134 sc env (Constant c) = return $ SConst c
135 sc env (Bind n (Let _ v) e) = do v' <- sc env v
136 e' <- sc (n : env) e
137 return (SLet n v' e')
138 sc env (Bind n (Lam _) e) = scLam [n] e
139 where
140 scLam args (Bind n (Lam _) e) = scLam (n : args) e
141 scLam args x = do x' <- sc (args ++ env) x
142 fn <- nextSC
143 add (fn, SCDef (zip (env ++ reverse args) (repeat Nothing)) 0 x')
144 return $ SApp (SRef fn) (map SRef env)
145 sc _ _ = return $ SConst (I 42424242)
148instance Lift SC SCExp where
149 sc env (Case n alts) = do alts' <- mapM (sc env) alts
150 return (SCase (SRef n) alts')
151 sc env (STerm t) = do t' <- sc env t
152 return t'
153 sc env (UnmatchedCase s) = return (SError s)
155instance Lift CaseAlt SAlt where
156 sc env (ConCase n t args e) = do e' <- sc env e
157 return (SConCase t args e')
158 sc env (ConstCase c e) = do e' <- sc env e
159 return (SConstCase c e')
160 sc env (DefaultCase e) = do e' <- sc env e
161 return (SDefaultCase e')
163-- Deal with primitives: mkForeign, -- lazy, prim__IO, io_bind, malloc, trace_malloc
165sPrim :: [Name] -> TT Name -> [TT Name] -> State SCState (Maybe SCExp)
166sPrim env (P _ (UN "mkForeign") _) args = do x <- doForeign env args
167 return (Just x)
168sPrim env (P _ (UN "lazy") _) [_, arg]
169 = do arg' <- sc env arg
170 fn <- nextSC
171 add (fn, SCDef (zip env (repeat Nothing)) 0 arg')
172 return $ Just $ SLazyApp fn (map SRef env)
173sPrim env (P _ (UN "prim__IO") _) [v] = do v' <- sc env v
174 return $ Just v'
175sPrim env (P _ (UN "io_bind") _) [_,_,v,k]
176 = do v' <- sc env v
177 k' <- sc env k
178 return $ Just $ SApp k'[v']
179sPrim env f args = return Nothing
181doForeign env (_ : fgn : args)
182 | (_, (Constant (Str fgnName) : fgnArgTys : ret : [])) <- unApply fgn
183 = let tys = getFTypes fgnArgTys
184 rty = mkEty' ret in
185 do args' <- mapM (sc env) args
186 return $ SFCall fgnName rty (zip args' tys)
187 | otherwise = fail "Badly formed foreign function call"
189getFTypes :: TT Name -> [CType]
190getFTypes tm = case unApply tm of
191 (nil, []) -> []
192 (cons, [ty, xs]) ->
193 let rest = getFTypes xs in
194 mkEty' ty : rest
196mkEty' (P _ (UN ty) _) = mkEty ty
197mkEty' _ = Nothing
199mkEty "FInt" = Just IType
200mkEty "FFloat" = Just FlType
201mkEty "FChar" = Just ChType
202mkEty "FString" = Just StrType
203mkEty "FPtr" = Just PtrType
204mkEty "FUnit" = Just VoidType
206-- Convert local variable names to de Bruijn levels, return the biggest
208dbl :: [Name] -> SCExp -> (SCExp, Int)
209dbl ns exp = runState (db' (extends [] ns) exp) (length ns) where
210 db' :: [(Name, Int)] -> SCExp -> State Int SCExp
211 db' env (SRef n) = case lookup n env of
212 Just i -> do ref i; return $ SLoc i
213 Nothing -> return $ SRef n
214 db' env (SApp f args) = do f' <- db' env f
215 args' <- mapM (db' env) args
216 return $ SApp f' args'
217 db' env (SLazyApp n args) = do args' <- mapM (db' env) args
218 return $ SLazyApp n args'
219 db' env (SLet n v sc) = do v' <- db' env v
220 sc' <- db' (extend env n) sc
221 ref (length env + 1)
222 return $ SLet n v' sc'
223 db' env (SFCall n t args) = do args' <- mapM (\ (e,t) -> do e' <- db' env e
224 return (e', t)) args
225 return $ SFCall n t args'
226 db' env (SCon t args) = do args' <- mapM (db' env) args
227 return $ SCon t args'
228 db' env (SCase n alts) = do n' <- db' env n
229 alts' <- mapM (dbAlt env) alts
230 return $ SCase n' alts'
231 db' env (SPrimOp p args) = do args' <- mapM (db' env) args
232 return $ SPrimOp p args'
233 db' env x = return x
235 dbAlt env (SConCase t ns exp) = do exp' <- db' (extends env ns) exp
236 ref (length env + length ns)
237 return $ SConCase t ns exp'
238 dbAlt env (SConstCase c e) = do e' <- db' env e
239 return $ SConstCase c e'
240 dbAlt env (SDefaultCase e) = do e' <- db' env e
241 return $ SDefaultCase e'
243 extend env n = env ++ [(n, length env)]
244 extends env [] = env
245 extends env (n : ns) = extends (extend env n) ns
247 ref i = do s <- get
248 when (i > s) $ put i