steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

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

cvs
Slava Pestov 2005-12-12 23:51:45 +00:00
parent ca035d7709
commit 58a3e3ed16
21 changed files with 105 additions and 69 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
CHANGES.html
View File

@ -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>

7
library/alien/primitive-types.factor
View File

@ -103,8 +103,11 @@ math namespaces ;
] "uchar" define-primitive-type
[
[ alien-c-string ] "getter" set
[ set-alien-c-string ] "setter" set
[ alien-unsigned-cell <alien> alien>string ] "getter" 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

4
library/bootstrap/primitives.factor
View File

@ -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" }
{ "set-alien-c-string" "alien" }
{ "alien>string" "alien" }
{ "string>alien" "alien" }
{ "throw" "errors" }
{ "string>memory" "kernel-internals" }
{ "memory>string" "kernel-internals" }

42
library/compiler/ppc/fixnum.factor
View File

@ -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
4 0 scratch MR
1 scratch 0 input-operand 1 input-operand MULHW
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
0 scratch 0 input-operand 1 input-operand DIVW
#! This VOP is funny. If there is an overflow, it falls
#! 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.
0 scratch 0 output-operand 0 input-operand MULLW
1 scratch 0 scratch 1 input-operand SUBF ;
#! x-(x/y)*y. Puts the result in 1 scratch.
1 scratch 0 scratch 0 input-operand MULLW
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
generate-fixnum-mod ;
0 scratch 1 input-operand 0 input-operand DIVW
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 -- )

7
library/compiler/ppc/generator.factor
View File

@ -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 ;

2
library/compiler/ppc/slots.factor
View File

@ -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 ;

10
library/inference/known-words.factor
View File

@ -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-c-string [ [ c-ptr integer ] [ string ] ] "infer-effect" set-word-prop
\ alien-c-string t "flushable" set-word-prop
\ alien>string [ [ c-ptr ] [ string ] ] "infer-effect" set-word-prop
\ alien>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

13
native/alien.c
View File

@ -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)

5
native/alien.h
View File

@ -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);

4
native/debug.c
View File

@ -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,"\"");
}

2
native/float.c
View File

@ -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))

2
native/image.c
View File

@ -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));
}

2
native/io.c
View File

@ -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();

2
native/misc.h
View File

@ -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

4
native/primitives.c
View File

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

43
native/string.c
View File

@ -108,19 +108,33 @@ void box_c_string(const char *c_string)
dpush(c_string ? tag_object(from_c_string(c_string)) : F);
}
/* untagged */
char *to_c_string(F_STRING *s)
F_ARRAY *string_to_alien(F_STRING *s, bool check)
{
CELL i;
CELL capacity = string_capacity(s);
for(i = 0; i < capacity; i++)
F_ARRAY *_c_str;
if(check)
{
u16 ch = string_nth(s,i);
if(ch == '\0' || ch > 255)
general_error(ERROR_C_STRING,tag_object(s));
CELL i;
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);
}

4
native/string.h
View File

@ -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);
char* to_c_string_unchecked(F_STRING* s);
F_ARRAY *string_to_alien(F_STRING *s, bool check);
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);

4
native/unix/ffi.c
View File

@ -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)

4
native/unix/file.c
View File

@ -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;

4
native/win32/ffi.c
View File

@ -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)
{

2
native/win32/file.c
View File

@ -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);
}