compiler: clean up code generation for alien boxing/unboxing a bit

basis/compiler/cfg/builder/builder-tests.factor

@@ -189,5 +189,17 @@ IN: compiler.cfg.builder.tests
 [ f t ] [
     [ { fixnum simple-alien } declare <displaced-alien> 0 alien-cell ]
     [ [ ##unbox-any-c-ptr? ] contains-insn? ]
-    [ [ ##slot-imm? ] contains-insn? ] bi
+    [ [ ##unbox-alien? ] contains-insn? ] bi
+] unit-test
+
+[ f t ] [
+    [ { byte-array fixnum } declare alien-cell 4 alien-float ]
+    [ [ ##box-alien? ] contains-insn? ]
+    [ [ ##box-float? ] contains-insn? ] bi
+] unit-test
+
+[ f t ] [
+    [ { byte-array fixnum } declare alien-cell { simple-alien } declare 4 alien-float ]
+    [ [ ##box-alien? ] contains-insn? ]
+    [ [ ##box-float? ] contains-insn? ] bi
 ] unit-test

basis/compiler/cfg/instructions/instructions.factor

@@ -341,11 +341,6 @@ use: src
 literal: rep ;
 
 ! Boxing and unboxing aliens
-PURE-INSN: ##unbox-any-c-ptr
-def: dst/int-rep
-use: src/int-rep
-temp: temp/int-rep ;
-
 PURE-INSN: ##box-alien
 def: dst/int-rep
 use: src/int-rep
@@ -357,9 +352,17 @@ use: displacement/int-rep base/int-rep
 temp: temp1/int-rep temp2/int-rep
 literal: base-class ;
 
+PURE-INSN: ##unbox-any-c-ptr
+def: dst/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 ;
-: ##unbox-alien ( dst src -- ) 3 object tag-number ##slot-imm ;
+
+PURE-INSN: ##unbox-alien
+def: dst/int-rep
+use: src/int-rep ;
 
 : ##unbox-c-ptr ( dst src class temp -- )
     {

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

@@ -14,7 +14,7 @@ M: copy-expr simplify* src>> ;
 : simplify-unbox-alien ( expr -- vn/expr/f )
     src>> vn>expr dup box-alien-expr? [ src>> ] [ drop f ] if ;
 
-! M: unbox-alien-expr simplify* simplify-unbox-alien ;
+M: unbox-alien-expr simplify* simplify-unbox-alien ;
 
 M: unbox-any-c-ptr-expr simplify* simplify-unbox-alien ;
 

basis/compiler/codegen/codegen.factor

@@ -175,9 +175,10 @@ CODEGEN: ##min-vector %min-vector
 CODEGEN: ##max-vector %max-vector
 CODEGEN: ##sqrt-vector %sqrt-vector
 CODEGEN: ##horizontal-add-vector %horizontal-add-vector
-CODEGEN: ##unbox-any-c-ptr %unbox-any-c-ptr
 CODEGEN: ##box-alien %box-alien
 CODEGEN: ##box-displaced-alien %box-displaced-alien
+CODEGEN: ##unbox-alien %unbox-alien
+CODEGEN: ##unbox-any-c-ptr %unbox-any-c-ptr
 CODEGEN: ##alien-unsigned-1 %alien-unsigned-1
 CODEGEN: ##alien-unsigned-2 %alien-unsigned-2
 CODEGEN: ##alien-unsigned-4 %alien-unsigned-4

basis/compiler/tree/propagation/known-words/known-words.factor

@@ -7,7 +7,7 @@ layouts words sequences sequences.private arrays assocs classes
 classes.algebra combinators generic.math splitting fry locals
 classes.tuple alien.accessors classes.tuple.private
 slots.private definitions strings.private vectors hashtables
-generic quotations
+generic quotations alien
 stack-checker.state
 compiler.tree.comparisons
 compiler.tree.propagation.info
@@ -264,6 +264,10 @@ generic-comparison-ops [
     '[ 2drop _ ] "outputs" set-word-prop
 ] each
 
+\ alien-cell [
+    2drop simple-alien \ f class-or <class-info>
+] "outputs" set-word-prop
+
 { <tuple> <tuple-boa> } [
     [
         literal>> dup array? [ first ] [ drop tuple ] if <class-info>

basis/compiler/tree/propagation/propagation-tests.factor

@@ -9,7 +9,7 @@ compiler.tree.propagation.info compiler.tree.def-use
 compiler.tree.debugger compiler.tree.checker
 slots.private words hashtables classes assocs locals
 specialized-arrays.double system sorting math.libm
-math.intervals quotations effects ;
+math.intervals quotations effects alien ;
 IN: compiler.tree.propagation.tests
 
 [ V{ } ] [ [ ] final-classes ] unit-test
@@ -809,3 +809,9 @@ M: tuple-with-read-only-slot clone
 [ V{ object } ] [
     [ { 1 2 3 } dup tuple-with-read-only-slot boa clone x>> eq? ] final-classes
 ] unit-test
+
+! alien-cell outputs a simple-alien or f
+[ t ] [
+    [ { byte-array fixnum } declare alien-cell dup [ "OOPS" throw ] unless ] final-classes
+    first simple-alien class=
+] unit-test

basis/cpu/architecture/architecture.factor

@@ -177,6 +177,7 @@ HOOK: %max-vector cpu ( dst src1 src2 rep -- )
 HOOK: %sqrt-vector cpu ( dst src rep -- )
 HOOK: %horizontal-add-vector cpu ( dst src rep -- )
 
+HOOK: %unbox-alien cpu ( dst src -- )
 HOOK: %unbox-any-c-ptr cpu ( dst src temp -- )
 HOOK: %box-alien cpu ( dst src temp -- )
 HOOK: %box-displaced-alien cpu ( dst displacement base temp1 temp2 base-class -- )

basis/cpu/x86/x86.factor

@@ -340,6 +340,9 @@ M: x86 %horizontal-add-vector ( dst src rep -- )
         { double-2-rep [ [ MOVAPD ] [ HADDPD ] 2bi ] }
     } case ;
 
+M: x86 %unbox-alien ( dst src -- )
+    alien-offset [+] MOV ;
+
 M:: x86 %unbox-any-c-ptr ( dst src temp -- )
     [
         { "is-byte-array" "end" "start" } [ define-label ] each