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

Runtime code cleanups

slava 2006-05-18 05:08:09 +00:00
parent c753fc98d0
commit fab5b6adb0
15 changed files with 143 additions and 184 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
library/bootstrap/image.factor
View File

@ -30,11 +30,11 @@ IN: image
: vector-type 11 ; inline
: string-type 12 ; inline
: sbuf-type 13 ; inline
: wrapper-type 14 ; inline
: word-type 16 ; inline
: quotation-type 14 ; inline
: dll-type 15 ; inline
: alien-type 16 ; inline
: tuple-type 17 ; inline
: byte-array-type 18 ; inline
: quotation-type 19 ; inline
: base 1024 ;
@ -179,7 +179,7 @@ M: f ' ( obj -- ptr )
dup word-props ' ,
0 ,
] { } make
word-type object-tag [ emit-seq ] emit-object
word-tag word-tag [ emit-seq ] emit-object
swap objects get set-hash ;
: word-error ( word msg -- )
@ -203,7 +203,7 @@ M: word ' ( word -- pointer ) ;
( Wrappers )
M: wrapper ' ( wrapper -- pointer )
wrapped ' wrapper-type object-tag [ emit ] emit-object ;
wrapped ' wrapper-tag wrapper-tag [ emit ] emit-object ;
( Ratios and complexes )

88
library/bootstrap/primitives.factor
View File

@ -267,6 +267,42 @@ num-types f <array> builtins set
"bignum" "math" create 1 "bignum?" "math" create { } define-builtin
"bignum" "math" create ">bignum" "math" lookup unit "coercer" set-word-prop
"word?" "words" create t "inline" set-word-prop
"word" "words" create 2 "word?" "words" create
{
{ 1 fixnum { "hashcode" "kernel" } f }
{
2
object
{ "word-name" "words" }
f
}
{
3
object
{ "word-vocabulary" "words" }
{ "set-word-vocabulary" "words" }
}
{
4
object
{ "word-primitive" "words" }
{ "set-word-primitive" "words" }
}
{
5
object
{ "word-def" "words" }
{ "set-word-def" "words" }
}
{
6
object
{ "word-props" "words" }
{ "set-word-props" "words" }
}
} define-builtin
"ratio?" "math" create t "inline" set-word-prop
"ratio" "math" create 4 "ratio?" "math" create
{
@ -285,8 +321,9 @@ num-types f <array> builtins set
{ 2 real { "imaginary" "math" } f }
} define-builtin
"alien" "alien" create 7 "alien?" "alien" create
{ { 1 object { "underlying-alien" "alien" } f } } define-builtin
"wrapper?" "kernel" create t "inline" set-word-prop
"wrapper" "kernel" create 7 "wrapper?" "kernel" create
{ { 1 object { "wrapped" "kernel" } f } } define-builtin
"array?" "arrays" create t "inline" set-word-prop
"array" "arrays" create 8 "array?" "arrays" create
@ -365,49 +402,16 @@ num-types f <array> builtins set
}
} define-builtin
"wrapper?" "kernel" create t "inline" set-word-prop
"wrapper" "kernel" create 14 "wrapper?" "kernel" create
{ { 1 object { "wrapped" "kernel" } f } } define-builtin
"quotation?" "kernel" create t "inline" set-word-prop
"quotation" "kernel" create 14 "quotation?" "kernel" create
{ } define-builtin
"dll?" "alien" create t "inline" set-word-prop
"dll" "alien" create 15 "dll?" "alien" create
{ { 1 object { "dll-path" "alien" } f } } define-builtin
"word?" "words" create t "inline" set-word-prop
"word" "words" create 16 "word?" "words" create
{
{ 1 fixnum { "hashcode" "kernel" } f }
{
2
object
{ "word-name" "words" }
f
}
{
3
object
{ "word-vocabulary" "words" }
{ "set-word-vocabulary" "words" }
}
{
4
object
{ "word-primitive" "words" }
{ "set-word-primitive" "words" }
}
{
5
object
{ "word-def" "words" }
{ "set-word-def" "words" }
}
{
6
object
{ "word-props" "words" }
{ "set-word-props" "words" }
}
} define-builtin
"alien" "alien" create 16 "alien?" "alien" create
{ { 1 object { "underlying-alien" "alien" } f } } define-builtin
"tuple?" "kernel" create t "inline" set-word-prop
"tuple" "kernel" create 17 "tuple?" "kernel" create
@ -418,10 +422,6 @@ num-types f <array> builtins set
"byte-array?" "arrays" create
{ } define-builtin
"quotation?" "kernel" create t "inline" set-word-prop
"quotation" "kernel" create 19 "quotation?" "kernel" create
{ } define-builtin
! Define general-t type, which is any object that is not f.
"general-t" "kernel" create dup define-symbol
f "f" "!syntax" lookup builtins get remove [ ] subset

