new alien>string and string>alien primitives; powerpc backend fixes

CHANGES.html

@@ -25,6 +25,13 @@
 rather than an association list for specifying style information.</li>
 </li>
 
+<li>C library interface:
+
+<ul>
+<li>Added a pair of words for between Factor strings and C strings, <code>alien&gt;string</code> and <code>string&gt;alien</code>.
+</li>
+
+
 <li>Compiler changes:
 
 <ul>

library/alien/primitive-types.factor

@@ -103,8 +103,11 @@ math namespaces ;
 ] "uchar" define-primitive-type
 
 [
-    [ alien-c-string ] "getter" set
+    [ alien-unsigned-cell <alien> alien>string ] "getter" set
-    [ set-alien-c-string ] "setter" set
+    [
+        >r >r string>alien alien-address r> r>
+        set-alien-unsigned-cell
+    ] "setter" set
     cell "width" set
     cell "align" set
     "box_c_string" "boxer" set

library/bootstrap/primitives.factor

@@ -176,8 +176,8 @@ vocabularies get [ "syntax" set [ reveal ] each ] bind
     { "set-alien-float" "alien"             }
     { "alien-double" "alien"                }
     { "set-alien-double" "alien"            }
-    { "alien-c-string" "alien"              }
+    { "alien>string" "alien"                }
-    { "set-alien-c-string" "alien"          }
+    { "string>alien" "alien"                }
     { "throw" "errors"                      }
     { "string>memory" "kernel-internals"    }
     { "memory>string" "kernel-internals"    }

library/compiler/ppc/fixnum.factor

@@ -11,7 +11,7 @@ math-internals memory namespaces words ;
     >r >r
     <label> "end" set
     "end" get BNO
-    r> execute
+    >3-vop< r> execute
     0 input-operand dup untag-fixnum
     1 input-operand dup untag-fixnum
     >3-vop< r> execute
@@ -34,8 +34,9 @@ M: %fixnum* generate-node ( vop -- )
     0 MTXER
     0 scratch 0 input-operand 1 input-operand MULLWO.
     "end" get BNO
-    >3-vop< MULHW
+    1 scratch 0 input-operand 1 input-operand MULHW
-    4 0 scratch MR
+    4 1 scratch MR
+    3 0 scratch MR
     "s48_long_pair_to_bignum" f compile-c-call
     ! now we have to shift it by three bits to remove the second
     ! tag
@@ -47,8 +48,11 @@ M: %fixnum* generate-node ( vop -- )
     0 output-operand 0 scratch MR ;
 
 : generate-fixnum/i
-    ! divide in2 by in1, store result in out1
+    #! This VOP is funny. If there is an overflow, it falls
-    0 scratch 0 input-operand 1 input-operand DIVW
+    #! through to the end, and the result is in 0 output-operand.
+    #! Otherwise it jumps to the "no-overflow" label and the
+    #! result is in 0 scratch.
+    0 scratch 1 input-operand 0 input-operand DIVW
     ! if the result is greater than the most positive fixnum,
     ! which can only ever happen if we do
     ! most-negative-fixnum -1 /i, then the result is a bignum.
@@ -57,9 +61,9 @@ M: %fixnum* generate-node ( vop -- )
     most-positive-fixnum 1 scratch LOAD
     0 scratch 0 1 scratch CMP
     "no-overflow" get BLE
-    most-negative-fixnum neg 0 output-operand LOAD
+    most-negative-fixnum neg 3 LOAD
     "s48_long_to_bignum" f compile-c-call
-    0 output-operand dup bignum-tag ORI ;
+    3 dup bignum-tag ORI ;
 
 M: %fixnum/i generate-node ( vop -- )
     #! This has specific vreg requirements.
@@ -72,26 +76,29 @@ M: %fixnum/i generate-node ( vop -- )
 
 : generate-fixnum-mod
     #! PowerPC doesn't have a MOD instruction; so we compute
-    #! x-(x/y)*y.
+    #! x-(x/y)*y. Puts the result in 1 scratch.
-    0 scratch 0 output-operand 0 input-operand MULLW
+    1 scratch 0 scratch 0 input-operand MULLW
-    1 scratch 0 scratch 1 input-operand SUBF ;
+    1 scratch 1 scratch 1 input-operand SUBF ;
 
 M: %fixnum-mod generate-node ( vop -- )
-    #! This has specific vreg requirements.
     drop
     ! divide in2 by in1, store result in out1
-    >3-vop< DIVW
+    0 scratch 1 input-operand 0 input-operand DIVW
-    generate-fixnum-mod ;
+    generate-fixnum-mod
+    0 output-operand 1 scratch MR ;
 
 M: %fixnum/mod generate-node ( vop -- )
-    #! This has specific vreg requirements.
+    #! This has specific vreg requirements. Note: if there's an
+    #! overflow, (most-negative-fixnum 1 /mod) the modulus is
+    #! always zero.
     drop
     generate-fixnum/i
-    0 1 scratch LI
+    0 0 output-operand LI
     "end" get B
     "no-overflow" get save-xt
     generate-fixnum-mod
-    0 output-operand 1 output-operand tag-fixnum
+    0 scratch 1 output-operand tag-fixnum
+    0 output-operand 1 scratch MR
     "end" get save-xt ;
 
 M: %fixnum-bitand generate-node ( vop -- ) drop >3-vop< AND ;
@@ -130,7 +137,8 @@ M: %fixnum<< generate-node ( vop -- )
     "end" get save-xt ;
 
 M: %fixnum>> generate-node ( vop -- )
-    0 output-operand 1 input-operand 0 output-operand SRAWI
+    drop
+    1 input-operand 0 output-operand 0 input SRAWI
     0 output-operand dup untag ;
 
 M: %fixnum-sgn generate-node ( vop -- )

library/compiler/ppc/generator.factor

@@ -5,7 +5,7 @@ USING: alien assembler compiler inference kernel
 kernel-internals lists math memory namespaces words ;
 
 : compile-dlsym ( symbol dll register -- )
-    >r 2dup dlsym  r> LOAD32 rel-2-2 rel-dlsym ;
+    >r 2dup dlsym  r> LOAD32 rel-2/2 rel-dlsym ;
 
 : compile-c-call ( symbol dll -- )
     11 [ compile-dlsym ] keep MTLR  BLRL ;
@@ -60,10 +60,11 @@ M: %jump-label generate-node ( vop -- )
     drop label B ;
 
 M: %jump-t generate-node ( vop -- )
-    drop 0 input-operand 0 swap f address CMPI vop-label BNE ;
+    drop 0 input-operand 0 swap f address CMPI label BNE ;
 
 M: %return-to generate-node ( vop -- )
-    drop label 0 3 LOAD32  absolute-2/2
+    drop
+    label 0 3 LOAD32  absolute-2/2
     1 1 stack-increment neg STWU
     3 1 stack-increment lr@ STW ;
 

library/compiler/ppc/slots.factor

@@ -56,7 +56,7 @@ M: %set-char-slot generate-node ( vop -- )
 
 : userenv ( reg -- )
     #! Load the userenv pointer in a virtual register.
-    "userenv" f dlsym swap LOAD32 rel-2/2 rel-userenv ;
+    "userenv" f dlsym swap LOAD32 0 rel-2/2 rel-userenv ;
 
 M: %getenv generate-node ( vop -- )
     drop 0 output-operand dup dup userenv 0 input cell * LWZ ;

library/inference/known-words.factor

@@ -440,13 +440,15 @@ sequences strings vectors words prettyprint ;
 \ alien-double [ [ c-ptr integer ] [ float ] ] "infer-effect" set-word-prop
 \ alien-double t "flushable" set-word-prop
 
-\ set-alien-double [ [ float c-ptr integer ] [ ] ] "infer-effect" set-word-prop
+\ alien>string [ [ c-ptr ] [ string ] ] "infer-effect" set-word-prop
-\ alien-c-string [ [ c-ptr integer ] [ string ] ] "infer-effect" set-word-prop
+\ alien>string t "flushable" set-word-prop
-\ alien-c-string t "flushable" set-word-prop
+
+\ string>alien [ [ string ] [ byte-array ] ] "infer-effect" set-word-prop
+\ string>alien t "flushable" set-word-prop
 
-\ set-alien-c-string [ [ string c-ptr integer ] [ ] ] "infer-effect" set-word-prop
 \ string>memory [ [ string integer ] [ ] ] "infer-effect" set-word-prop
 \ memory>string [ [ integer integer ] [ string ] ] "infer-effect" set-word-prop
+
 \ alien-address [ [ alien ] [ integer ] ] "infer-effect" set-word-prop
 
 \ slot [ [ object fixnum ] [ object ] ] "infer-effect" set-word-prop

native/alien.c

@@ -90,6 +90,18 @@ void primitive_alien_address(void)
 	box_unsigned_cell((CELL)alien_offset(dpop()));
 }
 
