Fix stage1 bootstrap bug, overly-eager object merging

core/bootstrap/image/image.factor

@@ -8,7 +8,7 @@ splitting growable classes classes.builtin classes.tuple
 classes.tuple.private words.private io.binary io.files vocabs
 vocabs.loader source-files definitions debugger float-arrays
 quotations.private sequences.private combinators
-io.encodings.binary math.order ;
+io.encodings.binary math.order accessors ;
 IN: bootstrap.image
 
 : my-arch ( -- arch )
@@ -31,6 +31,39 @@ IN: bootstrap.image
 
 <PRIVATE
 
+! Object cache; we only consider numbers equal if they have the
+! same type
+TUPLE: id obj ;
+
+C: <id> id
+
+M: id hashcode* obj>> hashcode* ;
+
+M: id equal?
+    over id? [
+        [ obj>> ] bi@
+        [ = ] [
+            dup number? [
+                [ class ] bi@ =
+            ] [
+                2drop t
+            ] if
+        ] 2bi and
+    ] [
+        2drop f
+    ] if ;
+
+SYMBOL: objects
+
+: (objects) <id> objects get ; inline
+
+: lookup-object ( obj -- n/f ) (objects) at ;
+
+: put-object ( n obj -- ) (objects) set-at ;
+
+: cache-object ( obj quot -- value )
+    >r (objects) r> [ obj>> ] prepose cache ; inline
+
 ! Constants
 
 : image-magic HEX: 0f0e0d0c ; inline
@@ -61,9 +94,6 @@ IN: bootstrap.image
 ! The image being constructed; a vector of word-size integers
 SYMBOL: image
 
-! Object cache
-SYMBOL: objects
-
 ! Image output format
 SYMBOL: big-endian
 
@@ -187,7 +217,9 @@ GENERIC: ' ( obj -- ptr )
     2tri ;
 
 M: bignum '
-    bignum tag-number dup [ emit-bignum ] emit-object ;
+    [
+        bignum tag-number dup [ emit-bignum ] emit-object
+    ] cache-object ;
 
 ! Fixnums
 
@@ -202,9 +234,11 @@ M: fixnum '
 ! Floats
 
 M: float '
-    float tag-number dup [
+    [
-        align-here double>bits emit-64
+        float tag-number dup [
-    ] emit-object ;
+            align-here double>bits emit-64
+        ] emit-object
+    ] cache-object ;
 
 ! Special objects
 
@@ -243,7 +277,7 @@ M: f '
         ] bi
         \ word type-number object tag-number
         [ emit-seq ] emit-object
-    ] keep objects get set-at ;
+    ] keep put-object ;
 
 : word-error ( word msg -- * )
     [ % dup word-vocabulary % " " % word-name % ] "" make throw ;
@@ -252,7 +286,7 @@ M: f '
     [ target-word ] keep or ;
 
 : fixup-word ( word -- offset )
-    transfer-word dup objects get at
+    transfer-word dup lookup-object
     [ ] [ "Not in image: " word-error ] ?if ;
 
 : fixup-words ( -- )
@@ -286,7 +320,7 @@ M: wrapper '
 M: string '
     #! We pool strings so that each string is only written once
     #! to the image
-    objects get [ emit-string ] cache ;
+    [ emit-string ] cache-object ;
 
 : assert-empty ( seq -- )
     length 0 assert= ;
@@ -311,12 +345,12 @@ M: float-array ' float-array emit-dummy-array ;
 
 : emit-tuple ( tuple -- pointer )
     dup class word-name "tombstone" =
-    [ objects get [ (emit-tuple) ] cache ] [ (emit-tuple) ] if ;
+    [ [ (emit-tuple) ] cache-object ] [ (emit-tuple) ] if ;
 
 M: tuple ' emit-tuple ;
 
 M: tuple-layout '
-    objects get [
+    [
         [
             {
                 [ layout-hashcode , ]
@@ -328,12 +362,12 @@ M: tuple-layout '
         ] { } make [ ' ] map
         \ tuple-layout type-number
         object tag-number [ emit-seq ] emit-object
-    ] cache ;
+    ] cache-object ;
 
 M: tombstone '
     delegate
     "((tombstone))" "((empty))" ? "hashtables.private" lookup
-    word-def first objects get [ emit-tuple ] cache ;
+    word-def first [ emit-tuple ] cache-object ;
 
 ! Arrays
 M: array '
@@ -343,7 +377,7 @@ M: array '
 ! Quotations
 
 M: quotation '
-    objects get [
+    [
         quotation-array '
         quotation type-number object tag-number [
             emit ! array
@@ -351,7 +385,7 @@ M: quotation '
             0 emit ! xt
             0 emit ! code
         ] emit-object
-    ] cache ;
+    ] cache-object ;
 
 ! End of the image