@@ -1,249 +0,0 @@
1−{-# LANGUAGE PatternGuards #-}
2−
3−module RTS.SC where
4−
5−import Core.TT
6−import Core.Evaluate
7−import Core.CaseTree
8−
9−import Control.Monad.State
10−
11−type CType = Maybe Const
12−type Tag = Int
13−type Arity = Int
14−
15−data SCDef = SCDef { sc_args :: [(Name, CType)],
16− sc_locals :: Int,
17− sc_def :: SCExp }
18− deriving Show
19−
20−data 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
32−
33−data 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
52−
53−data SAlt = SConCase Tag [Name] SCExp
54− | SConstCase Const SCExp
55− | SDefaultCase SCExp
56− deriving Show
57−
58−type Prims = [(Name, ([CType], CType, SPrim))]
59−
60−sInt, sFloat, sChar, sString, sPtr, sBigInt :: CType
61−sInt = Just IType
62−sFloat = Just FlType
63−sChar = Just ChType
64−sString = Just StrType
65−sPtr = Just PtrType
66−sBigInt = Just BIType
67−
68−type SCState = ([(Name, SCDef)], Name)
69−
70−toSC :: Prims -> (Name, Def) -> [(Name, SCDef)]
71−toSC 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)
80−
81−sclift :: (Name, Def) -> [(Name, SCDef)]
82−sclift (n, d) = fst (execState (sc [] d) ([], n))
83−
84−add (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)
88−
89−nextSC :: State SCState Name
90−nextSC = 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
97−
98−sname :: State SCState Name
99−sname = do (xs, n) <- get
100− return n
101−
102−class Lift s t | s -> t where
103− sc :: [Name] -> s -> State SCState t
104−
105−instance 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')
117−
118−instance 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)
146−
147−
148−instance 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)
154−
155−instance 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')
162−
163−-- Deal with primitives: mkForeign, -- lazy, prim__IO, io_bind, malloc, trace_malloc
164−
165−sPrim :: [Name] -> TT Name -> [TT Name] -> State SCState (Maybe SCExp)
166−sPrim env (P _ (UN "mkForeign") _) args = do x <- doForeign env args
167− return (Just x)
168−sPrim 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)
173−sPrim env (P _ (UN "prim__IO") _) [v] = do v' <- sc env v
174− return $ Just v'
175−sPrim env (P _ (UN "io_bind") _) [_,_,v,k]
176− = do v' <- sc env v
177− k' <- sc env k
178− return $ Just $ SApp k'[v']
179−sPrim env f args = return Nothing
180−
181−doForeign 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"
188−
189−getFTypes :: TT Name -> [CType]
190−getFTypes tm = case unApply tm of
191− (nil, []) -> []
192− (cons, [ty, xs]) ->
193− let rest = getFTypes xs in
194− mkEty' ty : rest
195−
196−mkEty' (P _ (UN ty) _) = mkEty ty
197−mkEty' _ = Nothing
198−
199−mkEty "FInt" = Just IType
200−mkEty "FFloat" = Just FlType
201−mkEty "FChar" = Just ChType
202−mkEty "FString" = Just StrType
203−mkEty "FPtr" = Just PtrType
204−mkEty "FUnit" = Just VoidType
205−
206−-- Convert local variable names to de Bruijn levels, return the biggest
207−
208−dbl :: [Name] -> SCExp -> (SCExp, Int)
209−dbl 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
234−
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'
242−
243− extend env n = env ++ [(n, length env)]
244− extends env [] = env
245− extends env (n : ns) = extends (extend env n) ns
246−
247− ref i = do s <- get
248− when (i > s) $ put i
249−