Merge pull request #246 from unisonweb/topic/broken-continuations

Topic/broken continuations

parser-typechecker/src/Unison/TermParser.hs

@@ -18,7 +18,7 @@ import           Data.Foldable (asum)
 import           Data.Int (Int64)
 import           Data.List (elem)
 import qualified Data.Map as Map
-import           Data.Maybe (isJust)
+import           Data.Maybe (isJust, fromMaybe)
 import           Data.Word (Word64)
 import           Prelude hiding (and, or)
 import qualified Text.Megaparsec as P
@@ -350,16 +350,23 @@ block' s openBlock closeBlock = do
                 ( (Binding <$> binding) <|>
                   (Action <$> blockTerm) <|>
                   namespaceBlock )
-    toBindings (Binding ((a, v), e)) = [((a, v), e)]
-    toBindings (Action e) = [((ann e, Var.named "_"), e)]
+    toBindings (Binding ((a, v), e)) = [((a, Just v), e)]
+    toBindings (Action e) = [((ann e, Nothing), e)]
     toBindings (Namespace name bs) = scope name $ (toBindings =<< bs)
-    scope :: String -> [((Ann, v), AnnotatedTerm v Ann)]
-                    -> [((Ann, v), AnnotatedTerm v Ann)]
+    v `orBlank` i = fromMaybe (Var.nameds $ "_" ++ show i) v
+    finishBindings bs =
+      [((a, v `orBlank` i), e) | (((a,v), e), i) <- bs `zip` [(1::Int)..]]
+
+    scope :: String -> [((Ann, Maybe v), AnnotatedTerm v Ann)]
+                    -> [((Ann, Maybe v), AnnotatedTerm v Ann)]
     scope name bs =
-      let vs = (snd . fst) <$> bs
+      let vs :: [Maybe v]
+          vs = (snd . fst) <$> bs
+          prefix :: v -> v
           prefix v = Var.named (Text.pack name `mappend` "." `mappend` Var.name v)