2
library/continuations.factor
View File

@ -9,7 +9,7 @@ IN: errors
USING: kernel kernel-internals ;
: catchstack ( -- cs ) catchstack* clone ; inline
: set-catchstack ( cs -- ) clone 6 setenv ; inline
: set-catchstack ( cs -- ) >vector 6 setenv ; inline
IN: kernel
USING: namespaces sequences ;

15
library/kernel.factor
View File

@ -23,8 +23,6 @@ M: object clone ;
: set-boot ( quot -- ) 8 setenv ;
: num-types ( -- n ) 20 ; inline
: ? ( cond t f -- t/f ) rot [ drop ] [ nip ] if ; inline
: >boolean t f ? ; inline
@ -67,15 +65,6 @@ inline
: keep-datastack datastack slip set-datastack drop ; inline
M: wrapper =
over wrapper? [ [ wrapped ] 2apply = ] [ 2drop f ] if ;
GENERIC: literalize ( obj -- obj )
M: object literalize ;
M: wrapper literalize <wrapper> ;
IN: kernel-internals
! These words are unsafe. Don't use them.
@ -88,17 +77,19 @@ IN: kernel-internals
: make-tuple <tuple> [ 2 set-slot ] keep ; flushable
! Some runtime implementation details
: num-types 19 ; inline
: tag-mask BIN: 111 ; inline
: num-tags 8 ; inline
: tag-bits 3 ; inline
: fixnum-tag BIN: 000 ; inline
: bignum-tag BIN: 001 ; inline
: cons-tag BIN: 010 ; inline
: word-tag BIN: 010 ; inline
: object-tag BIN: 011 ; inline
: ratio-tag BIN: 100 ; inline
: float-tag BIN: 101 ; inline
: complex-tag BIN: 110 ; inline
: wrapper-tag BIN: 111 ; inline
: cell 17 getenv ; foldable

13
library/quotations.factor
View File

@ -1,8 +1,11 @@
! Copyright (C) 2006 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
IN: kernel
USING: arrays kernel-internals math namespaces sequences
sequences-internals ;
USING: arrays generic kernel-internals math namespaces sequences
sequences-internals words ;
M: wrapper =
over wrapper? [ [ wrapped ] 2apply = ] [ 2drop f ] if ;
M: quotation clone (clone) ;
M: quotation length array-capacity ;
@ -10,7 +13,6 @@ M: quotation nth bounds-check nth-unsafe ;
M: quotation set-nth bounds-check set-nth-unsafe ;
M: quotation nth-unsafe >r >fixnum r> array-nth ;
M: quotation set-nth-unsafe >r >fixnum r> set-array-nth ;
M: quotation resize resize-array ;
: >quotation ( seq -- array ) [ <quotation> ] >sequence ; inline
@ -21,6 +23,11 @@ M: quotation like drop dup quotation? [ >quotation ] unless ;
: unit ( a -- [ a ] ) 1array >quotation ;
GENERIC: literalize ( obj -- obj )
M: object literalize ;
M: word literalize <wrapper> ;
M: wrapper literalize <wrapper> ;
: curry ( obj quot -- quot ) >r literalize unit r> append ;
: alist>quot ( default alist -- quot )

2
library/words.factor
View File

