cpu.x86: use available type info to generate more efficient %box-displaced-alien where possible

basis/cpu/x86/x86.factor

@@ -5,7 +5,8 @@ cpu.x86.assembler cpu.x86.assembler.private cpu.x86.assembler.operands
 cpu.x86.features cpu.x86.features.private cpu.architecture kernel
 kernel.private math memory namespaces make sequences words system
 layouts combinators math.order math.vectors fry locals compiler.constants
-byte-arrays io macros quotations compiler compiler.units init vm
+byte-arrays io macros quotations classes.algebra compiler
+compiler.units init vm
 compiler.cfg.registers
 compiler.cfg.instructions
 compiler.cfg.intrinsics
@@ -232,13 +233,69 @@ M:: x86 %box-alien ( dst src temp -- )
         "end" resolve-label
     ] with-scope ;
 
-M:: x86 %box-displaced-alien ( dst displacement base temp base-class -- )
+:: %box-displaced-alien/f ( dst displacement -- )
-    ! This is ridiculous
+    dst 1 alien@ \ f type-number MOV
-    [
+    dst 3 alien@ displacement MOV
-        "end" define-label
+    dst 4 alien@ displacement MOV ;
+
+:: %box-displaced-alien/alien ( dst displacement base temp -- )
+    ! 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 ;
+
+:: %box-displaced-alien/byte-array ( dst displacement base temp -- )
+    dst 1 alien@ base MOV
+    dst 3 alien@ displacement MOV
+    temp base displacement byte-array-offset [++] LEA
+    dst 4 alien@ temp MOV ;
+
+:: %box-displaced-alien/dynamic ( dst displacement base temp -- )
     "not-f" define-label
     "not-alien" define-label
 
+    ! Check base type
+    temp base MOV
+    temp tag-mask get AND
+
+    ! Is base f?
+    temp \ f type-number CMP
+    "not-f" get JNE
+
+    ! Yes, it is f. Fill in new object
+    dst displacement %box-displaced-alien/f
+
+    "end" get JMP
+
+    "not-f" resolve-label
+
+    ! Is base an alien?
+    temp alien type-number CMP
+    "not-alien" get JNE
+
+    dst displacement base temp %box-displaced-alien/alien
+
+    ! We are done
+    "end" get JMP
+
+    ! Is base a byte array? It has to be, by now...
+    "not-alien" resolve-label
+
+    dst displacement base temp %box-displaced-alien/byte-array ;
+
+M:: x86 %box-displaced-alien ( dst displacement base temp base-class -- )
+    [
+        "end" define-label
+
         ! If displacement is zero, return the base
         dst base MOV
         displacement displacement TEST
@@ -251,51 +308,13 @@ M:: x86 %box-displaced-alien ( dst displacement base temp base-class -- )
         ! Set expired to f
         dst 2 alien@ \ f type-number MOV
 
-        ! Is base f?
+        dst displacement base temp
-        base \ f type-number CMP
+        {
-        "not-f" get JNE
+            { [ base-class \ f class<= ] [ 2drop %box-displaced-alien/f ] }
-
+            { [ base-class \ alien class<= ] [ %box-displaced-alien/alien ] }
-        ! Yes, it is f. Fill in new object
+            { [ base-class \ byte-array class<= ] [ %box-displaced-alien/byte-array ] }
-        dst 1 alien@ base MOV
+            [ %box-displaced-alien/dynamic ]
-        dst 3 alien@ displacement MOV
+        } cond
-        dst 4 alien@ displacement MOV
-
-        "end" get JMP
-
-        "not-f" resolve-label
-
-        ! 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 displacement byte-array-offset [++] LEA
-        dst 4 alien@ temp MOV
 
         "end" resolve-label
     ] with-scope ;

vm/alien.cpp

@@ -35,8 +35,8 @@ VM_C_API char *pinned_alien_offset(cell obj, factor_vm *parent)
 /* make an alien */
 cell factor_vm::allot_alien(cell delegate_, cell displacement)
 {
-	if(delegate_ == false_object && displacement == 0)
+	if(displacement == 0)
-		return false_object;
+		return delegate_;
 
 	data_root<object> delegate(delegate_,this);
 	data_root<alien> new_alien(allot<alien>(sizeof(alien)),this);