+void primitive_alien_to_string(void)
+{
+	maybe_gc(0);
+	drepl(tag_object(from_c_string(alien_offset(dpeek()))));
+}
+
+void primitive_string_to_alien(void)
+{
+	maybe_gc(0);
+	drepl(tag_object(string_to_alien(untag_string(dpeek()),true)));
+}
+
 void fixup_alien(ALIEN* alien)
 {
 	alien->expired = true;
@@ -129,4 +141,3 @@ DEF_ALIEN_SLOT(signed_1,BYTE,signed_1)
 DEF_ALIEN_SLOT(unsigned_1,BYTE,unsigned_1)
 DEF_ALIEN_SLOT(float,float,float)
 DEF_ALIEN_SLOT(double,double,double)
-DEF_ALIEN_SLOT(c_string,char*,c_string)

native/alien.h

@@ -27,6 +27,9 @@ void primitive_alien_address(void);
 
 void* alien_offset(CELL object);
 
+void primitive_alien_to_string(void);
+void primitive_string_to_alien(void);
+
 void fixup_alien(ALIEN* alien);
 void fixup_displaced_alien(DISPLACED_ALIEN* d);
 void collect_displaced_alien(DISPLACED_ALIEN* d);
@@ -59,5 +62,3 @@ void primitive_alien_float(void);
 void primitive_set_alien_float(void);
 void primitive_alien_double(void);
 void primitive_set_alien_double(void);
-void primitive_alien_c_string(void);
-void primitive_set_alien_c_string(void);

native/debug.c

@@ -24,7 +24,7 @@ void print_cons(CELL cons)
 void print_word(F_WORD* word)
 {
 	if(type_of(word->name) == STRING_TYPE)
-		fprintf(stderr,"%s",to_c_string(untag_string(word->name)));
+		fprintf(stderr,"%s",to_c_string(untag_string(word->name),true));
 	else
 	{
 		fprintf(stderr,"#<not a string: ");
@@ -38,7 +38,7 @@ void print_word(F_WORD* word)
 void print_string(F_STRING* str)
 {
 	fprintf(stderr,"\"");
-	fprintf(stderr,"%s",to_c_string(str));
+	fprintf(stderr,"%s",to_c_string(str,true));
 	fprintf(stderr,"\"");
 }
 

native/float.c

@@ -40,7 +40,7 @@ void primitive_str_to_float(void)
 	maybe_gc(sizeof(F_FLOAT));
 
 	str = untag_string(dpeek());
-	c_str = to_c_string(str);
+	c_str = to_c_string(str,true);
 	end = c_str;
 	f = strtod(c_str,&end);
 	if(end != c_str + string_capacity(str))

native/image.c

@@ -134,5 +134,5 @@ void primitive_save_image(void)
 	/* do a full GC to push everything into tenured space */
 	garbage_collection(TENURED);
 	filename = untag_string(dpop());
-	save_image(to_c_string(filename));
+	save_image(to_c_string(filename,true));
 }

native/io.c

@@ -64,7 +64,7 @@ void primitive_fwrite(void)
 	if(string_capacity(text) == 0)
 		return;
 
-	if(fwrite(to_c_string_unchecked(text),1,
+	if(fwrite(to_c_string(text,false),1,
 		untag_fixnum_fast(text->length),
 		file) == 0)
 		io_error();

native/misc.h

@@ -5,6 +5,6 @@ s64 current_millis(void);
 void primitive_millis(void);
 #ifdef WIN32
 char *buffer_to_c_string(char *buffer);
-F_STRING *get_error_message();
+F_STRING *get_error_message(void);
 DLLEXPORT char *error_message(DWORD id);
 #endif

native/primitives.c

@@ -154,8 +154,8 @@ void* primitives[] = {
 	primitive_set_alien_float,
 	primitive_alien_double,
 	primitive_set_alien_double,
-	primitive_alien_c_string,
+	primitive_alien_to_string,
-	primitive_set_alien_c_string,
+	primitive_string_to_alien,
 	primitive_throw,
 	primitive_string_to_memory,
 	primitive_memory_to_string,

native/string.c

@@ -108,19 +108,33 @@ void box_c_string(const char *c_string)
 	dpush(c_string ? tag_object(from_c_string(c_string)) : F);
 }
 
-/* untagged */
+F_ARRAY *string_to_alien(F_STRING *s, bool check)
-char *to_c_string(F_STRING *s)
+{
+	CELL capacity = string_capacity(s);
+	F_ARRAY *_c_str;
+	
+	if(check)
 	{
 		CELL i;
-	CELL capacity = string_capacity(s);
 		for(i = 0; i < capacity; i++)
 		{
 			u16 ch = string_nth(s,i);
 			if(ch == '\0' || ch > 255)
 				general_error(ERROR_C_STRING,tag_object(s));
 		}
+	}
 
-	return to_c_string_unchecked(s);
+	_c_str = allot_array(BYTE_ARRAY_TYPE,capacity / CELLS + 1);
+	BYTE *c_str = (BYTE*)(_c_str + 1);
+	string_to_memory(s,c_str);
+	c_str[capacity] = '\0';
+	return _c_str;
+}
+
+/* untagged */
+char *to_c_string(F_STRING *s, bool check)
+{
+	return (char*)(string_to_alien(s,check) + 1);
 }
 
 void string_to_memory(F_STRING *s, BYTE *string)
@@ -138,23 +152,12 @@ void primitive_string_to_memory(void)
 	string_to_memory(str,address);
 }
 
-/* untagged */
-char *to_c_string_unchecked(F_STRING *s)
-{
-	CELL capacity = string_capacity(s);
-	F_STRING *_c_str = allot_string(capacity / CHARS + 1);
-	BYTE *c_str = (BYTE*)(_c_str + 1);
-	string_to_memory(s,c_str);
-	c_str[capacity] = '\0';
-	return (char*)c_str;
-}
-
 /* FFI calls this */
 char* unbox_c_string(void)
 {
 	CELL str = dpop();
 	if(type_of(str) == STRING_TYPE)
-		return to_c_string(untag_string(str));
+		return to_c_string(untag_string(str),true);
 	else
 		return (char*)alien_offset(str);
 }

native/string.h

@@ -35,8 +35,8 @@ void rehash_string(F_STRING* str);
 void primitive_rehash_string(void);
 F_STRING* resize_string(F_STRING* string, F_FIXNUM capacity, u16 fill);
 void primitive_resize_string(void);
-char* to_c_string(F_STRING* s);
+F_ARRAY *string_to_alien(F_STRING *s, bool check);
-char* to_c_string_unchecked(F_STRING* s);
+char* to_c_string(F_STRING* s, bool check);
 void string_to_memory(F_STRING* s, BYTE* string);
 void primitive_string_to_memory(void);
 DLLEXPORT void box_c_string(const char* c_string);

native/unix/ffi.c

@@ -9,7 +9,7 @@ void init_ffi(void)
 
 void ffi_dlopen(DLL *dll, bool error)
 {
-	void *dllptr = dlopen(to_c_string(untag_string(dll->path)), RTLD_LAZY);
+	void *dllptr = dlopen(to_c_string(untag_string(dll->path),true), RTLD_LAZY);
 
 	if(dllptr == NULL)
 	{
@@ -30,7 +30,7 @@ void ffi_dlopen(DLL *dll, bool error)
 void *ffi_dlsym(DLL *dll, F_STRING *symbol, bool error)
 {
 	void *handle = (dll == NULL ? null_dll : dll->dll);
-	void *sym = dlsym(handle,to_c_string(symbol));
+	void *sym = dlsym(handle,to_c_string(symbol,true));
 	if(sym == NULL)
 	{
 		if(error)

native/unix/file.c

@@ -8,7 +8,7 @@ void primitive_stat(void)
 	maybe_gc(0);
 
 	path = untag_string(dpop());
-	if(stat(to_c_string(path),&sb) < 0)
+	if(stat(to_c_string(path,true),&sb) < 0)
 		dpush(F);
 	else
 	{
@@ -36,7 +36,7 @@ void primitive_read_dir(void)
 	maybe_gc(0);
 
 	path = untag_string(dpop());
-	dir = opendir(to_c_string(path));
+	dir = opendir(to_c_string(path,true));
 	if(dir != NULL)
 	{
 		struct dirent* file;

native/win32/ffi.c

@@ -7,7 +7,7 @@ void init_ffi (void)
 void ffi_dlopen (DLL *dll, bool error)
 {
 	HMODULE module;
-	char *path = to_c_string(untag_string(dll->path));
+	char *path = to_c_string(untag_string(dll->path,true));
 
 	module = LoadLibrary(path);
 
@@ -26,7 +26,7 @@ void ffi_dlopen (DLL *dll, bool error)
 void *ffi_dlsym (DLL *dll, F_STRING *symbol, bool error)
 {
 	void *sym = GetProcAddress(dll ? (HMODULE)dll->dll : GetModuleHandle(NULL),
-		to_c_string(symbol));
+		to_c_string(symbol,true));
 
 	if (!sym)
 	{

native/win32/file.c

@@ -8,7 +8,7 @@ void primitive_stat(void)
 	maybe_gc(0);
 	path = untag_string(dpop());
 
-	if(!GetFileAttributesEx(to_c_string(path), GetFileExInfoStandard, &st)) 
+	if(!GetFileAttributesEx(to_c_string(path,true), GetFileExInfoStandard, &st)) 
 	{
 		dpush(F);
 	}