Skip to content

Commit 8634f4b

Browse files
thmathma
thma
authored and
thma
committed
I and K are working, wohoo
1 parent 4275aaf commit 8634f4b

File tree

1 file changed

+144
-135
lines changed

1 file changed

+144
-135
lines changed

‎src/AllInOne.hs

Lines changed: 144 additions & 135 deletions
Original file line numberDiff line numberDiff line change
@@ -7,10 +7,6 @@ import Data.Maybe
77
import Text.Parsec
88
import Data.Functor.Identity (Identity)
99
import System.IO (hSetEncoding, stdin, stdout, utf8)
10-
import Data.IORef ( newIORef, readIORef )
11-
import GHC.IORef ( IORef(IORef) )
12-
import GHC.Base ( IO(IO) )
13-
1410

1511
type Parser = Parsec String ()
1612

@@ -48,7 +44,7 @@ source = catMaybes <$> many maybeLet where
4844
app = foldl1' (:@) <$> many1
4945
(
5046
try num
51-
<|> (Var <$> var)
47+
<|> Var <$> var
5248
<|> between (str "(") (str ")") term )
5349

5450
var :: ParsecT String u Identity String
@@ -100,10 +96,10 @@ noLamEq _ _ = False
10096

10197

10298
opt :: Expr -> Expr
103-
opt (Var "i" :@ n@(Int _n)) = n
104-
opt ((Var "s" :@ e1) :@ (Var "k" :@ e2)) = (Var "c" :@ e1) :@ e2
99+
--opt (Var "i" :@ n@(Int _n)) = n
100+
--opt ((Var "s" :@ e1) :@ (Var "k" :@ e2)) = (Var "c" :@ e1) :@ e2
105101

106-
opt (x :@ y) = opt x :@ opt y
102+
--opt (x :@ y) = opt x :@ opt y
107103
opt x = x
108104

109105
ropt :: Expr -> Expr
@@ -133,13 +129,28 @@ data Graph =
133129
Node Pointer Pointer
134130
| Comb String
135131
| Num Integer
136-
deriving Show
132+
deriving (Eq, Show)
133+
134+
type AllocatedGraph = [(Pointer, Graph)]
135+
136+
collectAllReachables :: Pointer -> AllocatedGraph -> AllocatedGraph -> AllocatedGraph
137+
collectAllReachables rootP aGraph result =
138+
let rootNode = peek rootP aGraph
139+
in case rootNode of
140+
Node l r -> (l, peek l aGraph) : (r, peek r aGraph) : collectAllReachables l aGraph result ++ collectAllReachables r aGraph result ++ result
141+
Comb s -> result
142+
Num n -> result
143+
144+
145+
compactify :: Pointer -> AllocatedGraph -> AllocatedGraph
146+
compactify rootP aGraph = (rootP, peek rootP aGraph) : collectAllReachables rootP aGraph []
137147

138-
allocate :: Expr -> [(Pointer, Graph)]
148+
149+
allocate :: Expr -> AllocatedGraph
139150
allocate expr =
140151
alloc expr 1 []
141152
where
142-
maxPointer :: [(Pointer, Graph)] -> Pointer
153+
maxPointer :: AllocatedGraph -> Pointer
143154
maxPointer x = maximum $ map fst x
144155

145156
alloc :: Expr -> Int -> [(Int, Graph)] -> [(Int, Graph)]
@@ -156,67 +167,119 @@ allocate expr =
156167
(pointer, Node pointerL pointerR) : (allocL ++ allocR ++ memMap)
157168
alloc (Lam _ _) pointer memMap = error "lambdas should already be abstracted"
158169