-          vs' = prefix <$> vs
-          substs = [ (v, Term.var () v') | (v,v') <- vs `zip` vs' ]
+          vs' :: [Maybe v]
+          vs' = fmap prefix <$> vs
+          substs = [ (v, Term.var () v') | (Just v, Just v') <- vs `zip` vs' ]
           sub e = ABT.substsInheritAnnotation substs e
       in [ ((a, v'), sub e) | (((a,_),e), v') <- bs `zip` vs' ]
 
@@ -378,7 +385,7 @@ block' s openBlock closeBlock = do
                             (a <> ann annotatedTerm)
         Action e : es ->
           pure $ Term.letRec (startAnnotation <> ann e)
-                             (toBindings =<< reverse es)
+                             (finishBindings $ toBindings =<< reverse es)
                              e
         [] -> customFailure $ EmptyBlock (const s <$> open)
 

parser-typechecker/src/Unison/Typechecker/Components.hs

@@ -43,14 +43,16 @@ components = components' ABT.freeVars
 components' :: Var v => (t -> Set v) -> [(v, t)] -> [[(v, t)]]
 components' freeVars bs =
   let
-    varIds = Map.fromList (map fst bs `zip` [(0::Int)..])
+    varIds = Map.fromList (map fst bs `zip` reverse [(1::Int) .. length bs])
     varId v = fromJust $ Map.lookup v varIds -- something horribly wrong if this bombs
     -- use ints as keys for graph to preserve original source order as much as possible
     graph = [ ((v,b), varId v, deps b) | (v,b) <- bs ]
     vars = Set.fromList (map fst bs)
     deps b = varId <$> Set.toList (Set.intersection vars (freeVars b))
   in
-    Graph.flattenSCC <$> Graph.stronglyConnComp graph
+    if Map.size varIds /= length bs then
+      error $ "duplicate names in components: " ++ show (fst <$> bs)
+    else Graph.flattenSCC <$> Graph.stronglyConnComp graph
 
 -- | Algorithm for minimizing cycles of a `let rec`. This can
 -- improve generalization during typechecking and may also be more

runtime-jvm/main/src/main/scala/Param.scala

@@ -92,13 +92,16 @@ object Value {
           }
         case _ =>
           (r, rec, top, stackU, x1, x0, stackB, x1b, x0b) => {
-            val v = evalLam(f,r,top,stackU,x1,x0,stackB,x1b,x0b)
+            val v =
+              try evalLam(f,r,top,stackU,x1,x0,stackB,x1b,x0b)
+              catch { case Requested(effect, ctor, args, k) =>
+                throw Requested(effect, ctor, args, self compose k)
+              }
             val vb = r.boxed
             self(r,top,stackU,U0,v,stackB,null,vb)
           }
       }
-      val compose = Term.Lam('f, 'g, 'x)('f.v('g.v('x))) // todo: intern this
-      new Lambda(f.names, k, compose(self.decompile, f.decompile))
+      new Lambda(f.names, k, Term.compose(self.decompile, f.decompile))
     }
 
     def saturatedNonTailCall(args: List[Computation]): Computation =

runtime-jvm/main/src/main/scala/Term.scala

@@ -48,25 +48,29 @@ object Term {
     // arg1 -> foo (x + 1) blah
     // arg1 -> let arg1 = x + 1; foo arg1 blah
     case ABT.Abs(name, body) => ABT.Abs(name, ANF(body))
-    case Apply(f @ (ABT.Var(_) | Lam(_,_) | Id(_) |
+    // This is the case where the function is already in ANF, but the
+    // arguments may not be yet
+    case ApplyNested(f @ (ABT.Var(_) | Lam(_,_) | Id(_) |
                     Constructor(_,_) | Request(_,_)), args) =>
       val (bindings2, args2) =
-        args.zipWithIndex.foldRight((List.empty[(Name,Term)], List.empty[Term])) { (argi, accs) =>
-          val (bindings, args) = accs
-          val (arg, i) = argi
+        args.zipWithIndex.foldRight((List.empty[(Name,Term)], List.empty[Term])) {
+          case ((arg, i), (bindings, args)) =>
           arg match {
-            case Unboxed(_,_) => (bindings, arg :: args)
-            case ABT.Var(_) => (bindings, arg :: args)
-            case lam @ Lam(_, _) /* if freeVars(lam).isEmpty */ => (bindings, arg :: args)
-            case arg =>
+            // don't need to introduce a new binding for these simple cases
+            case Unboxed(_,_) | ABT.Var(_) |
+                 Lam(_, _) | Id(_) | Constructor(_,_) => (bindings, arg :: args)
+            case arg => //
               val freshName = freshen(Name(s"arg$i"), arg)
-              ((freshName, arg) :: bindings, Var(freshName) :: args)
+              ((freshName, ANF(arg)) :: bindings, Var(freshName) :: args)
           }
         }
       Let(bindings2: _*)(Apply(f, args2: _*))
+    // If the above falls through, then the function is not yet in ANF,
+    // so we convert it to ANF and then make a recursive call to convert
+    // its args
     case Apply(f, args) =>
       val freshName = freshen(Name("f"), f)
-      Let(freshName -> f)(ANF(Apply(Var(freshName), args: _*)))
+      Let(freshName -> ANF(f))(ANF(Apply(Var(freshName), args: _*)))
     case ABT.Tm(other) => ABT.Tm(F.instance.map(other)(ANF))
   }
 
@@ -363,6 +367,13 @@ object Term {
       if (args.isEmpty) f
       else Tm(Apply_(f, args.toList))
   }
+  object ApplyNested {
+    def unapply[A](t: AnnotatedTerm[F,A]): Option[(AnnotatedTerm[F,A], List[AnnotatedTerm[F,A]])] = t match {
+      case Apply(ApplyNested(f, args1), args2) => Some((f, args1 ++ args2))
+      case Apply(f, args) => Some((f, args))
+      case _ => None
+    }
+  }
 
   object Var {
     def apply(n: Name): Term = ABT.Var(n)
@@ -511,5 +522,8 @@ object Term {
     implicit def stringKeyToNameTerm[A <% Term](kv: (String, A)): (Name, Term) = (kv._1, kv._2)
     implicit def symbolKeyToNameTerm[A <% Term](kv: (Symbol, A)): (Name, Term) = (kv._1, kv._2)
   }
+
+  val compose = { import Syntax._; Term.Lam('f, 'g, 'x)('f.v('g.v('x))) }
+
 }
 

runtime-jvm/main/src/main/scala/compilation.scala

@@ -941,8 +941,7 @@ package object compilation {
   }
 
   def normalize(builtins: Environment)(e: Term, fullyDecompile: Boolean = true): Term = {
-    val anf = Term.ANF(e)
-    val c = compileTop(builtins)(anf)
+    val c = compileTop(builtins)(e)
     val v = run(c)
     val x = Term.etaNormalForm(v.decompile)
     if (fullyDecompile) Term.fullyDecompile(x)
@@ -963,7 +962,7 @@ package object compilation {
       sys.error("Can't compile top-level term with free variables "
                 + Term.freeVars(e).mkString(", "))
     else
-      compile(builtins)(e, Vector(), CurrentRec.none, RecursiveVars.empty, IsTail)
+      compile(builtins)(Term.ANF(e), Vector(), CurrentRec.none, RecursiveVars.empty, IsTail)
 
   def compile(builtins: Environment)(
     e: Term,

runtime-jvm/main/src/main/scala/util/PrettyPrint.scala

@@ -210,9 +210,9 @@ object PrettyPrint {
         prettyTerm(arg1, 5) <> " " <> infixName(name) <> softbreak <> prettyTerm(arg2, 6).nest("  ")
     }
     case Tuple(args) => "(" <> commas(args.map(prettyTerm)) <> ")"
-    case Term.Apply(Term.Constructor(BuiltinTypes.Tuple.Id, BuiltinTypes.Tuple.cid), args) =>
+    case Term.ApplyNested(Term.Constructor(BuiltinTypes.Tuple.Id, BuiltinTypes.Tuple.cid), args) =>
       "(" <> commas(args.map(prettyTerm)) <> ")"
-    case Term.Apply(f, args) => parenthesizeGroupIf(precedence > 9) {
+    case Term.ApplyNested(f, args) => parenthesizeGroupIf(precedence > 9) {
       prettyTerm(f, 9) <> softbreak <>
         softbreaks(args.map(arg => prettyTerm(arg, 10).nest("  ")))
     }
@@ -260,23 +260,21 @@ object PrettyPrint {
     def unapply(term: Term): Option[Seq[Term]] = {
       val B = BuiltinTypes
 
-      def go(t: Term, elements: Seq[Term]): Seq[Term] = {
+      def go(t: Term, elements: Seq[Term]): Option[Seq[Term]] = {
         t match {
           case Term.Apply(Term.Constructor(B.Tuple.Id, B.Tuple.cid), args) =>
             args match {
               case element :: term :: Nil => go(term, elements :+ element)
-              case other => throw new Exception(s"tuple wasn't a cons, it was ${args.size} elements:\n  $other\n in $term")
+              case other => None
             }
-
-          case B.Unit.term => elements
+          case B.Unit.term => Some(elements)
+          case _ => None
         }
       }
       term match {
         case Term.Apply(Term.Constructor(B.Tuple.Id, B.Tuple.cid), args) =>
-          Some(go(term, Seq.empty))
-
+          go(term, Seq.empty)
         case _ => None
-
       }
     }
   }

runtime-jvm/main/src/test/scala/FileCompilationTests.scala

@@ -14,6 +14,8 @@ object FileCompilationTests {
   val checkResultTests = Map[String, Term](
     "fib4" -> 2249999.u,
     "tuple" -> ((3.u, 7.u)),
+    "state4" -> 15.u,
+    "state2b-min" -> 20.u,
     "stream-shouldnt-damage-stack" -> ((4950.u, 9999.u)),
     "stream/iterate-increment-take-drop-reduce" ->
       scala.Stream.from(0).take(5).drop(3).sum,

unison-src/tests/state2b-min.u

@@ -0,0 +1,14 @@
+--State2 effect
+effect State s where
+  put : s -> {State s} ()
+
+state : s -> Effect (State s) a -> s
+state s eff = case eff of
+  { State.put snew -> k } -> handle (state snew) in k ()
+  { a } -> s
+
+handle (state 10) in
+  State.put (11 + 1)
+  State.put (5 + 15)
+  ()
+  -- should be 20

unison-src/tests/state4.u

@@ -0,0 +1,25 @@
+effect State s where
+  put : s -> {State s} ()
+  get : {State s} s
+
+state : s -> Effect (State s) a -> s
+state s eff = case eff of
+  { State.get -> k } -> handle (state s) in k s
+  { State.put snew -> k } -> handle (state snew) in k ()
+  { a } -> s
+
+modify : (s -> s) -> {State s} ()
+modify f = State.put (f State.get)
+
+increment : '{State UInt64} ()
+increment = '(modify ((+) 1))
+
+ex : UInt64
+ex = handle (state 10) in
+  State.put (11 + 1)
+  !increment
+  !increment
+  !increment
+  State.get -- should be 15, amirite??
+
+ex