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

huge alien cleanup

cvs
Slava Pestov 2005-04-09 22:30:46 +00:00
parent 8f1ee76193
commit 0d612fd94d
32 changed files with 444 additions and 388 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
Makefile
View File

@ -20,7 +20,8 @@ OBJS = $(UNIX_OBJS) native/arithmetic.o native/array.o native/bignum.o \
native/sbuf.o native/stack.o \
native/string.o native/types.o native/vector.o \
native/word.o native/compiler.o \
native/ffi.o native/boolean.o \
native/alien.o native/dll.o \
native/boolean.o \
native/debug.o \
native/hashtable.o \
native/icache.o

36
Makefile.win32
View File

@ -1,5 +1,7 @@
# :mode=makefile:
CC = gcc
DEFAULT_CFLAGS = -Wall -Os -fomit-frame-pointer $(SITE_CFLAGS)
DEFAULT_CFLAGS = -Wall -O3 -fomit-frame-pointer $(SITE_CFLAGS)
DEFAULT_LIBS = -lm
STRIP = strip
@ -8,21 +10,23 @@ WIN32_OBJS = native\win32\ffi.o native\win32\file.o native\win32\io.o \
native\win32\misc.o native\win32\read.o native\win32\write.o \
native\win32\run.o
OBJS = $(WIN32_OBJS) native\arithmetic.o native\array.o native\bignum.o \
native\s48_bignum.o \
native\complex.o native\cons.o native\error.o \
native\factor.o native\fixnum.o \
native\float.o native\gc.o \
native\image.o native\memory.o \
native\misc.o native\port.o native\primitives.o \
native\ratio.o native\relocate.o \
native\run.o \
native\sbuf.o native\stack.o \
native\string.o native\types.o native\vector.o \
native\word.o native\compiler.o \
native\ffi.o native\boolean.o \
native\debug.o \
native\hashtable.o
OBJS = $(WIN32_OBJS) native/arithmetic.o native/array.o native/bignum.o \
native/s48_bignum.o \
native/complex.o native/cons.o native/error.o \
native/factor.o native/fixnum.o \
native/float.o native/gc.o \
native/image.o native/memory.o \
native/misc.o native/port.o native/primitives.o \
native/ratio.o native/relocate.o \
native/run.o \
native/sbuf.o native/stack.o \
native/string.o native/types.o native/vector.o \
native/word.o native/compiler.o \
native/alien.o native/dll.o \
native/boolean.o \
native/debug.o \
native/hashtable.o \
native/icache.o
default:
@echo "Run 'make' with one of the following parameters:"

63
library/alien/aliens.factor Normal file
View File