159-
spine' :: Graph -> [(Pointer, Graph)] -> [Graph]-> (Graph, [Graph])
160-
spine' c@(Comb _) mm stack = (c, stack)
161-
spine' n@(Num _) mm stack = (n, stack)
162-
spine' g@(Node l r) mm stack = spine' (getNode l mm) mm (g:stack)
163-
where
164-
getNode :: Pointer -> [(Pointer, Graph)] -> Graph
165-
getNode p mm = case lookup p mm of
166-
Nothing -> error $ "deref " ++ show p ++ " in " ++ show mm
167-
Just g -> g
168-
169-
spine :: IORef Graf -> [IORef Graf]-> IO (IORef Graf, [IORef Graf])
170-
spine ioRefGraph stack = do
171-
derefGraph <- readIORef ioRefGraph
172-
case derefGraph of
173-
Com c -> return (ioRefGraph, stack)
174-
Numb i -> return (ioRefGraph, stack)
175-
Nod l r -> do
176-
derefL <- l
177-
spine derefL (ioRefGraph:stack)
178-
179-
180-
-- spine c@(Comb _) mm stack = (c, stack)
181-
-- spine n@(Num _) mm stack = (n, stack)
182-
-- spine g@(Node l r) mm stack = spine (getNode l mm) mm (g:stack)
183-
-- where
184-
-- getNode :: Pointer -> [(Pointer, Graph)] -> Graph
185-
-- getNode p mm = case lookup p mm of
186-
-- Nothing -> error $ "deref " ++ show p ++ " in " ++ show mm
187-
-- Just g -> g
188-
189-
--- allocation with IORefs
190-
data Graf =
191-
Nod (IO (IORef Graf)) (IO (IORef Graf))
192-
| Com String
193-
| Numb Integer
194-
195-
196-
alloc :: Expr -> IO (IORef Graf)
197-
alloc expr = newIORef(allocate expr)
198-
where
199-
allocate (Var name) = Com name
200-
allocate (Int val) = Numb val
201-
allocate (l :@ r) =
202-
let refL = newIORef (allocate l)
203-
refR = newIORef (allocate r)
204-
in Nod refL refR
205-
allocate _ = error $ "all lambdas must be abstracted first: " ++ show expr
206-
207-
dealloc :: IO (IORef Graf) -> IO Expr
208-
dealloc graphRef = do
209-
gRef <- graphRef
210-
payload <- readIORef gRef
211-
case payload of
212-
(Com c) -> return $ Var c
213-
(Numb n) -> return $ Int n
214-
(Nod l r) -> do
215-
rExpr <- dealloc r
216-
lExpr <- dealloc l
217-
return (lExpr :@ rExpr)
218-
219-
170+
171+
spine :: Pointer -> AllocatedGraph -> [(Pointer, Graph)] -> (Graph, [(Pointer, Graph)])
172+
spine rootP graph stack =
173+
case peek rootP graph of
174+
c@(Comb _) -> (c, stack)
175+
n@(Num _) -> (n, stack)
176+
g@(Node l r) -> spine l graph ((rootP,g):stack)
177+
178+
179+
run :: String -> IO Graph
180+
run source = do
181+
let sk = getSK . toSK $ source
182+
g = allocate sk
183+
print sk
184+
print g
185+
print (spine 1 g [])
186+
return $ snd(head(loop 1 g))
187+
188+
loop :: Pointer -> AllocatedGraph -> AllocatedGraph
189+
loop rootP aGraph =
190+
let aGraph' = compactify rootP (step rootP aGraph)
191+
in if aGraph == aGraph'
192+
then aGraph
193+
else loop rootP aGraph'
194+
195+
step :: Pointer -> AllocatedGraph -> AllocatedGraph
196+
step rootP graph =
197+
let root = peek rootP
198+
(g,stack) = spine rootP graph []
199+
in case g of
200+
(Comb k) -> apply k stack graph rootP
201+
_ -> graph
202+
203+
apply :: String -> [(Pointer, Graph)] -> AllocatedGraph-> Pointer -> AllocatedGraph
204+
apply "i" ((p,Node _ xPointer):_) aGraph rootP =
205+
let xVal = peek xPointer aGraph
206+
in poke p xVal aGraph
207+
apply "k" ((_p, Node _ xPointer):(p, Node _ _):_) aGraph rootP =
208+
poke p (peek xPointer aGraph) aGraph
209+
210+
apply k _ _ _ = error $ "undefined combinator " ++ k
211+
212+
-- |apply (I,(node as ref(app((_,ref x),_,ref q)))::_) =
213+
-- (node := x; set_q node q)
214+
-- |apply (K,ref(app((_,ref x),_,ref q))::(node as ref(app(_,_,_)))::_) =
215+
-- (node := x; set_q node q)
216+
-- |apply (S,(ref(app((_,x),_,_)))::(ref(app((_,y),_,_)))
217+
-- ::(node as (ref(app((_,z),m,q))))::_) =
218+
-- node := app((ref(app((x,z),ref Eval,q)),
219+
-- ref(app((y,z),ref Eval,q))),
220+
-- ref Eval,q)
221+
-- |apply (B,(ref(app((_,x),_,_)))::(ref(app((_,y),_,_)))
222+
-- ::(node as (ref(app((_,z),m,q))))::_) =
223+
-- node := app((x,ref (app((y,z),ref Eval,q))),ref Eval,q)
224+
-- |apply (C,(ref(app((_,x),_,_)))::(ref(app((_,y),_,_)))
225+
-- ::(node as (ref(app((_,z),m,q))))::_) =
226+
-- node := app((ref(app((x,z),ref Eval,q)),y),ref Eval,q)
227+
228+
-- |apply (Y,(node as ref(app((_,f),m,q)))::_) =
229+
-- node := app((f,node),ref Eval,q)
230+
-- |apply (DEF(name),(node as ref(app((_,_),_,_)))::_) =
231+
-- node := !(copy(lookup name))
232+
-- |apply (PLUS,ref(app((_,ref(atom(int x,_,_))),_,_))::(node as
233+
-- ref(app((_,ref(atom(int y,_,_))),_,q)))::_) =
234+
-- node := atom(int(x+y),ref Ready,q)
235+
-- |apply (PLUS,(stack as ref(app((_,x),_,_))::
236+
-- ref(app((_,y),_,_))::_)) =
237+
-- (subEval (last stack,x);
238+
-- subEval (last stack,y); ())
239+
-- |apply (MINUS,ref(app((_,ref(atom(int x,_,_))),_,_))::(node as
240+
-- ref(app((_,ref(atom(int y,_,_))),_,q)))::_) =
241+
-- node := atom(int(x-y),ref Ready,q)
242+
-- |apply (MINUS,(stack as ref(app((_,x),_,_))::
243+
-- ref(app((_,y),_,_))::_)) =
244+
-- (subEval (last stack,x);
245+
-- subEval (last stack,y); ())
246+
-- |apply (TIMES,ref(app((_,ref(atom(int x,_,_))),_,_))::(node as
247+
-- ref(app((_,ref(atom(int y,_,_))),_,q)))::_) =
248+
-- node := atom(int(x*y),ref Ready,q)
249+
-- |apply (TIMES,(stack as ref(app((_,x),_,_))::
250+
-- ref(app((_,y),_,_))::_)) =
251+
-- (subEval (last stack,x);
252+
-- subEval (last stack,y); ())
253+
-- |apply (DIV,ref(app((_,ref(atom(int x,_,_))),_,_))::(node as
254+
-- ref(app((_,ref(atom(int y,_,_))),_,q)))::_) =
255+
-- node := atom(int(x div y),ref Ready,q)
256+
-- |apply (DIV,(stack as ref(app((_,x),_,_))::
257+
-- ref(app((_,y),_,_))::_)) =
258+
-- (subEval (last stack,x);
259+
-- subEval (last stack,y); ())
260+
-- |apply (EQ,(stack as ref(app((_,x),_,_))::(node as
261+
-- ref(app((_,y),_,q)))::_)) =
262+
-- if (!(get_mark x)) = Ready andalso
263+
-- (!(get_mark y)) = Ready
264+
-- then node := atom(bool(equal x y),ref Ready,q)
265+
-- else
266+
-- (subEval (last stack,x);
267+
-- subEval (last stack,y); ())
268+
-- |apply (IF,(ref(app((_,ref(atom(bool test,_,_))),_,_)))::
269+
-- (ref(app((_,x),_,_)))::(node as (ref(app((_,y),_,_))))::_) =
270+
-- if test then node := !x
271+
-- else node := !y
272+
-- |apply (IF,(stack as (ref(app((_,test),_,_))::
273+
-- ref(app((_,x),_,_))::(node as ref(app((_,y),_,q)))::_))) =
274+
-- subEval (last stack,test)
275+
276+
277+
peek :: Pointer -> AllocatedGraph -> Graph
278+
peek pointer graph = fromMaybe (error "merde") (lookup pointer graph)
279+
280+
poke :: Pointer -> Graph -> AllocatedGraph -> AllocatedGraph
281+
poke key value assoc = (key,value):filter ((key /=).fst) assoc
282+
220283