@ -82,8 +82,6 @@ M: word unxref-word* drop ;
: reset-generic ( word -- )
dup reset-word { "methods" "combination" } reset-props ;
M: word literalize <wrapper> ;
: gensym ( -- word )
[ "G:" % \ gensym counter # ] "" make
f <word> dup init-word ;

56
native/fixnum.c
View File

@ -32,34 +32,35 @@ void primitive_to_fixnum(void)
drepl(tag_fixnum(to_fixnum(dpeek())));
}
#define POP_FIXNUMS(x,y) \
F_FIXNUM x, y; \
y = untag_fixnum_fast(dpop()); \
x = untag_fixnum_fast(dpop());
/* The fixnum arithmetic operations defined in C are relatively slow.
The Factor compiler has optimized assembly intrinsics for all these
operations. */
void primitive_fixnum_add(void)
{
F_FIXNUM y = untag_fixnum_fast(dpop());
F_FIXNUM x = untag_fixnum_fast(dpop());
POP_FIXNUMS(x,y)
box_signed_cell(x + y);
}
void primitive_fixnum_add_fast(void)
{
F_FIXNUM y = untag_fixnum_fast(dpop());
F_FIXNUM x = untag_fixnum_fast(dpop());
POP_FIXNUMS(x,y)
dpush(tag_fixnum(x + y));
}
void primitive_fixnum_subtract(void)
{
F_FIXNUM y = untag_fixnum_fast(dpop());
F_FIXNUM x = untag_fixnum_fast(dpop());
POP_FIXNUMS(x,y)
box_signed_cell(x - y);
}
void primitive_fixnum_subtract_fast(void)
{
F_FIXNUM y = untag_fixnum_fast(dpop());
F_FIXNUM x = untag_fixnum_fast(dpop());
POP_FIXNUMS(x,y)
dpush(tag_fixnum(x - y));
}
@ -69,8 +70,7 @@ void primitive_fixnum_subtract_fast(void)
*/
void primitive_fixnum_multiply(void)
{
F_FIXNUM y = untag_fixnum_fast(dpop());
F_FIXNUM x = untag_fixnum_fast(dpop());
POP_FIXNUMS(x,y)
if(x == 0 || y == 0)
dpush(tag_fixnum(0));
@ -92,51 +92,44 @@ void primitive_fixnum_multiply(void)
void primitive_fixnum_divint(void)
{
F_FIXNUM y = untag_fixnum_fast(dpop());
F_FIXNUM x = untag_fixnum_fast(dpop());
POP_FIXNUMS(x,y)
box_signed_cell(x / y);
}
void primitive_fixnum_divfloat(void)
{
F_FIXNUM y = untag_fixnum_fast(dpop());
F_FIXNUM x = untag_fixnum_fast(dpop());
POP_FIXNUMS(x,y)
dpush(tag_float((double)x / (double)y));
}
void primitive_fixnum_divmod(void)
{
F_FIXNUM y = untag_fixnum_fast(dpop());
F_FIXNUM x = untag_fixnum_fast(dpop());
POP_FIXNUMS(x,y)
box_signed_cell(x / y);
box_signed_cell(x % y);
}
void primitive_fixnum_mod(void)
{
F_FIXNUM y = untag_fixnum_fast(dpop());
F_FIXNUM x = untag_fixnum_fast(dpop());
POP_FIXNUMS(x,y)
dpush(tag_fixnum(x % y));
}
void primitive_fixnum_and(void)
{
F_FIXNUM y = untag_fixnum_fast(dpop());
F_FIXNUM x = untag_fixnum_fast(dpop());
POP_FIXNUMS(x,y)
dpush(tag_fixnum(x & y));
}
void primitive_fixnum_or(void)
{
F_FIXNUM y = untag_fixnum_fast(dpop());
F_FIXNUM x = untag_fixnum_fast(dpop());
POP_FIXNUMS(x,y)
dpush(tag_fixnum(x | y));
}
void primitive_fixnum_xor(void)
{
F_FIXNUM y = untag_fixnum_fast(dpop());
F_FIXNUM x = untag_fixnum_fast(dpop());
POP_FIXNUMS(x,y)
dpush(tag_fixnum(x ^ y));
}
@ -147,8 +140,7 @@ void primitive_fixnum_xor(void)
*/
void primitive_fixnum_shift(void)
{
F_FIXNUM y = untag_fixnum_fast(dpop());
F_FIXNUM x = untag_fixnum_fast(dpop());
POP_FIXNUMS(x,y)
if(x == 0 || y == 0)
{
@ -179,29 +171,25 @@ void primitive_fixnum_shift(void)
void primitive_fixnum_less(void)
{
F_FIXNUM y = untag_fixnum_fast(dpop());
F_FIXNUM x = untag_fixnum_fast(dpop());
POP_FIXNUMS(x,y)
box_boolean(x < y);
}
void primitive_fixnum_lesseq(void)
{
F_FIXNUM y = untag_fixnum_fast(dpop());
F_FIXNUM x = untag_fixnum_fast(dpop());
POP_FIXNUMS(x,y)
box_boolean(x <= y);
}
void primitive_fixnum_greater(void)
{
F_FIXNUM y = untag_fixnum_fast(dpop());
F_FIXNUM x = untag_fixnum_fast(dpop());
POP_FIXNUMS(x,y)
box_boolean(x > y);
}
void primitive_fixnum_greatereq(void)
{
F_FIXNUM y = untag_fixnum_fast(dpop());
F_FIXNUM x = untag_fixnum_fast(dpop());
POP_FIXNUMS(x,y)
box_boolean(x >= y);
}

37
native/memory.c
View File

@ -1,33 +1,13 @@
#include "factor.h"
CELL object_size(CELL pointer)
CELL object_size(CELL tagged)
{
CELL size;
switch(TAG(pointer))
{
case FIXNUM_TYPE:
size = 0;
break;
case RATIO_TYPE:
case FLOAT_TYPE:
case COMPLEX_TYPE:
case BIGNUM_TYPE:
size = untagged_object_size(UNTAG(pointer));
break;
case OBJECT_TYPE:
if(pointer == F)
size = 0;
if(tagged == F)
return 0;
else if(TAG(tagged) == FIXNUM_TYPE)
return 0;
else
size = untagged_object_size(UNTAG(pointer));
break;
default:
critical_error("Cannot determine object_size",pointer);
size = 0; /* Can't happen */
break;
}
return align8(size);
return untagged_object_size(UNTAG(tagged));
}
CELL untagged_object_size(CELL pointer)
@ -167,6 +147,7 @@ void primitive_room(void)
dpush(tag_object(a));
}
/* Disables GC and activates next-object ( -- obj ) primitive */
void primitive_begin_scan(void)
{
garbage_collection(TENURED);
@ -174,6 +155,7 @@ void primitive_begin_scan(void)
heap_scan = true;
}
/* Push object at heap scan cursor and advance; pushes f when done */
void primitive_next_object(void)
{
CELL value = get(heap_scan_ptr);
@ -190,7 +172,7 @@ void primitive_next_object(void)
}
type = untag_header(value);
heap_scan_ptr += align8(untagged_object_size(heap_scan_ptr));
heap_scan_ptr += untagged_object_size(heap_scan_ptr);
if(type <= HEADER_TYPE)
dpush(RETAG(obj,type));
@ -198,6 +180,7 @@ void primitive_next_object(void)
dpush(RETAG(obj,OBJECT_TYPE));
}
/* Re-enables GC */
void primitive_end_scan(void)
{
heap_scan = false;

16
native/memory.h
View File

@ -54,16 +54,17 @@ INLINE CELL align8(CELL a)
/*** Tags ***/
#define FIXNUM_TYPE 0
#define BIGNUM_TYPE 1
#define WORD_TYPE 2
#define OBJECT_TYPE 3
#define RATIO_TYPE 4
#define FLOAT_TYPE 5
#define COMPLEX_TYPE 6
#define HEADER_TYPE 7 /* anything less than this is a tag */
#define GC_COLLECTED 7 /* See gc.c */
#define WRAPPER_TYPE 7
#define HEADER_TYPE 7 /* anything less than or equal to this is a tag */
#define GC_COLLECTED 0 /* See gc.c */
/*** Header types ***/
#define ALIEN_TYPE 7
#define ARRAY_TYPE 8
/* Canonical F object */
@ -74,14 +75,13 @@ INLINE CELL align8(CELL a)
#define VECTOR_TYPE 11
#define STRING_TYPE 12
#define SBUF_TYPE 13
#define WRAPPER_TYPE 14
#define QUOTATION_TYPE 14
#define DLL_TYPE 15
#define WORD_TYPE 16
#define ALIEN_TYPE 16
#define TUPLE_TYPE 17
#define BYTE_ARRAY_TYPE 18
#define QUOTATION_TYPE 19
#define TYPE_COUNT 20
#define TYPE_COUNT 19
/* Canonical T object. It's just a word */
CELL T;

39
native/relocate.c
View File

@ -42,16 +42,9 @@ void relocate_object(CELL relocating)
}
}
INLINE CELL relocate_data_next(CELL relocating)
{
CELL size = untagged_object_size(relocating);
relocate_object(relocating);
return relocating + size;
}
void relocate_data()
{
CELL relocating = tenured.base;
CELL relocating;
data_fixup(&userenv[BOOT_ENV]);
data_fixup(&userenv[GLOBAL_ENV]);
@ -60,23 +53,19 @@ void relocate_data()
data_fixup(&bignum_pos_one);
data_fixup(&bignum_neg_one);
for(;;)
for(relocating = tenured.base;
relocating < tenured.here;
relocating += untagged_object_size(relocating))
{
if(relocating >= tenured.here)
break;
allot_barrier(relocating);
relocating = relocate_data_next(relocating);
relocate_object(relocating);
}
relocating = compiling.base;
for(;;)
for(relocating = compiling.base;
relocating < literal_top;
relocating += CELLS)
{
if(relocating >= literal_top)
break;
relocating = relocate_data_next(relocating);
data_fixup((CELL*)relocating);
}
}
@ -88,7 +77,7 @@ void undefined_symbol(void)
CELL get_rel_symbol(F_REL* rel)
{
CELL arg = REL_ARGUMENT(rel);
F_ARRAY *pair = untag_array(get(compiling.base + arg * sizeof(CELL)));
F_ARRAY *pair = untag_array(get(compiling.base + arg * CELLS));
F_STRING *symbol = untag_string(AREF(pair,0));
DLL* dll = (AREF(pair,1) == F ? NULL : untag_dll(AREF(pair,1)));
CELL sym;
@ -199,12 +188,6 @@ void relocate_code()
{
/* start relocating from the end of the space reserved for literals */
CELL relocating = literal_max;
for(;;)
{
if(relocating >= compiling.here)
break;
while(relocating < compiling.here)
relocating = relocate_code_next(relocating);
}
}

9
native/run.c
View File

@ -72,7 +72,7 @@ void run(void)
next = get(callframe_scan);
callframe_scan += CELLS;
switch(type_of(next))
switch(TAG(next))
{
case WORD_TYPE:
execute(untag_word_fast(next));
@ -131,10 +131,9 @@ void primitive_call(void)
void primitive_ifte(void)
{
CELL f = dpop();
CELL t = dpop();
CELL cond = dpop();
call(cond == F ? f : t);
ds -= CELLS * 3;
CELL cond = get(ds + CELLS);
call(cond == F ? get(ds + CELLS * 3) : get(ds + CELLS * 2));
}
void primitive_dispatch(void)

2
native/word.c
View File

@ -26,7 +26,7 @@ void primitive_word(void)
word->def = F;
word->props = F;
word->xt = (CELL)undefined;
dpush(tag_object(word));
dpush(tag_word(word));
}
void primitive_update_xt(void)

13
native/word.h
View File

@ -13,23 +13,28 @@ typedef struct {
CELL def;
/* TAGGED property hash for library code */
CELL props;
/* untagged execution token: jump here to execute word */
/* UNTAGGED execution token: jump here to execute word */
CELL xt;
} F_WORD;
typedef void (*XT)(F_WORD* word);
typedef void (*XT)(F_WORD *word);
INLINE F_WORD* untag_word_fast(CELL tagged)
INLINE F_WORD *untag_word_fast(CELL tagged)
{
return (F_WORD*)UNTAG(tagged);
}
INLINE F_WORD* untag_word(CELL tagged)
INLINE F_WORD *untag_word(CELL tagged)
{
type_check(WORD_TYPE,tagged);
return untag_word_fast(tagged);
}
INLINE CELL tag_word(F_WORD *word)
{
return RETAG(word,WORD_TYPE);
}
void update_xt(F_WORD* word);
void primitive_word(void);
void primitive_update_xt(void);

8
native/wrapper.c
View File

@ -2,21 +2,21 @@
void primitive_wrapper(void)
{
F_WRAPPER* wrapper;
F_WRAPPER *wrapper;
maybe_gc(sizeof(F_WRAPPER));
wrapper = allot_object(WRAPPER_TYPE,sizeof(F_WRAPPER));
wrapper->object = dpeek();
drepl(tag_object(wrapper));
drepl(tag_wrapper(wrapper));
}
void fixup_wrapper(F_WRAPPER* wrapper)
void fixup_wrapper(F_WRAPPER *wrapper)
{
data_fixup(&wrapper->object);
}
void collect_wrapper(F_WRAPPER* wrapper)
void collect_wrapper(F_WRAPPER *wrapper)
{
copy_handle(&wrapper->object);
}

11
native/wrapper.h
View File

@ -3,11 +3,16 @@ typedef struct {
CELL object;
} F_WRAPPER;
INLINE F_WRAPPER* untag_wrapper_fast(CELL tagged)
INLINE F_WRAPPER *untag_wrapper_fast(CELL tagged)
{
return (F_WRAPPER*)UNTAG(tagged);
}
INLINE CELL tag_wrapper(F_WRAPPER *wrapper)
{
return RETAG(wrapper,WRAPPER_TYPE);
}
void primitive_wrapper(void);
void fixup_wrapper(F_WRAPPER* wrapper);
void collect_wrapper(F_WRAPPER* wrapper);
void fixup_wrapper(F_WRAPPER *wrapper);
void collect_wrapper(F_WRAPPER *wrapper);