@ -0,0 +1,63 @@
! Copyright (C) 2004, 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: alien
USING: hashtables kernel lists math namespaces parser
prettyprint stdio unparser ;
BUILTIN: dll 15 [ 1 "dll-path" f ] ;
BUILTIN: alien 16 ;
BUILTIN: byte-array 19 ;
BUILTIN: displaced-alien 20 ;
: NULL ( -- null )
#! C null value.
0 <alien> ;
: null? ( alien -- ? ) dup [ alien-address 0 = ] when ;
: null>f ( alien -- alien/f )
dup alien-address 0 = [ drop f ] when ;
M: alien hashcode ( obj -- n )
alien-address >fixnum ;
M: alien = ( obj obj -- ? )
over alien? [
alien-address swap alien-address =
] [
2drop f
] ifte ;
: ALIEN: scan <alien> swons ; parsing
M: alien prettyprint* ( alien -- str )
\ ALIEN: word-bl alien-address unparse write ;
M: dll unparse ( obj -- str )
[ "DLL\" " , dll-path unparse-string CHAR: " , ] make-string ;
: DLL" skip-blank parse-string dlopen swons ; parsing
: library ( name -- object )
dup [ "libraries" get hash ] when ;
: load-dll ( name -- dll )
#! Higher level wrapper around dlopen primitive.
library dup [
[
"dll" get dup [
drop "name" get dlopen dup "dll" set
] unless
] bind
] when ;
: add-library ( library name abi -- )
"libraries" get [
<namespace> [
"abi" set
"name" set
] extend put
] bind ;
: library-abi ( library -- abi )
library [ [ "abi" get ] bind ] [ "cdecl" ] ifte* ;

87
library/compiler/alien-types.factor → library/alien/c-types.factor
View File

@ -1,29 +1,8 @@
! Copyright (C) 2004, 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: alien
USING: assembler compiler errors hashtables kernel lists math
namespaces parser strings words ;
! Some code for interfacing with C structures.
: BEGIN-ENUM:
#! C-style enumerations. Their use is not encouraged unless
#! it is for C library interfaces. Used like this:
#!
#! BEGIN-ENUM 0
#! ENUM: x
#! ENUM: y
#! ENUM: z
#! END-ENUM
#!
#! This is the same as : x 0 ; : y 1 ; : z 2 ;.
scan str>number ; parsing
: ENUM:
dup CREATE swap unit define-compound 1 + ; parsing
: END-ENUM
drop ; parsing
USING: assembler errors hashtables kernel namespaces parser
strings ;
: <c-type> ( -- type )
<namespace> [
@ -46,67 +25,7 @@ SYMBOL: c-types
: define-c-type ( quot name -- )
c-types get [ >r <c-type> swap extend r> set ] bind ; inline
: define-getter ( offset type name -- )
#! Define a word with stack effect ( alien -- obj ) in the
#! current 'in' vocabulary.
create-in >r
[ "getter" get ] bind cons r> swap define-compound ;
: define-setter ( offset type name -- )
#! Define a word with stack effect ( obj alien -- ) in the
#! current 'in' vocabulary.
"set-" swap cat2 create-in >r
[ "setter" get ] bind cons r> swap define-compound ;
: define-field ( offset type name -- offset )
>r c-type dup >r [ "align" get ] bind align r> r>
"struct-name" get swap "-" swap cat3
( offset type name -- )
3dup define-getter 3dup define-setter
drop [ "width" get ] bind + ;
: define-member ( max type -- max )
c-type [ "width" get ] bind max ;
: define-constructor ( width -- )
#! Make a word <foo> where foo is the structure name that
#! allocates a Factor heap-local instance of this structure.
#! Used for C functions that expect you to pass in a struct.
[ <local-alien> ] cons
[ "<" , "struct-name" get , ">" , ] make-string
create-in swap
define-compound ;
: define-struct-type ( width -- )
#! Define inline and pointer type for the struct. Pointer
#! type is exactly like void*.
[ "width" set ] "struct-name" get define-c-type
"void*" c-type "struct-name" get "*" cat2
c-types get set-hash ;
: BEGIN-STRUCT: ( -- offset )
scan "struct-name" set 0 ; parsing
: FIELD: ( offset -- offset )
scan scan define-field ; parsing
: END-STRUCT ( length -- )
dup define-constructor define-struct-type ; parsing
: BEGIN-UNION: ( -- max )
scan "struct-name" set 0 ; parsing
: MEMBER: ( max -- max )
scan define-member ; parsing
: END-UNION ( max -- )
dup define-constructor define-struct-type ; parsing
: NULL ( -- null )
#! C null value.
0 <alien> ;
global [ <namespace> c-types set ] bind
[

64
library/compiler/alien.factor → library/alien/compiler.factor
View File

@ -1,9 +1,8 @@
! Copyright (C) 2004, 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: alien
USING: assembler compiler errors generic hashtables
inference interpreter kernel lists math namespaces parser
prettyprint sequences stdio strings unparser words ;
USING: assembler errors generic inference kernel lists math
namespaces sequences stdio strings words ;
! ! ! WARNING ! ! !
! Reloading this file into a running Factor instance on Win32
@ -24,70 +23,11 @@ prettyprint sequences stdio strings unparser words ;
! parameter, or a missing abi parameter indicates the cdecl ABI
! should be used, which is common on Unix.
: null? ( alien -- ? ) dup [ alien-address 0 = ] when ;
: null>f ( alien -- alien/f )
dup alien-address 0 = [ drop f ] when ;
M: alien hashcode ( obj -- n )
alien-address >fixnum ;
M: alien = ( obj obj -- ? )
over alien? [
over local-alien? over local-alien? or [
eq?
] [
alien-address swap alien-address =
] ifte
] [
2drop f
] ifte ;
: ALIEN: scan <alien> swons ; parsing
: LOCAL-ALIEN: "Local aliens are not readable" throw ; parsing
M: alien prettyprint* ( alien -- str )
dup local-alien? [
\ LOCAL-ALIEN:
] [
\ ALIEN:
] ifte word-bl alien-address unparse write ;
M: dll unparse ( obj -- str )
[ "DLL\" " , dll-path unparse-string CHAR: " , ] make-string ;
: DLL" skip-blank parse-string dlopen swons ; parsing
: library ( name -- object )
dup [ "libraries" get hash ] when ;
: load-dll ( name -- dll )
#! Higher level wrapper around dlopen primitive.
library dup [
[
"dll" get dup [
drop "name" get dlopen dup "dll" set
] unless
] bind
] when ;
: add-library ( library name abi -- )
"libraries" get [
<namespace> [
"abi" set
"name" set
] extend put
] bind ;
SYMBOL: #cleanup ( unwind stack by parameter )
SYMBOL: #unbox ( move top of datastack to C stack )
SYMBOL: #box ( move EAX to datastack )
: library-abi ( library -- abi )
library [ [ "abi" get ] bind ] [ "cdecl" ] ifte* ;
SYMBOL: #alien-invoke
SYMBOL: #alien-global

23
library/alien/enums.factor Normal file
View File

@ -0,0 +1,23 @@
! Copyright (C) 2004, 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: alien
USING: kernel lists math parser words ;
: BEGIN-ENUM:
#! C-style enumerations. Their use is not encouraged unless
#! it is for C library interfaces. Used like this:
#!
#! BEGIN-ENUM 0
#! ENUM: x
#! ENUM: y
#! ENUM: z
#! END-ENUM
#!
#! This is the same as : x 0 ; : y 1 ; : z 2 ;.
scan str>number ; parsing
: ENUM:
dup CREATE swap unit define-compound 1 + ; parsing
: END-ENUM
drop ; parsing

63
library/alien/structs.factor Normal file
View File

@ -0,0 +1,63 @@
! Copyright (C) 2004, 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: alien
USING: assembler compiler errors hashtables kernel lists math
namespaces parser strings words ;
! Some code for interfacing with C structures.
: define-getter ( offset type name -- )
#! Define a word with stack effect ( alien -- obj ) in the
#! current 'in' vocabulary.
create-in >r
[ "getter" get ] bind cons r> swap define-compound ;
: define-setter ( offset type name -- )
#! Define a word with stack effect ( obj alien -- ) in the
#! current 'in' vocabulary.
"set-" swap cat2 create-in >r
[ "setter" get ] bind cons r> swap define-compound ;
: define-field ( offset type name -- offset )
>r c-type dup >r [ "align" get ] bind align r> r>
"struct-name" get swap "-" swap cat3
( offset type name -- )
3dup define-getter 3dup define-setter
drop [ "width" get ] bind + ;
: define-member ( max type -- max )
c-type [ "width" get ] bind max ;
: define-constructor ( width -- )
#! Make a word <foo> where foo is the structure name that
#! allocates a Factor heap-local instance of this structure.
#! Used for C functions that expect you to pass in a struct.
[ <byte-array> ] cons
[ "<" , "struct-name" get , ">" , ] make-string
create-in swap
define-compound ;
: define-struct-type ( width -- )
#! Define inline and pointer type for the struct. Pointer
#! type is exactly like void*.
[ "width" set ] "struct-name" get define-c-type
"void*" c-type "struct-name" get "*" cat2
c-types get set-hash ;
: BEGIN-STRUCT: ( -- offset )
scan "struct-name" set 0 ; parsing
: FIELD: ( offset -- offset )
scan scan define-field ; parsing
: END-STRUCT ( length -- )
dup define-constructor define-struct-type ; parsing
: BEGIN-UNION: ( -- max )
scan "struct-name" set 0 ; parsing
: MEMBER: ( max -- max )
scan define-member ; parsing
: END-UNION ( max -- )
dup define-constructor define-struct-type ; parsing

1
library/bootstrap/boot-stage1.factor
View File

@ -54,6 +54,7 @@ hashtables ;
"/library/syntax/prettyprint.factor"
"/library/io/files.factor"
"/library/cli.factor"
"/library/alien/aliens.factor"
] pull-in
"delegate" [ "generic" ] search

5
library/bootstrap/boot-stage2.factor
View File

@ -38,8 +38,9 @@ t [
"/library/compiler/simplifier.factor"
"/library/compiler/generator.factor"
"/library/compiler/compiler.factor"
"/library/compiler/alien-types.factor"
"/library/compiler/alien.factor"
"/library/alien/c-types.factor"
"/library/alien/compiler.factor"
] pull-in
cpu "x86" = [

3
library/bootstrap/boot-stage3.factor
View File

@ -14,6 +14,9 @@ unparser ;
] when
t [
"/library/alien/enums.factor"
"/library/alien/structs.factor"
"/library/math/constants.factor"
"/library/math/pow.factor"
"/library/math/trig-hyp.factor"

4
library/bootstrap/primitives.factor
View File

@ -181,7 +181,8 @@ vocabularies get [
[ "dlsym" "alien" [ [ string object ] [ integer ] ] ]
[ "dlclose" "alien" [ [ dll ] [ ] ] ]
[ "<alien>" "alien" [ [ integer ] [ alien ] ] ]
[ "<local-alien>" "alien" [ [ integer ] [ alien ] ] ]
[ "<byte-array>" "alien" [ [ integer ] [ byte-array ] ] ]
[ "<displaced-alien>" "alien" [ [ integer object ] [ displaced-alien ] ] ]
[ "alien-signed-cell" "alien" [ [ alien integer ] [ integer ] ] ]
[ "set-alien-signed-cell" "alien" [ [ integer alien integer ] [ ] ] ]
[ "alien-unsigned-cell" "alien" [ [ alien integer ] [ integer ] ] ]
@ -206,7 +207,6 @@ vocabularies get [
[ "throw" "errors" [ [ object ] [ ] ] ]
[ "string>memory" "kernel-internals" [ [ string integer ] [ ] ] ]
[ "memory>string" "kernel-internals" [ [ integer integer ] [ string ] ] ]
[ "local-alien?" "alien" [ [ alien ] [ object ] ] ]
[ "alien-address" "alien" [ [ alien ] [ integer ] ] ]
[ "slot" "kernel-internals" [ [ object fixnum ] [ object ] ] ]
[ "set-slot" "kernel-internals" [ [ object object fixnum ] [ ] ] ]

9
library/kernel.factor
View File

@ -29,7 +29,7 @@ M: object clone ;
: num-types ( -- n )
#! One more than the maximum value from type primitive.
19 ;
21 ;
: ? ( cond t f -- t/f )
#! Push t if cond is true, otherwise push f.
@ -41,10 +41,3 @@ M: object clone ;
: not ( a -- ~a ) f t ? ; inline
: or ( a b -- a|b ) t swap ? ; inline
: xor ( a b -- a^b ) dup not swap ? ; inline
IN: alien
! See compiler/alien.factor for the rest; this needs to be here
! since primitive stack effects involve alien inputs/outputs.
BUILTIN: dll 15 [ 1 "dll-path" f ] ;
BUILTIN: alien 16 ;

9
library/sequences-epilogue.factor
View File

@ -58,6 +58,15 @@ M: sequence = ( obj seq -- ? )
: >pop> ( stack -- stack ) dup pop drop ;
GENERIC: (tree-each) ( quot obj -- ) inline
M: object (tree-each) swap call ;
M: cons (tree-each) [ car (tree-each) ] 2keep cdr (tree-each) ;
M: f (tree-each) swap call ;
M: sequence (tree-each) [ swap call ] seq-each-with ;
: tree-each swap (tree-each) ; inline
: tree-each-with ( obj vector quot -- )
swap [ with ] tree-each 2drop ; inline
IN: kernel
: depth ( -- n )

2
library/test/alien.factor
View File

@ -6,10 +6,8 @@ USE: inference
[ t ] [ 0 <alien> 0 <alien> = ] unit-test
[ f ] [ 0 <alien> local-alien? ] unit-test
[ f ] [ 0 <alien> 1024 <local-alien> = ] unit-test
[ f ] [ 0 <alien> 1024 <alien> = ] unit-test
[ f ] [ "hello" 1024 <alien> = ] unit-test
[ t ] [ 1024 <local-alien> local-alien? ] unit-test
! : alien-inference-1
! "void" "foobar" "boo" [ "short" "short" ] alien-invoke ;

2
library/ui/paint.factor
View File

@ -9,7 +9,7 @@ stdio strings ;
SYMBOL: clip
: intersect* ( gadget rect quot -- t1 t2 )
call >r >r max r> r> min 2dup > [ drop dup ] when ;
call >r >r max r> r> min 2dup > [ drop dup ] when ; inline
: intersect-x ( gadget rect -- x1 x2 )
[

2
library/win32/winsock.factor
View File

@ -29,7 +29,7 @@ IN: win32-api
USE: alien
USE: kernel
: <wsadata> HEX: 190 <local-alien> ;
: <wsadata> HEX: 190 <byte-array> ;
: AF_INET 2 ;
: SOCK_STREAM 1 ;

10
library/words.factor
View File

@ -4,16 +4,6 @@ IN: words
USING: generic hashtables kernel kernel-internals lists math
namespaces sequences strings vectors ;
! Utility
GENERIC: (tree-each) ( quot obj -- ) inline
M: object (tree-each) swap call ;
M: cons (tree-each) [ car (tree-each) ] 2keep cdr (tree-each) ;
M: f (tree-each) swap call ;
M: sequence (tree-each) [ swap call ] seq-each-with ;
: tree-each swap (tree-each) ; inline
: tree-each-with ( obj vector quot -- )
swap [ with ] tree-each 2drop ; inline
! The basic word type. Words can be named and compared using
! identity. They hold a property map.
BUILTIN: word 17

114
native/alien.c Normal file
View File

@ -0,0 +1,114 @@
#include "factor.h"
INLINE void* alien_offset(CELL object)
{
ALIEN *alien;
F_ARRAY *array;
DISPLACED_ALIEN *d;
switch(type_of(object))
{
case ALIEN_TYPE:
alien = untag_alien_fast(object);
if(alien->expired)
general_error(ERROR_EXPIRED,object);
return alien->ptr;
case BYTE_ARRAY_TYPE:
array = untag_byte_array_fast(object);
return array + sizeof(F_ARRAY);
case DISPLACED_ALIEN_TYPE:
d = untag_displaced_alien_fast(object);
return alien_offset(d->alien) + d->displacement;
default:
type_error(ALIEN_TYPE,object);
return (void*)-1; /* can't happen */
}
}
INLINE void* alien_pointer(void)
{
F_FIXNUM offset = unbox_signed_cell();
return alien_offset(dpop()) + offset;
}
void* unbox_alien(void)
{
return alien_offset(dpop());
}
void box_alien(void* ptr)
{
ALIEN* alien = allot_object(ALIEN_TYPE,sizeof(ALIEN));
alien->ptr = ptr;
alien->expired = false;
dpush(tag_object(alien));
}
void primitive_alien(void)
{
void* ptr = (void*)unbox_signed_cell();
maybe_garbage_collection();
box_alien(ptr);
}
void primitive_displaced_alien(void)
{
CELL alien;
CELL displacement;
DISPLACED_ALIEN* d;
maybe_garbage_collection();
alien = dpop();
displacement = unbox_unsigned_cell();
d = allot_object(DISPLACED_ALIEN_TYPE,sizeof(DISPLACED_ALIEN));
d->alien = alien;
d->displacement = displacement;
dpush(tag_object(d));
}
void primitive_alien_address(void)
{
box_unsigned_cell((CELL)alien_offset(dpop()));
}
void fixup_alien(ALIEN* alien)
{
alien->expired = true;
}
void fixup_displaced_alien(DISPLACED_ALIEN* d)
{
data_fixup(&d->alien);
}
void collect_displaced_alien(DISPLACED_ALIEN* d)
{
COPY_OBJECT(d->alien);
}
#define DEF_ALIEN_SLOT(name,type,boxer) \
void primitive_alien_##name (void) \
{ \
box_##boxer (*(type*)alien_pointer()); \
} \
void primitive_set_alien_##name (void) \
{ \
type* ptr = alien_pointer(); \
type value = unbox_##boxer (); \
*ptr = value; \
}
DEF_ALIEN_SLOT(signed_cell,int,signed_cell)
DEF_ALIEN_SLOT(unsigned_cell,CELL,unsigned_cell)
DEF_ALIEN_SLOT(signed_8,s64,signed_8)
DEF_ALIEN_SLOT(unsigned_8,u64,unsigned_8)
DEF_ALIEN_SLOT(signed_4,s32,signed_4)
DEF_ALIEN_SLOT(unsigned_4,u32,unsigned_4)
DEF_ALIEN_SLOT(signed_2,s16,signed_2)
DEF_ALIEN_SLOT(unsigned_2,u16,unsigned_2)
DEF_ALIEN_SLOT(signed_1,BYTE,signed_1)
DEF_ALIEN_SLOT(unsigned_1,BYTE,unsigned_1)
void primitive_alien_value_string(void)
{
box_c_string(alien_pointer());
}

45
native/ffi.h → native/alien.h
View File

@ -1,43 +1,36 @@
typedef struct {
CELL header;
/* tagged string */
CELL path;
/* OS-specific handle */
void* dll;
} DLL;
DLL* untag_dll(CELL tagged);
typedef struct {
CELL header;
void* ptr;
/* local aliens are heap-allocated as strings and must be collected. */
bool local;
bool expired;
} ALIEN;
INLINE ALIEN* untag_alien(CELL tagged)
INLINE ALIEN* untag_alien_fast(CELL tagged)
{
type_check(ALIEN_TYPE,tagged);
return (ALIEN*)UNTAG(tagged);
}
void ffi_dlopen(DLL *dll);
void *ffi_dlsym(DLL *dll, F_STRING *symbol);
void ffi_dlclose(DLL *dll);
typedef struct {
CELL header;
CELL alien;
CELL displacement;
} DISPLACED_ALIEN;
INLINE DISPLACED_ALIEN* untag_displaced_alien_fast(CELL tagged)
{
return (DISPLACED_ALIEN*)UNTAG(tagged);
}
void primitive_dlopen(void);
void primitive_dlsym(void);
void primitive_dlclose(void);
void primitive_alien(void);
void primitive_local_alien(void);
void fixup_dll(DLL* dll);
void collect_dll(DLL* dll);
void primitive_displaced_alien(void);
void primitive_alien_address(void);
void fixup_alien(ALIEN* alien);
void collect_alien(ALIEN* alien);
void fixup_displaced_alien(DISPLACED_ALIEN* d);
void collect_displaced_alien(DISPLACED_ALIEN* d);
DLLEXPORT void* unbox_alien(void);
DLLEXPORT void box_alien(void* ptr);
void primitive_local_alienp(void);
void primitive_alien_address(void);
void primitive_alien_signed_cell(void);
void primitive_set_alien_signed_cell(void);
void primitive_alien_unsigned_cell(void);

8
native/array.c
View File

@ -32,6 +32,12 @@ void primitive_tuple(void)
dpush(tag_object(array(TUPLE_TYPE,to_fixnum(dpop()),F)));
}
void primitive_byte_array(void)
{
maybe_garbage_collection();
dpush(tag_object(array(BYTE_ARRAY_TYPE,to_fixnum(dpop()),0)));
}
F_ARRAY* grow_array(F_ARRAY* array, CELL capacity, CELL fill)
{
/* later on, do an optimization: if end of array is here, just grow */
@ -50,7 +56,7 @@ void primitive_grow_array(void)
{
F_ARRAY* array; CELL capacity;
maybe_garbage_collection();
array = untag_array(dpop());
array = untag_array_fast(dpop());
capacity = to_fixnum(dpop());
dpush(tag_object(grow_array(array,capacity,F)));
}

11
native/array.h
View File

@ -4,16 +4,23 @@ typedef struct {
CELL capacity;
} F_ARRAY;
INLINE F_ARRAY* untag_array(CELL tagged)
INLINE F_ARRAY* untag_array_fast(CELL tagged)
{
return (F_ARRAY*)UNTAG(tagged);
}
INLINE F_ARRAY* untag_byte_array_fast(CELL tagged)
{
type_check(ARRAY_TYPE,tagged);
return (F_ARRAY*)UNTAG(tagged);
}
F_ARRAY* allot_array(CELL type, CELL capacity);
F_ARRAY* array(CELL type, CELL capacity, CELL fill);
void primitive_array(void);
void primitive_tuple(void);
void primitive_byte_array(void);
F_ARRAY* grow_array(F_ARRAY* array, CELL capacity, CELL fill);
void primitive_grow_array(void);
F_ARRAY* shrink_array(F_ARRAY* array, CELL capacity);

2
native/debug.c
View File

@ -60,7 +60,7 @@ CELL hash(CELL hash, CELL key)
return F;
}
a = untag_array(array);
a = untag_array_fast(array);
for(i = 0; i < array_capacity(a); i++)
{

57
native/dll.c Normal file
View File

@ -0,0 +1,57 @@
#include "factor.h"
void primitive_dlopen(void)
{
DLL* dll;
F_STRING* path;
maybe_garbage_collection();
path = untag_string(dpop());
dll = allot_object(DLL_TYPE,sizeof(DLL));
dll->path = tag_object(path);
ffi_dlopen(dll);
dpush(tag_object(dll));
}
void primitive_dlsym(void)
{
CELL dll;
F_STRING* sym;
maybe_garbage_collection();
dll = dpop();
sym = untag_string(dpop());
dpush(tag_cell((CELL)ffi_dlsym(
dll == F ? NULL : untag_dll(dll),
sym)));
}
void primitive_dlclose(void)
{
maybe_garbage_collection();
ffi_dlclose(untag_dll(dpop()));
}
DLL* untag_dll(CELL tagged)
{
DLL* dll = (DLL*)UNTAG(tagged);
type_check(DLL_TYPE,tagged);
if(dll->dll == NULL)
general_error(ERROR_EXPIRED,tagged);
return (DLL*)UNTAG(tagged);
}
void fixup_dll(DLL* dll)
{
data_fixup(&dll->path);
ffi_dlopen(dll);
}
void collect_dll(DLL* dll)
{
COPY_OBJECT(dll->path);
}

20
native/dll.h Normal file
View File

@ -0,0 +1,20 @@
typedef struct {
CELL header;
/* tagged string */
CELL path;
/* OS-specific handle */
void* dll;
} DLL;
DLL* untag_dll(CELL tagged);
void ffi_dlopen(DLL *dll);
void *ffi_dlsym(DLL *dll, F_STRING *symbol);
void ffi_dlclose(DLL *dll);
void primitive_dlopen(void);
void primitive_dlsym(void);
void primitive_dlclose(void);
void fixup_dll(DLL* dll);
void collect_dll(DLL* dll);

3
native/factor.h
View File

@ -144,7 +144,8 @@ typedef unsigned char BYTE;
#include "stack.h"
#include "compiler.h"
#include "relocate.h"
#include "ffi.h"
#include "alien.h"
#include "dll.h"
#include "debug.h"
#endif /* __FACTOR_H__ */

159
native/ffi.c
View File

@ -1,159 +0,0 @@
#include "factor.h"
void foo(int fd) { close(fd); }
void primitive_dlopen(void)
{
DLL* dll;
F_STRING* path;
maybe_garbage_collection();
path = untag_string(dpop());
dll = allot_object(DLL_TYPE,sizeof(DLL));
dll->path = tag_object(path);
ffi_dlopen(dll);
dpush(tag_object(dll));
}
void primitive_dlsym(void)
{
CELL dll;
F_STRING* sym;
maybe_garbage_collection();
dll = dpop();
sym = untag_string(dpop());
dpush(tag_cell((CELL)ffi_dlsym(
dll == F ? NULL : untag_dll(dll),
sym)));
}
void primitive_dlclose(void)
{
maybe_garbage_collection();
ffi_dlclose(untag_dll(dpop()));
}
DLL* untag_dll(CELL tagged)
{
DLL* dll = (DLL*)UNTAG(tagged);
type_check(DLL_TYPE,tagged);
if(dll->dll == NULL)
general_error(ERROR_EXPIRED,tagged);
return (DLL*)UNTAG(tagged);
}
void* unbox_alien(void)
{
return untag_alien(dpop())->ptr;
}
void box_alien(void* ptr)
{
ALIEN* alien = allot_object(ALIEN_TYPE,sizeof(ALIEN));
alien->ptr = ptr;
alien->local = false;
dpush(tag_object(alien));
}
INLINE void* alien_pointer(void)
{
F_FIXNUM offset = unbox_signed_cell();
ALIEN* alien = untag_alien(dpop());
void* ptr = alien->ptr;
if(ptr == NULL)
general_error(ERROR_EXPIRED,tag_object(alien));
return ptr + offset;
}
void primitive_alien(void)
{
void* ptr = (void*)unbox_signed_cell();
maybe_garbage_collection();
box_alien(ptr);
}
void primitive_local_alien(void)
{
F_FIXNUM length = unbox_signed_cell();
ALIEN* alien;
F_STRING* local;
if(length < 0)
general_error(ERROR_NEGATIVE_ARRAY_SIZE,tag_fixnum(length));
maybe_garbage_collection();
alien = allot_object(ALIEN_TYPE,sizeof(ALIEN));
local = string(length / CHARS,'\0');
alien->ptr = (void*)(local + 1);
alien->local = true;
dpush(tag_object(alien));
}
void primitive_local_alienp(void)
{
box_boolean(untag_alien(dpop())->local);
}
void primitive_alien_address(void)
{
box_unsigned_cell((CELL)untag_alien(dpop())->ptr);
}
void fixup_dll(DLL* dll)
{
data_fixup(&dll->path);
ffi_dlopen(dll);
}
void collect_dll(DLL* dll)
{
COPY_OBJECT(dll->path);
}
void fixup_alien(ALIEN* alien)
{
alien->ptr = NULL;
}
void collect_alien(ALIEN* alien)
{
if(alien->local && alien->ptr != NULL)
{
F_STRING* ptr = (F_STRING*)(alien->ptr - sizeof(F_STRING));
ptr = copy_untagged_object(ptr,SSIZE(ptr));
alien->ptr = (void*)(ptr + 1);
}
}
#define DEF_ALIEN_SLOT(name,type,boxer) \
void primitive_alien_##name (void) \
{ \
box_##boxer (*(type*)alien_pointer()); \
} \
void primitive_set_alien_##name (void) \
{ \
type* ptr = alien_pointer(); \
type value = unbox_##boxer (); \
*ptr = value; \
}
DEF_ALIEN_SLOT(signed_cell,int,signed_cell)
DEF_ALIEN_SLOT(unsigned_cell,CELL,unsigned_cell)
DEF_ALIEN_SLOT(signed_8,s64,signed_8)
DEF_ALIEN_SLOT(unsigned_8,u64,unsigned_8)
DEF_ALIEN_SLOT(signed_4,s32,signed_4)
DEF_ALIEN_SLOT(unsigned_4,u32,unsigned_4)
DEF_ALIEN_SLOT(signed_2,s16,signed_2)
DEF_ALIEN_SLOT(unsigned_2,u16,unsigned_2)
DEF_ALIEN_SLOT(signed_1,BYTE,signed_1)
DEF_ALIEN_SLOT(unsigned_1,BYTE,unsigned_1)
void primitive_alien_value_string(void)
{
box_c_string(alien_pointer());
}

6
native/gc.c
View File

@ -79,12 +79,12 @@ INLINE void collect_object(CELL scan)
case PORT_TYPE:
collect_port((F_PORT*)scan);
break;
case ALIEN_TYPE:
collect_alien((ALIEN*)scan);
break;
case DLL_TYPE:
collect_dll((DLL*)scan);
break;
case DISPLACED_ALIEN_TYPE:
collect_displaced_alien((DISPLACED_ALIEN*)scan);
break;
}
}

4
native/primitives.c
View File

@ -145,7 +145,8 @@ void* primitives[] = {
primitive_dlsym,
primitive_dlclose,
primitive_alien,
primitive_local_alien,
primitive_byte_array,
primitive_displaced_alien,
primitive_alien_signed_cell,
primitive_set_alien_signed_cell,
primitive_alien_unsigned_cell,
@ -170,7 +171,6 @@ void* primitives[] = {
primitive_throw,
primitive_string_to_memory,
primitive_memory_to_string,
primitive_local_alienp,
primitive_alien_address,
primitive_slot,
primitive_set_slot,

3
native/relocate.c
View File

@ -32,6 +32,9 @@ void relocate_object(CELL relocating)
case ALIEN_TYPE:
fixup_alien((ALIEN*)relocating);
break;
case DISPLACED_ALIEN_TYPE:
fixup_displaced_alien((DISPLACED_ALIEN*)relocating);
break;
}
}

4
native/stack.c
View File

@ -75,7 +75,7 @@ F_VECTOR* stack_to_vector(CELL bottom, CELL top)
{
CELL depth = (top - bottom + CELLS) / CELLS;
F_VECTOR* v = vector(depth);
F_ARRAY* a = untag_array(v->array);
F_ARRAY* a = untag_array_fast(v->array);
memcpy(a + 1,(void*)bottom,depth * CELLS);
v->top = tag_fixnum(depth);
return v;
@ -98,7 +98,7 @@ CELL vector_to_stack(F_VECTOR* vector, CELL bottom)
{
CELL start = bottom;
CELL len = untag_fixnum_fast(vector->top) * CELLS;
memcpy((void*)start,untag_array(vector->array) + 1,len);
memcpy((void*)start,untag_array_fast(vector->array) + 1,len);
return start + len - CELLS;
}

6
native/types.c
View File

@ -52,8 +52,9 @@ CELL untagged_object_size(CELL pointer)
size = CELLS * 2;
break;
case ARRAY_TYPE:
case BIGNUM_TYPE:
case TUPLE_TYPE:
case BIGNUM_TYPE:
case BYTE_ARRAY_TYPE:
size = align8(sizeof(F_ARRAY) +
array_capacity((F_ARRAY*)(pointer)) * CELLS);
break;
@ -81,6 +82,9 @@ CELL untagged_object_size(CELL pointer)
case ALIEN_TYPE:
size = sizeof(ALIEN);
break;
case DISPLACED_ALIEN_TYPE:
size = sizeof(DISPLACED_ALIEN);
break;
default:
critical_error("Cannot determine size",pointer);
size = -1;/* can't happen */

4
native/types.h
View File

@ -36,8 +36,10 @@ CELL T;
#define ALIEN_TYPE 16
#define WORD_TYPE 17
#define TUPLE_TYPE 18
#define BYTE_ARRAY_TYPE 19
#define DISPLACED_ALIEN_TYPE 20
#define TYPE_COUNT 19
#define TYPE_COUNT 21
INLINE bool headerp(CELL cell)
{