compiler.cfg: open-code parameter boxing and unboxing for certain C types

basis/alien/c-types/c-types.factor

@@ -258,7 +258,7 @@ M: pointer c-type
         2 >>align
         2 >>align-first
         "from_signed_2" >>boxer
-        "to_fixnum" >>unboxer
+        "to_signed_2" >>unboxer
         [ >fixnum ] >>unboxer-quot
     \ short define-primitive-type
 
@@ -271,7 +271,7 @@ M: pointer c-type
         2 >>align
         2 >>align-first
         "from_unsigned_2" >>boxer
-        "to_cell" >>unboxer
+        "to_unsigned_2" >>unboxer
         [ >fixnum ] >>unboxer-quot
     \ ushort define-primitive-type
 
@@ -284,7 +284,7 @@ M: pointer c-type
         1 >>align
         1 >>align-first
         "from_signed_1" >>boxer
-        "to_fixnum" >>unboxer
+        "to_signed_1" >>unboxer
         [ >fixnum ] >>unboxer-quot
     \ char define-primitive-type
 
@@ -297,7 +297,7 @@ M: pointer c-type
         1 >>align
         1 >>align-first
         "from_unsigned_1" >>boxer
-        "to_cell" >>unboxer
+        "to_unsigned_1" >>unboxer
         [ >fixnum ] >>unboxer-quot
     \ uchar define-primitive-type
 
@@ -338,7 +338,7 @@ M: pointer c-type
             4 >>align
             4 >>align-first
             "from_signed_4" >>boxer
-            "to_fixnum" >>unboxer
+            "to_signed_4" >>unboxer
             [ >fixnum ] >>unboxer-quot
         \ int define-primitive-type
     
@@ -351,7 +351,7 @@ M: pointer c-type
             4 >>align
             4 >>align-first
             "from_unsigned_4" >>boxer
-            "to_cell" >>unboxer
+            "to_unsigned_4" >>unboxer
             [ >fixnum ] >>unboxer-quot
         \ uint define-primitive-type
 

basis/compiler/cfg/builder/alien/boxing/boxing.factor

@@ -6,6 +6,7 @@ sequences sequences.generalizations system
 compiler.cfg.builder.alien.params compiler.cfg.hats
 compiler.cfg.registers compiler.cfg.instructions
 compiler.cfg.intrinsics.allot cpu.architecture ;
+QUALIFIED-WITH: alien.c-types c
 IN: compiler.cfg.builder.alien.boxing
 
 SYMBOL: struct-return-area
@@ -49,9 +50,15 @@ M: c-type unbox
     [ rep>> ] [ unboxer>> ] bi
     [
         {
-            ! { "to_float" [ drop ] }
+            { "to_float" [ drop ] }
-            ! { "to_double" [ drop ] }
+            { "to_double" [ drop ] }
-            ! { "alien_offset" [ drop ^^unbox-any-c-ptr ] }
+            { "to_signed_1" [ drop ] }
+            { "to_unsigned_1" [ drop ] }
+            { "to_signed_2" [ drop ] }
+            { "to_unsigned_2" [ drop ] }
+            { "to_signed_4" [ drop ] }
+            { "to_unsigned_4" [ drop ] }
+            { "alien_offset" [ drop ^^unbox-any-c-ptr ] }
             [ swap ^^unbox ]
         } case 1array
     ]
@@ -107,9 +114,15 @@ GENERIC: box ( vregs reps c-type -- dst )
 M: c-type box
     [ [ first ] bi@ ] [ boxer>> ] bi*
     {
-        ! { "from_float" [ drop ] }
+        { "from_float" [ drop ] }
-        ! { "from_double" [ drop ] }
+        { "from_double" [ drop ] }
-        ! { "allot_alien" [ drop ^^box-alien ] }
+        { "from_signed_1" [ drop c:char ^^convert-integer ] }
+        { "from_unsigned_1" [ drop c:uchar ^^convert-integer ] }
+        { "from_signed_2" [ drop c:short ^^convert-integer ] }
+        { "from_unsigned_2" [ drop c:ushort ^^convert-integer ] }
+        { "from_signed_4" [ drop c:int ^^convert-integer ] }
+        { "from_unsigned_4" [ drop c:uint ^^convert-integer ] }
+        { "allot_alien" [ drop ^^box-alien ] }
         [ swap <gc-map> ^^box ]
     } case ;
 

