Fix quadratic performance bug in interpreter, added simple test of indexed traversal

shared/src/Unison/Eval/Interpreter.hs

@@ -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

shared/src/Unison/Node/Builtin.hs

@@ -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")
 

shared/src/Unison/Remote.hs

@@ -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)

shared/src/Unison/Term.hs

@@ -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

unison-src/indexed-traversal.u

@@ -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);;