221284
-- parse a lambda expression
222285
toSK :: String -> Either ParseError Expr
@@ -271,7 +334,7 @@ reduce expr =
271334
then expr
272335
else reduce expr'
273336

274-
showSK :: Expr -> [Char]
337+
showSK :: Expr -> String
275338
showSK (Var s) = s ++ " "
276339
showSK (x :@ y) = showSK x ++ showR y where
277340
showR (Var s) = s ++ " "
@@ -282,18 +345,18 @@ main :: IO ()
282345
main = do
283346
hSetEncoding stdin utf8
284347
hSetEncoding stdout utf8
285-
putStrLn testSource
348+
--putStrLn testSource
286349
case toSK testSource of
287350
Left err -> print $ "error: " ++ show err
288351
Right sk -> do
289-
putStrLn $ "compiled to SKI: " ++ showSK sk
290-
putStrLn $ "as graph: " ++ show sk
291-
putStrLn $ "reduce: " ++ show (reduce sk)
292-
let sk = getSK (toSK "main = c i 2 (+ 1)")
352+
--putStrLn $ "compiled to SKI: " ++ showSK sk
353+
--putStrLn $ "as graph: " ++ show sk
354+
--putStrLn $ "reduce: " ++ show (reduce sk)
355+
let sk = getSK (toSK "main = i 23") --(toSK "main = c i 2 (+ 1)")
293356
print sk
294-
let g = alloc sk
295-
deallocG <- dealloc g
296-
print deallocG
357+
let g = allocate sk
358+
print g
359+
print $ spine 1 g []
297360

