cpu.x86: update %box-displaced-alien for introduction of address field

basis/compiler/cfg/instructions/instructions.factor

@@ -512,13 +512,12 @@ temp: temp/int-rep ;
 PURE-INSN: ##box-displaced-alien
 def: dst/int-rep
 use: displacement/int-rep base/int-rep
-temp: temp1/int-rep temp2/int-rep
+temp: temp/int-rep
 literal: base-class ;
 
 PURE-INSN: ##unbox-any-c-ptr
 def: dst/int-rep
-use: src/int-rep
+use: src/int-rep ;
-temp: temp/int-rep ;
 
 : ##unbox-f ( dst src -- ) drop 0 ##load-immediate ;
 : ##unbox-byte-array ( dst src -- ) byte-array-offset ##add-imm ;
@@ -527,12 +526,12 @@ PURE-INSN: ##unbox-alien
 def: dst/int-rep
 use: src/int-rep ;
 
-: ##unbox-c-ptr ( dst src class temp -- )
+: ##unbox-c-ptr ( dst src class -- )
     {
-        { [ over \ f class<= ] [ 2drop ##unbox-f ] }
+        { [ dup \ f class<= ] [ drop ##unbox-f ] }
-        { [ over alien class<= ] [ 2drop ##unbox-alien ] }
+        { [ dup alien class<= ] [ drop ##unbox-alien ] }
-        { [ over byte-array class<= ] [ 2drop ##unbox-byte-array ] }
+        { [ dup byte-array class<= ] [ drop ##unbox-byte-array ] }
-        [ nip ##unbox-any-c-ptr ]
+        [ drop ##unbox-any-c-ptr ]
     } cond ;
 
 ! Alien accessors

basis/compiler/cfg/intrinsics/alien/alien.factor

@@ -33,7 +33,7 @@ IN: compiler.cfg.intrinsics.alien
     bi and ;
 
 : ^^unbox-c-ptr ( src class -- dst )
-    [ next-vreg dup ] 2dip next-vreg ##unbox-c-ptr ;
+    [ next-vreg dup ] 2dip ##unbox-c-ptr ;
 
 : prepare-alien-accessor ( info -- ptr-vreg offset )
     class>> [ 2inputs ^^untag-fixnum swap ] dip ^^unbox-c-ptr ^^add 0 ;

basis/compiler/cfg/value-numbering/rewrite/rewrite.factor

@@ -440,7 +440,7 @@ M: ##sar rewrite \ ##sar-imm rewrite-arithmetic ;
 :: rewrite-unbox-displaced-alien ( insn expr -- insns )
     [
         next-vreg :> temp
-        temp expr base>> vn>vreg expr base-class>> insn temp>> ##unbox-c-ptr
+        temp expr base>> vn>vreg expr base-class>> ##unbox-c-ptr
         insn dst>> temp expr displacement>> vn>vreg ##add
     ] { } make ;
 

basis/cpu/architecture/architecture.factor

@@ -386,9 +386,9 @@ M: object %horizontal-shl-vector-imm-reps { } ;
 M: object %horizontal-shr-vector-imm-reps { } ;
 
 HOOK: %unbox-alien cpu ( dst src -- )
-HOOK: %unbox-any-c-ptr cpu ( dst src temp -- )
+HOOK: %unbox-any-c-ptr cpu ( dst src -- )
 HOOK: %box-alien cpu ( dst src temp -- )
-HOOK: %box-displaced-alien cpu ( dst displacement base temp1 temp2 base-class -- )
+HOOK: %box-displaced-alien cpu ( dst displacement base temp base-class -- )
 
 HOOK: %alien-unsigned-1 cpu ( dst src offset -- )
 HOOK: %alien-unsigned-2 cpu ( dst src offset -- )

basis/cpu/x86/x86.factor

@@ -177,20 +177,20 @@ M: x86 %fixnum-mul ( label dst src1 src2 -- )
 M: x86 %unbox-alien ( dst src -- )
     alien-offset [+] MOV ;
 
-M:: x86 %unbox-any-c-ptr ( dst src temp -- )
+M:: x86 %unbox-any-c-ptr ( dst src -- )
     [
         "end" define-label
-        ! Compute tag in temp register
+        dst dst XOR
-        temp src MOV
-        temp tag-mask get AND
-        dst 0 MOV
         ! Is the object f?
         src \ f type-number CMP
         "end" get JE
+        ! Compute tag in dst register
+        dst src MOV
+        dst tag-mask get AND
+        ! Is the object an alien?
+        dst alien type-number CMP
         ! Add an offset to start of byte array's data
         dst src byte-array-offset [+] LEA
-        ! Is the object an alien?
-        temp alien type-number CMP
         "end" get JNE
         ! If so, load the offset and add it to the address
         dst src alien-offset [+] MOV
@@ -203,7 +203,7 @@ M:: x86 %box-alien ( dst src temp -- )
     [
         "end" define-label
         dst \ f type-number MOV
-        src 0 CMP
+        src src TEST
         "end" get JE
         dst 5 cells alien temp %allot
         dst 1 alien@ \ f type-number MOV ! base
@@ -213,32 +213,73 @@ M:: x86 %box-alien ( dst src temp -- )
         "end" resolve-label
     ] with-scope ;
 
-M:: x86 %box-displaced-alien ( dst displacement base displacement' base' base-class -- )
+M:: x86 %box-displaced-alien ( dst displacement base temp base-class -- )
+    ! This is ridiculous
     [
         "end" define-label
-        "ok" define-label
+        "not-f" define-label
+        "not-alien" define-label
+
         ! If displacement is zero, return the base
         dst base MOV
-        displacement 0 CMP
+        displacement displacement TEST
         "end" get JE
-        ! Quickly use displacement' before its needed for real, as allot temporary
+
-        dst 4 cells alien displacement' %allot
+        ! Displacement is non-zero, we're going to be allocating a new
-        ! If base is already a displaced alien, unpack it
+        ! object
-        base' base MOV
+        dst 5 cells alien temp %allot
-        displacement' displacement MOV
+
+        ! Set expired to f
+        dst 2 alien@ \ f type-number MOV
+
+        ! Is base f?
         base \ f type-number CMP
-        "ok" get JE
+        "not-f" get JNE
-        ! XXX
+
-        base 0 [+] alien type-number tag-fixnum CMP
+        ! Yes, it is f. Fill in new object
-        "ok" get JNE
+        dst 1 alien@ base MOV
-        ! displacement += base.displacement
+        dst 3 alien@ displacement MOV
-        displacement' base 3 alien@ ADD
+        dst 4 alien@ displacement MOV
-        ! base = base.base
+
-        base' base 1 alien@ MOV
+        "end" get JMP
-        "ok" resolve-label
+
-        dst 1 alien@ base' MOV ! alien
+        "not-f" resolve-label
-        dst 2 alien@ \ f type-number MOV ! expired
+
-        dst 3 alien@ displacement' MOV ! displacement
+        ! Check base type
+        temp base MOV
+        temp tag-mask get AND
+
+        ! Is base an alien?
+        temp alien type-number CMP
+        "not-alien" get JNE
+
+        ! Yes, it is an alien. Set new alien's base to base.base
+        temp base 1 alien@ MOV
+        dst 1 alien@ temp MOV
+
+        ! Compute displacement
+        temp base 3 alien@ MOV
+        temp displacement ADD
+        dst 3 alien@ temp MOV
+
+        ! Compute address
+        temp base 4 alien@ MOV
+        temp displacement ADD
+        dst 4 alien@ temp MOV
+
+        ! We are done
+        "end" get JMP
+
+        ! Is base a byte array? It has to be, by now...
+        "not-alien" resolve-label
+
+        dst 1 alien@ base MOV
+        dst 3 alien@ displacement MOV
+        temp base MOV
+        temp byte-array-offset ADD
+        temp displacement ADD
+        dst 4 alien@ temp MOV
+
         "end" resolve-label
     ] with-scope ;