mirror of
https://github.com/unisonweb/unison.git
synced 2024-09-11 02:25:39 +03:00
Fix quadratic performance bug in interpreter, added simple test of indexed traversal
This commit is contained in:
parent
45a4274d22
commit
d18364fa84
@ -1,9 +1,12 @@
|
||||
{-# LANGUAGE PatternSynonyms #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE BangPatterns #-}
|
||||
|
||||
-- | Very simple and inefficient interpreter of Unison terms
|
||||
module Unison.Eval.Interpreter where
|
||||
|
||||
import Data.Map (Map)
|
||||
import Data.List
|
||||
import Debug.Trace
|
||||
import Unison.Eval
|
||||
import Unison.Term (Term)
|
||||
@ -26,13 +29,13 @@ eval :: forall f v . (Monad f, Var v) => Map R.Reference (Primop f v) -> Eval f
|
||||
eval env = Eval whnf step
|
||||
where
|
||||
-- reduce x args | trace ("reduce:" ++ show (x:args)) False = undefined
|
||||
reduce resolveRef (E.Ann' e _) args = reduce resolveRef e args
|
||||
reduce resolveRef (E.App' f x) args = do
|
||||
x <- whnf resolveRef x
|
||||
reduce resolveRef f (x:args)
|
||||
reduce resolveRef (E.Let1' binding body) xs = do
|
||||
binding <- whnf resolveRef binding
|
||||
reduce resolveRef (ABT.bind body binding) xs
|
||||
reduce resolveRef (E.Ann' e _) args = reduce resolveRef e args
|
||||
reduce resolveRef f args = do
|
||||
f <- whnf resolveRef f
|
||||
case f of
|
||||
@ -45,25 +48,29 @@ eval env = Eval whnf step
|
||||
_ -> pure Nothing
|
||||
_ -> pure Nothing
|
||||
E.Ref' h -> case M.lookup h env of
|
||||
Nothing -> pure Nothing
|
||||
Nothing -> case h of
|
||||
R.Derived h -> do
|
||||
r <- resolveRef h
|
||||
r <- whnf resolveRef r
|
||||
reduce resolveRef r args
|
||||
R.Builtin b -> pure Nothing
|
||||
Just op | length args >= arity op ->
|
||||
call op (take (arity op) args) >>= \e ->
|
||||
pure . Just $ foldl E.app e (drop (arity op) args)
|
||||
Just _ | otherwise -> pure Nothing
|
||||
E.Lam' f -> case args of
|
||||
E.LamsNamed' vs body -> let n = length vs in case args of
|
||||
[] -> pure Nothing
|
||||
(arg1:args) ->
|
||||
let r = ABT.bind f arg1
|
||||
in pure $ Just (foldl E.app r args)
|
||||
args | length args >= n -> pure $ Just (foldl' E.app (ABT.substs (vs `zip` args) body) (drop n args))
|
||||
| otherwise -> pure Nothing
|
||||
_ -> pure Nothing
|
||||
|
||||
step resolveRef e = case e of
|
||||
E.Ann' e _ -> step resolveRef e
|
||||
E.Ref' h -> case M.lookup h env of
|
||||
Just op | arity op == 0 -> call op []
|
||||
_ -> pure e
|
||||
E.App' f x -> do
|
||||
f <- E.link resolveRef f
|
||||
e' <- reduce resolveRef f [x]
|
||||
E.Apps' f xs -> do
|
||||
e' <- reduce resolveRef f xs
|
||||
maybe (pure e) pure e'
|
||||
E.Let1' binding body -> step resolveRef (ABT.bind body binding)
|
||||
E.LetRecNamed' bs body -> step resolveRef (ABT.substs substs body) where
|
||||
@ -76,7 +83,12 @@ eval env = Eval whnf step
|
||||
whnf resolveRef e = case e of
|
||||
E.Ref' h -> case M.lookup h env of
|
||||
Just op | arity op == 0 -> call op []
|
||||
_ -> pure e
|
||||
| otherwise -> pure e
|
||||
Nothing -> case h of
|
||||
R.Derived h -> do
|
||||
r <- resolveRef h
|
||||
whnf resolveRef r
|
||||
R.Builtin b -> pure e
|
||||
E.Ann' e _ -> whnf resolveRef e
|
||||
E.Apps' E.If' (cond:t:f:tl) -> do
|
||||
cond <- whnf resolveRef cond
|
||||
@ -85,9 +97,8 @@ eval env = Eval whnf step
|
||||
| otherwise -> whnf resolveRef t >>= \t -> (`E.apps` tl) <$> whnf resolveRef t
|
||||
_ -> pure e
|
||||
E.Apps' f xs -> do
|
||||
f' <- E.link resolveRef f
|
||||
f <- whnf resolveRef f'
|
||||
xs <- traverse (whnf resolveRef) xs
|
||||
f <- whnf resolveRef f
|
||||
e' <- reduce resolveRef f xs
|
||||
maybe (pure $ f `E.apps` xs) (whnf resolveRef) e'
|
||||
E.Let1' binding body -> do
|
||||
@ -97,4 +108,5 @@ eval env = Eval whnf step
|
||||
bs' = [ (v, expandBinding v b) | (v,b) <- bs ]
|
||||
expandBinding v (E.LamNamed' name body) = E.lam name (expandBinding v body)
|
||||
expandBinding v body = E.letRec bs body
|
||||
E.Vector' es -> E.vector' <$> traverse (whnf resolveRef) es
|
||||
_ -> pure e
|
||||
|
@ -297,7 +297,7 @@ makeBuiltins logger whnf =
|
||||
op [fz,f,o] = whnf o >>= \o -> case o of
|
||||
Term.Builtin' tag | tag == "Optional.None" -> whnf fz
|
||||
Term.App' (Term.Builtin' tag) a | tag == "Optional.Some" -> whnf (f `Term.app` a)
|
||||
_ -> error "Optional.fold unpossible"
|
||||
_ -> error $ "Optional.fold unpossible: " ++ show o
|
||||
op _ = error "Optional.fold unpossible"
|
||||
in (r, Just (I.Primop 3 op), unsafeParseType "forall a r . r -> (a -> r) -> Optional a -> r", prefix "Optional.fold")
|
||||
|
||||
|
@ -123,7 +123,8 @@ instance Hashable1 Local where
|
||||
Receive c -> [tag 4, H.accumulateToken c]
|
||||
Send c t -> [tag 5, H.accumulateToken c, hashed t]
|
||||
Spawn -> [tag 6]
|
||||
Pure t -> [tag 7, hashed t]
|
||||
Sleep (Seconds d) -> [tag 7, H.Double d]
|
||||
Pure t -> [tag 8, hashed t]
|
||||
where
|
||||
tag = H.Tag
|
||||
hashed1 = H.Hashed . (H.hash1 hashCycle hash)
|
||||
|
@ -262,6 +262,14 @@ unApps t = case go t [] of [] -> Nothing; f:args -> Just (f,args)
|
||||
go _ [] = []
|
||||
go fn args = fn:args
|
||||
|
||||
pattern LamsNamed' vs body <- (unLams' -> Just (vs, body))
|
||||
|
||||
unLams' :: Term v -> Maybe ([v], Term v)
|
||||
unLams' (LamNamed' v body) = case unLams' body of
|
||||
Nothing -> Just ([v], body)
|
||||
Just (vs, body) -> Just (v:vs, body)
|
||||
unLams' _ = Nothing
|
||||
|
||||
dependencies' :: Ord v => Term v -> Set Reference
|
||||
dependencies' t = Set.fromList . Writer.execWriter $ ABT.visit' f t
|
||||
where f t@(Ref r) = Writer.tell [r] *> pure t
|
||||
@ -275,15 +283,6 @@ countBlanks t = Monoid.getSum . Writer.execWriter $ ABT.visit' f t
|
||||
where f Blank = Writer.tell (Monoid.Sum (1 :: Int)) *> pure Blank
|
||||
f t = pure t
|
||||
|
||||
-- | Convert all 'Ref' constructors to the corresponding term
|
||||
link :: (Applicative f, Monad f, Var v) => (Hash -> f (Term v)) -> Term v -> f (Term v)
|
||||
link env e =
|
||||
let ds = map (\h -> (h, link env =<< env h)) (Set.toList (dependencies e))
|
||||
sub e (h, ft) = replace <$> ft
|
||||
where replace t = ABT.replace ((==) rt) t e
|
||||
rt = ref (Reference.Derived h)
|
||||
in foldM sub e ds
|
||||
|
||||
-- | If the outermost term is a function application,
|
||||
-- perform substitution of the argument into the body
|
||||
betaReduce :: Var v => Term v -> Term v
|
||||
|
13
unison-src/indexed-traversal.u
Normal file
13
unison-src/indexed-traversal.u
Normal file
@ -0,0 +1,13 @@
|
||||
|
||||
do Remote
|
||||
n := Remote.spawn;
|
||||
Remote.transfer n;
|
||||
ind1 := Index.empty;
|
||||
ind2 := Index.empty;
|
||||
Index.inserts [(1,"a"), (3,"b"), (9,"c")] ind1;
|
||||
t1 = Index.traversal ind1;
|
||||
Index.inserts [(3,"a"), (4,"b"), (9,"c"), (10, "d")] ind2;
|
||||
t2 = Index.traversal ind2;
|
||||
t3 = IndexedTraversal.intersect (Order.by-2nd Hash.Order) t1 t2;
|
||||
vs := IndexedTraversal.take 10 t3;
|
||||
pure (Debug.watch "result" vs);;
|
Loading…
Reference in New Issue
Block a user