From 0f7240a0acfa7446366249398e46237fe0e6e1eb Mon Sep 17 00:00:00 2001 From: =?utf8?q?Hannu=20Niemist=C3=B6?= Date: Wed, 20 Sep 2017 18:29:53 +0300 Subject: [PATCH] (refs #7498) Bugfixing implementation of skeleton refs Change-Id: If396a5e40fdcb08ce0911115ac44fb516fc2bea7 --- .../elaboration/contexts/TypingContext.java | 17 ++- .../elaboration/expressions/EAmbiguous.java | 7 +- .../scl/compiler/types/Skeletons.java | 2 +- .../scl/compiler/types/TMetaVar.java | 103 ++++++++++++++++-- .../compiler/tests/ModuleRegressionTests.java | 1 + .../tests/scl/FoldMissingInitialValue.scl | 2 +- .../tests/scl/PolymorphicRecursion.scl | 3 +- .../scl/compiler/tests/scl/Record3.scl | 14 +++ .../compiler/tests/scl/TypeInferenceBug2.scl | 4 +- 9 files changed, 135 insertions(+), 18 deletions(-) create mode 100644 tests/org.simantics.scl.compiler.tests/src/org/simantics/scl/compiler/tests/scl/Record3.scl diff --git a/bundles/org.simantics.scl.compiler/src/org/simantics/scl/compiler/elaboration/contexts/TypingContext.java b/bundles/org.simantics.scl.compiler/src/org/simantics/scl/compiler/elaboration/contexts/TypingContext.java index ac004eab6..410ec0213 100644 --- a/bundles/org.simantics.scl.compiler/src/org/simantics/scl/compiler/elaboration/contexts/TypingContext.java +++ b/bundles/org.simantics.scl.compiler/src/org/simantics/scl/compiler/elaboration/contexts/TypingContext.java @@ -22,6 +22,7 @@ import org.simantics.scl.compiler.internal.elaboration.constraints.ExpressionAug import org.simantics.scl.compiler.internal.elaboration.constraints.ReducedConstraints; import org.simantics.scl.compiler.internal.elaboration.subsumption.SubSolver; import org.simantics.scl.compiler.internal.elaboration.subsumption.Subsumption; +import org.simantics.scl.compiler.types.Skeletons; import org.simantics.scl.compiler.types.TApply; import org.simantics.scl.compiler.types.TCon; import org.simantics.scl.compiler.types.TForAll; @@ -116,8 +117,10 @@ public class TypingContext { if(a instanceof TMetaVar) { TMetaVar aVar = (TMetaVar)a; - if(b instanceof TMetaVar) + if(b instanceof TMetaVar) { + Skeletons.unifySkeletons(a, b); subsumptions.add(new Subsumption(loc, a, b)); + } else { if(b.contains(aVar)) throw new UnificationException(a, b); @@ -182,6 +185,11 @@ public class TypingContext { else if(type instanceof TMetaVar) { TMetaVar var = (TMetaVar)type; TMetaVar newVar = Types.metaVar(var.getKind()); + try { + newVar.setSkeletonRef(var); + } catch (UnificationException e) { + throw new InternalCompilerError(loc, e); + } subsumptions.add(new Subsumption(loc, newVar, var)); return newVar; } @@ -232,6 +240,11 @@ public class TypingContext { else if(type instanceof TMetaVar) { TMetaVar var = (TMetaVar)type; TMetaVar newVar = Types.metaVar(var.getKind()); + try { + newVar.setSkeletonRef(var); + } catch (UnificationException e) { + throw new InternalCompilerError(loc, e); + } subsumptions.add(new Subsumption(loc, var, newVar)); return newVar; } @@ -372,7 +385,7 @@ public class TypingContext { Types.unify(sub.a, sub.b); } catch (UnificationException e) { // Should not happen. Both types should be metavars. - throw new InternalCompilerError(); + throw new InternalCompilerError(e); } subsumptions.clear(); return true; diff --git a/bundles/org.simantics.scl.compiler/src/org/simantics/scl/compiler/elaboration/expressions/EAmbiguous.java b/bundles/org.simantics.scl.compiler/src/org/simantics/scl/compiler/elaboration/expressions/EAmbiguous.java index 09397ba05..1d17281dd 100644 --- a/bundles/org.simantics.scl.compiler/src/org/simantics/scl/compiler/elaboration/expressions/EAmbiguous.java +++ b/bundles/org.simantics.scl.compiler/src/org/simantics/scl/compiler/elaboration/expressions/EAmbiguous.java @@ -177,14 +177,19 @@ public class EAmbiguous extends SimplifiableExpression { if(resolvedExpression != null) return resolvedExpression; else { + if(DEBUG) + System.out.println("EAmbigious.simplify: error"); context.getErrorLog().log(location, getAmbiguousDescription(getType())); return this; } } public void assertResolved(ErrorLog errorLog) { - if(resolvedExpression == null) + if(resolvedExpression == null) { + if(DEBUG) + System.out.println("EAmbigious.assertResolved: error"); errorLog.log(location, getAmbiguousDescription(getType())); + } } @Override diff --git a/bundles/org.simantics.scl.compiler/src/org/simantics/scl/compiler/types/Skeletons.java b/bundles/org.simantics.scl.compiler/src/org/simantics/scl/compiler/types/Skeletons.java index b7266ef7e..2b99c28a6 100644 --- a/bundles/org.simantics.scl.compiler/src/org/simantics/scl/compiler/types/Skeletons.java +++ b/bundles/org.simantics.scl.compiler/src/org/simantics/scl/compiler/types/Skeletons.java @@ -17,7 +17,7 @@ public class Skeletons { if(metaVar.ref != null) type = metaVar.ref; else if(metaVar.skeletonRef != null) - type = metaVar.skeletonRef; + return metaVar.skeletonRef = canonicalSkeleton(metaVar.skeletonRef); else return metaVar; } diff --git a/bundles/org.simantics.scl.compiler/src/org/simantics/scl/compiler/types/TMetaVar.java b/bundles/org.simantics.scl.compiler/src/org/simantics/scl/compiler/types/TMetaVar.java index d78d745eb..00b289f46 100644 --- a/bundles/org.simantics.scl.compiler/src/org/simantics/scl/compiler/types/TMetaVar.java +++ b/bundles/org.simantics.scl.compiler/src/org/simantics/scl/compiler/types/TMetaVar.java @@ -2,6 +2,7 @@ package org.simantics.scl.compiler.types; import java.util.ArrayList; +import org.simantics.databoard.util.IdentityHashSet; import org.simantics.scl.compiler.common.exceptions.InternalCompilerError; import org.simantics.scl.compiler.environment.Environment; import org.simantics.scl.compiler.internal.types.HashCodeUtils; @@ -134,27 +135,112 @@ public class TMetaVar extends Type { } public void setRef(Type type) throws UnificationException { - if(type instanceof TMetaVar && ((TMetaVar)type).ref != null) - throw new InternalCompilerError("Not canonical!"); + //System.out.println("----"); + //System.out.println("this = " + refStructure(this)); + //System.out.println("type = " + refStructure(type)); if(type == this) throw new InternalCompilerError("Illegal setRef"); if(DEBUG) System.out.println("setRef " + System.identityHashCode(this) + " -> " + type); if(ref != null) throw new InternalCompilerError("Method setRef should be called only for unbound meta variables."); - if(type.contains(this)) + Type thisSkeleton = Skeletons.canonicalSkeleton(this); + + if(type instanceof TMetaVar) { + TMetaVar other = (TMetaVar)type; + if(other.ref != null) + throw new InternalCompilerError("Not canonical!"); + + Type typeSkeleton = Skeletons.canonicalSkeleton(type); + if(thisSkeleton == typeSkeleton) { + if(skeletonRef != null) + setRefBase(type); + else + other.setRefBase(this); + return; + } + else if(thisSkeleton instanceof TMetaVar && type.contains((TMetaVar)thisSkeleton)) + throw new UnificationException(this, type); + } + else if(thisSkeleton instanceof TMetaVar && type.contains((TMetaVar)thisSkeleton)) throw new UnificationException(this, type); + + // Common case + if(skeletonRef != null) { + Skeletons.unifySkeletons(thisSkeleton, type); + } + setRefBase(type); + } + + private void setRefBase(Type type) throws UnificationException { + skeletonRef = null; ref = type; if(polarity != Polarity.NO_POLARITY) type.addPolarity(polarity); - if(skeletonRef != null) { - Type skeleton = skeletonRef; - skeletonRef = null; - Skeletons.unifySkeletons(skeleton, type); - } + //System.out.println("result = " + refStructure(this)); + //checkRefLoop(this); fireNotifyAboutChange(); } + private static String refStructure(Type t) { + StringBuilder b = new StringBuilder(); + IdentityHashSet seenVars = new IdentityHashSet(); + refType(b, t, seenVars); + return b.toString(); + } + + private void refStructure(StringBuilder b, IdentityHashSet seenVars) { + b.append(System.identityHashCode(this)); + if(!seenVars.add(this)) + b.append(" (loop)"); + else if(ref != null) { + b.append(" => "); + refType(b, ref, seenVars); + } + else if(skeletonRef != null) { + b.append(" -> "); + refType(b, skeletonRef, seenVars); + } + else + b.append(" (canonical)"); + } + + private static void refType(StringBuilder b, Type t, IdentityHashSet seenVars) { + if(t instanceof TMetaVar) + ((TMetaVar)t).refStructure(b, seenVars); + else { + b.append('['); + t.toString(new TypeUnparsingContext(), b); + b.append(']'); + } + } + + private void checkRefLoop(TMetaVar var) { + IdentityHashSet seenVars = new IdentityHashSet(); + StringBuilder b = new StringBuilder(); + while(true) { + b.append(var); + if(!seenVars.add(var)) + throw new InternalCompilerError("Cyclic meta var references: " + b); + if(var.ref != null) { + b.append(" => "); + if(var.ref instanceof TMetaVar) + var = (TMetaVar)var.ref; + else + return; + } + else if(var.skeletonRef != null) { + b.append(" -> "); + if(var.skeletonRef instanceof TMetaVar) + var = (TMetaVar)var.skeletonRef; + else + return; + } + else + return; + } + } + public Type getRef() { return ref; } @@ -273,6 +359,7 @@ public class TMetaVar extends Type { if(type.contains(this)) throw new UnificationException(this, type); this.skeletonRef = type; + //checkRefLoop(this); fireNotifyAboutChange(); } diff --git a/tests/org.simantics.scl.compiler.tests/src/org/simantics/scl/compiler/tests/ModuleRegressionTests.java b/tests/org.simantics.scl.compiler.tests/src/org/simantics/scl/compiler/tests/ModuleRegressionTests.java index 275bba86e..9eb49d2f7 100644 --- a/tests/org.simantics.scl.compiler.tests/src/org/simantics/scl/compiler/tests/ModuleRegressionTests.java +++ b/tests/org.simantics.scl.compiler.tests/src/org/simantics/scl/compiler/tests/ModuleRegressionTests.java @@ -208,6 +208,7 @@ public class ModuleRegressionTests extends TestBase { @Test public void RangeSyntax() { test(); } @Test public void Record1() { test(); } @Test public void Record2() { test(); } + @Test public void Record3() { test(); } @Test public void RecordShorthand() { test(); } @Test public void RecursionBug() { test(); } @Test public void RecursiveContext() { test(); } diff --git a/tests/org.simantics.scl.compiler.tests/src/org/simantics/scl/compiler/tests/scl/FoldMissingInitialValue.scl b/tests/org.simantics.scl.compiler.tests/src/org/simantics/scl/compiler/tests/scl/FoldMissingInitialValue.scl index 5d68c4c06..d188d8f9a 100644 --- a/tests/org.simantics.scl.compiler.tests/src/org/simantics/scl/compiler/tests/scl/FoldMissingInitialValue.scl +++ b/tests/org.simantics.scl.compiler.tests/src/org/simantics/scl/compiler/tests/scl/FoldMissingInitialValue.scl @@ -2,4 +2,4 @@ import "Prelude" f p l = (foldl (+) (map ((+)p) l)) + p -- -3:25-3:31: Type [a b] -> a b is not a subtype of a. \ No newline at end of file +3:38-3:39: Expected <[a] -> b c> got . \ No newline at end of file diff --git a/tests/org.simantics.scl.compiler.tests/src/org/simantics/scl/compiler/tests/scl/PolymorphicRecursion.scl b/tests/org.simantics.scl.compiler.tests/src/org/simantics/scl/compiler/tests/scl/PolymorphicRecursion.scl index b37ff0283..ba5df53f4 100644 --- a/tests/org.simantics.scl.compiler.tests/src/org/simantics/scl/compiler/tests/scl/PolymorphicRecursion.scl +++ b/tests/org.simantics.scl.compiler.tests/src/org/simantics/scl/compiler/tests/scl/PolymorphicRecursion.scl @@ -11,6 +11,5 @@ cons x (Zero ps) = One x ps cons x (One y ps) = Zero (cons (x, y) ps) -- 11:21-11:42: Expected got . -11:33-11:34: Type (a, a) is not a subtype of a. -11:36-11:37: Type (a, a) is not a subtype of a. +11:32-11:38: Expected got <(b, c)>. 11:39-11:41: Expected got . \ No newline at end of file diff --git a/tests/org.simantics.scl.compiler.tests/src/org/simantics/scl/compiler/tests/scl/Record3.scl b/tests/org.simantics.scl.compiler.tests/src/org/simantics/scl/compiler/tests/scl/Record3.scl new file mode 100644 index 000000000..3e14cf762 --- /dev/null +++ b/tests/org.simantics.scl.compiler.tests/src/org/simantics/scl/compiler/tests/scl/Record3.scl @@ -0,0 +1,14 @@ +module { + features = [fields] +} + +import "Prelude" + +data Foo = Foo { x :: Double } +data Bar = Bar { x :: Double, y :: Double } + +main = sum $ map (\v -> v.x) l + where + l = [Foo 1.0, Foo 2.0] +-- +3.0 \ No newline at end of file diff --git a/tests/org.simantics.scl.compiler.tests/src/org/simantics/scl/compiler/tests/scl/TypeInferenceBug2.scl b/tests/org.simantics.scl.compiler.tests/src/org/simantics/scl/compiler/tests/scl/TypeInferenceBug2.scl index d224b3da6..e8c80551f 100644 --- a/tests/org.simantics.scl.compiler.tests/src/org/simantics/scl/compiler/tests/scl/TypeInferenceBug2.scl +++ b/tests/org.simantics.scl.compiler.tests/src/org/simantics/scl/compiler/tests/scl/TypeInferenceBug2.scl @@ -4,6 +4,4 @@ distance (x1,y1) (x2,y2) = let dx = x1-x2 dy = y1-y2 in sqrt (dx*dx + dy*dy) print x1 -- -5:31-5:35: Constrain Real ((a -> ()) -> ((c -> ()) -> e -> f) -> i) contains free variables not mentioned in the type of the value. -5:52-5:57: Constrain Show a contains free variables not mentioned in the type of the value. -5:58-5:60: Unification of types failed. \ No newline at end of file +5:58-5:60: Expected got . \ No newline at end of file -- 2.43.2