basis/compiler/cfg/instructions/instructions.factor

@@ -591,6 +591,12 @@ FOLDABLE-INSN: ##unbox-alien
 def: dst/int-rep
 use: src/tagged-rep ;
 
+! Zero-extending and sign-extending integers
+FOLDABLE-INSN: ##convert-integer
+def: dst/int-rep
+use: src/int-rep
+literal: c-type ;
+
 ! Raw memory accessors
 FLUSHABLE-INSN: ##load-memory
 def: dst

basis/compiler/cfg/save-contexts/save-contexts-tests.factor

@@ -65,7 +65,7 @@ V{
 
 V{
     T{ ##phi }
-    T{ ##add }
+    T{ ##box }
 } 0 test-bb
 
 0 get insert-save-context
@@ -74,7 +74,7 @@ V{
     V{
         T{ ##phi }
         T{ ##save-context f 7 8 }
-        T{ ##add }
+        T{ ##box }
     }
 ] [
     0 get instructions>>

basis/compiler/codegen/codegen.factor

@@ -236,6 +236,7 @@ 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: ##convert-integer %convert-integer
 CODEGEN: ##load-memory %load-memory
 CODEGEN: ##load-memory-imm %load-memory-imm
 CODEGEN: ##store-memory %store-memory

basis/compiler/tests/low-level-ir.factor

@@ -105,3 +105,24 @@ IN: compiler.tests.low-level-ir
         T{ ##add-imm f 0 0 -16 }
     } compile-test-bb
 ] unit-test
+
+[ -1 ] [
+    V{
+        T{ ##load-tagged f 1 $[ -1 tag-fixnum ] }
+        T{ ##convert-integer f 0 1 char }
+    } compile-test-bb
+] unit-test
+
+[ -1 ] [
+    V{
+        T{ ##load-tagged f 1 $[ -1 9 2^ bitxor tag-fixnum ] }
+        T{ ##convert-integer f 0 1 char }
+    } compile-test-bb
+] unit-test
+
+[ $[ 255 tag-bits get neg shift ] ] [
+    V{
+        T{ ##load-tagged f 1 $[ -1 9 2^ bitxor tag-fixnum ] }
+        T{ ##convert-integer f 0 1 uchar }
+    } compile-test-bb
+] unit-test

basis/cpu/architecture/architecture.factor

@@ -473,6 +473,8 @@ HOOK: %unbox-any-c-ptr cpu ( dst src -- )
 HOOK: %box-alien cpu ( dst src temp -- )
 HOOK: %box-displaced-alien cpu ( dst displacement base temp base-class -- )
 
+HOOK: %convert-integer cpu ( dst src c-type -- )
+
 HOOK: %load-memory cpu ( dst base displacement scale offset rep c-type -- )
 HOOK: %load-memory-imm cpu ( dst base offset rep c-type -- )
 HOOK: %store-memory cpu ( value base displacement scale offset rep c-type -- )

basis/cpu/x86/x86.factor

@@ -345,6 +345,29 @@ M: x86.64 has-small-reg? 2drop t ;
         [ quot call ] with-save/restore
     ] if ; inline
 
+:: (%convert-integer) ( dst src bits quot -- )
+    dst { src } bits [| new-dst |
+        new-dst dup bits n-bit-version-of dup src MOV
+        quot call
+        dst new-dst int-rep %copy
+    ] with-small-register ; inline
+
+: %zero-extend ( dst src bits -- )
+    [ MOVZX ] (%convert-integer) ; inline
+
+: %sign-extend ( dst src bits -- )
+    [ MOVSX ] (%convert-integer) ; inline
+
+M: x86 %convert-integer ( dst src c-type -- )
+    {
+        { c:char   [ 8 %sign-extend ] }
+        { c:uchar  [ 8 %zero-extend ] }
+        { c:short  [ 16 %sign-extend ] }
+        { c:ushort [ 16 %zero-extend ] }
+        { c:int    [ 32 %sign-extend ] }
+        { c:uint   [ 32 [ 2drop ] (%convert-integer) ] }
+    } case ;
+
 :: %alien-integer-getter ( dst exclude address bits quot -- )
     dst exclude bits [| new-dst |
         new-dst dup bits n-bit-version-of dup address MOV

vm/alien.cpp

@@ -27,11 +27,6 @@ char *factor_vm::pinned_alien_offset(cell obj)
 	}
 }
 
-VM_C_API char *pinned_alien_offset(cell obj, factor_vm *parent)
-{
-	return parent->pinned_alien_offset(obj);
-}
-
 /* make an alien */
 cell factor_vm::allot_alien(cell delegate_, cell displacement)
 {
@@ -62,11 +57,6 @@ cell factor_vm::allot_alien(void *address)
 	return allot_alien(false_object,(cell)address);
 }
 
-VM_C_API cell allot_alien(void *address, factor_vm *vm)
-{
-	return vm->allot_alien(address);
-}
-
 /* make an alien pointing at an offset of another alien */
 void factor_vm::primitive_displaced_alien()
 {
@@ -90,7 +80,7 @@ void factor_vm::primitive_displaced_alien()
 if the object is a byte array, as a sanity check. */
 void factor_vm::primitive_alien_address()
 {
-	ctx->push(allot_cell((cell)pinned_alien_offset(ctx->pop())));
+	ctx->push(from_unsigned_cell((cell)pinned_alien_offset(ctx->pop())));
 }
 
 /* pop ( alien n ) from datastack, return alien's address plus n */
@@ -182,9 +172,4 @@ char *factor_vm::alien_offset(cell obj)
 	}
 }
 
-VM_C_API char *alien_offset(cell obj, factor_vm *parent)
-{
-	return parent->alien_offset(obj);
-}
-
 }

vm/alien.hpp

@@ -1,8 +1,4 @@
 namespace factor
 {
 
-VM_C_API char *alien_offset(cell object, factor_vm *vm);
-VM_C_API char *pinned_alien_offset(cell object, factor_vm *vm);
-VM_C_API cell allot_alien(void *address, factor_vm *vm);
-
 }

vm/code_heap.cpp

@@ -222,9 +222,10 @@ struct code_block_accumulator {
 
 		/* Note: the entry point is always a multiple of the heap
 		alignment (16 bytes). We cannot allocate while iterating
-		through the code heap, so it is not possible to call allot_cell()
+		through the code heap, so it is not possible to call
-		here. It is OK, however, to add it as if it were a fixnum, and
+		from_unsigned_cell() here. It is OK, however, to add it as
-		have library code shift it to the left by 4. */
+		if it were a fixnum, and have library code shift it to the
+		left by 4. */
 		cell entry_point = (cell)compiled->entry_point();
 		assert((entry_point & (data_alignment - 1)) == 0);
 		assert((entry_point & TAG_MASK) == FIXNUM_TYPE);

vm/errors.cpp

@@ -102,12 +102,12 @@ void factor_vm::memory_protection_error(cell addr, stack_frame *stack)
 	else if(ctx->callstack_seg->overflow_p(addr))
 		general_error(ERROR_CALLSTACK_UNDERFLOW,false_object,false_object,stack);
 	else
-		general_error(ERROR_MEMORY,allot_cell(addr),false_object,stack);
+		general_error(ERROR_MEMORY,from_unsigned_cell(addr),false_object,stack);
 }
 
 void factor_vm::signal_error(cell signal, stack_frame *stack)
 {
-	general_error(ERROR_SIGNAL,allot_cell(signal),false_object,stack);
+	general_error(ERROR_SIGNAL,from_unsigned_cell(signal),false_object,stack);
 }
 
 void factor_vm::divide_by_zero_error()

vm/math.cpp

@@ -21,7 +21,7 @@ void factor_vm::primitive_fixnum_divint()
 	fixnum x = untag_fixnum(ctx->peek());
 	fixnum result = x / y;
 	if(result == -fixnum_min)
-		ctx->replace(allot_integer(-fixnum_min));
+		ctx->replace(from_signed_cell(-fixnum_min));
 	else
 		ctx->replace(tag_fixnum(result));
 }
@@ -32,7 +32,7 @@ void factor_vm::primitive_fixnum_divmod()
 	cell x = ((cell *)ctx->datastack)[-1];
 	if(y == tag_fixnum(-1) && x == tag_fixnum(fixnum_min))
 	{
-		((cell *)ctx->datastack)[-1] = allot_integer(-fixnum_min);
+		((cell *)ctx->datastack)[-1] = from_signed_cell(-fixnum_min);
 		((cell *)ctx->datastack)[0] = tag_fixnum(0);
 	}
 	else
@@ -335,7 +335,7 @@ void factor_vm::primitive_float_greatereq()
 
 void factor_vm::primitive_float_bits()
 {
-	ctx->push(from_unsigned_4(float_bits((float)untag_float_check(ctx->pop()))));
+	ctx->push(from_unsigned_cell(float_bits((float)untag_float_check(ctx->pop()))));
 }
 
 void factor_vm::primitive_bits_float()
@@ -383,76 +383,6 @@ VM_C_API cell to_cell(cell tagged, factor_vm *parent)
 	return parent->to_cell(tagged);
 }
 
-cell factor_vm::from_signed_1(s8 n)
-{
-	return tag_fixnum(n);
-}
-
-VM_C_API cell from_signed_1(s8 n, factor_vm *parent)
-{
-	return parent->from_signed_1(n);
-}
-
-cell factor_vm::from_unsigned_1(u8 n)
-{
-	return tag_fixnum(n);
-}
-
-VM_C_API cell from_unsigned_1(u8 n, factor_vm *parent)
-{
-	return parent->from_unsigned_1(n);
-}
-
-cell factor_vm::from_signed_2(s16 n)
-{
-	return tag_fixnum(n);
-}
-
-VM_C_API cell from_signed_2(s16 n, factor_vm *parent)
-{
-	return parent->from_signed_2(n);
-}
-
-cell factor_vm::from_unsigned_2(u16 n)
-{
-	return tag_fixnum(n);
-}
-
-VM_C_API cell from_unsigned_2(u16 n, factor_vm *parent)
-{
-	return parent->from_unsigned_2(n);
-}
-
-cell factor_vm::from_signed_4(s32 n)
-{
-	return allot_integer(n);
-}
-
-VM_C_API cell from_signed_4(s32 n, factor_vm *parent)
-{
-	return parent->from_signed_4(n);
-}
-
-cell factor_vm::from_unsigned_4(u32 n)
-{
-	return allot_cell(n);
-}
-
-VM_C_API cell from_unsigned_4(u32 n, factor_vm *parent)
-{
-	return parent->from_unsigned_4(n);
-}
-
-cell factor_vm::from_signed_cell(fixnum integer)
-{
-	return allot_integer(integer);
-}
-
-cell factor_vm::from_unsigned_cell(cell integer)
-{
-	return allot_cell(integer);
-}
-
 VM_C_API cell from_signed_cell(fixnum integer, factor_vm *parent)
 {
 	return parent->from_signed_cell(integer);
@@ -529,38 +459,18 @@ VM_C_API u64 to_unsigned_8(cell obj, factor_vm *parent)
 	return parent->to_unsigned_8(obj);
 }
  
-VM_C_API cell from_float(float flo, factor_vm *parent)
-{
-	return parent->allot_float(flo);
-}
-
 /* Cannot allocate */
 float factor_vm::to_float(cell value)
 {
 	return (float)untag_float_check(value);
 }
 
-VM_C_API float to_float(cell value, factor_vm *parent)
-{
-	return parent->to_float(value);
-}
-
-VM_C_API cell from_double(double flo, factor_vm *parent)
-{
-	return parent->allot_float(flo);
-}
-
 /* Cannot allocate */
 double factor_vm::to_double(cell value)
 {
 	return untag_float_check(value);
 }
 
-VM_C_API double to_double(cell value, factor_vm *parent)
-{
-	return parent->to_double(value);
-}
-
 /* The fixnum+, fixnum- and fixnum* primitives are defined in cpu_*.S. On
 overflow, they call these functions. */
 inline void factor_vm::overflow_fixnum_add(fixnum x, fixnum y)

vm/math.hpp

@@ -5,7 +5,7 @@ static const fixnum fixnum_max = (((fixnum)1 << (WORD_SIZE - TAG_BITS - 1)) - 1)
 static const fixnum fixnum_min = (-((fixnum)1 << (WORD_SIZE - TAG_BITS - 1)));
 static const fixnum array_size_max = ((cell)1 << (WORD_SIZE - TAG_BITS - 2));
 
-inline cell factor_vm::allot_integer(fixnum x)
+inline cell factor_vm::from_signed_cell(fixnum x)
 {
 	if(x < fixnum_min || x > fixnum_max)
 		return tag<bignum>(fixnum_to_bignum(x));
@@ -13,7 +13,7 @@ inline cell factor_vm::allot_integer(fixnum x)
 		return tag_fixnum(x);
 }
 
-inline cell factor_vm::allot_cell(cell x)
+inline cell factor_vm::from_unsigned_cell(cell x)
 {
 	if(x > (cell)fixnum_max)
 		return tag<bignum>(cell_to_bignum(x));
@@ -74,17 +74,6 @@ inline cell factor_vm::unbox_array_size()
 	return unbox_array_size_slow();
 }
 
-VM_C_API cell from_float(float flo, factor_vm *vm);
-VM_C_API float to_float(cell value, factor_vm *vm);
-VM_C_API cell from_double(double flo, factor_vm *vm);
-VM_C_API double to_double(cell value, factor_vm *vm);
-
-VM_C_API cell from_signed_1(s8 n, factor_vm *vm);
-VM_C_API cell from_unsigned_1(u8 n, factor_vm *vm);
-VM_C_API cell from_signed_2(s16 n, factor_vm *vm);
-VM_C_API cell from_unsigned_2(u16 n, factor_vm *vm);
-VM_C_API cell from_signed_4(s32 n, factor_vm *vm);
-VM_C_API cell from_unsigned_4(u32 n, factor_vm *vm);
 VM_C_API cell from_signed_cell(fixnum integer, factor_vm *vm);
 VM_C_API cell from_unsigned_cell(cell integer, factor_vm *vm);
 VM_C_API cell from_signed_8(s64 n, factor_vm *vm);

vm/objects.cpp

@@ -79,7 +79,7 @@ cell factor_vm::object_size(cell tagged)
 
 void factor_vm::primitive_size()
 {
-	ctx->push(allot_cell(object_size(ctx->pop())));
+	ctx->push(from_unsigned_cell(object_size(ctx->pop())));
 }
 
 struct slot_become_fixup : no_fixup {

vm/primitives.hpp

@@ -138,12 +138,12 @@ namespace factor
 	_(unsigned_cell,cell,from_unsigned_cell,to_cell) \
 	_(signed_8,s64,from_signed_8,to_signed_8) \
 	_(unsigned_8,u64,from_unsigned_8,to_unsigned_8) \
-	_(signed_4,s32,from_signed_4,to_fixnum) \
+	_(signed_4,s32,from_unsigned_cell,to_fixnum) \
-	_(unsigned_4,u32,from_unsigned_4,to_cell) \
+	_(unsigned_4,u32,from_unsigned_cell,to_cell) \
-	_(signed_2,s16,from_signed_2,to_fixnum) \
+	_(signed_2,s16,from_unsigned_cell,to_fixnum) \
-	_(unsigned_2,u16,from_unsigned_2,to_cell) \
+	_(unsigned_2,u16,from_unsigned_cell,to_cell) \
-	_(signed_1,s8,from_signed_1,to_fixnum) \
+	_(signed_1,s8,from_unsigned_cell,to_fixnum) \
-	_(unsigned_1,u8,from_unsigned_1,to_cell) \
+	_(unsigned_1,u8,from_unsigned_cell,to_cell) \
 	_(float,float,allot_float,to_float) \
 	_(double,double,allot_float,to_double) \
 	_(cell,void *,allot_alien,pinned_alien_offset)

vm/quotations.cpp

@@ -328,8 +328,8 @@ void factor_vm::primitive_quotation_code()
 {
 	quotation *quot = untag_check<quotation>(ctx->pop());
 
-	ctx->push(allot_cell((cell)quot->code->entry_point()));
+	ctx->push(from_unsigned_cell((cell)quot->code->entry_point()));
-	ctx->push(allot_cell((cell)quot->code + quot->code->size()));
+	ctx->push(from_unsigned_cell((cell)quot->code + quot->code->size()));
 }
 
 /* Allocates memory */

vm/vm.hpp

@@ -475,14 +475,6 @@ struct factor_vm
 	void primitive_bits_double();
 	fixnum to_fixnum(cell tagged);
 	cell to_cell(cell tagged);
-	cell from_signed_1(s8 n);
-	cell from_unsigned_1(u8 n);
-	cell from_signed_2(s16 n);
-	cell from_unsigned_2(u16 n);
-	cell from_signed_4(s32 n);
-	cell from_unsigned_4(u32 n);
-	cell from_signed_cell(fixnum integer);
-	cell from_unsigned_cell(cell integer);
 	cell from_signed_8(s64 n);
 	s64 to_signed_8(cell obj);
 	cell from_unsigned_8(u64 n);
@@ -492,8 +484,8 @@ struct factor_vm
 	inline void overflow_fixnum_add(fixnum x, fixnum y);
 	inline void overflow_fixnum_subtract(fixnum x, fixnum y);
 	inline void overflow_fixnum_multiply(fixnum x, fixnum y);
-	inline cell allot_integer(fixnum x);
+	inline cell from_signed_cell(fixnum x);
-	inline cell allot_cell(cell x);
+	inline cell from_unsigned_cell(cell x);
 	inline cell allot_float(double n);
 	inline bignum *float_to_bignum(cell tagged);
 	inline double bignum_to_float(cell tagged);

vm/words.cpp

@@ -91,13 +91,13 @@ void factor_vm::primitive_word_code()
 
 	if(profiling_p)
 	{
-		ctx->push(allot_cell((cell)w->profiling->entry_point()));
+		ctx->push(from_unsigned_cell((cell)w->profiling->entry_point()));
-		ctx->push(allot_cell((cell)w->profiling + w->profiling->size()));
+		ctx->push(from_unsigned_cell((cell)w->profiling + w->profiling->size()));
 	}
 	else
 	{
-		ctx->push(allot_cell((cell)w->code->entry_point()));
+		ctx->push(from_unsigned_cell((cell)w->code->entry_point()));
-		ctx->push(allot_cell((cell)w->code + w->code->size()));
+		ctx->push(from_unsigned_cell((cell)w->code + w->code->size()));
 	}
 }