298361

299362
-- putStrLn $ "encoded: " ++ show (I.fromAscList $ zip [0..] $ encodeTree sk)
@@ -331,59 +394,5 @@ testSource =
331394
-- "fact = Y(\\f n -> (is0 n) 1 (mul n (f (pred n)))) \n" ++
332395
-- "main = fact (succ (succ (succ 1))) \n"
333396

334-
-- compilation to byte arrays:
335-
-- toArr :: Int -> Expr -> [Int]
336-
-- toArr n (Var "z") = [0]
337-
-- toArr n (Var "u") = [1]
338-
-- toArr n (Var "k") = [2]
339-
-- toArr n (Var "s") = [3]
340-
-- toArr n (x@(Var _) :@ y@(Var _)) = toArr n x ++ toArr n y
341-
-- toArr n (x@(Var _) :@ y) = toArr n x ++ [n + 2] ++ toArr (n + 2) y
342-
-- toArr n (x :@ y@(Var _)) = n + 2 : toArr n y ++ toArr (n + 2) x
343-
-- toArr n (x :@ y) = [n + 2, nl] ++ l ++ toArr nl y
344-
-- where l = toArr (n + 2) x
345-
-- nl = n + 2 + length l
346-
347-
-- encodeTree :: Expr -> [Int]
348-
-- encodeTree e = concatMap f $ 0 : toArr 4 e where
349-
-- f n | n < 4 = [n, 0, 0, 0]
350-
-- | otherwise = toU32 $ (n - 3) * 4
351-
352-
-- toU32 :: Int -> [Int]
353-
-- toU32 = take 4 . byteMe
354-
355-
-- byteMe :: Integral t => t -> [t]
356-
-- byteMe n | n < 256 = n : repeat 0
357-
-- | otherwise = n `mod` 256 : byteMe (n `div` 256)
358-
359-
360-
-- run :: Num p => I.IntMap Int -> [Int] -> p
361-
-- run m (p:sp) = case p of
362-
-- 0 -> 0
363-
-- 1 -> 1 + run m (arg 0 : sp)
364-
-- 2 -> run m $ arg 0 : drop 2 sp
365-
-- 3 -> run m' $ hp:drop 2 sp where
366-
-- m' = insList m $
367-
-- zip [hp..] (concatMap toU32 [arg 0, arg 2, arg 1, arg 2]) ++
368-
-- zip [sp!!2..] (concatMap toU32 [hp, hp + 8])
369-
-- hp = I.size m
370-
-- _ -> run m $ get p:p:sp
371-
-- where
372-
-- arg k = get (sp!!k + 4)
373-
-- get n = sum $ zipWith (*) ((m I.!) <$> [n..n+3]) ((256^) <$> [0..3])
374-
-- insList = foldr (\(k, a) m -> I.insert k a m)
375-
376-
377-
--skRepl :: InputT IO ()
378-
--skRepl = do
379-
-- ms <- getInputLine "> "
380-
-- case ms of
381-
-- Nothing -> outputStrLn ""
382-
-- Just s -> do
383-
-- let Right e = parse expr "" s
384-
-- outputStrLn $ show $ encodeTree e
385-
-- --outputStrLn $ show $ compile $ encodeTree e
386-
-- outputStrLn $ show $ run (I.fromAscList $ zip [0..] $ encodeTree e) [4]
387-
-- skRepl
388397

389398

0 commit comments

Comments
 (0)