compiler.tree.propagation: type function for clone had an issue, sometimes clone...

diff --git a/basis/compiler/tree/propagation/known-words/known-words.factor b/basis/compiler/tree/propagation/known-words/known-words.factor
index 69785c8c0ab886499ab02e47df50582684a0408e..0ea811c7105b68980c5f609904641ef41538a8e8 100644 (file)
--- a/basis/compiler/tree/propagation/known-words/known-words.factor
+++ b/basis/compiler/tree/propagation/known-words/known-words.factor
@@ -16,7 +16,8 @@ compiler.tree.propagation.slots
 compiler.tree.propagation.simple
 compiler.tree.propagation.constraints
 compiler.tree.propagation.call-effect
-compiler.tree.propagation.transforms ;
+compiler.tree.propagation.transforms
+compiler.tree.propagation.simd ;
 IN: compiler.tree.propagation.known-words
 
 { + - * / }
@@ -275,9 +276,12 @@ generic-comparison-ops [
 ] "outputs" set-word-prop
 
 ! the output of clone has the same type as the input
+: cloned-value-info ( value-info -- value-info' )
+    clone f >>literal f >>literal?
+    [ [ dup [ cloned-value-info ] when ] map ] change-slots ;
+
 { clone (clone) } [
-    [ clone f >>literal f >>literal? ]
-    "outputs" set-word-prop
+    [ cloned-value-info ] "outputs" set-word-prop
 ] each
 
 \ slot [

diff --git a/basis/compiler/tree/propagation/propagation-tests.factor b/basis/compiler/tree/propagation/propagation-tests.factor
index 879ab82c4b18cb9d9a85aa0247deea704a8b9fe8..fa5ce551366b4f2baa29a02c838fef7614316644 100644 (file)
--- a/basis/compiler/tree/propagation/propagation-tests.factor
+++ b/basis/compiler/tree/propagation/propagation-tests.factor
@@ -799,3 +799,13 @@ SYMBOL: not-an-assoc
 
 [ t ] [ [ (( a b c -- c b a )) shuffle ] { shuffle } inlined? ] unit-test
 [ f ] [ [ { 1 2 3 } swap shuffle ] { shuffle } inlined? ] unit-test
+
+! Type function for 'clone' had a subtle issue
+TUPLE: tuple-with-read-only-slot { x read-only } ;
+
+M: tuple-with-read-only-slot clone
+    x>> clone tuple-with-read-only-slot boa ; inline
+
+[ V{ object } ] [
+    [ { 1 2 3 } dup tuple-with-read-only-slot boa clone x>> eq? ] final-classes
+] unit-test