mirror of
https://github.com/unisonweb/unison.git
synced 2024-09-20 06:47:15 +03:00
Merge pull request #246 from unisonweb/topic/broken-continuations
Topic/broken continuations
This commit is contained in:
commit
493c052b18
@ -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)
|
||||
|
||||
|
@ -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
|
||||
|
@ -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 =
|
||||
|
@ -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))) }
|
||||
|
||||
}
|
||||
|
||||
|
@ -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,
|
||||
|
@ -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
|
||||
|
||||
}
|
||||
}
|
||||
}
|
||||
|
@ -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,
|
||||
|
14
unison-src/tests/state2b-min.u
Normal file
14
unison-src/tests/state2b-min.u
Normal file
@ -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
|
25
unison-src/tests/state4.u
Normal file
25
unison-src/tests/state4.u
Normal file
@ -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
|
Loading…
Reference in New Issue
Block a user