Merge branch 'master' of git://factorcode.org/git/factor

db4
Joe Groff 2010-01-19 10:30:00 -08:00
commit 06fb0fb71d
58 changed files with 1053 additions and 1117 deletions

View File

@ -1,16 +1,15 @@
ifdef CONFIG
CC = gcc CC = gcc
CPP = g++ CPP = g++
AR = ar AR = ar
LD = ld LD = ld
EXECUTABLE = factor
CONSOLE_EXECUTABLE = factor-console
TEST_LIBRARY = factor-ffi-test
VERSION = 0.92 VERSION = 0.92
BUNDLE = Factor.app BUNDLE = Factor.app
LIBPATH = -L/usr/X11R6/lib LIBPATH = -L/usr/X11R6/lib
CFLAGS = -Wall
CFLAGS = -Wall $(SITE_CFLAGS)
ifdef DEBUG ifdef DEBUG
CFLAGS += -g -DFACTOR_DEBUG CFLAGS += -g -DFACTOR_DEBUG
@ -18,17 +17,11 @@ else
CFLAGS += -O3 CFLAGS += -O3
endif endif
ifdef REENTRANT include $(CONFIG)
CFLAGS += -DFACTOR_REENTRANT
endif
CFLAGS += $(SITE_CFLAGS)
ENGINE = $(DLL_PREFIX)factor$(DLL_SUFFIX)$(DLL_EXTENSION) ENGINE = $(DLL_PREFIX)factor$(DLL_SUFFIX)$(DLL_EXTENSION)
EXECUTABLE = factor$(EXE_SUFFIX)$(EXE_EXTENSION)
ifdef CONFIG CONSOLE_EXECUTABLE = factor$(EXE_SUFFIX)$(CONSOLE_EXTENSION)
include $(CONFIG)
endif
DLL_OBJS = $(PLAF_DLL_OBJS) \ DLL_OBJS = $(PLAF_DLL_OBJS) \
vm/aging_collector.o \ vm/aging_collector.o \
@ -75,7 +68,10 @@ DLL_OBJS = $(PLAF_DLL_OBJS) \
EXE_OBJS = $(PLAF_EXE_OBJS) EXE_OBJS = $(PLAF_EXE_OBJS)
FFI_TEST_LIBRARY = libfactor-ffi-test$(SHARED_DLL_EXTENSION)
TEST_OBJS = vm/ffi_test.o TEST_OBJS = vm/ffi_test.o
endif
default: default:
$(MAKE) `./build-support/factor.sh make-target` $(MAKE) `./build-support/factor.sh make-target`
@ -110,60 +106,62 @@ help:
@echo "X11=1 force link with X11 libraries instead of Cocoa (only on Mac OS X)" @echo "X11=1 force link with X11 libraries instead of Cocoa (only on Mac OS X)"
openbsd-x86-32: openbsd-x86-32:
$(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) CONFIG=vm/Config.openbsd.x86.32 $(MAKE) factor factor-ffi-test CONFIG=vm/Config.openbsd.x86.32
openbsd-x86-64: openbsd-x86-64:
$(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) CONFIG=vm/Config.openbsd.x86.64 $(MAKE) factor factor-ffi-test CONFIG=vm/Config.openbsd.x86.64
freebsd-x86-32: freebsd-x86-32:
$(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) CONFIG=vm/Config.freebsd.x86.32 $(MAKE) factor factor-ffi-test CONFIG=vm/Config.freebsd.x86.32
freebsd-x86-64: freebsd-x86-64:
$(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) CONFIG=vm/Config.freebsd.x86.64 $(MAKE) factor factor-ffi-test CONFIG=vm/Config.freebsd.x86.64
netbsd-x86-32: netbsd-x86-32:
$(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) CONFIG=vm/Config.netbsd.x86.32 $(MAKE) factor factor-ffi-test CONFIG=vm/Config.netbsd.x86.32
netbsd-x86-64: netbsd-x86-64:
$(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) CONFIG=vm/Config.netbsd.x86.64 $(MAKE) factor factor-ffi-test CONFIG=vm/Config.netbsd.x86.64
macosx-ppc: macosx-ppc:
$(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) macosx.app CONFIG=vm/Config.macosx.ppc $(MAKE) factor factor-ffi-test macosx.app CONFIG=vm/Config.macosx.ppc
macosx-x86-32: macosx-x86-32:
$(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) macosx.app CONFIG=vm/Config.macosx.x86.32 $(MAKE) factor factor-ffi-test macosx.app CONFIG=vm/Config.macosx.x86.32
macosx-x86-64: macosx-x86-64:
$(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) macosx.app CONFIG=vm/Config.macosx.x86.64 $(MAKE) factor factor-ffi-test macosx.app CONFIG=vm/Config.macosx.x86.64
linux-x86-32: linux-x86-32:
$(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) CONFIG=vm/Config.linux.x86.32 $(MAKE) factor factor-ffi-test CONFIG=vm/Config.linux.x86.32
linux-x86-64: linux-x86-64:
$(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) CONFIG=vm/Config.linux.x86.64 $(MAKE) factor factor-ffi-test CONFIG=vm/Config.linux.x86.64
linux-ppc: linux-ppc:
$(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) CONFIG=vm/Config.linux.ppc $(MAKE) factor factor-ffi-test CONFIG=vm/Config.linux.ppc
linux-arm: linux-arm:
$(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) CONFIG=vm/Config.linux.arm $(MAKE) factor factor-ffi-test CONFIG=vm/Config.linux.arm
solaris-x86-32: solaris-x86-32:
$(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) CONFIG=vm/Config.solaris.x86.32 $(MAKE) factor factor-ffi-test CONFIG=vm/Config.solaris.x86.32
solaris-x86-64: solaris-x86-64:
$(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) CONFIG=vm/Config.solaris.x86.64 $(MAKE) factor factor-ffi-test CONFIG=vm/Config.solaris.x86.64
winnt-x86-32: winnt-x86-32:
$(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) CONFIG=vm/Config.windows.nt.x86.32 $(MAKE) factor factor-ffi-test CONFIG=vm/Config.windows.nt.x86.32
$(MAKE) $(CONSOLE_EXECUTABLE) CONFIG=vm/Config.windows.nt.x86.32 $(MAKE) factor-console CONFIG=vm/Config.windows.nt.x86.32
winnt-x86-64: winnt-x86-64:
$(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) CONFIG=vm/Config.windows.nt.x86.64 $(MAKE) factor factor-ffi-test CONFIG=vm/Config.windows.nt.x86.64
$(MAKE) $(CONSOLE_EXECUTABLE) CONFIG=vm/Config.windows.nt.x86.64 $(MAKE) factor-console CONFIG=vm/Config.windows.nt.x86.64
wince-arm: wince-arm:
$(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) CONFIG=vm/Config.windows.ce.arm $(MAKE) factor factor-ffi-test CONFIG=vm/Config.windows.ce.arm
ifdef CONFIG
macosx.app: factor macosx.app: factor
mkdir -p $(BUNDLE)/Contents/MacOS mkdir -p $(BUNDLE)/Contents/MacOS
@ -177,18 +175,40 @@ macosx.app: factor
@executable_path/../Frameworks/libfactor.dylib \ @executable_path/../Frameworks/libfactor.dylib \
Factor.app/Contents/MacOS/factor Factor.app/Contents/MacOS/factor
$(EXECUTABLE): $(DLL_OBJS) $(EXE_OBJS) $(ENGINE): $(DLL_OBJS)
$(TOOLCHAIN_PREFIX)$(LINKER) $(ENGINE) $(DLL_OBJS) $(TOOLCHAIN_PREFIX)$(LINKER) $(ENGINE) $(DLL_OBJS)
$(TOOLCHAIN_PREFIX)$(CPP) $(LIBS) $(LIBPATH) -L. $(LINK_WITH_ENGINE) \
$(CFLAGS) -o $@$(EXE_SUFFIX)$(EXE_EXTENSION) $(EXE_OBJS)
$(CONSOLE_EXECUTABLE): $(DLL_OBJS) $(EXE_OBJS) factor: $(EXE_OBJS) $(ENGINE)
$(TOOLCHAIN_PREFIX)$(LINKER) $(ENGINE) $(DLL_OBJS)
$(TOOLCHAIN_PREFIX)$(CPP) $(LIBS) $(LIBPATH) -L. $(LINK_WITH_ENGINE) \ $(TOOLCHAIN_PREFIX)$(CPP) $(LIBS) $(LIBPATH) -L. $(LINK_WITH_ENGINE) \
$(CFLAGS) $(CFLAGS_CONSOLE) -o factor$(EXE_SUFFIX)$(CONSOLE_EXTENSION) $(EXE_OBJS) $(CFLAGS) -o $(EXECUTABLE) $(EXE_OBJS)
$(TEST_LIBRARY): vm/ffi_test.o factor-console: $(EXE_OBJS) $(ENGINE)
$(TOOLCHAIN_PREFIX)$(CC) $(LIBPATH) $(CFLAGS) $(FFI_TEST_CFLAGS) $(SHARED_FLAG) -o libfactor-ffi-test$(SHARED_DLL_EXTENSION) $(TEST_OBJS) $(TOOLCHAIN_PREFIX)$(CPP) $(LIBS) $(LIBPATH) -L. $(LINK_WITH_ENGINE) \
$(CFLAGS) $(CFLAGS_CONSOLE) -o $(CONSOLE_EXECUTABLE) $(EXE_OBJS)
factor-ffi-test: $(FFI_TEST_LIBRARY)
$(FFI_TEST_LIBRARY): vm/ffi_test.o
$(TOOLCHAIN_PREFIX)$(CC) $(LIBPATH) $(CFLAGS) $(FFI_TEST_CFLAGS) $(SHARED_FLAG) -o $(FFI_TEST_LIBRARY) $(TEST_OBJS)
vm/resources.o:
$(TOOLCHAIN_PREFIX)$(WINDRES) vm/factor.rs vm/resources.o
vm/ffi_test.o: vm/ffi_test.c
$(TOOLCHAIN_PREFIX)$(CC) -c $(CFLAGS) $(FFI_TEST_CFLAGS) -o $@ $<
.cpp.o:
$(TOOLCHAIN_PREFIX)$(CPP) -c $(CFLAGS) -o $@ $<
.S.o:
$(TOOLCHAIN_PREFIX)$(CC) -x assembler-with-cpp -c $(CFLAGS) -o $@ $<
.mm.o:
$(TOOLCHAIN_PREFIX)$(CPP) -c $(CFLAGS) -o $@ $<
.SUFFIXES: .mm
endif
clean: clean:
rm -f vm/*.o rm -f vm/*.o
@ -200,24 +220,4 @@ clean:
tags: tags:
etags vm/*.{cpp,hpp,mm,S,c} etags vm/*.{cpp,hpp,mm,S,c}
vm/resources.o: .PHONY: factor factor-console factor-ffi-test tags clean macosx.app
$(TOOLCHAIN_PREFIX)$(WINDRES) vm/factor.rs vm/resources.o
vm/ffi_test.o: vm/ffi_test.c
$(TOOLCHAIN_PREFIX)$(CC) -c $(CFLAGS) $(FFI_TEST_CFLAGS) -o $@ $<
.c.o:
$(TOOLCHAIN_PREFIX)$(CC) -c $(CFLAGS) -o $@ $<
.cpp.o:
$(TOOLCHAIN_PREFIX)$(CPP) -c $(CFLAGS) -o $@ $<
.S.o:
$(TOOLCHAIN_PREFIX)$(CC) -x assembler-with-cpp -c $(CFLAGS) -o $@ $<
.mm.o:
$(TOOLCHAIN_PREFIX)$(CPP) -c $(CFLAGS) -o $@ $<
.PHONY: factor tags clean
.SUFFIXES: .mm

View File

@ -1,4 +1,4 @@
LINK_CLFAGS = /nologo LINK_FLAGS = /nologo shell32.lib
CL_FLAGS = /nologo /O2 /W3 CL_FLAGS = /nologo /O2 /W3
EXE_OBJS = factor.dll.lib vm\main-windows-nt.obj vm\factor.res EXE_OBJS = factor.dll.lib vm\main-windows-nt.obj vm\factor.res
@ -66,11 +66,12 @@ factor.exe: $(EXE_OBJS)
clean: clean:
del vm\*.obj del vm\*.obj
del factor.lib
del factor.com del factor.com
del factor.exe del factor.exe
del factor.dll del factor.dll
del factor.dll.lib del factor.dll.lib
.PHONY: clean .PHONY: all clean
.SUFFIXES: .rs .SUFFIXES: .rs

View File

@ -76,7 +76,7 @@ gc
"." write flush "." write flush
{ {
+ 2/ < <= > >= shift + * 2/ < <= > >= shift
} compile-unoptimized } compile-unoptimized
"." write flush "." write flush

View File

@ -62,16 +62,13 @@ MEMO: cached-string>symbol ( symbol -- obj ) string>symbol ;
[ add-dlsym-parameters ] dip rt-dlsym rel-fixup ; [ add-dlsym-parameters ] dip rt-dlsym rel-fixup ;
: rel-word ( word class -- ) : rel-word ( word class -- )
[ add-literal ] dip rt-xt rel-fixup ; [ add-literal ] dip rt-entry-point rel-fixup ;
: rel-word-pic ( word class -- ) : rel-word-pic ( word class -- )
[ add-literal ] dip rt-xt-pic rel-fixup ; [ add-literal ] dip rt-entry-point-pic rel-fixup ;
: rel-word-pic-tail ( word class -- ) : rel-word-pic-tail ( word class -- )
[ add-literal ] dip rt-xt-pic-tail rel-fixup ; [ add-literal ] dip rt-entry-point-pic-tail rel-fixup ;
: rel-primitive ( word class -- )
[ def>> first add-parameter ] dip rt-primitive rel-fixup ;
: rel-immediate ( literal class -- ) : rel-immediate ( literal class -- )
[ add-literal ] dip rt-literal rel-fixup ; [ add-literal ] dip rt-literal rel-fixup ;

View File

@ -32,7 +32,6 @@ SYMBOL: compiled
[ "forgotten" word-prop ] [ "forgotten" word-prop ]
[ compiled get key? ] [ compiled get key? ]
[ inlined-block? ] [ inlined-block? ]
[ primitive? ]
} 1|| not ; } 1|| not ;
: queue-compile ( word -- ) : queue-compile ( word -- )
@ -126,7 +125,10 @@ M: word combinator? inline? ;
} cond ; } cond ;
: optimize? ( word -- ? ) : optimize? ( word -- ? )
single-generic? not ; {
[ single-generic? ]
[ primitive? ]
} 1|| not ;
: contains-breakpoints? ( -- ? ) : contains-breakpoints? ( -- ? )
dependencies get keys [ "break?" word-prop ] any? ; dependencies get keys [ "break?" word-prop ] any? ;

View File

@ -20,8 +20,8 @@ CONSTANT: deck-bits 18
: alien-offset ( -- n ) 4 alien type-number slot-offset ; inline : alien-offset ( -- n ) 4 alien type-number slot-offset ; inline
: underlying-alien-offset ( -- n ) 1 alien type-number slot-offset ; inline : underlying-alien-offset ( -- n ) 1 alien type-number slot-offset ; inline
: tuple-class-offset ( -- n ) 1 tuple type-number slot-offset ; inline : tuple-class-offset ( -- n ) 1 tuple type-number slot-offset ; inline
: word-xt-offset ( -- n ) 10 \ word type-number slot-offset ; inline : word-entry-point-offset ( -- n ) 10 \ word type-number slot-offset ; inline
: quot-xt-offset ( -- n ) 4 quotation type-number slot-offset ; inline : quot-entry-point-offset ( -- n ) 4 quotation type-number slot-offset ; inline
: word-code-offset ( -- n ) 11 \ word type-number slot-offset ; inline : word-code-offset ( -- n ) 11 \ word type-number slot-offset ; inline
: array-start-offset ( -- n ) 2 array type-number slot-offset ; inline : array-start-offset ( -- n ) 2 array type-number slot-offset ; inline
: compiled-header-size ( -- n ) 4 bootstrap-cells ; inline : compiled-header-size ( -- n ) 4 bootstrap-cells ; inline
@ -47,21 +47,18 @@ CONSTANT: rc-indirect-arm-pc 9
CONSTANT: rc-absolute-2 10 CONSTANT: rc-absolute-2 10
! Relocation types ! Relocation types
CONSTANT: rt-primitive 0 CONSTANT: rt-dlsym 0
CONSTANT: rt-dlsym 1 CONSTANT: rt-entry-point 1
CONSTANT: rt-dispatch 2 CONSTANT: rt-entry-point-pic 2
CONSTANT: rt-xt 3 CONSTANT: rt-entry-point-pic-tail 3
CONSTANT: rt-xt-pic 4 CONSTANT: rt-here 4
CONSTANT: rt-xt-pic-tail 5 CONSTANT: rt-this 5
CONSTANT: rt-here 6 CONSTANT: rt-literal 6
CONSTANT: rt-this 7 CONSTANT: rt-untagged 7
CONSTANT: rt-literal 8 CONSTANT: rt-megamorphic-cache-hits 8
CONSTANT: rt-context 9 CONSTANT: rt-vm 9
CONSTANT: rt-untagged 10 CONSTANT: rt-cards-offset 10
CONSTANT: rt-megamorphic-cache-hits 11 CONSTANT: rt-decks-offset 11
CONSTANT: rt-vm 12
CONSTANT: rt-cards-offset 13
CONSTANT: rt-decks-offset 14
: rc-absolute? ( n -- ? ) : rc-absolute? ( n -- ? )
${ rc-absolute-ppc-2/2 rc-absolute-cell rc-absolute } member? ; ${ rc-absolute-ppc-2/2 rc-absolute-cell rc-absolute } member? ;

View File

@ -7,7 +7,7 @@ math.private kernel tools.test accessors slots.private
quotations.private prettyprint classes.tuple.private classes quotations.private prettyprint classes.tuple.private classes
classes.tuple namespaces classes.tuple namespaces
compiler.tree.propagation.info stack-checker.errors compiler.tree.propagation.info stack-checker.errors
compiler.tree.checker compiler.tree.checker compiler.tree.def-use compiler.tree.dead-code
kernel.private vectors ; kernel.private vectors ;
IN: compiler.tree.escape-analysis.tests IN: compiler.tree.escape-analysis.tests
@ -37,6 +37,8 @@ M: node count-unboxed-allocations* drop ;
cleanup cleanup
escape-analysis escape-analysis
dup check-nodes dup check-nodes
compute-def-use
remove-dead-code
0 swap [ count-unboxed-allocations* ] each-node ; 0 swap [ count-unboxed-allocations* ] each-node ;
[ 0 ] [ [ [ + ] curry ] count-unboxed-allocations ] unit-test [ 0 ] [ [ [ + ] curry ] count-unboxed-allocations ] unit-test
@ -173,12 +175,6 @@ TUPLE: cons { car read-only } { cdr read-only } ;
[ 10 [ drop ] each-integer ] count-unboxed-allocations [ 10 [ drop ] each-integer ] count-unboxed-allocations
] unit-test ] unit-test
[ 2 ] [
[
1 2 cons boa 10 [ 2drop 1 2 cons boa ] each-integer car>>
] count-unboxed-allocations
] unit-test
[ 0 ] [ [ 0 ] [
[ [
1 2 cons boa 10 [ drop 2 cons boa ] each-integer car>> 1 2 cons boa 10 [ drop 2 cons boa ] each-integer car>>
@ -304,14 +300,6 @@ C: <ro-box> ro-box
[ 0 ] [ [ 1 cons boa "x" get slot ] count-unboxed-allocations ] unit-test [ 0 ] [ [ 1 cons boa "x" get slot ] count-unboxed-allocations ] unit-test
: impeach-node ( quot: ( node -- ) -- )
[ call ] keep impeach-node ; inline recursive
: bleach-node ( quot: ( node -- ) -- )
[ bleach-node ] curry [ ] compose impeach-node ; inline recursive
[ 3 ] [ [ [ ] bleach-node ] count-unboxed-allocations ] unit-test
[ 0 ] [ [ 0 ] [
[ dup -1 over >= [ 0 >= [ "A" throw ] unless ] [ drop ] if ] [ dup -1 over >= [ 0 >= [ "A" throw ] unless ] [ drop ] if ]
count-unboxed-allocations count-unboxed-allocations
@ -322,10 +310,6 @@ C: <ro-box> ro-box
count-unboxed-allocations count-unboxed-allocations
] unit-test ] unit-test
[ 0 ] [
[ { null } declare [ 1 ] [ 2 ] if ] count-unboxed-allocations
] unit-test
! Doug found a regression ! Doug found a regression
TUPLE: empty-tuple ; TUPLE: empty-tuple ;

View File

@ -74,7 +74,7 @@ M: quotation cached-effect
: call-effect-unsafe? ( quot effect -- ? ) : call-effect-unsafe? ( quot effect -- ? )
[ cached-effect ] dip [ cached-effect ] dip
over +unknown+ eq? over +unknown+ eq?
[ 2drop f ] [ effect<= ] if ; inline [ 2drop f ] [ [ { effect } declare ] dip effect<= ] if ; inline
: (call-effect-slow>quot) ( in out effect -- quot ) : (call-effect-slow>quot) ( in out effect -- quot )
[ [

View File

@ -1,10 +1,9 @@
! Copyright (C) 2007, 2010 Slava Pestov. ! Copyright (C) 2007, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: bootstrap.image.private kernel kernel.private namespaces USING: bootstrap.image.private kernel kernel.private namespaces
system cpu.ppc.assembler compiler.codegen.fixup compiler.units system cpu.ppc.assembler compiler.units compiler.constants math
compiler.constants math math.private math.ranges layouts words vocabs math.private math.ranges layouts words vocabs slots.private
slots.private locals locals.backend generic.single.private fry locals locals.backend generic.single.private fry sequences ;
sequences ;
FROM: cpu.ppc.assembler => B ; FROM: cpu.ppc.assembler => B ;
IN: bootstrap.ppc IN: bootstrap.ppc
@ -66,7 +65,7 @@ CONSTANT: ctx-reg 16
0 vm-reg LOAD32 rc-absolute-ppc-2/2 rt-vm jit-rel 0 vm-reg LOAD32 rc-absolute-ppc-2/2 rt-vm jit-rel
0 2 LOAD32 rc-absolute-ppc-2/2 rt-xt jit-rel 0 2 LOAD32 rc-absolute-ppc-2/2 rt-entry-point jit-rel
2 MTLR 2 MTLR
BLRL BLRL
@ -126,25 +125,25 @@ CONSTANT: ctx-reg 16
[ [
jit-save-context jit-save-context
3 vm-reg MR 3 vm-reg MR
0 4 LOAD32 rc-absolute-ppc-2/2 rt-primitive jit-rel 0 4 LOAD32 rc-absolute-ppc-2/2 rt-dlsym jit-rel
4 MTLR 4 MTLR
BLRL BLRL
jit-restore-context jit-restore-context
] jit-primitive jit-define ] jit-primitive jit-define
[ 0 BL rc-relative-ppc-3 rt-xt-pic jit-rel ] jit-word-call jit-define [ 0 BL rc-relative-ppc-3 rt-entry-point-pic jit-rel ] jit-word-call jit-define
[ [
0 6 LOAD32 rc-absolute-ppc-2/2 rt-here jit-rel 0 6 LOAD32 rc-absolute-ppc-2/2 rt-here jit-rel
0 B rc-relative-ppc-3 rt-xt-pic-tail jit-rel 0 B rc-relative-ppc-3 rt-entry-point-pic-tail jit-rel
] jit-word-jump jit-define ] jit-word-jump jit-define
[ [
3 ds-reg 0 LWZ 3 ds-reg 0 LWZ
ds-reg dup 4 SUBI ds-reg dup 4 SUBI
0 3 \ f type-number CMPI 0 3 \ f type-number CMPI
[ BEQ ] [ 0 B rc-relative-ppc-3 rt-xt jit-rel ] jit-conditional* [ BEQ ] [ 0 B rc-relative-ppc-3 rt-entry-point jit-rel ] jit-conditional*
0 B rc-relative-ppc-3 rt-xt jit-rel 0 B rc-relative-ppc-3 rt-entry-point jit-rel
] jit-if jit-define ] jit-if jit-define
: jit->r ( -- ) : jit->r ( -- )
@ -195,19 +194,19 @@ CONSTANT: ctx-reg 16
[ [
jit->r jit->r
0 BL rc-relative-ppc-3 rt-xt jit-rel 0 BL rc-relative-ppc-3 rt-entry-point jit-rel
jit-r> jit-r>
] jit-dip jit-define ] jit-dip jit-define
[ [
jit-2>r jit-2>r
0 BL rc-relative-ppc-3 rt-xt jit-rel 0 BL rc-relative-ppc-3 rt-entry-point jit-rel
jit-2r> jit-2r>
] jit-2dip jit-define ] jit-2dip jit-define
[ [
jit-3>r jit-3>r
0 BL rc-relative-ppc-3 rt-xt jit-rel 0 BL rc-relative-ppc-3 rt-entry-point jit-rel
jit-3r> jit-3r>
] jit-3dip jit-define ] jit-3dip jit-define
@ -256,7 +255,7 @@ CONSTANT: ctx-reg 16
] pic-check-tuple jit-define ] pic-check-tuple jit-define
[ [
[ BNE ] [ 0 B rc-relative-ppc-3 rt-xt jit-rel ] jit-conditional* [ BNE ] [ 0 B rc-relative-ppc-3 rt-entry-point jit-rel ] jit-conditional*
] pic-hit jit-define ] pic-hit jit-define
! Inline cache miss entry points ! Inline cache miss entry points
@ -308,7 +307,7 @@ CONSTANT: ctx-reg 16
5 4 0 STW 5 4 0 STW
! ... goto get(cache + 4) ! ... goto get(cache + 4)
3 3 4 LWZ 3 3 4 LWZ
3 3 word-xt-offset LWZ 3 3 word-entry-point-offset LWZ
3 MTCTR 3 MTCTR
BCTR BCTR
] ]
@ -322,7 +321,7 @@ CONSTANT: ctx-reg 16
[ [
3 ds-reg 0 LWZ 3 ds-reg 0 LWZ
ds-reg dup 4 SUBI ds-reg dup 4 SUBI
5 3 quot-xt-offset LWZ 5 3 quot-entry-point-offset LWZ
] ]
[ 5 MTLR BLRL ] [ 5 MTLR BLRL ]
[ 5 MTCTR BCTR ] \ (call) define-combinator-primitive [ 5 MTCTR BCTR ] \ (call) define-combinator-primitive
@ -330,7 +329,7 @@ CONSTANT: ctx-reg 16
[ [
3 ds-reg 0 LWZ 3 ds-reg 0 LWZ
ds-reg dup 4 SUBI ds-reg dup 4 SUBI
4 3 word-xt-offset LWZ 4 3 word-entry-point-offset LWZ
] ]
[ 4 MTLR BLRL ] [ 4 MTLR BLRL ]
[ 4 MTCTR BCTR ] \ (execute) define-combinator-primitive [ 4 MTCTR BCTR ] \ (execute) define-combinator-primitive
@ -338,7 +337,7 @@ CONSTANT: ctx-reg 16
[ [
3 ds-reg 0 LWZ 3 ds-reg 0 LWZ
ds-reg dup 4 SUBI ds-reg dup 4 SUBI
4 3 word-xt-offset LWZ 4 3 word-entry-point-offset LWZ
4 MTCTR BCTR 4 MTCTR BCTR
] jit-execute jit-define ] jit-execute jit-define
@ -348,7 +347,7 @@ CONSTANT: ctx-reg 16
! Save ctx->callstack_bottom ! Save ctx->callstack_bottom
1 ctx-reg context-callstack-bottom-offset STW 1 ctx-reg context-callstack-bottom-offset STW
! Call quotation ! Call quotation
5 3 quot-xt-offset LWZ 5 3 quot-entry-point-offset LWZ
5 MTLR 5 MTLR
BLRL BLRL
jit-save-context jit-save-context
@ -370,7 +369,7 @@ CONSTANT: ctx-reg 16
0 MTLR 0 MTLR
! Call quotation ! Call quotation
4 3 quot-xt-offset LWZ 4 3 quot-entry-point-offset LWZ
4 MTCTR 4 MTCTR
BCTR BCTR
] \ unwind-native-frames define-sub-primitive ] \ unwind-native-frames define-sub-primitive
@ -409,7 +408,7 @@ CONSTANT: ctx-reg 16
0 2 LOAD32 "lazy_jit_compile" f rc-absolute-ppc-2/2 jit-dlsym 0 2 LOAD32 "lazy_jit_compile" f rc-absolute-ppc-2/2 jit-dlsym
2 MTLR 2 MTLR
BLRL BLRL
5 3 quot-xt-offset LWZ 5 3 quot-entry-point-offset LWZ
] ]
[ 5 MTLR BLRL ] [ 5 MTLR BLRL ]
[ 5 MTCTR BCTR ] [ 5 MTCTR BCTR ]

View File

@ -81,7 +81,7 @@ M: ppc %inc-r ( n -- ) rs-reg (%inc) ;
HOOK: reserved-area-size os ( -- n ) HOOK: reserved-area-size os ( -- n )
! The start of the stack frame contains the size of this frame ! The start of the stack frame contains the size of this frame
! as well as the currently executing XT ! as well as the currently executing code block
: factor-area-size ( -- n ) 2 cells ; foldable : factor-area-size ( -- n ) 2 cells ; foldable
: next-save ( n -- i ) cell - ; foldable : next-save ( n -- i ) cell - ; foldable
: xt-save ( n -- i ) 2 cells - ; foldable : xt-save ( n -- i ) 2 cells - ; foldable
@ -702,7 +702,7 @@ M: ppc %alien-invoke ( symbol dll -- )
M: ppc %alien-callback ( quot -- ) M: ppc %alien-callback ( quot -- )
3 4 %restore-context 3 4 %restore-context
3 swap %load-reference 3 swap %load-reference
4 3 quot-xt-offset LWZ 4 3 quot-entry-point-offset LWZ
4 MTLR 4 MTLR
BLRL BLRL
3 4 %save-context ; 3 4 %save-context ;

View File

@ -244,7 +244,7 @@ M: x86.32 %alien-indirect ( -- )
M: x86.32 %alien-callback ( quot -- ) M: x86.32 %alien-callback ( quot -- )
EAX EDX %restore-context EAX EDX %restore-context
EAX swap %load-reference EAX swap %load-reference
EAX quot-xt-offset [+] CALL EAX quot-entry-point-offset [+] CALL
EAX EDX %save-context ; EAX EDX %save-context ;
M: x86.32 %callback-value ( ctype -- ) M: x86.32 %callback-value ( ctype -- )

View File

@ -30,7 +30,7 @@ IN: bootstrap.x86
[ [
! save stack frame size ! save stack frame size
stack-frame-size PUSH stack-frame-size PUSH
! push XT ! push entry point
0 PUSH rc-absolute-cell rt-this jit-rel 0 PUSH rc-absolute-cell rt-this jit-rel
! alignment ! alignment
ESP stack-frame-size 3 bootstrap-cells - SUB ESP stack-frame-size 3 bootstrap-cells - SUB
@ -59,7 +59,7 @@ IN: bootstrap.x86
jit-save-context jit-save-context
! call the primitive ! call the primitive
ESP [] vm-reg MOV ESP [] vm-reg MOV
0 CALL rc-relative rt-primitive jit-rel 0 CALL rc-relative rt-dlsym jit-rel
! restore ds, rs registers ! restore ds, rs registers
jit-restore-context jit-restore-context
] jit-primitive jit-define ] jit-primitive jit-define
@ -74,7 +74,7 @@ IN: bootstrap.x86
EDX stack-reg stack-frame-size 4 - [+] LEA EDX stack-reg stack-frame-size 4 - [+] LEA
ctx-reg context-callstack-bottom-offset [+] EDX MOV ctx-reg context-callstack-bottom-offset [+] EDX MOV
! call the quotation ! call the quotation
EAX quot-xt-offset [+] CALL EAX quot-entry-point-offset [+] CALL
! save ds, rs registers ! save ds, rs registers
jit-save-context jit-save-context
] \ c-to-factor define-sub-primitive ] \ c-to-factor define-sub-primitive
@ -83,8 +83,8 @@ IN: bootstrap.x86
EAX ds-reg [] MOV EAX ds-reg [] MOV
ds-reg bootstrap-cell SUB ds-reg bootstrap-cell SUB
] ]
[ EAX quot-xt-offset [+] CALL ] [ EAX quot-entry-point-offset [+] CALL ]
[ EAX quot-xt-offset [+] JMP ] [ EAX quot-entry-point-offset [+] JMP ]
\ (call) define-combinator-primitive \ (call) define-combinator-primitive
[ [
@ -108,7 +108,7 @@ IN: bootstrap.x86
jit-restore-context jit-restore-context
! Call quotation ! Call quotation
EAX quot-xt-offset [+] JMP EAX quot-entry-point-offset [+] JMP
] \ unwind-native-frames define-sub-primitive ] \ unwind-native-frames define-sub-primitive
[ [
@ -150,8 +150,8 @@ IN: bootstrap.x86
! Call VM ! Call VM
0 CALL "lazy_jit_compile" f rc-relative jit-dlsym 0 CALL "lazy_jit_compile" f rc-relative jit-dlsym
] ]
[ EAX quot-xt-offset [+] CALL ] [ EAX quot-entry-point-offset [+] CALL ]
[ EAX quot-xt-offset [+] JMP ] [ EAX quot-entry-point-offset [+] JMP ]
\ lazy-jit-compile define-combinator-primitive \ lazy-jit-compile define-combinator-primitive
! Inline cache miss entry points ! Inline cache miss entry points

View File

@ -234,7 +234,7 @@ M: x86.64 %alien-indirect ( -- )
M: x86.64 %alien-callback ( quot -- ) M: x86.64 %alien-callback ( quot -- )
param-reg-0 param-reg-1 %restore-context param-reg-0 param-reg-1 %restore-context
param-reg-0 swap %load-reference param-reg-0 swap %load-reference
param-reg-0 quot-xt-offset [+] CALL param-reg-0 quot-entry-point-offset [+] CALL
param-reg-0 param-reg-1 %save-context ; param-reg-0 param-reg-1 %save-context ;
M: x86.64 %callback-value ( ctype -- ) M: x86.64 %callback-value ( ctype -- )

View File

@ -27,11 +27,11 @@ IN: bootstrap.x86
: rex-length ( -- n ) 1 ; : rex-length ( -- n ) 1 ;
[ [
! load XT ! load entry point
safe-reg 0 MOV rc-absolute-cell rt-this jit-rel safe-reg 0 MOV rc-absolute-cell rt-this jit-rel
! save stack frame size ! save stack frame size
stack-frame-size PUSH stack-frame-size PUSH
! push XT ! push entry point
safe-reg PUSH safe-reg PUSH
! alignment ! alignment
RSP stack-frame-size 3 bootstrap-cells - SUB RSP stack-frame-size 3 bootstrap-cells - SUB
@ -56,7 +56,7 @@ IN: bootstrap.x86
jit-save-context jit-save-context
! call the primitive ! call the primitive
arg1 vm-reg MOV arg1 vm-reg MOV
RAX 0 MOV rc-absolute-cell rt-primitive jit-rel RAX 0 MOV rc-absolute-cell rt-dlsym jit-rel
RAX CALL RAX CALL
jit-restore-context jit-restore-context
] jit-primitive jit-define ] jit-primitive jit-define
@ -67,7 +67,7 @@ IN: bootstrap.x86
safe-reg stack-reg stack-frame-size 8 - [+] LEA safe-reg stack-reg stack-frame-size 8 - [+] LEA
ctx-reg context-callstack-bottom-offset [+] safe-reg MOV ctx-reg context-callstack-bottom-offset [+] safe-reg MOV
! call the quotation ! call the quotation
arg1 quot-xt-offset [+] CALL arg1 quot-entry-point-offset [+] CALL
jit-save-context jit-save-context
] \ c-to-factor define-sub-primitive ] \ c-to-factor define-sub-primitive
@ -75,8 +75,8 @@ IN: bootstrap.x86
arg1 ds-reg [] MOV arg1 ds-reg [] MOV
ds-reg bootstrap-cell SUB ds-reg bootstrap-cell SUB
] ]
[ arg1 quot-xt-offset [+] CALL ] [ arg1 quot-entry-point-offset [+] CALL ]
[ arg1 quot-xt-offset [+] JMP ] [ arg1 quot-entry-point-offset [+] JMP ]
\ (call) define-combinator-primitive \ (call) define-combinator-primitive
[ [
@ -97,7 +97,7 @@ IN: bootstrap.x86
jit-restore-context jit-restore-context
! Call quotation ! Call quotation
arg1 quot-xt-offset [+] JMP arg1 quot-entry-point-offset [+] JMP
] \ unwind-native-frames define-sub-primitive ] \ unwind-native-frames define-sub-primitive
[ [
@ -133,8 +133,8 @@ IN: bootstrap.x86
safe-reg 0 MOV "lazy_jit_compile" f rc-absolute-cell jit-dlsym safe-reg 0 MOV "lazy_jit_compile" f rc-absolute-cell jit-dlsym
safe-reg CALL safe-reg CALL
] ]
[ return-reg quot-xt-offset [+] CALL ] [ return-reg quot-entry-point-offset [+] CALL ]
[ return-reg quot-xt-offset [+] JMP ] [ return-reg quot-entry-point-offset [+] JMP ]
\ lazy-jit-compile define-combinator-primitive \ lazy-jit-compile define-combinator-primitive
! Inline cache miss entry points ! Inline cache miss entry points

View File

@ -34,7 +34,7 @@ big-endian off
vm-reg 0 MOV rc-absolute-cell rt-vm jit-rel vm-reg 0 MOV rc-absolute-cell rt-vm jit-rel
! Call into Factor code ! Call into Factor code
safe-reg 0 MOV rc-absolute-cell rt-xt jit-rel safe-reg 0 MOV rc-absolute-cell rt-entry-point jit-rel
safe-reg CALL safe-reg CALL
! Tear down register shadow area ! Tear down register shadow area
@ -61,9 +61,9 @@ big-endian off
temp0 profile-count-offset [+] 1 tag-fixnum ADD temp0 profile-count-offset [+] 1 tag-fixnum ADD
! Load word->code ! Load word->code
temp0 temp0 word-code-offset [+] MOV temp0 temp0 word-code-offset [+] MOV
! Compute word XT ! Compute word entry point
temp0 compiled-header-size ADD temp0 compiled-header-size ADD
! Jump to XT ! Jump to entry point
temp0 JMP temp0 JMP
] jit-profiling jit-define ] jit-profiling jit-define
@ -78,11 +78,11 @@ big-endian off
[ [
temp3 0 MOV rc-absolute-cell rt-here jit-rel temp3 0 MOV rc-absolute-cell rt-here jit-rel
0 JMP rc-relative rt-xt-pic-tail jit-rel 0 JMP rc-relative rt-entry-point-pic-tail jit-rel
] jit-word-jump jit-define ] jit-word-jump jit-define
[ [
0 CALL rc-relative rt-xt-pic jit-rel 0 CALL rc-relative rt-entry-point-pic jit-rel
] jit-word-call jit-define ] jit-word-call jit-define
[ [
@ -93,9 +93,9 @@ big-endian off
! compare boolean with f ! compare boolean with f
temp0 \ f type-number CMP temp0 \ f type-number CMP
! jump to true branch if not equal ! jump to true branch if not equal
0 JNE rc-relative rt-xt jit-rel 0 JNE rc-relative rt-entry-point jit-rel
! jump to false branch if equal ! jump to false branch if equal
0 JMP rc-relative rt-xt jit-rel 0 JMP rc-relative rt-entry-point jit-rel
] jit-if jit-define ] jit-if jit-define
: jit->r ( -- ) : jit->r ( -- )
@ -148,19 +148,19 @@ big-endian off
[ [
jit->r jit->r
0 CALL rc-relative rt-xt jit-rel 0 CALL rc-relative rt-entry-point jit-rel
jit-r> jit-r>
] jit-dip jit-define ] jit-dip jit-define
[ [
jit-2>r jit-2>r
0 CALL rc-relative rt-xt jit-rel 0 CALL rc-relative rt-entry-point jit-rel
jit-2r> jit-2r>
] jit-2dip jit-define ] jit-2dip jit-define
[ [
jit-3>r jit-3>r
0 CALL rc-relative rt-xt jit-rel 0 CALL rc-relative rt-entry-point jit-rel
jit-3r> jit-3r>
] jit-3dip jit-define ] jit-3dip jit-define
@ -170,14 +170,14 @@ big-endian off
! pop stack ! pop stack
ds-reg bootstrap-cell SUB ds-reg bootstrap-cell SUB
] ]
[ temp0 word-xt-offset [+] CALL ] [ temp0 word-entry-point-offset [+] CALL ]
[ temp0 word-xt-offset [+] JMP ] [ temp0 word-entry-point-offset [+] JMP ]
\ (execute) define-combinator-primitive \ (execute) define-combinator-primitive
[ [
temp0 ds-reg [] MOV temp0 ds-reg [] MOV
ds-reg bootstrap-cell SUB ds-reg bootstrap-cell SUB
temp0 word-xt-offset [+] JMP temp0 word-entry-point-offset [+] JMP
] jit-execute jit-define ] jit-execute jit-define
[ [
@ -224,7 +224,7 @@ big-endian off
temp1 temp2 CMP temp1 temp2 CMP
] pic-check-tuple jit-define ] pic-check-tuple jit-define
[ 0 JE rc-relative rt-xt jit-rel ] pic-hit jit-define [ 0 JE rc-relative rt-entry-point jit-rel ] pic-hit jit-define
! ! ! Megamorphic caches ! ! ! Megamorphic caches
@ -248,7 +248,7 @@ big-endian off
temp1 [] 1 ADD temp1 [] 1 ADD
! goto get(cache + bootstrap-cell) ! goto get(cache + bootstrap-cell)
temp0 temp0 bootstrap-cell [+] MOV temp0 temp0 bootstrap-cell [+] MOV
temp0 word-xt-offset [+] JMP temp0 word-entry-point-offset [+] JMP
! fall-through on miss ! fall-through on miss
] mega-lookup jit-define ] mega-lookup jit-define

View File

@ -96,7 +96,7 @@ M: threaded-server handle-client* handler>> call( -- ) ;
[ [ accept-connection ] with-semaphore ] [ [ accept-connection ] with-semaphore ]
[ accept-connection ] [ accept-connection ]
if* if*
] [ accept-loop ] bi ; inline recursive ] [ accept-loop ] bi ;
: started-accept-loop ( threaded-server -- ) : started-accept-loop ( threaded-server -- )
threaded-server get threaded-server get

View File

@ -155,7 +155,7 @@ HELP: with-client
HELP: <server> HELP: <server>
{ $values { "addrspec" "an address specifier" } { "encoding" "an encoding descriptor" } { "server" "a handle" } } { $values { "addrspec" "an address specifier" } { "encoding" "an encoding descriptor" } { "server" "a handle" } }
{ $description { $description
"Begins listening for network connections to a local address. Server objects responds to two words:" "Begins listening for network connections to a local address. Server objects respond to two words:"
{ $list { $list
{ { $link dispose } " - stops listening on the port and frees all associated resources" } { { $link dispose } " - stops listening on the port and frees all associated resources" }
{ { $link accept } " - blocks until there is a connection, and returns a stream of the encoding passed to the constructor" } { { $link accept } " - blocks until there is a connection, and returns a stream of the encoding passed to the constructor" }

View File

@ -1,49 +1,49 @@
! Copyright (C) 2005, 2009 Slava Pestov. ! Copyright (C) 2005, 2010 Slava Pestov, Joe Groff.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: arrays alien.c-types assocs kernel sequences math math.functions USING: arrays alien.c-types assocs kernel sequences math
grouping hints math.order math.libm math.floats.private fry combinators math.functions grouping math.order math.libm math.floats.private
byte-arrays accessors locals ; fry combinators byte-arrays accessors locals ;
QUALIFIED-WITH: alien.c-types c QUALIFIED-WITH: alien.c-types c
IN: math.vectors IN: math.vectors
GENERIC: vneg ( u -- v ) GENERIC: vneg ( u -- v )
M: object vneg [ neg ] map ; M: object vneg [ neg ] map ; inline
GENERIC# v+n 1 ( u n -- w ) GENERIC# v+n 1 ( u n -- w )
M: object v+n [ + ] curry map ; M: object v+n [ + ] curry map ; inline
GENERIC: n+v ( n v -- w ) GENERIC: n+v ( n v -- w )
M: object n+v [ + ] with map ; M: object n+v [ + ] with map ; inline
GENERIC# v-n 1 ( u n -- w ) GENERIC# v-n 1 ( u n -- w )
M: object v-n [ - ] curry map ; M: object v-n [ - ] curry map ; inline
GENERIC: n-v ( n v -- w ) GENERIC: n-v ( n v -- w )
M: object n-v [ - ] with map ; M: object n-v [ - ] with map ; inline
GENERIC# v*n 1 ( u n -- w ) GENERIC# v*n 1 ( u n -- w )
M: object v*n [ * ] curry map ; M: object v*n [ * ] curry map ; inline
GENERIC: n*v ( n v -- w ) GENERIC: n*v ( n v -- w )
M: object n*v [ * ] with map ; M: object n*v [ * ] with map ; inline
GENERIC# v/n 1 ( u n -- w ) GENERIC# v/n 1 ( u n -- w )
M: object v/n [ / ] curry map ; M: object v/n [ / ] curry map ; inline
GENERIC: n/v ( n v -- w ) GENERIC: n/v ( n v -- w )
M: object n/v [ / ] with map ; M: object n/v [ / ] with map ; inline
GENERIC: v+ ( u v -- w ) GENERIC: v+ ( u v -- w )
M: object v+ [ + ] 2map ; M: object v+ [ + ] 2map ; inline
GENERIC: v- ( u v -- w ) GENERIC: v- ( u v -- w )
M: object v- [ - ] 2map ; M: object v- [ - ] 2map ; inline
GENERIC: [v-] ( u v -- w ) GENERIC: [v-] ( u v -- w )
M: object [v-] [ [-] ] 2map ; M: object [v-] [ [-] ] 2map ; inline
GENERIC: v* ( u v -- w ) GENERIC: v* ( u v -- w )
M: object v* [ * ] 2map ; M: object v* [ * ] 2map ; inline
GENERIC: v*high ( u v -- w ) GENERIC: v*high ( u v -- w )
@ -53,43 +53,43 @@ GENERIC: v*high ( u v -- w )
PRIVATE> PRIVATE>
GENERIC: v*hs+ ( u v -- w ) GENERIC: v*hs+ ( u v -- w )
M: object v*hs+ [ * ] 2map (h+) ; M: object v*hs+ [ * ] 2map (h+) ; inline
GENERIC: v/ ( u v -- w ) GENERIC: v/ ( u v -- w )
M: object v/ [ / ] 2map ; M: object v/ [ / ] 2map ; inline
GENERIC: vavg ( u v -- w ) GENERIC: vavg ( u v -- w )
M: object vavg [ + 2 / ] 2map ; M: object vavg [ + 2 / ] 2map ; inline
GENERIC: vmax ( u v -- w ) GENERIC: vmax ( u v -- w )
M: object vmax [ max ] 2map ; M: object vmax [ max ] 2map ; inline
GENERIC: vmin ( u v -- w ) GENERIC: vmin ( u v -- w )
M: object vmin [ min ] 2map ; M: object vmin [ min ] 2map ; inline
GENERIC: v+- ( u v -- w ) GENERIC: v+- ( u v -- w )
M: object v+- M: object v+-
[ t ] 2dip [ t ] 2dip
[ [ not ] 2dip pick [ + ] [ - ] if ] 2map [ [ not ] 2dip pick [ + ] [ - ] if ] 2map
nip ; nip ; inline
GENERIC: vs+ ( u v -- w ) GENERIC: vs+ ( u v -- w )
M: object vs+ [ + ] 2map ; M: object vs+ [ + ] 2map ; inline
GENERIC: vs- ( u v -- w ) GENERIC: vs- ( u v -- w )
M: object vs- [ - ] 2map ; M: object vs- [ - ] 2map ; inline
GENERIC: vs* ( u v -- w ) GENERIC: vs* ( u v -- w )
M: object vs* [ * ] 2map ; M: object vs* [ * ] 2map ; inline
GENERIC: vabs ( u -- v ) GENERIC: vabs ( u -- v )
M: object vabs [ abs ] map ; M: object vabs [ abs ] map ; inline
GENERIC: vsqrt ( u -- v ) GENERIC: vsqrt ( u -- v )
M: object vsqrt [ >float fsqrt ] map ; M: object vsqrt [ >float fsqrt ] map ; inline
GENERIC: vsad ( u v -- n ) GENERIC: vsad ( u v -- n )
M: object vsad [ - abs ] [ + ] 2map-reduce ; M: object vsad [ - abs ] [ + ] 2map-reduce ; inline
<PRIVATE <PRIVATE
@ -98,23 +98,23 @@ M: object vsad [ - abs ] [ + ] 2map-reduce ;
PRIVATE> PRIVATE>
GENERIC: vbitand ( u v -- w ) GENERIC: vbitand ( u v -- w )
M: object vbitand [ bitand ] 2map ; M: object vbitand [ bitand ] 2map ; inline
GENERIC: vbitandn ( u v -- w ) GENERIC: vbitandn ( u v -- w )
M: object vbitandn [ bitandn ] 2map ; M: object vbitandn [ bitandn ] 2map ; inline
GENERIC: vbitor ( u v -- w ) GENERIC: vbitor ( u v -- w )
M: object vbitor [ bitor ] 2map ; M: object vbitor [ bitor ] 2map ; inline
GENERIC: vbitxor ( u v -- w ) GENERIC: vbitxor ( u v -- w )
M: object vbitxor [ bitxor ] 2map ; M: object vbitxor [ bitxor ] 2map ; inline
GENERIC: vbitnot ( u -- w ) GENERIC: vbitnot ( u -- w )
M: object vbitnot [ bitnot ] map ; M: object vbitnot [ bitnot ] map ; inline
GENERIC# vbroadcast 1 ( u n -- v ) GENERIC# vbroadcast 1 ( u n -- v )
M:: object vbroadcast ( u n -- v ) u length n u nth <repetition> u like ; M:: object vbroadcast ( u n -- v ) u length n u nth <repetition> u like ; inline
GENERIC# vshuffle-elements 1 ( u perm -- v ) GENERIC# vshuffle-elements 1 ( u perm -- v )
M: object vshuffle-elements M: object vshuffle-elements
over length 0 pad-tail over length 0 pad-tail
swap [ '[ _ nth ] ] keep map-as ; swap [ '[ _ nth ] ] keep map-as ; inline
GENERIC# vshuffle-bytes 1 ( u perm -- v ) GENERIC# vshuffle-bytes 1 ( u perm -- v )
@ -123,66 +123,66 @@ M: array vshuffle ( u perm -- v )
vshuffle-elements ; inline vshuffle-elements ; inline
GENERIC# vlshift 1 ( u n -- w ) GENERIC# vlshift 1 ( u n -- w )
M: object vlshift '[ _ shift ] map ; M: object vlshift '[ _ shift ] map ; inline
GENERIC# vrshift 1 ( u n -- w ) GENERIC# vrshift 1 ( u n -- w )
M: object vrshift neg '[ _ shift ] map ; M: object vrshift neg '[ _ shift ] map ; inline
GENERIC# hlshift 1 ( u n -- w ) GENERIC# hlshift 1 ( u n -- w )
GENERIC# hrshift 1 ( u n -- w ) GENERIC# hrshift 1 ( u n -- w )
GENERIC: (vmerge-head) ( u v -- h ) GENERIC: (vmerge-head) ( u v -- h )
M: object (vmerge-head) over length 2 /i '[ _ head-slice ] bi@ [ zip ] keep concat-as ; M: object (vmerge-head) over length 2 /i '[ _ head-slice ] bi@ [ zip ] keep concat-as ; inline
GENERIC: (vmerge-tail) ( u v -- t ) GENERIC: (vmerge-tail) ( u v -- t )
M: object (vmerge-tail) over length 2 /i '[ _ tail-slice ] bi@ [ zip ] keep concat-as ; M: object (vmerge-tail) over length 2 /i '[ _ tail-slice ] bi@ [ zip ] keep concat-as ; inline
GENERIC: (vmerge) ( u v -- h t ) GENERIC: (vmerge) ( u v -- h t )
M: object (vmerge) M: object (vmerge)
[ (vmerge-head) ] [ (vmerge-tail) ] 2bi ; inline [ (vmerge-head) ] [ (vmerge-tail) ] 2bi ; inline
GENERIC: vmerge ( u v -- w ) GENERIC: vmerge ( u v -- w )
M: object vmerge [ zip ] keep concat-as ; M: object vmerge [ zip ] keep concat-as ; inline
GENERIC: vand ( u v -- w ) GENERIC: vand ( u v -- w )
M: object vand [ and ] 2map ; M: object vand [ and ] 2map ; inline
GENERIC: vandn ( u v -- w ) GENERIC: vandn ( u v -- w )
M: object vandn [ [ not ] dip and ] 2map ; M: object vandn [ [ not ] dip and ] 2map ; inline
GENERIC: vor ( u v -- w ) GENERIC: vor ( u v -- w )
M: object vor [ or ] 2map ; M: object vor [ or ] 2map ; inline
GENERIC: vxor ( u v -- w ) GENERIC: vxor ( u v -- w )
M: object vxor [ xor ] 2map ; M: object vxor [ xor ] 2map ; inline
GENERIC: vnot ( u -- w ) GENERIC: vnot ( u -- w )
M: object vnot [ not ] map ; M: object vnot [ not ] map ; inline
GENERIC: vall? ( v -- ? ) GENERIC: vall? ( v -- ? )
M: object vall? [ ] all? ; M: object vall? [ ] all? ; inline
GENERIC: vany? ( v -- ? ) GENERIC: vany? ( v -- ? )
M: object vany? [ ] any? ; M: object vany? [ ] any? ; inline
GENERIC: vnone? ( v -- ? ) GENERIC: vnone? ( v -- ? )
M: object vnone? [ not ] all? ; M: object vnone? [ not ] all? ; inline
GENERIC: v< ( u v -- w ) GENERIC: v< ( u v -- w )
M: object v< [ < ] 2map ; M: object v< [ < ] 2map ; inline
GENERIC: v<= ( u v -- w ) GENERIC: v<= ( u v -- w )
M: object v<= [ <= ] 2map ; M: object v<= [ <= ] 2map ; inline
GENERIC: v>= ( u v -- w ) GENERIC: v>= ( u v -- w )
M: object v>= [ >= ] 2map ; M: object v>= [ >= ] 2map ; inline
GENERIC: v> ( u v -- w ) GENERIC: v> ( u v -- w )
M: object v> [ > ] 2map ; M: object v> [ > ] 2map ; inline
GENERIC: vunordered? ( u v -- w ) GENERIC: vunordered? ( u v -- w )
M: object vunordered? [ unordered? ] 2map ; M: object vunordered? [ unordered? ] 2map ; inline
GENERIC: v= ( u v -- w ) GENERIC: v= ( u v -- w )
M: object v= [ = ] 2map ; M: object v= [ = ] 2map ; inline
GENERIC: v? ( mask true false -- result ) GENERIC: v? ( mask true false -- result )
M: object v? M: object v?
@ -203,17 +203,17 @@ M: object v?
: vinfimum ( seq -- vmin ) [ ] [ vmin ] map-reduce ; inline : vinfimum ( seq -- vmin ) [ ] [ vmin ] map-reduce ; inline
GENERIC: v. ( u v -- x ) GENERIC: v. ( u v -- x )
M: object v. [ conjugate * ] [ + ] 2map-reduce ; M: object v. [ conjugate * ] [ + ] 2map-reduce ; inline
GENERIC: norm-sq ( v -- x ) GENERIC: norm-sq ( v -- x )
M: object norm-sq [ absq ] [ + ] map-reduce ; M: object norm-sq [ absq ] [ + ] map-reduce ; inline
: norm ( v -- x ) norm-sq sqrt ; inline : norm ( v -- x ) norm-sq sqrt ; inline
: normalize ( u -- v ) dup norm v/n ; inline : normalize ( u -- v ) dup norm v/n ; inline
GENERIC: distance ( u v -- x ) GENERIC: distance ( u v -- x )
M: object distance [ - absq ] [ + ] 2map-reduce sqrt ; M: object distance [ - absq ] [ + ] 2map-reduce sqrt ; inline
: set-axis ( u v axis -- w ) : set-axis ( u v axis -- w )
[ [ zero? 2over ? ] dip swap nth ] map-index 2nip ; [ [ zero? 2over ? ] dip swap nth ] map-index 2nip ;
@ -245,28 +245,3 @@ PRIVATE>
: v~ ( a b epsilon -- ? ) : v~ ( a b epsilon -- ? )
[ ~ ] curry 2all? ; inline [ ~ ] curry 2all? ; inline
HINTS: M\ object vneg { array } ;
HINTS: M\ object norm-sq { array } ;
HINTS: norm { array } ;
HINTS: M\ object distance { array array } ;
HINTS: M\ object n*v { object array } ;
HINTS: M\ object v*n { array object } ;
HINTS: M\ object n/v { object array } ;
HINTS: M\ object v/n { array object } ;
HINTS: M\ object v+ { array array } ;
HINTS: M\ object v- { array array } ;
HINTS: M\ object v* { array array } ;
HINTS: M\ object v/ { array array } ;
HINTS: M\ object vmax { array array } ;
HINTS: M\ object vmin { array array } ;
HINTS: M\ object v. { array array } ;
HINTS: vlerp { array array array } ;
HINTS: vnlerp { array array object } ;
HINTS: bilerp { object object object object array } ;
HINTS: trilerp { object object object object object object object object array } ;

View File

@ -101,11 +101,11 @@ SYNTAX: A@ scan-object scan-object <direct-A> suffix! ;
INSTANCE: A specialized-array INSTANCE: A specialized-array
M: A vs+ [ + \ T c-type-clamp ] 2map ; M: A vs+ [ + \ T c-type-clamp ] 2map ; inline
M: A vs- [ - \ T c-type-clamp ] 2map ; M: A vs- [ - \ T c-type-clamp ] 2map ; inline
M: A vs* [ * \ T c-type-clamp ] 2map ; M: A vs* [ * \ T c-type-clamp ] 2map ; inline
M: A v*high [ * \ T heap-size neg shift ] 2map ; M: A v*high [ * \ T heap-size neg shift ] 2map ; inline
;FUNCTOR ;FUNCTOR

View File

@ -486,8 +486,8 @@ M: bad-executable summary
\ (word) { object object object } { word } define-primitive \ (word) { object object object } { word } define-primitive
\ (word) make-flushable \ (word) make-flushable
\ word-xt { word } { integer integer } define-primitive \ word-code { word } { integer integer } define-primitive
\ word-xt make-flushable \ word-code make-flushable
\ special-object { fixnum } { object } define-primitive \ special-object { fixnum } { object } define-primitive
\ special-object make-flushable \ special-object make-flushable
@ -648,6 +648,8 @@ M: bad-executable summary
\ fseek { alien integer integer } { } define-primitive \ fseek { alien integer integer } { } define-primitive
\ ftell { alien } { integer } define-primitive
\ fclose { alien } { } define-primitive \ fclose { alien } { } define-primitive
\ <wrapper> { object } { wrapper } define-primitive \ <wrapper> { object } { wrapper } define-primitive
@ -662,8 +664,8 @@ M: bad-executable summary
\ array>quotation { array } { quotation } define-primitive \ array>quotation { array } { quotation } define-primitive
\ array>quotation make-flushable \ array>quotation make-flushable
\ quotation-xt { quotation } { integer } define-primitive \ quotation-code { quotation } { integer integer } define-primitive
\ quotation-xt make-flushable \ quotation-code make-flushable
\ <tuple> { tuple-layout } { tuple } define-primitive \ <tuple> { tuple-layout } { tuple } define-primitive
\ <tuple> make-flushable \ <tuple> make-flushable

View File

@ -1,5 +1,5 @@
USING: tools.test tools.annotations tools.time math parser eval USING: tools.test tools.annotations tools.time math parser eval
io.streams.string kernel strings ; io.streams.string kernel strings sequences memory ;
IN: tools.annotations.tests IN: tools.annotations.tests
: foo ( -- ) ; : foo ( -- ) ;
@ -60,3 +60,10 @@ M: object my-generic ;
f my-generic drop ; f my-generic drop ;
[ ] [ some-code ] unit-test [ ] [ some-code ] unit-test
! Make sure annotations work on primitives
\ gc watch
[ f ] [ [ gc ] with-string-writer empty? ] unit-test
\ gc reset

View File

@ -7,12 +7,16 @@ IN: tools.disassembler
GENERIC: disassemble ( obj -- ) GENERIC: disassemble ( obj -- )
<PRIVATE
SYMBOL: disassembler-backend SYMBOL: disassembler-backend
HOOK: disassemble* disassembler-backend ( from to -- lines ) HOOK: disassemble* disassembler-backend ( from to -- lines )
TR: tabs>spaces "\t" "\s" ; TR: tabs>spaces "\t" "\s" ;
PRIVATE>
M: byte-array disassemble M: byte-array disassemble
[ [
[ malloc-byte-array &free alien-address dup ] [ malloc-byte-array &free alien-address dup ]
@ -22,7 +26,7 @@ M: byte-array disassemble
M: pair disassemble first2 disassemble* [ tabs>spaces print ] each ; M: pair disassemble first2 disassemble* [ tabs>spaces print ] each ;
M: word disassemble word-xt 2array disassemble ; M: word disassemble word-code 2array disassemble ;
M: quotation disassemble [ dup infer define-temp ] with-compilation-unit disassemble ; M: quotation disassemble [ dup infer define-temp ] with-compilation-unit disassemble ;

View File

@ -1,9 +1,9 @@
! Copyright (C) 2008 Slava Pestov, Jorge Acereda Macia. ! Copyright (C) 2008, 2010 Slava Pestov, Jorge Acereda Macia.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: io.files io.files.temp io words alien kernel math.parser USING: io.files io.files.temp io words alien kernel math.parser
alien.syntax io.launcher assocs arrays sequences alien.syntax io.launcher assocs arrays sequences namespaces make
namespaces make system math io.encodings.ascii system math io.encodings.ascii accessors tools.disassembler
accessors tools.disassembler ; tools.disassembler.private ;
IN: tools.disassembler.gdb IN: tools.disassembler.gdb
SINGLETON: gdb-disassembler SINGLETON: gdb-disassembler

View File

@ -1,11 +1,11 @@
! Copyright (C) 2008 Slava Pestov, Jorge Acereda Macia. ! Copyright (C) 2008, 2010 Slava Pestov, Jorge Acereda Macia.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: tools.disassembler namespaces combinators USING: tools.disassembler namespaces combinators
alien alien.syntax alien.c-types lexer parser kernel alien alien.syntax alien.c-types lexer parser kernel
sequences layouts math math.order alien.libraries sequences layouts math math.order alien.libraries
math.parser system make fry arrays libc destructors math.parser system make fry arrays libc destructors
tools.disassembler.utils splitting alien.data tools.disassembler.utils tools.disassembler.private splitting
classes.struct ; alien.data classes.struct ;
IN: tools.disassembler.udis IN: tools.disassembler.udis
<< <<
@ -105,7 +105,7 @@ FUNCTION: char* ud_lookup_mnemonic ( int c ) ;
dup UD_SYN_INTEL ud_set_syntax ; dup UD_SYN_INTEL ud_set_syntax ;
: with-ud ( quot: ( ud -- ) -- ) : with-ud ( quot: ( ud -- ) -- )
[ [ [ <ud> ] dip call ] with-destructors ] with-words-xt ; inline [ [ [ <ud> ] dip call ] with-destructors ] with-word-entry-points ; inline
SINGLETON: udis-disassembler SINGLETON: udis-disassembler

View File

@ -2,13 +2,13 @@ USING: accessors arrays binary-search kernel math math.order
math.parser namespaces sequences sorting splitting vectors vocabs words ; math.parser namespaces sequences sorting splitting vectors vocabs words ;
IN: tools.disassembler.utils IN: tools.disassembler.utils
SYMBOL: words-xt SYMBOL: word-entry-points
SYMBOL: smallest-xt SYMBOL: smallest-xt
SYMBOL: greatest-xt SYMBOL: greatest-xt
: (words-xt) ( -- assoc ) : (word-entry-points) ( -- assoc )
vocabs [ words ] map concat [ [ word-xt ] keep 3array ] map vocabs [ words ] map concat [ [ word-code ] keep 3array ] map
[ [ first ] bi@ <=> ] sort >vector ; [ first ] sort-with ;
: complete-address ( n seq -- str ) : complete-address ( n seq -- str )
[ first - ] [ third name>> ] bi [ first - ] [ third name>> ] bi
@ -18,7 +18,7 @@ SYMBOL: greatest-xt
dup [ smallest-xt get < ] [ greatest-xt get > ] bi or [ dup [ smallest-xt get < ] [ greatest-xt get > ] bi or [
drop f drop f
] [ ] [
words-xt get over [ swap first <=> ] curry search nip word-entry-points get over [ swap first <=> ] curry search nip
2dup second <= [ 2dup second <= [
[ complete-address ] [ drop f ] if* [ complete-address ] [ drop f ] if*
] [ ] [
@ -33,9 +33,11 @@ SYMBOL: greatest-xt
: resolve-call ( str -- str' ) : resolve-call ( str -- str' )
"0x" split1-last [ resolve-xt "0x" glue ] when* ; "0x" split1-last [ resolve-xt "0x" glue ] when* ;
: with-words-xt ( quot -- ) : with-word-entry-points ( quot -- )
[ (words-xt) [
[ words-xt set ] (word-entry-points)
[ word-entry-points set ]
[ first first smallest-xt set ] [ first first smallest-xt set ]
[ last second greatest-xt set ] tri [ last second greatest-xt set ] tri
] prepose with-scope ; inline call
] with-scope ; inline

View File

@ -7,3 +7,4 @@ GNUmakefile
Nmakefile Nmakefile
unmaintained unmaintained
build-support build-support
images

View File

@ -1,11 +1,11 @@
! Copyright (C) 2004, 2009 Slava Pestov. ! Copyright (C) 2004, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: alien arrays byte-arrays generic hashtables USING: alien alien.strings arrays byte-arrays generic hashtables
hashtables.private io kernel math math.private math.order hashtables.private io io.encodings.ascii kernel math
namespaces make parser sequences strings vectors words math.private math.order namespaces make parser sequences strings
quotations assocs layouts classes classes.builtin classes.tuple vectors words quotations assocs layouts classes classes.builtin
classes.tuple.private kernel.private vocabs vocabs.loader classes.tuple classes.tuple.private kernel.private vocabs
source-files definitions slots classes.union vocabs.loader source-files definitions slots classes.union
classes.intersection classes.predicate compiler.units classes.intersection classes.predicate compiler.units
bootstrap.image.private io.files accessors combinators ; bootstrap.image.private io.files accessors combinators ;
IN: bootstrap.primitives IN: bootstrap.primitives
@ -309,7 +309,11 @@ tuple
! Sub-primitive words ! Sub-primitive words
: make-sub-primitive ( word vocab effect -- ) : make-sub-primitive ( word vocab effect -- )
[ create dup 1quotation ] dip define-declared ; [
create
dup t "primitive" set-word-prop
dup 1quotation
] dip define-declared ;
{ {
{ "mega-cache-lookup" "generic.single.private" (( methods index cache -- )) } { "mega-cache-lookup" "generic.single.private" (( methods index cache -- )) }
@ -364,169 +368,173 @@ tuple
} [ first3 make-sub-primitive ] each } [ first3 make-sub-primitive ] each
! Primitive words ! Primitive words
: make-primitive ( word vocab n effect -- ) : make-primitive ( word vocab function effect -- )
[ [
[ create dup reset-word ] dip [
[ do-primitive ] curry create
dup reset-word
dup t "primitive" set-word-prop
] dip
ascii string>alien [ do-primitive ] curry
] dip define-declared ; ] dip define-declared ;
{ {
{ "bignum>fixnum" "math.private" (( x -- y )) } { "<callback>" "alien" "primitive_callback" (( return-rewind word -- alien )) }
{ "float>fixnum" "math.private" (( x -- y )) } { "<displaced-alien>" "alien" "primitive_displaced_alien" (( displacement c-ptr -- alien )) }
{ "fixnum>bignum" "math.private" (( x -- y )) } { "alien-address" "alien" "primitive_alien_address" (( c-ptr -- addr )) }
{ "float>bignum" "math.private" (( x -- y )) } { "alien-cell" "alien.accessors" "primitive_alien_cell" (( c-ptr n -- value )) }
{ "fixnum>float" "math.private" (( x -- y )) } { "alien-double" "alien.accessors" "primitive_alien_double" (( c-ptr n -- value )) }
{ "bignum>float" "math.private" (( x -- y )) } { "alien-float" "alien.accessors" "primitive_alien_float" (( c-ptr n -- value )) }
{ "(string>float)" "math.parser.private" (( str -- n/f )) } { "alien-signed-1" "alien.accessors" "primitive_alien_signed_1" (( c-ptr n -- value )) }
{ "(float>string)" "math.parser.private" (( n -- str )) } { "alien-signed-2" "alien.accessors" "primitive_alien_signed_2" (( c-ptr n -- value )) }
{ "float>bits" "math" (( x -- n )) } { "alien-signed-4" "alien.accessors" "primitive_alien_signed_4" (( c-ptr n -- value )) }
{ "double>bits" "math" (( x -- n )) } { "alien-signed-8" "alien.accessors" "primitive_alien_signed_8" (( c-ptr n -- value )) }
{ "bits>float" "math" (( n -- x )) } { "alien-signed-cell" "alien.accessors" "primitive_alien_signed_cell" (( c-ptr n -- value )) }
{ "bits>double" "math" (( n -- x )) } { "alien-unsigned-1" "alien.accessors" "primitive_alien_unsigned_1" (( c-ptr n -- value )) }
{ "fixnum/i" "math.private" (( x y -- z )) } { "alien-unsigned-2" "alien.accessors" "primitive_alien_unsigned_2" (( c-ptr n -- value )) }
{ "fixnum/mod" "math.private" (( x y -- z w )) } { "alien-unsigned-4" "alien.accessors" "primitive_alien_unsigned_4" (( c-ptr n -- value )) }
{ "fixnum-shift" "math.private" (( x y -- z )) } { "alien-unsigned-8" "alien.accessors" "primitive_alien_unsigned_8" (( c-ptr n -- value )) }
{ "bignum=" "math.private" (( x y -- ? )) } { "alien-unsigned-cell" "alien.accessors" "primitive_alien_unsigned_cell" (( c-ptr n -- value )) }
{ "bignum+" "math.private" (( x y -- z )) } { "set-alien-cell" "alien.accessors" "primitive_set_alien_cell" (( value c-ptr n -- )) }
{ "bignum-" "math.private" (( x y -- z )) } { "set-alien-double" "alien.accessors" "primitive_set_alien_double" (( value c-ptr n -- )) }
{ "bignum*" "math.private" (( x y -- z )) } { "set-alien-float" "alien.accessors" "primitive_set_alien_float" (( value c-ptr n -- )) }
{ "bignum/i" "math.private" (( x y -- z )) } { "set-alien-signed-1" "alien.accessors" "primitive_set_alien_signed_1" (( value c-ptr n -- )) }
{ "bignum-mod" "math.private" (( x y -- z )) } { "set-alien-signed-2" "alien.accessors" "primitive_set_alien_signed_2" (( value c-ptr n -- )) }
{ "bignum/mod" "math.private" (( x y -- z w )) } { "set-alien-signed-4" "alien.accessors" "primitive_set_alien_signed_4" (( value c-ptr n -- )) }
{ "bignum-bitand" "math.private" (( x y -- z )) } { "set-alien-signed-8" "alien.accessors" "primitive_set_alien_signed_8" (( value c-ptr n -- )) }
{ "bignum-bitor" "math.private" (( x y -- z )) } { "set-alien-signed-cell" "alien.accessors" "primitive_set_alien_signed_cell" (( value c-ptr n -- )) }
{ "bignum-bitxor" "math.private" (( x y -- z )) } { "set-alien-unsigned-1" "alien.accessors" "primitive_set_alien_unsigned_1" (( value c-ptr n -- )) }
{ "bignum-bitnot" "math.private" (( x -- y )) } { "set-alien-unsigned-2" "alien.accessors" "primitive_set_alien_unsigned_2" (( value c-ptr n -- )) }
{ "bignum-shift" "math.private" (( x y -- z )) } { "set-alien-unsigned-4" "alien.accessors" "primitive_set_alien_unsigned_4" (( value c-ptr n -- )) }
{ "bignum<" "math.private" (( x y -- ? )) } { "set-alien-unsigned-8" "alien.accessors" "primitive_set_alien_unsigned_8" (( value c-ptr n -- )) }
{ "bignum<=" "math.private" (( x y -- ? )) } { "set-alien-unsigned-cell" "alien.accessors" "primitive_set_alien_unsigned_cell" (( value c-ptr n -- )) }
{ "bignum>" "math.private" (( x y -- ? )) } { "(dlopen)" "alien.libraries" "primitive_dlopen" (( path -- dll )) }
{ "bignum>=" "math.private" (( x y -- ? )) } { "(dlsym)" "alien.libraries" "primitive_dlsym" (( name dll -- alien )) }
{ "bignum-bit?" "math.private" (( n x -- ? )) } { "dlclose" "alien.libraries" "primitive_dlclose" (( dll -- )) }
{ "bignum-log2" "math.private" (( x -- n )) } { "dll-valid?" "alien.libraries" "primitive_dll_validp" (( dll -- ? )) }
{ "byte-array>bignum" "math" (( x -- y )) } { "<array>" "arrays" "primitive_array" (( n elt -- array )) }
{ "float=" "math.private" (( x y -- ? )) } { "resize-array" "arrays" "primitive_resize_array" (( n array -- newarray )) }
{ "float+" "math.private" (( x y -- z )) } { "(byte-array)" "byte-arrays" "primitive_uninitialized_byte_array" (( n -- byte-array )) }
{ "float-" "math.private" (( x y -- z )) } { "<byte-array>" "byte-arrays" "primitive_byte_array" (( n -- byte-array )) }
{ "float*" "math.private" (( x y -- z )) } { "resize-byte-array" "byte-arrays" "primitive_resize_byte_array" (( n byte-array -- newbyte-array )) }
{ "float/f" "math.private" (( x y -- z )) } { "<tuple-boa>" "classes.tuple.private" "primitive_tuple_boa" (( ... layout -- tuple )) }
{ "float-mod" "math.private" (( x y -- z )) } { "<tuple>" "classes.tuple.private" "primitive_tuple" (( layout -- tuple )) }
{ "float<" "math.private" (( x y -- ? )) } { "modify-code-heap" "compiler.units" "primitive_modify_code_heap" (( alist -- )) }
{ "float<=" "math.private" (( x y -- ? )) } { "lookup-method" "generic.single.private" "primitive_lookup_method" (( object methods -- method )) }
{ "float>" "math.private" (( x y -- ? )) } { "mega-cache-miss" "generic.single.private" "primitive_mega_cache_miss" (( methods index cache -- method )) }
{ "float>=" "math.private" (( x y -- ? )) } { "(exists?)" "io.files.private" "primitive_existsp" (( path -- ? )) }
{ "float-u<" "math.private" (( x y -- ? )) } { "(fopen)" "io.streams.c" "primitive_fopen" (( path mode -- alien )) }
{ "float-u<=" "math.private" (( x y -- ? )) } { "fclose" "io.streams.c" "primitive_fclose" (( alien -- )) }
{ "float-u>" "math.private" (( x y -- ? )) } { "fflush" "io.streams.c" "primitive_fflush" (( alien -- )) }
{ "float-u>=" "math.private" (( x y -- ? )) } { "fgetc" "io.streams.c" "primitive_fgetc" (( alien -- ch/f )) }
{ "(word)" "words.private" (( name vocab -- word )) } { "fputc" "io.streams.c" "primitive_fputc" (( ch alien -- )) }
{ "word-xt" "words" (( word -- start end )) } { "fread" "io.streams.c" "primitive_fread" (( n alien -- str/f )) }
{ "special-object" "kernel.private" (( n -- obj )) } { "fseek" "io.streams.c" "primitive_fseek" (( alien offset whence -- )) }
{ "set-special-object" "kernel.private" (( obj n -- )) } { "ftell" "io.streams.c" "primitive_ftell" (( alien -- n )) }
{ "(exists?)" "io.files.private" (( path -- ? )) } { "fwrite" "io.streams.c" "primitive_fwrite" (( string alien -- )) }
{ "minor-gc" "memory" (( -- )) } { "(clone)" "kernel" "primitive_clone" (( obj -- newobj )) }
{ "gc" "memory" (( -- )) } { "<wrapper>" "kernel" "primitive_wrapper" (( obj -- wrapper )) }
{ "compact-gc" "memory" (( -- )) } { "callstack" "kernel" "primitive_callstack" (( -- cs )) }
{ "(save-image)" "memory.private" (( path -- )) } { "callstack>array" "kernel" "primitive_callstack_to_array" (( callstack -- array )) }
{ "(save-image-and-exit)" "memory.private" (( path -- )) } { "datastack" "kernel" "primitive_datastack" (( -- ds )) }
{ "datastack" "kernel" (( -- ds )) } { "die" "kernel" "primitive_die" (( -- )) }
{ "retainstack" "kernel" (( -- rs )) } { "retainstack" "kernel" "primitive_retainstack" (( -- rs )) }
{ "callstack" "kernel" (( -- cs )) } { "(identity-hashcode)" "kernel.private" "primitive_identity_hashcode" (( obj -- code )) }
{ "set-datastack" "kernel.private" (( ds -- )) } { "become" "kernel.private" "primitive_become" (( old new -- )) }
{ "set-retainstack" "kernel.private" (( rs -- )) } { "call-clear" "kernel.private" "primitive_call_clear" (( quot -- * )) }
{ "(exit)" "system" (( n -- )) } { "check-datastack" "kernel.private" "primitive_check_datastack" (( array in# out# -- ? )) }
{ "data-room" "memory" (( -- data-room )) } { "compute-identity-hashcode" "kernel.private" "primitive_compute_identity_hashcode" (( obj -- )) }
{ "code-room" "memory" (( -- code-room )) } { "innermost-frame-executing" "kernel.private" "primitive_innermost_stack_frame_executing" (( callstack -- obj )) }
{ "system-micros" "system" (( -- us )) } { "innermost-frame-scan" "kernel.private" "primitive_innermost_stack_frame_scan" (( callstack -- n )) }
{ "nano-count" "system" (( -- ns )) } { "set-datastack" "kernel.private" "primitive_set_datastack" (( ds -- )) }
{ "modify-code-heap" "compiler.units" (( alist -- )) } { "set-innermost-frame-quot" "kernel.private" "primitive_set_innermost_stack_frame_quot" (( n callstack -- )) }
{ "(dlopen)" "alien.libraries" (( path -- dll )) } { "set-retainstack" "kernel.private" "primitive_set_retainstack" (( rs -- )) }
{ "(dlsym)" "alien.libraries" (( name dll -- alien )) } { "set-special-object" "kernel.private" "primitive_set_special_object" (( obj n -- )) }
{ "dlclose" "alien.libraries" (( dll -- )) } { "special-object" "kernel.private" "primitive_special_object" (( n -- obj )) }
{ "<byte-array>" "byte-arrays" (( n -- byte-array )) } { "strip-stack-traces" "kernel.private" "primitive_strip_stack_traces" (( -- )) }
{ "(byte-array)" "byte-arrays" (( n -- byte-array )) } { "unimplemented" "kernel.private" "primitive_unimplemented" (( -- * )) }
{ "<displaced-alien>" "alien" (( displacement c-ptr -- alien )) } { "load-locals" "locals.backend" "primitive_load_locals" (( ... n -- )) }
{ "alien-signed-cell" "alien.accessors" (( c-ptr n -- value )) } { "bits>double" "math" "primitive_bits_double" (( n -- x )) }
{ "set-alien-signed-cell" "alien.accessors" (( value c-ptr n -- )) } { "bits>float" "math" "primitive_bits_float" (( n -- x )) }
{ "alien-unsigned-cell" "alien.accessors" (( c-ptr n -- value )) } { "byte-array>bignum" "math" "primitive_byte_array_to_bignum" (( x -- y )) }
{ "set-alien-unsigned-cell" "alien.accessors" (( value c-ptr n -- )) } { "double>bits" "math" "primitive_double_bits" (( x -- n )) }
{ "alien-signed-8" "alien.accessors" (( c-ptr n -- value )) } { "float>bits" "math" "primitive_float_bits" (( x -- n )) }
{ "set-alien-signed-8" "alien.accessors" (( value c-ptr n -- )) } { "(float>string)" "math.parser.private" "primitive_float_to_str" (( n -- str )) }
{ "alien-unsigned-8" "alien.accessors" (( c-ptr n -- value )) } { "(string>float)" "math.parser.private" "primitive_str_to_float" (( str -- n/f )) }
{ "set-alien-unsigned-8" "alien.accessors" (( value c-ptr n -- )) } { "bignum*" "math.private" "primitive_bignum_multiply" (( x y -- z )) }
{ "alien-signed-4" "alien.accessors" (( c-ptr n -- value )) } { "bignum+" "math.private" "primitive_bignum_add" (( x y -- z )) }
{ "set-alien-signed-4" "alien.accessors" (( value c-ptr n -- )) } { "bignum-" "math.private" "primitive_bignum_subtract" (( x y -- z )) }
{ "alien-unsigned-4" "alien.accessors" (( c-ptr n -- value )) } { "bignum-bit?" "math.private" "primitive_bignum_bitp" (( n x -- ? )) }
{ "set-alien-unsigned-4" "alien.accessors" (( value c-ptr n -- )) } { "bignum-bitand" "math.private" "primitive_bignum_and" (( x y -- z )) }
{ "alien-signed-2" "alien.accessors" (( c-ptr n -- value )) } { "bignum-bitnot" "math.private" "primitive_bignum_not" (( x -- y )) }
{ "set-alien-signed-2" "alien.accessors" (( value c-ptr n -- )) } { "bignum-bitor" "math.private" "primitive_bignum_or" (( x y -- z )) }
{ "alien-unsigned-2" "alien.accessors" (( c-ptr n -- value )) } { "bignum-bitxor" "math.private" "primitive_bignum_xor" (( x y -- z )) }
{ "set-alien-unsigned-2" "alien.accessors" (( value c-ptr n -- )) } { "bignum-log2" "math.private" "primitive_bignum_log2" (( x -- n )) }
{ "alien-signed-1" "alien.accessors" (( c-ptr n -- value )) } { "bignum-mod" "math.private" "primitive_bignum_mod" (( x y -- z )) }
{ "set-alien-signed-1" "alien.accessors" (( value c-ptr n -- )) } { "bignum-shift" "math.private" "primitive_bignum_shift" (( x y -- z )) }
{ "alien-unsigned-1" "alien.accessors" (( c-ptr n -- value )) } { "bignum/i" "math.private" "primitive_bignum_divint" (( x y -- z )) }
{ "set-alien-unsigned-1" "alien.accessors" (( value c-ptr n -- )) } { "bignum/mod" "math.private" "primitive_bignum_divmod" (( x y -- z w )) }
{ "alien-float" "alien.accessors" (( c-ptr n -- value )) } { "bignum<" "math.private" "primitive_bignum_less" (( x y -- ? )) }
{ "set-alien-float" "alien.accessors" (( value c-ptr n -- )) } { "bignum<=" "math.private" "primitive_bignum_lesseq" (( x y -- ? )) }
{ "alien-double" "alien.accessors" (( c-ptr n -- value )) } { "bignum=" "math.private" "primitive_bignum_eq" (( x y -- ? )) }
{ "set-alien-double" "alien.accessors" (( value c-ptr n -- )) } { "bignum>" "math.private" "primitive_bignum_greater" (( x y -- ? )) }
{ "alien-cell" "alien.accessors" (( c-ptr n -- value )) } { "bignum>=" "math.private" "primitive_bignum_greatereq" (( x y -- ? )) }
{ "set-alien-cell" "alien.accessors" (( value c-ptr n -- )) } { "bignum>fixnum" "math.private" "primitive_bignum_to_fixnum" (( x -- y )) }
{ "alien-address" "alien" (( c-ptr -- addr )) } { "bignum>float" "math.private" "primitive_bignum_to_float" (( x -- y )) }
{ "set-slot" "slots.private" (( value obj n -- )) } { "fixnum-shift" "math.private" "primitive_fixnum_shift" (( x y -- z )) }
{ "string-nth" "strings.private" (( n string -- ch )) } { "fixnum/i" "math.private" "primitive_fixnum_divint" (( x y -- z )) }
{ "set-string-nth-fast" "strings.private" (( ch n string -- )) } { "fixnum/mod" "math.private" "primitive_fixnum_divmod" (( x y -- z w )) }
{ "set-string-nth-slow" "strings.private" (( ch n string -- )) } { "fixnum>bignum" "math.private" "primitive_fixnum_to_bignum" (( x -- y )) }
{ "resize-array" "arrays" (( n array -- newarray )) } { "fixnum>float" "math.private" "primitive_fixnum_to_float" (( x -- y )) }
{ "resize-string" "strings" (( n str -- newstr )) } { "float*" "math.private" "primitive_float_multiply" (( x y -- z )) }
{ "<array>" "arrays" (( n elt -- array )) } { "float+" "math.private" "primitive_float_add" (( x y -- z )) }
{ "all-instances" "memory" (( -- array )) } { "float-" "math.private" "primitive_float_subtract" (( x y -- z )) }
{ "size" "memory" (( obj -- n )) } { "float-mod" "math.private" "primitive_float_mod" (( x y -- z )) }
{ "die" "kernel" (( -- )) } { "float-u<" "math.private" "primitive_float_less" (( x y -- ? )) }
{ "(fopen)" "io.streams.c" (( path mode -- alien )) } { "float-u<=" "math.private" "primitive_float_lesseq" (( x y -- ? )) }
{ "fgetc" "io.streams.c" (( alien -- ch/f )) } { "float-u>" "math.private" "primitive_float_greater" (( x y -- ? )) }
{ "fread" "io.streams.c" (( n alien -- str/f )) } { "float-u>=" "math.private" "primitive_float_greatereq" (( x y -- ? )) }
{ "fputc" "io.streams.c" (( ch alien -- )) } { "float/f" "math.private" "primitive_float_divfloat" (( x y -- z )) }
{ "fwrite" "io.streams.c" (( string alien -- )) } { "float<" "math.private" "primitive_float_less" (( x y -- ? )) }
{ "fflush" "io.streams.c" (( alien -- )) } { "float<=" "math.private" "primitive_float_lesseq" (( x y -- ? )) }
{ "ftell" "io.streams.c" (( alien -- n )) } { "float=" "math.private" "primitive_float_eq" (( x y -- ? )) }
{ "fseek" "io.streams.c" (( alien offset whence -- )) } { "float>" "math.private" "primitive_float_greater" (( x y -- ? )) }
{ "fclose" "io.streams.c" (( alien -- )) } { "float>=" "math.private" "primitive_float_greatereq" (( x y -- ? )) }
{ "<wrapper>" "kernel" (( obj -- wrapper )) } { "float>bignum" "math.private" "primitive_float_to_bignum" (( x -- y )) }
{ "(clone)" "kernel" (( obj -- newobj )) } { "float>fixnum" "math.private" "primitive_float_to_fixnum" (( x -- y )) }
{ "<string>" "strings" (( n ch -- string )) } { "all-instances" "memory" "primitive_all_instances" (( -- array )) }
{ "array>quotation" "quotations.private" (( array -- quot )) } { "code-room" "memory" "primitive_code_room" (( -- code-room )) }
{ "quotation-xt" "quotations" (( quot -- xt )) } { "compact-gc" "memory" "primitive_compact_gc" (( -- )) }
{ "<tuple>" "classes.tuple.private" (( layout -- tuple )) } { "data-room" "memory" "primitive_data_room" (( -- data-room )) }
{ "profiling" "tools.profiler.private" (( ? -- )) } { "disable-gc-events" "memory" "primitive_disable_gc_events" (( -- events )) }
{ "become" "kernel.private" (( old new -- )) } { "enable-gc-events" "memory" "primitive_enable_gc_events" (( -- )) }
{ "(sleep)" "threads.private" (( nanos -- )) } { "gc" "memory" "primitive_full_gc" (( -- )) }
{ "<tuple-boa>" "classes.tuple.private" (( ... layout -- tuple )) } { "minor-gc" "memory" "primitive_minor_gc" (( -- )) }
{ "callstack>array" "kernel" (( callstack -- array )) } { "size" "memory" "primitive_size" (( obj -- n )) }
{ "innermost-frame-executing" "kernel.private" (( callstack -- obj )) } { "(save-image)" "memory.private" "primitive_save_image" (( path -- )) }
{ "innermost-frame-scan" "kernel.private" (( callstack -- n )) } { "(save-image-and-exit)" "memory.private" "primitive_save_image_and_exit" (( path -- )) }
{ "set-innermost-frame-quot" "kernel.private" (( n callstack -- )) } { "jit-compile" "quotations" "primitive_jit_compile" (( quot -- )) }
{ "call-clear" "kernel.private" (( quot -- * )) } { "quot-compiled?" "quotations" "primitive_quot_compiled_p" (( quot -- ? )) }
{ "resize-byte-array" "byte-arrays" (( n byte-array -- newbyte-array )) } { "quotation-code" "quotations" "primitive_quotation_code" (( quot -- start end )) }
{ "dll-valid?" "alien.libraries" (( dll -- ? )) } { "array>quotation" "quotations.private" "primitive_array_to_quotation" (( array -- quot )) }
{ "unimplemented" "kernel.private" (( -- * )) } { "set-slot" "slots.private" "primitive_set_slot" (( value obj n -- )) }
{ "jit-compile" "quotations" (( quot -- )) } { "<string>" "strings" "primitive_string" (( n ch -- string )) }
{ "load-locals" "locals.backend" (( ... n -- )) } { "resize-string" "strings" "primitive_resize_string" (( n str -- newstr )) }
{ "check-datastack" "kernel.private" (( array in# out# -- ? )) } { "set-string-nth-fast" "strings.private" "primitive_set_string_nth_fast" (( ch n string -- )) }
{ "mega-cache-miss" "generic.single.private" (( methods index cache -- method )) } { "set-string-nth-slow" "strings.private" "primitive_set_string_nth_slow" (( ch n string -- )) }
{ "lookup-method" "generic.single.private" (( object methods -- method )) } { "string-nth" "strings.private" "primitive_string_nth" (( n string -- ch )) }
{ "reset-dispatch-stats" "tools.dispatch.private" (( -- )) } { "(exit)" "system" "primitive_exit" (( n -- )) }
{ "dispatch-stats" "tools.dispatch.private" (( -- stats )) } { "nano-count" "system" "primitive_nano_count" (( -- ns )) }
{ "optimized?" "words" (( word -- ? )) } { "system-micros" "system" "primitive_system_micros" (( -- us )) }
{ "quot-compiled?" "quotations" (( quot -- ? )) } { "(sleep)" "threads.private" "primitive_sleep" (( nanos -- )) }
{ "vm-ptr" "vm" (( -- ptr )) } { "dispatch-stats" "tools.dispatch.private" "primitive_dispatch_stats" (( -- stats )) }
{ "strip-stack-traces" "kernel.private" (( -- )) } { "reset-dispatch-stats" "tools.dispatch.private" "primitive_reset_dispatch_stats" (( -- )) }
{ "<callback>" "alien" (( return-rewind word -- alien )) } { "profiling" "tools.profiler.private" "primitive_profiling" (( ? -- )) }
{ "enable-gc-events" "memory" (( -- )) } { "vm-ptr" "vm" "primitive_vm_ptr" (( -- ptr )) }
{ "disable-gc-events" "memory" (( -- events )) } { "optimized?" "words" "primitive_optimized_p" (( word -- ? )) }
{ "(identity-hashcode)" "kernel.private" (( obj -- code )) } { "word-code" "words" "primitive_word_code" (( word -- start end )) }
{ "compute-identity-hashcode" "kernel.private" (( obj -- )) } { "(word)" "words.private" "primitive_word" (( name vocab -- word )) }
} [ [ first3 ] dip swap make-primitive ] each-index } [ first4 make-primitive ] each
! Bump build number ! Bump build number
"build" "kernel" create build 1 + [ ] curry (( -- n )) define-declared "build" "kernel" create build 1 + [ ] curry (( -- n )) define-declared

View File

@ -3,7 +3,9 @@ vectors kernel combinators ;
IN: quotations IN: quotations
ARTICLE: "quotations" "Quotations" ARTICLE: "quotations" "Quotations"
"A quotation is an anonymous function (a value denoting a snippet of code) which can be used as a value and called. Quotations are delimited by square brackets (" { $snippet "[ ]" } "); see " { $link "syntax-quots" } " for details on their syntax." "A quotation is an anonymous function (a value denoting a snippet of code) which can be used as a value and called using the " { $link "call" } "."
$nl
"Quotation literals appearing in source code are delimited by square brackets, for example " { $snippet "[ 2 + ]" } "; see " { $link "syntax-quots" } " for details on their syntax."
$nl $nl
"Quotations form a class of objects:" "Quotations form a class of objects:"
{ $subsections { $subsections

View File

@ -221,8 +221,8 @@ TUPLE: slice-error from to seq reason ;
3tri ; inline 3tri ; inline
: <slice> ( from to seq -- slice ) : <slice> ( from to seq -- slice )
dup slice? [ collapse-slice ] when
check-slice check-slice
dup slice? [ collapse-slice ] when
slice boa ; inline slice boa ; inline
M: slice virtual-exemplar seq>> ; inline M: slice virtual-exemplar seq>> ; inline
@ -836,6 +836,12 @@ PRIVATE>
[ 3dup ] dip [ + swap nth-unsafe ] keep rot nth-unsafe = [ 3dup ] dip [ + swap nth-unsafe ] keep rot nth-unsafe =
] all? nip ; inline ] all? nip ; inline
: prepare-2map-reduce ( seq1 seq2 map-quot -- initial length seq1 seq2 )
[ drop min-length dup 1 < [ "Empty sequence" throw ] when 1 - ]
[ drop [ [ 1 + ] 2dip 2nth-unsafe ] 2curry ]
[ [ [ first-unsafe ] bi@ ] dip call ]
3tri -rot ; inline
PRIVATE> PRIVATE>
: start* ( subseq seq n -- i ) : start* ( subseq seq n -- i )
@ -868,8 +874,8 @@ PRIVATE>
compose reduce ; inline compose reduce ; inline
: 2map-reduce ( seq1 seq2 map-quot reduce-quot -- result ) : 2map-reduce ( seq1 seq2 map-quot reduce-quot -- result )
[ [ 2unclip-slice ] dip [ call ] keep ] dip [ [ prepare-2map-reduce ] keep ] dip
compose 2reduce ; inline compose compose each-integer ; inline
<PRIVATE <PRIVATE

View File

@ -133,8 +133,8 @@ $nl
ARTICLE: "word.private" "Word implementation details" ARTICLE: "word.private" "Word implementation details"
"The " { $snippet "def" } " slot of a word holds a " { $link quotation } " instance that is called when the word is executed." "The " { $snippet "def" } " slot of a word holds a " { $link quotation } " instance that is called when the word is executed."
$nl $nl
"An " { $emphasis "XT" } " (execution token) is the machine code address of a word:" "A primitive to get the memory range storing the machine code for a word:"
{ $subsections word-xt } ; { $subsections word-code } ;
ARTICLE: "words.introspection" "Word introspection" ARTICLE: "words.introspection" "Word introspection"
"Word introspection facilities and implementation details are found in the " { $vocab-link "words" } " vocabulary." "Word introspection facilities and implementation details are found in the " { $vocab-link "words" } " vocabulary."
@ -209,9 +209,9 @@ HELP: remove-word-prop
{ $description "Removes a word property, so future lookups will output " { $link f } " until it is set again. Word property names are conventionally strings." } { $description "Removes a word property, so future lookups will output " { $link f } " until it is set again. Word property names are conventionally strings." }
{ $side-effects "word" } ; { $side-effects "word" } ;
HELP: word-xt ( word -- start end ) HELP: word-code ( word -- start end )
{ $values { "word" word } { "start" "the word's start address" } { "end" "the word's end address" } } { $values { "word" word } { "start" "the word's start address" } { "end" "the word's end address" } }
{ $description "Outputs the machine code address of the word's definition." } ; { $description "Outputs the memory range containing the word's machine code." } ;
HELP: define HELP: define
{ $values { "word" word } { "def" quotation } } { $values { "word" word } { "def" quotation } }

View File

@ -127,4 +127,4 @@ DEFER: x
] map harvest ] map harvest
] unit-test ] unit-test
[ "hi" word-xt ] must-fail [ "hi" word-code ] must-fail

View File

@ -1,4 +1,4 @@
! Copyright (C) 2004, 2009 Slava Pestov. ! Copyright (C) 2004, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays definitions kernel kernel.private USING: accessors arrays definitions kernel kernel.private
slots.private math namespaces sequences strings vectors sbufs slots.private math namespaces sequences strings vectors sbufs
@ -21,20 +21,6 @@ M: word definer drop \ : \ ; ;
M: word definition def>> ; M: word definition def>> ;
ERROR: undefined ;
PREDICATE: deferred < word ( obj -- ? )
def>> [ undefined ] = ;
M: deferred definer drop \ DEFER: f ;
M: deferred definition drop f ;
PREDICATE: primitive < word ( obj -- ? )
[ def>> [ do-primitive ] tail? ]
[ sub-primitive>> >boolean ]
bi or ;
M: primitive definer drop \ PRIMITIVE: f ;
M: primitive definition drop f ;
: word-prop ( word name -- value ) swap props>> at ; : word-prop ( word name -- value ) swap props>> at ;
: remove-word-prop ( word name -- ) swap props>> delete-at ; : remove-word-prop ( word name -- ) swap props>> delete-at ;
@ -46,6 +32,16 @@ M: primitive definition drop f ;
: reset-props ( word seq -- ) [ remove-word-prop ] with each ; : reset-props ( word seq -- ) [ remove-word-prop ] with each ;
ERROR: undefined ;
PREDICATE: deferred < word ( obj -- ? ) def>> [ undefined ] = ;
M: deferred definer drop \ DEFER: f ;
M: deferred definition drop f ;
PREDICATE: primitive < word ( obj -- ? ) "primitive" word-prop ;
M: primitive definer drop \ PRIMITIVE: f ;
M: primitive definition drop f ;
: lookup ( name vocab -- word ) vocab-words at ; : lookup ( name vocab -- word ) vocab-words at ;
: target-word ( word -- target ) : target-word ( word -- target )

View File

@ -102,11 +102,11 @@ void *factor_vm::alien_pointer()
/* define words to read/write values at an alien address */ /* define words to read/write values at an alien address */
#define DEFINE_ALIEN_ACCESSOR(name,type,from,to) \ #define DEFINE_ALIEN_ACCESSOR(name,type,from,to) \
PRIMITIVE(alien_##name) \ VM_C_API void primitive_alien_##name(factor_vm *parent) \
{ \ { \
parent->ctx->push(from(*(type*)(parent->alien_pointer()),parent)); \ parent->ctx->push(from(*(type*)(parent->alien_pointer()),parent)); \
} \ } \
PRIMITIVE(set_alien_##name) \ VM_C_API void primitive_set_alien_##name(factor_vm *parent) \
{ \ { \
type *ptr = (type *)parent->alien_pointer(); \ type *ptr = (type *)parent->alien_pointer(); \
type value = (type)to(parent->ctx->pop(),parent); \ type value = (type)to(parent->ctx->pop(),parent); \

View File

@ -38,7 +38,7 @@ void callback_heap::store_callback_operand(code_block *stub, cell index, cell va
void callback_heap::update(code_block *stub) void callback_heap::update(code_block *stub)
{ {
store_callback_operand(stub,1,(cell)callback_xt(stub)); store_callback_operand(stub,1,(cell)callback_entry_point(stub));
stub->flush_icache(); stub->flush_icache();
} }
@ -60,7 +60,7 @@ code_block *callback_heap::add(cell owner, cell return_rewind)
stub->parameters = false_object; stub->parameters = false_object;
stub->relocation = false_object; stub->relocation = false_object;
memcpy(stub->xt(),insns->data<void>(),size); memcpy(stub->entry_point(),insns->data<void>(),size);
/* Store VM pointer */ /* Store VM pointer */
store_callback_operand(stub,0,(cell)parent); store_callback_operand(stub,0,(cell)parent);
@ -99,7 +99,7 @@ void factor_vm::primitive_callback()
tagged<word> w(ctx->pop()); tagged<word> w(ctx->pop());
w.untag_check(this); w.untag_check(this);
ctx->push(allot_alien(callbacks->add(w.value(),return_rewind)->xt())); ctx->push(allot_alien(callbacks->add(w.value(),return_rewind)->entry_point()));
} }
} }

View File

@ -4,13 +4,13 @@ namespace factor
/* The callback heap is used to store the machine code that alien-callbacks /* The callback heap is used to store the machine code that alien-callbacks
actually jump to when C code invokes them. actually jump to when C code invokes them.
The callback heap has entries that look like code_blocks from the code heap, The callback heap has entries that look like code_blocks from the code heap, but
but callback heap entries are allocated contiguously, never deallocated, and all callback heap entries are allocated contiguously, never deallocated, and all
fields but the owner are set to false_object. The owner points to the callback fields but the owner are set to false_object. The owner points to the callback
bottom word, whose XT is the callback body itself, generated by the optimizing bottom word, whose entry point is the callback body itself, generated by the
compiler. The machine code that follows a callback stub consists of a single optimizing compiler. The machine code that follows a callback stub consists of a
CALLBACK_STUB machine code template, which performs a jump to a "far" address single CALLBACK_STUB machine code template, which performs a jump to a "far"
(on PowerPC and x86-64, its loaded into a register first). address (on PowerPC and x86-64, its loaded into a register first).
GC updates the CALLBACK_STUB code if the code block of the callback bottom word GC updates the CALLBACK_STUB code if the code block of the callback bottom word
is ever moved. The callback stub itself won't move, though, and is never is ever moved. The callback stub itself won't move, though, and is never
@ -32,10 +32,10 @@ struct callback_heap {
explicit callback_heap(cell size, factor_vm *parent); explicit callback_heap(cell size, factor_vm *parent);
~callback_heap(); ~callback_heap();
void *callback_xt(code_block *stub) void *callback_entry_point(code_block *stub)
{ {
word *w = (word *)UNTAG(stub->owner); word *w = (word *)UNTAG(stub->owner);
return w->xt; return w->entry_point;
} }
void store_callback_operand(code_block *stub, cell index, cell value); void store_callback_operand(code_block *stub, cell index, cell value);

View File

@ -6,7 +6,7 @@ namespace factor
void factor_vm::check_frame(stack_frame *frame) void factor_vm::check_frame(stack_frame *frame)
{ {
#ifdef FACTOR_DEBUG #ifdef FACTOR_DEBUG
check_code_pointer((cell)frame->xt); check_code_pointer((cell)frame->entry_point);
assert(frame->size != 0); assert(frame->size != 0);
#endif #endif
} }
@ -63,7 +63,7 @@ void factor_vm::primitive_callstack()
code_block *factor_vm::frame_code(stack_frame *frame) code_block *factor_vm::frame_code(stack_frame *frame)
{ {
check_frame(frame); check_frame(frame);
return (code_block *)frame->xt - 1; return (code_block *)frame->entry_point - 1;
} }
code_block_type factor_vm::frame_type(stack_frame *frame) code_block_type factor_vm::frame_type(stack_frame *frame)
@ -105,10 +105,10 @@ cell factor_vm::frame_scan(stack_frame *frame)
if(obj.type_p(QUOTATION_TYPE)) if(obj.type_p(QUOTATION_TYPE))
{ {
char *return_addr = (char *)FRAME_RETURN_ADDRESS(frame,this); char *return_addr = (char *)FRAME_RETURN_ADDRESS(frame,this);
char *quot_xt = (char *)(frame_code(frame) + 1); char *quot_entry_point = (char *)(frame_code(frame) + 1);
return tag_fixnum(quot_code_offset_to_scan( return tag_fixnum(quot_code_offset_to_scan(
obj.value(),(cell)(return_addr - quot_xt))); obj.value(),(cell)(return_addr - quot_entry_point)));
} }
else else
return false_object; return false_object;
@ -190,9 +190,9 @@ void factor_vm::primitive_set_innermost_stack_frame_quot()
jit_compile_quot(quot.value(),true); jit_compile_quot(quot.value(),true);
stack_frame *inner = innermost_stack_frame(callstack.untagged()); stack_frame *inner = innermost_stack_frame(callstack.untagged());
cell offset = (char *)FRAME_RETURN_ADDRESS(inner,this) - (char *)inner->xt; cell offset = (char *)FRAME_RETURN_ADDRESS(inner,this) - (char *)inner->entry_point;
inner->xt = quot->xt; inner->entry_point = quot->entry_point;
FRAME_RETURN_ADDRESS(inner,this) = (char *)quot->xt + offset; FRAME_RETURN_ADDRESS(inner,this) = (char *)quot->entry_point + offset;
} }
} }

View File

@ -42,12 +42,12 @@ struct call_frame_code_block_visitor {
void operator()(stack_frame *frame) void operator()(stack_frame *frame)
{ {
cell offset = (cell)FRAME_RETURN_ADDRESS(frame,parent) - (cell)frame->xt; cell offset = (cell)FRAME_RETURN_ADDRESS(frame,parent) - (cell)frame->entry_point;
code_block *new_block = visitor(parent->frame_code(frame)); code_block *new_block = visitor(parent->frame_code(frame));
frame->xt = new_block->xt(); frame->entry_point = new_block->entry_point();
FRAME_RETURN_ADDRESS(frame,parent) = (void *)((cell)frame->xt + offset); FRAME_RETURN_ADDRESS(frame,parent) = (void *)((cell)frame->entry_point + offset);
} }
}; };
@ -64,14 +64,14 @@ void code_block_visitor<Visitor>::visit_object_code_block(object *obj)
if(w->profiling) if(w->profiling)
w->profiling = visitor(w->profiling); w->profiling = visitor(w->profiling);
parent->update_word_xt(w); parent->update_word_entry_point(w);
break; break;
} }
case QUOTATION_TYPE: case QUOTATION_TYPE:
{ {
quotation *q = (quotation *)obj; quotation *q = (quotation *)obj;
if(q->code) if(q->code)
parent->set_quot_xt(q,visitor(q->code)); parent->set_quot_entry_point(q,visitor(q->code));
break; break;
} }
case CALLSTACK_TYPE: case CALLSTACK_TYPE:
@ -93,7 +93,9 @@ struct embedded_code_pointers_visitor {
void operator()(instruction_operand op) void operator()(instruction_operand op)
{ {
relocation_type type = op.rel_type(); relocation_type type = op.rel_type();
if(type == RT_XT || type == RT_XT_PIC || type == RT_XT_PIC_TAIL) if(type == RT_ENTRY_POINT
|| type == RT_ENTRY_POINT_PIC
|| type == RT_ENTRY_POINT_PIC_TAIL)
op.store_code_block(visitor(op.load_code_block())); op.store_code_block(visitor(op.load_code_block()));
} }
}; };

View File

@ -3,44 +3,44 @@
namespace factor namespace factor
{ {
cell factor_vm::compute_xt_address(cell obj) cell factor_vm::compute_entry_point_address(cell obj)
{ {
switch(tagged<object>(obj).type()) switch(tagged<object>(obj).type())
{ {
case WORD_TYPE: case WORD_TYPE:
return (cell)untag<word>(obj)->xt; return (cell)untag<word>(obj)->entry_point;
case QUOTATION_TYPE: case QUOTATION_TYPE:
return (cell)untag<quotation>(obj)->xt; return (cell)untag<quotation>(obj)->entry_point;
default: default:
critical_error("Expected word or quotation",obj); critical_error("Expected word or quotation",obj);
return 0; return 0;
} }
} }
cell factor_vm::compute_xt_pic_address(word *w, cell tagged_quot) cell factor_vm::compute_entry_point_pic_address(word *w, cell tagged_quot)
{ {
if(!to_boolean(tagged_quot) || max_pic_size == 0) if(!to_boolean(tagged_quot) || max_pic_size == 0)
return (cell)w->xt; return (cell)w->entry_point;
else else
{ {
quotation *quot = untag<quotation>(tagged_quot); quotation *quot = untag<quotation>(tagged_quot);
if(quot_compiled_p(quot)) if(quot_compiled_p(quot))
return (cell)quot->xt; return (cell)quot->entry_point;
else else
return (cell)w->xt; return (cell)w->entry_point;
} }
} }
cell factor_vm::compute_xt_pic_address(cell w_) cell factor_vm::compute_entry_point_pic_address(cell w_)
{ {
tagged<word> w(w_); tagged<word> w(w_);
return compute_xt_pic_address(w.untagged(),w->pic_def); return compute_entry_point_pic_address(w.untagged(),w->pic_def);
} }
cell factor_vm::compute_xt_pic_tail_address(cell w_) cell factor_vm::compute_entry_point_pic_tail_address(cell w_)
{ {
tagged<word> w(w_); tagged<word> w(w_);
return compute_xt_pic_address(w.untagged(),w->pic_tail_def); return compute_entry_point_pic_address(w.untagged(),w->pic_tail_def);
} }
cell factor_vm::code_block_owner(code_block *compiled) cell factor_vm::code_block_owner(code_block *compiled)
@ -74,25 +74,28 @@ struct update_word_references_relocation_visitor {
{ {
switch(op.rel_type()) switch(op.rel_type())
{ {
case RT_XT: case RT_ENTRY_POINT:
{ {
code_block *compiled = op.load_code_block(); code_block *compiled = op.load_code_block();
cell owner = compiled->owner; cell owner = compiled->owner;
if(to_boolean(owner)) op.store_value(parent->compute_xt_address(owner)); if(to_boolean(owner))
op.store_value(parent->compute_entry_point_address(owner));
break; break;
} }
case RT_XT_PIC: case RT_ENTRY_POINT_PIC:
{ {
code_block *compiled = op.load_code_block(); code_block *compiled = op.load_code_block();
cell owner = parent->code_block_owner(compiled); cell owner = parent->code_block_owner(compiled);
if(to_boolean(owner)) op.store_value(parent->compute_xt_pic_address(owner)); if(to_boolean(owner))
op.store_value(parent->compute_entry_point_pic_address(owner));
break; break;
} }
case RT_XT_PIC_TAIL: case RT_ENTRY_POINT_PIC_TAIL:
{ {
code_block *compiled = op.load_code_block(); code_block *compiled = op.load_code_block();
cell owner = parent->code_block_owner(compiled); cell owner = parent->code_block_owner(compiled);
if(to_boolean(owner)) op.store_value(parent->compute_xt_pic_tail_address(owner)); if(to_boolean(owner))
op.store_value(parent->compute_entry_point_pic_tail_address(owner));
break; break;
} }
default: default:
@ -111,7 +114,7 @@ void factor_vm::update_word_references(code_block *compiled)
initialize_code_block(compiled); initialize_code_block(compiled);
/* update_word_references() is always applied to every block in /* update_word_references() is always applied to every block in
the code heap. Since it resets all call sites to point to the code heap. Since it resets all call sites to point to
their canonical XT (cold entry point for non-tail calls, their canonical entry point (cold entry point for non-tail calls,
standard entry point for tail calls), it means that no PICs standard entry point for tail calls), it means that no PICs
are referenced after this is done. So instead of polluting are referenced after this is done. So instead of polluting
the code heap with dead PICs that will be freed on the next the code heap with dead PICs that will be freed on the next
@ -133,12 +136,6 @@ void factor_vm::check_code_address(cell address)
#endif #endif
} }
cell factor_vm::compute_primitive_address(cell arg)
{
return (cell)primitives[untag_fixnum(arg)];
}
/* References to undefined symbols are patched up to call this function on /* References to undefined symbols are patched up to call this function on
image load */ image load */
void factor_vm::undefined_symbol() void factor_vm::undefined_symbol()
@ -193,11 +190,6 @@ cell factor_vm::compute_dlsym_address(array *literals, cell index)
} }
} }
cell factor_vm::compute_context_address()
{
return (cell)&ctx;
}
cell factor_vm::compute_vm_address(cell arg) cell factor_vm::compute_vm_address(cell arg)
{ {
return (cell)this + untag_fixnum(arg); return (cell)this + untag_fixnum(arg);
@ -211,17 +203,11 @@ void factor_vm::store_external_address(instruction_operand op)
switch(op.rel_type()) switch(op.rel_type())
{ {
case RT_PRIMITIVE:
op.store_value(compute_primitive_address(array_nth(parameters,index)));
break;
case RT_DLSYM: case RT_DLSYM:
op.store_value(compute_dlsym_address(parameters,index)); op.store_value(compute_dlsym_address(parameters,index));
break; break;
case RT_THIS: case RT_THIS:
op.store_value((cell)compiled->xt()); op.store_value((cell)compiled->entry_point());
break;
case RT_CONTEXT:
op.store_value(compute_context_address());
break; break;
case RT_MEGAMORPHIC_CACHE_HITS: case RT_MEGAMORPHIC_CACHE_HITS:
op.store_value((cell)&dispatch_stats.megamorphic_cache_hits); op.store_value((cell)&dispatch_stats.megamorphic_cache_hits);
@ -244,7 +230,10 @@ void factor_vm::store_external_address(instruction_operand op)
cell factor_vm::compute_here_address(cell arg, cell offset, code_block *compiled) cell factor_vm::compute_here_address(cell arg, cell offset, code_block *compiled)
{ {
fixnum n = untag_fixnum(arg); fixnum n = untag_fixnum(arg);
return n >= 0 ? ((cell)compiled->xt() + offset + n) : ((cell)compiled->xt() - n); if(n >= 0)
return (cell)compiled->entry_point() + offset + n;
else
return (cell)compiled->entry_point() - n;
} }
struct initial_code_block_visitor { struct initial_code_block_visitor {
@ -267,14 +256,14 @@ struct initial_code_block_visitor {
case RT_LITERAL: case RT_LITERAL:
op.store_value(next_literal()); op.store_value(next_literal());
break; break;
case RT_XT: case RT_ENTRY_POINT:
op.store_value(parent->compute_xt_address(next_literal())); op.store_value(parent->compute_entry_point_address(next_literal()));
break; break;
case RT_XT_PIC: case RT_ENTRY_POINT_PIC:
op.store_value(parent->compute_xt_pic_address(next_literal())); op.store_value(parent->compute_entry_point_pic_address(next_literal()));
break; break;
case RT_XT_PIC_TAIL: case RT_ENTRY_POINT_PIC_TAIL:
op.store_value(parent->compute_xt_pic_tail_address(next_literal())); op.store_value(parent->compute_entry_point_pic_tail_address(next_literal()));
break; break;
case RT_HERE: case RT_HERE:
op.store_value(parent->compute_here_address(next_literal(),op.rel_offset(),op.parent_code_block())); op.store_value(parent->compute_here_address(next_literal(),op.rel_offset(),op.parent_code_block()));
@ -320,7 +309,7 @@ void factor_vm::fixup_labels(array *labels, code_block *compiled)
relocation_entry new_entry(RT_HERE,rel_class,offset); relocation_entry new_entry(RT_HERE,rel_class,offset);
instruction_operand op(new_entry,compiled,0); instruction_operand op(new_entry,compiled,0);
op.store_value(target + (cell)compiled->xt()); op.store_value(target + (cell)compiled->entry_point());
} }
} }

View File

@ -43,7 +43,7 @@ struct code_block
return size; return size;
} }
void *xt() const void *entry_point() const
{ {
return (void *)(this + 1); return (void *)(this + 1);
} }

View File

@ -141,7 +141,7 @@ void factor_vm::primitive_modify_code_heap()
break; break;
} }
update_word_xt(word.untagged()); update_word_entry_point(word.untagged());
} }
update_code_heap_words(); update_code_heap_words();

View File

@ -104,16 +104,16 @@ struct code_block_compaction_relocation_visitor {
void operator()(instruction_operand op) void operator()(instruction_operand op)
{ {
cell old_offset = op.rel_offset() + (cell)old_address->xt(); cell old_offset = op.rel_offset() + (cell)old_address->entry_point();
switch(op.rel_type()) switch(op.rel_type())
{ {
case RT_LITERAL: case RT_LITERAL:
op.store_value(slot_forwarder.visit_pointer(op.load_value(old_offset))); op.store_value(slot_forwarder.visit_pointer(op.load_value(old_offset)));
break; break;
case RT_XT: case RT_ENTRY_POINT:
case RT_XT_PIC: case RT_ENTRY_POINT_PIC:
case RT_XT_PIC_TAIL: case RT_ENTRY_POINT_PIC_TAIL:
op.store_code_block(code_forwarder.visit_code_block(op.load_code_block(old_offset))); op.store_code_block(code_forwarder.visit_code_block(op.load_code_block(old_offset)));
break; break;
case RT_HERE: case RT_HERE:

View File

@ -171,7 +171,7 @@ struct stack_frame_printer {
std::cout << std::hex << (cell)parent->frame_executing(frame) << std::dec; std::cout << std::hex << (cell)parent->frame_executing(frame) << std::dec;
std::cout << std::endl; std::cout << std::endl;
std::cout << "word/quot xt: "; std::cout << "word/quot xt: ";
std::cout << std::hex << (cell)frame->xt << std::dec; std::cout << std::hex << (cell)frame->entry_point << std::dec;
std::cout << std::endl; std::cout << std::endl;
std::cout << "return address: "; std::cout << "return address: ";
std::cout << std::hex << (cell)FRAME_RETURN_ADDRESS(frame,parent) << std::dec; std::cout << std::hex << (cell)FRAME_RETURN_ADDRESS(frame,parent) << std::dec;

View File

@ -13,7 +13,7 @@ void factor_vm::c_to_factor(cell quot)
{ {
tagged<word> c_to_factor_word(special_objects[C_TO_FACTOR_WORD]); tagged<word> c_to_factor_word(special_objects[C_TO_FACTOR_WORD]);
code_block *c_to_factor_block = callbacks->add(c_to_factor_word.value(),0); code_block *c_to_factor_block = callbacks->add(c_to_factor_word.value(),0);
c_to_factor_func = (c_to_factor_func_type)c_to_factor_block->xt(); c_to_factor_func = (c_to_factor_func_type)c_to_factor_block->entry_point();
} }
c_to_factor_func(quot); c_to_factor_func(quot);
@ -22,7 +22,7 @@ void factor_vm::c_to_factor(cell quot)
void factor_vm::unwind_native_frames(cell quot, stack_frame *to) void factor_vm::unwind_native_frames(cell quot, stack_frame *to)
{ {
tagged<word> unwind_native_frames_word(special_objects[UNWIND_NATIVE_FRAMES_WORD]); tagged<word> unwind_native_frames_word(special_objects[UNWIND_NATIVE_FRAMES_WORD]);
unwind_native_frames_func_type unwind_native_frames_func = (unwind_native_frames_func_type)unwind_native_frames_word->xt; unwind_native_frames_func_type unwind_native_frames_func = (unwind_native_frames_func_type)unwind_native_frames_word->entry_point;
unwind_native_frames_func(quot,to); unwind_native_frames_func(quot,to);
} }

View File

@ -178,16 +178,16 @@ struct code_block_fixup_relocation_visitor {
void operator()(instruction_operand op) void operator()(instruction_operand op)
{ {
code_block *compiled = op.parent_code_block(); code_block *compiled = op.parent_code_block();
cell old_offset = op.rel_offset() + (cell)compiled->xt() - code_offset; cell old_offset = op.rel_offset() + (cell)compiled->entry_point() - code_offset;
switch(op.rel_type()) switch(op.rel_type())
{ {
case RT_LITERAL: case RT_LITERAL:
op.store_value(data_visitor.visit_pointer(op.load_value(old_offset))); op.store_value(data_visitor.visit_pointer(op.load_value(old_offset)));
break; break;
case RT_XT: case RT_ENTRY_POINT:
case RT_XT_PIC: case RT_ENTRY_POINT_PIC:
case RT_XT_PIC_TAIL: case RT_ENTRY_POINT_PIC_TAIL:
op.store_code_block(code_visitor(op.load_code_block(old_offset))); op.store_code_block(code_visitor(op.load_code_block(old_offset)));
break; break;
case RT_HERE: case RT_HERE:

View File

@ -11,10 +11,10 @@ void factor_vm::init_inline_caching(int max_size)
void factor_vm::deallocate_inline_cache(cell return_address) void factor_vm::deallocate_inline_cache(cell return_address)
{ {
/* Find the call target. */ /* Find the call target. */
void *old_xt = get_call_target(return_address); void *old_entry_point = get_call_target(return_address);
check_code_pointer((cell)old_xt); check_code_pointer((cell)old_entry_point);
code_block *old_block = (code_block *)old_xt - 1; code_block *old_block = (code_block *)old_entry_point - 1;
/* Free the old PIC since we know its unreachable */ /* Free the old PIC since we know its unreachable */
if(old_block->pic_p()) if(old_block->pic_p())
@ -148,7 +148,7 @@ code_block *factor_vm::compile_inline_cache(fixnum index,
/* A generic word's definition performs general method lookup. */ /* A generic word's definition performs general method lookup. */
void *factor_vm::megamorphic_call_stub(cell generic_word) void *factor_vm::megamorphic_call_stub(cell generic_word)
{ {
return untag<word>(generic_word)->xt; return untag<word>(generic_word)->entry_point;
} }
cell factor_vm::inline_cache_size(cell cache_entries) cell factor_vm::inline_cache_size(cell cache_entries)
@ -226,7 +226,7 @@ void *factor_vm::inline_cache_miss(cell return_address_)
generic_word.value(), generic_word.value(),
methods.value(), methods.value(),
new_cache_entries.value(), new_cache_entries.value(),
tail_call_site)->xt(); tail_call_site)->entry_point();
} }
/* Install the new stub. */ /* Install the new stub. */

View File

@ -4,7 +4,7 @@ namespace factor
{ {
instruction_operand::instruction_operand(relocation_entry rel_, code_block *compiled_, cell index_) : instruction_operand::instruction_operand(relocation_entry rel_, code_block *compiled_, cell index_) :
rel(rel_), compiled(compiled_), index(index_), pointer((cell)compiled_->xt() + rel_.rel_offset()) {} rel(rel_), compiled(compiled_), index(index_), pointer((cell)compiled_->entry_point() + rel_.rel_offset()) {}
/* Load a 32-bit value from a PowerPC LIS/ORI sequence */ /* Load a 32-bit value from a PowerPC LIS/ORI sequence */
fixnum instruction_operand::load_value_2_2() fixnum instruction_operand::load_value_2_2()
@ -132,7 +132,7 @@ void instruction_operand::store_value(fixnum absolute_value)
void instruction_operand::store_code_block(code_block *compiled) void instruction_operand::store_code_block(code_block *compiled)
{ {
store_value((cell)compiled->xt()); store_value((cell)compiled->entry_point());
} }
} }

View File

@ -2,26 +2,20 @@ namespace factor
{ {
enum relocation_type { enum relocation_type {
/* arg is a primitive number */ /* arg is a literal table index, holding a pair (symbol/dll) */
RT_PRIMITIVE,
/* arg is a literal table index, holding an array pair (symbol/dll) */
RT_DLSYM, RT_DLSYM,
/* a pointer to a compiled word reference */
RT_DISPATCH,
/* a word or quotation's general entry point */ /* a word or quotation's general entry point */
RT_XT, RT_ENTRY_POINT,
/* a word's PIC entry point */ /* a word's PIC entry point */
RT_XT_PIC, RT_ENTRY_POINT_PIC,
/* a word's tail-call PIC entry point */ /* a word's tail-call PIC entry point */
RT_XT_PIC_TAIL, RT_ENTRY_POINT_PIC_TAIL,
/* current offset */ /* current offset */
RT_HERE, RT_HERE,
/* current code block */ /* current code block */
RT_THIS, RT_THIS,
/* data heap literal */ /* data heap literal */
RT_LITERAL, RT_LITERAL,
/* address of ctx var */
RT_CONTEXT,
/* untagged fixnum literal */ /* untagged fixnum literal */
RT_UNTAGGED, RT_UNTAGGED,
/* address of megamorphic_cache_hits var */ /* address of megamorphic_cache_hits var */
@ -97,19 +91,17 @@ struct relocation_entry {
{ {
switch(rel_type()) switch(rel_type())
{ {
case RT_PRIMITIVE:
case RT_VM: case RT_VM:
return 1; return 1;
case RT_DLSYM: case RT_DLSYM:
return 2; return 2;
case RT_XT: case RT_ENTRY_POINT:
case RT_XT_PIC: case RT_ENTRY_POINT_PIC:
case RT_XT_PIC_TAIL: case RT_ENTRY_POINT_PIC_TAIL:
case RT_LITERAL: case RT_LITERAL:
case RT_HERE: case RT_HERE:
case RT_UNTAGGED: case RT_UNTAGGED:
case RT_THIS: case RT_THIS:
case RT_CONTEXT:
case RT_MEGAMORPHIC_CACHE_HITS: case RT_MEGAMORPHIC_CACHE_HITS:
case RT_CARDS_OFFSET: case RT_CARDS_OFFSET:
case RT_DECKS_OFFSET: case RT_DECKS_OFFSET:

View File

@ -232,8 +232,8 @@ struct word : public object {
cell counter; cell counter;
/* TAGGED machine code for sub-primitive */ /* TAGGED machine code for sub-primitive */
cell subprimitive; cell subprimitive;
/* UNTAGGED execution token: jump here to execute word */ /* UNTAGGED entry point: jump here to execute word */
void *xt; void *entry_point;
/* UNTAGGED compiled code block */ /* UNTAGGED compiled code block */
code_block *code; code_block *code;
/* UNTAGGED profiler stub */ /* UNTAGGED profiler stub */
@ -266,8 +266,8 @@ struct quotation : public object {
cell cached_effect; cell cached_effect;
/* tagged */ /* tagged */
cell cache_counter; cell cache_counter;
/* UNTAGGED */ /* UNTAGGED entry point; jump here to call quotation */
void *xt; void *entry_point;
/* UNTAGGED compiled code block */ /* UNTAGGED compiled code block */
code_block *code; code_block *code;
}; };
@ -302,7 +302,8 @@ struct dll : public object {
}; };
struct stack_frame { struct stack_frame {
void *xt; /* Updated by procedure prologue with procedure start address */
void *entry_point;
/* Frame size in bytes */ /* Frame size in bytes */
cell size; cell size;
}; };

View File

@ -1,5 +1,120 @@
#include "master.hpp" #include "master.hpp"
/*
Windows argument parsing ported to work on
int main(int argc, wchar_t **argv).
Based on MinGW's public domain char** version.
*/
VM_C_API int parse_tokens(wchar_t *string, wchar_t ***tokens, int length)
{
/* Extract whitespace- and quotes- delimited tokens from the given string
and put them into the tokens array. Returns number of tokens
extracted. Length specifies the current size of tokens[].
THIS METHOD MODIFIES string. */
const wchar_t *whitespace = L" \t\r\n";
wchar_t *tokenEnd = 0;
const wchar_t *quoteCharacters = L"\"\'";
wchar_t *end = string + wcslen(string);
if (string == NULL)
return length;
while (1)
{
const wchar_t *q;
/* Skip over initial whitespace. */
string += wcsspn(string, whitespace);
if (*string == '\0')
break;
for (q = quoteCharacters; *q; ++q)
{
if (*string == *q)
break;
}
if (*q)
{
/* Token is quoted. */
wchar_t quote = *string++;
tokenEnd = wcschr(string, quote);
/* If there is no endquote, the token is the rest of the string. */
if (!tokenEnd)
tokenEnd = end;
}
else
{
tokenEnd = string + wcscspn(string, whitespace);
}
*tokenEnd = '\0';
{
wchar_t **new_tokens;
int newlen = length + 1;
new_tokens = (wchar_t **)realloc (*tokens, sizeof (wchar_t**) * newlen);
if (!new_tokens)
{
/* Out of memory. */
return -1;
}
*tokens = new_tokens;
(*tokens)[length] = string;
length = newlen;
}
if (tokenEnd == end)
break;
string = tokenEnd + 1;
}
return length;
}
VM_C_API void parse_args(int *argc, wchar_t ***argv, wchar_t *cmdlinePtrW)
{
int cmdlineLen = 0;
if (!cmdlinePtrW)
cmdlineLen = 0;
else
cmdlineLen = wcslen(cmdlinePtrW);
/* gets realloc()'d later */
*argc = 0;
*argv = (wchar_t **)malloc (sizeof (wchar_t**));
if (!*argv)
ExitProcess(1);
#ifdef WINCE
wchar_t cmdnameBufW[MAX_UNICODE_PATH];
/* argv[0] is the path of invoked program - get this from CE. */
cmdnameBufW[0] = 0;
GetModuleFileNameW(NULL, cmdnameBufW, sizeof (cmdnameBufW)/sizeof (cmdnameBufW[0]));
(*argv)[0] = wcsdup(cmdnameBufW);
if(!(*argv[0]))
ExitProcess(1);
/* Add one to account for argv[0] */
(*argc)++;
#endif
if (cmdlineLen > 0)
{
wchar_t *string = wcsdup(cmdlinePtrW);
if(!string)
ExitProcess(1);
*argc = parse_tokens(string, argv, *argc);
if (*argc < 0)
ExitProcess(1);
}
(*argv)[*argc] = 0;
return;
}
int WINAPI WinMain( int WINAPI WinMain(
HINSTANCE hInstance, HINSTANCE hInstance,
HINSTANCE hPrevInstance, HINSTANCE hPrevInstance,

View File

@ -21,7 +21,7 @@ int WINAPI WinMain(
int argc; int argc;
wchar_t **argv; wchar_t **argv;
factor::parse_args(&argc, &argv, (wchar_t *)GetCommandLine()); argv = CommandLineToArgvW(GetCommandLine(),&argc);
wmain(argc,argv); wmain(argc,argv);
// memory leak from malloc, wcsdup // memory leak from malloc, wcsdup

View File

@ -137,123 +137,4 @@ long getpagesize()
return g_pagesize; return g_pagesize;
} }
/*
Windows argument parsing ported to work on
int main(int argc, wchar_t **argv).
Based on MinGW's public domain char** version.
Used by WinMain() implementation in main-windows-ce.cpp
and main-windows-nt.cpp.
*/
VM_C_API int parse_tokens(wchar_t *string, wchar_t ***tokens, int length)
{
/* Extract whitespace- and quotes- delimited tokens from the given string
and put them into the tokens array. Returns number of tokens
extracted. Length specifies the current size of tokens[].
THIS METHOD MODIFIES string. */
const wchar_t *whitespace = L" \t\r\n";
wchar_t *tokenEnd = 0;
const wchar_t *quoteCharacters = L"\"\'";
wchar_t *end = string + wcslen(string);
if (string == NULL)
return length;
while (1)
{
const wchar_t *q;
/* Skip over initial whitespace. */
string += wcsspn(string, whitespace);
if (*string == '\0')
break;
for (q = quoteCharacters; *q; ++q)
{
if (*string == *q)
break;
}
if (*q)
{
/* Token is quoted. */
wchar_t quote = *string++;
tokenEnd = wcschr(string, quote);
/* If there is no endquote, the token is the rest of the string. */
if (!tokenEnd)
tokenEnd = end;
}
else
{
tokenEnd = string + wcscspn(string, whitespace);
}
*tokenEnd = '\0';
{
wchar_t **new_tokens;
int newlen = length + 1;
new_tokens = (wchar_t **)realloc (*tokens, sizeof (wchar_t**) * newlen);
if (!new_tokens)
{
/* Out of memory. */
return -1;
}
*tokens = new_tokens;
(*tokens)[length] = string;
length = newlen;
}
if (tokenEnd == end)
break;
string = tokenEnd + 1;
}
return length;
}
VM_C_API void parse_args(int *argc, wchar_t ***argv, wchar_t *cmdlinePtrW)
{
int cmdlineLen = 0;
if (!cmdlinePtrW)
cmdlineLen = 0;
else
cmdlineLen = wcslen(cmdlinePtrW);
/* gets realloc()'d later */
*argc = 0;
*argv = (wchar_t **)malloc (sizeof (wchar_t**));
if (!*argv)
ExitProcess(1);
#ifdef WINCE
wchar_t cmdnameBufW[MAX_UNICODE_PATH];
/* argv[0] is the path of invoked program - get this from CE. */
cmdnameBufW[0] = 0;
GetModuleFileNameW(NULL, cmdnameBufW, sizeof (cmdnameBufW)/sizeof (cmdnameBufW[0]));
(*argv)[0] = wcsdup(cmdnameBufW);
if(!(*argv[0]))
ExitProcess(1);
/* Add one to account for argv[0] */
(*argc)++;
#endif
if (cmdlineLen > 0)
{
wchar_t *argv1 = wcsdup(cmdlinePtrW);
if(!argv1)
ExitProcess(1);
*argc = parse_tokens(argv1, argv, *argc);
if (*argc < 0)
ExitProcess(1);
}
(*argv)[*argc] = 0;
return;
}
} }

View File

@ -51,8 +51,4 @@ u64 nano_count();
void sleep_nanos(u64 nsec); void sleep_nanos(u64 nsec);
long getpagesize(); long getpagesize();
/* Used by-main-windows-*.cpp */
VM_C_API int parse_tokens(wchar_t* string, wchar_t*** tokens, int length);
VM_C_API void parse_args(int *argc, wchar_t ***argv, wchar_t *cmdlinePtrW);
} }

View File

@ -3,290 +3,135 @@
namespace factor namespace factor
{ {
PRIMITIVE_FORWARD(bignum_to_fixnum) #define PRIMITIVE(name) VM_C_API void primitive_##name(factor_vm *parent) \
PRIMITIVE_FORWARD(float_to_fixnum) { \
PRIMITIVE_FORWARD(fixnum_to_bignum) parent->primitive_##name(); \
PRIMITIVE_FORWARD(float_to_bignum) }
PRIMITIVE_FORWARD(fixnum_to_float)
PRIMITIVE_FORWARD(bignum_to_float)
PRIMITIVE_FORWARD(str_to_float)
PRIMITIVE_FORWARD(float_to_str)
PRIMITIVE_FORWARD(float_bits)
PRIMITIVE_FORWARD(double_bits)
PRIMITIVE_FORWARD(bits_float)
PRIMITIVE_FORWARD(bits_double)
PRIMITIVE_FORWARD(fixnum_divint)
PRIMITIVE_FORWARD(fixnum_divmod)
PRIMITIVE_FORWARD(fixnum_shift)
PRIMITIVE_FORWARD(bignum_eq)
PRIMITIVE_FORWARD(bignum_add)
PRIMITIVE_FORWARD(bignum_subtract)
PRIMITIVE_FORWARD(bignum_multiply)
PRIMITIVE_FORWARD(bignum_divint)
PRIMITIVE_FORWARD(bignum_mod)
PRIMITIVE_FORWARD(bignum_divmod)
PRIMITIVE_FORWARD(bignum_and)
PRIMITIVE_FORWARD(bignum_or)
PRIMITIVE_FORWARD(bignum_xor)
PRIMITIVE_FORWARD(bignum_not)
PRIMITIVE_FORWARD(bignum_shift)
PRIMITIVE_FORWARD(bignum_less)
PRIMITIVE_FORWARD(bignum_lesseq)
PRIMITIVE_FORWARD(bignum_greater)
PRIMITIVE_FORWARD(bignum_greatereq)
PRIMITIVE_FORWARD(bignum_bitp)
PRIMITIVE_FORWARD(bignum_log2)
PRIMITIVE_FORWARD(byte_array_to_bignum)
PRIMITIVE_FORWARD(float_eq)
PRIMITIVE_FORWARD(float_add)
PRIMITIVE_FORWARD(float_subtract)
PRIMITIVE_FORWARD(float_multiply)
PRIMITIVE_FORWARD(float_divfloat)
PRIMITIVE_FORWARD(float_mod)
PRIMITIVE_FORWARD(float_less)
PRIMITIVE_FORWARD(float_lesseq)
PRIMITIVE_FORWARD(float_greater)
PRIMITIVE_FORWARD(float_greatereq)
PRIMITIVE_FORWARD(word)
PRIMITIVE_FORWARD(word_xt)
PRIMITIVE_FORWARD(special_object)
PRIMITIVE_FORWARD(set_special_object)
PRIMITIVE_FORWARD(existsp)
PRIMITIVE_FORWARD(minor_gc)
PRIMITIVE_FORWARD(full_gc)
PRIMITIVE_FORWARD(compact_gc)
PRIMITIVE_FORWARD(save_image)
PRIMITIVE_FORWARD(save_image_and_exit)
PRIMITIVE_FORWARD(datastack)
PRIMITIVE_FORWARD(retainstack)
PRIMITIVE_FORWARD(callstack)
PRIMITIVE_FORWARD(set_datastack)
PRIMITIVE_FORWARD(set_retainstack)
PRIMITIVE_FORWARD(exit)
PRIMITIVE_FORWARD(data_room)
PRIMITIVE_FORWARD(code_room)
PRIMITIVE_FORWARD(system_micros)
PRIMITIVE_FORWARD(nano_count)
PRIMITIVE_FORWARD(modify_code_heap)
PRIMITIVE_FORWARD(dlopen)
PRIMITIVE_FORWARD(dlsym)
PRIMITIVE_FORWARD(dlclose)
PRIMITIVE_FORWARD(byte_array)
PRIMITIVE_FORWARD(uninitialized_byte_array)
PRIMITIVE_FORWARD(displaced_alien)
PRIMITIVE_FORWARD(alien_address)
PRIMITIVE_FORWARD(set_slot)
PRIMITIVE_FORWARD(string_nth)
PRIMITIVE_FORWARD(set_string_nth_fast)
PRIMITIVE_FORWARD(set_string_nth_slow)
PRIMITIVE_FORWARD(resize_array)
PRIMITIVE_FORWARD(resize_string)
PRIMITIVE_FORWARD(array)
PRIMITIVE_FORWARD(all_instances)
PRIMITIVE_FORWARD(size)
PRIMITIVE_FORWARD(die)
PRIMITIVE_FORWARD(fopen)
PRIMITIVE_FORWARD(fgetc)
PRIMITIVE_FORWARD(fread)
PRIMITIVE_FORWARD(fputc)
PRIMITIVE_FORWARD(fwrite)
PRIMITIVE_FORWARD(fflush)
PRIMITIVE_FORWARD(ftell)
PRIMITIVE_FORWARD(fseek)
PRIMITIVE_FORWARD(fclose)
PRIMITIVE_FORWARD(wrapper)
PRIMITIVE_FORWARD(clone)
PRIMITIVE_FORWARD(string)
PRIMITIVE_FORWARD(array_to_quotation)
PRIMITIVE_FORWARD(quotation_xt)
PRIMITIVE_FORWARD(tuple)
PRIMITIVE_FORWARD(profiling)
PRIMITIVE_FORWARD(become)
PRIMITIVE_FORWARD(sleep)
PRIMITIVE_FORWARD(tuple_boa)
PRIMITIVE_FORWARD(callstack_to_array)
PRIMITIVE_FORWARD(innermost_stack_frame_executing)
PRIMITIVE_FORWARD(innermost_stack_frame_scan)
PRIMITIVE_FORWARD(set_innermost_stack_frame_quot)
PRIMITIVE_FORWARD(call_clear)
PRIMITIVE_FORWARD(resize_byte_array)
PRIMITIVE_FORWARD(dll_validp)
PRIMITIVE_FORWARD(unimplemented)
PRIMITIVE_FORWARD(jit_compile)
PRIMITIVE_FORWARD(load_locals)
PRIMITIVE_FORWARD(check_datastack)
PRIMITIVE_FORWARD(mega_cache_miss)
PRIMITIVE_FORWARD(lookup_method)
PRIMITIVE_FORWARD(reset_dispatch_stats)
PRIMITIVE_FORWARD(dispatch_stats)
PRIMITIVE_FORWARD(optimized_p)
PRIMITIVE_FORWARD(quot_compiled_p)
PRIMITIVE_FORWARD(vm_ptr)
PRIMITIVE_FORWARD(strip_stack_traces)
PRIMITIVE_FORWARD(callback)
PRIMITIVE_FORWARD(enable_gc_events)
PRIMITIVE_FORWARD(disable_gc_events)
PRIMITIVE_FORWARD(identity_hashcode)
PRIMITIVE_FORWARD(compute_identity_hashcode)
const primitive_type primitives[] = { PRIMITIVE(alien_address)
primitive_bignum_to_fixnum, PRIMITIVE(all_instances)
primitive_float_to_fixnum, PRIMITIVE(array)
primitive_fixnum_to_bignum, PRIMITIVE(array_to_quotation)
primitive_float_to_bignum, PRIMITIVE(become)
primitive_fixnum_to_float, PRIMITIVE(bignum_add)
primitive_bignum_to_float, PRIMITIVE(bignum_and)
primitive_str_to_float, PRIMITIVE(bignum_bitp)
primitive_float_to_str, PRIMITIVE(bignum_divint)
primitive_float_bits, PRIMITIVE(bignum_divmod)
primitive_double_bits, PRIMITIVE(bignum_eq)
primitive_bits_float, PRIMITIVE(bignum_greater)
primitive_bits_double, PRIMITIVE(bignum_greatereq)
primitive_fixnum_divint, PRIMITIVE(bignum_less)
primitive_fixnum_divmod, PRIMITIVE(bignum_lesseq)
primitive_fixnum_shift, PRIMITIVE(bignum_log2)
primitive_bignum_eq, PRIMITIVE(bignum_mod)
primitive_bignum_add, PRIMITIVE(bignum_multiply)
primitive_bignum_subtract, PRIMITIVE(bignum_not)
primitive_bignum_multiply, PRIMITIVE(bignum_or)
primitive_bignum_divint, PRIMITIVE(bignum_shift)
primitive_bignum_mod, PRIMITIVE(bignum_subtract)
primitive_bignum_divmod, PRIMITIVE(bignum_to_fixnum)
primitive_bignum_and, PRIMITIVE(bignum_to_float)
primitive_bignum_or, PRIMITIVE(bignum_xor)
primitive_bignum_xor, PRIMITIVE(bits_double)
primitive_bignum_not, PRIMITIVE(bits_float)
primitive_bignum_shift, PRIMITIVE(byte_array)
primitive_bignum_less, PRIMITIVE(byte_array_to_bignum)
primitive_bignum_lesseq, PRIMITIVE(call_clear)
primitive_bignum_greater, PRIMITIVE(callback)
primitive_bignum_greatereq, PRIMITIVE(callstack)
primitive_bignum_bitp, PRIMITIVE(callstack_to_array)
primitive_bignum_log2, PRIMITIVE(check_datastack)
primitive_byte_array_to_bignum, PRIMITIVE(clone)
primitive_float_eq, PRIMITIVE(code_room)
primitive_float_add, PRIMITIVE(compact_gc)
primitive_float_subtract, PRIMITIVE(compute_identity_hashcode)
primitive_float_multiply, PRIMITIVE(data_room)
primitive_float_divfloat, PRIMITIVE(datastack)
primitive_float_mod, PRIMITIVE(die)
primitive_float_less, PRIMITIVE(disable_gc_events)
primitive_float_lesseq, PRIMITIVE(dispatch_stats)
primitive_float_greater, PRIMITIVE(displaced_alien)
primitive_float_greatereq, PRIMITIVE(dlclose)
/* The unordered comparison primitives don't have a non-optimizing PRIMITIVE(dll_validp)
compiler implementation */ PRIMITIVE(dlopen)
primitive_float_less, PRIMITIVE(dlsym)
primitive_float_lesseq, PRIMITIVE(double_bits)
primitive_float_greater, PRIMITIVE(enable_gc_events)
primitive_float_greatereq, PRIMITIVE(existsp)
primitive_word, PRIMITIVE(exit)
primitive_word_xt, PRIMITIVE(fclose)
primitive_special_object, PRIMITIVE(fflush)
primitive_set_special_object, PRIMITIVE(fgetc)
primitive_existsp, PRIMITIVE(fixnum_divint)
primitive_minor_gc, PRIMITIVE(fixnum_divmod)
primitive_full_gc, PRIMITIVE(fixnum_shift)
primitive_compact_gc, PRIMITIVE(fixnum_to_bignum)
primitive_save_image, PRIMITIVE(fixnum_to_float)
primitive_save_image_and_exit, PRIMITIVE(float_add)
primitive_datastack, PRIMITIVE(float_bits)
primitive_retainstack, PRIMITIVE(float_divfloat)
primitive_callstack, PRIMITIVE(float_eq)
primitive_set_datastack, PRIMITIVE(float_greater)
primitive_set_retainstack, PRIMITIVE(float_greatereq)
primitive_exit, PRIMITIVE(float_less)
primitive_data_room, PRIMITIVE(float_lesseq)
primitive_code_room, PRIMITIVE(float_mod)
primitive_system_micros, PRIMITIVE(float_multiply)
primitive_nano_count, PRIMITIVE(float_subtract)
primitive_modify_code_heap, PRIMITIVE(float_to_bignum)
primitive_dlopen, PRIMITIVE(float_to_fixnum)
primitive_dlsym, PRIMITIVE(float_to_str)
primitive_dlclose, PRIMITIVE(fopen)
primitive_byte_array, PRIMITIVE(fputc)
primitive_uninitialized_byte_array, PRIMITIVE(fread)
primitive_displaced_alien, PRIMITIVE(fseek)
primitive_alien_signed_cell, PRIMITIVE(ftell)
primitive_set_alien_signed_cell, PRIMITIVE(full_gc)
primitive_alien_unsigned_cell, PRIMITIVE(fwrite)
primitive_set_alien_unsigned_cell, PRIMITIVE(identity_hashcode)
primitive_alien_signed_8, PRIMITIVE(innermost_stack_frame_executing)
primitive_set_alien_signed_8, PRIMITIVE(innermost_stack_frame_scan)
primitive_alien_unsigned_8, PRIMITIVE(jit_compile)
primitive_set_alien_unsigned_8, PRIMITIVE(load_locals)
primitive_alien_signed_4, PRIMITIVE(lookup_method)
primitive_set_alien_signed_4, PRIMITIVE(mega_cache_miss)
primitive_alien_unsigned_4, PRIMITIVE(minor_gc)
primitive_set_alien_unsigned_4, PRIMITIVE(modify_code_heap)
primitive_alien_signed_2, PRIMITIVE(nano_count)
primitive_set_alien_signed_2, PRIMITIVE(optimized_p)
primitive_alien_unsigned_2, PRIMITIVE(profiling)
primitive_set_alien_unsigned_2, PRIMITIVE(quot_compiled_p)
primitive_alien_signed_1, PRIMITIVE(quotation_code)
primitive_set_alien_signed_1, PRIMITIVE(reset_dispatch_stats)
primitive_alien_unsigned_1, PRIMITIVE(resize_array)
primitive_set_alien_unsigned_1, PRIMITIVE(resize_byte_array)
primitive_alien_float, PRIMITIVE(resize_string)
primitive_set_alien_float, PRIMITIVE(retainstack)
primitive_alien_double, PRIMITIVE(save_image)
primitive_set_alien_double, PRIMITIVE(save_image_and_exit)
primitive_alien_cell, PRIMITIVE(set_datastack)
primitive_set_alien_cell, PRIMITIVE(set_innermost_stack_frame_quot)
primitive_alien_address, PRIMITIVE(set_retainstack)
primitive_set_slot, PRIMITIVE(set_slot)
primitive_string_nth, PRIMITIVE(set_special_object)
primitive_set_string_nth_fast, PRIMITIVE(set_string_nth_fast)
primitive_set_string_nth_slow, PRIMITIVE(set_string_nth_slow)
primitive_resize_array, PRIMITIVE(size)
primitive_resize_string, PRIMITIVE(sleep)
primitive_array, PRIMITIVE(special_object)
primitive_all_instances, PRIMITIVE(str_to_float)
primitive_size, PRIMITIVE(string)
primitive_die, PRIMITIVE(string_nth)
primitive_fopen, PRIMITIVE(strip_stack_traces)
primitive_fgetc, PRIMITIVE(system_micros)
primitive_fread, PRIMITIVE(tuple)
primitive_fputc, PRIMITIVE(tuple_boa)
primitive_fwrite, PRIMITIVE(unimplemented)
primitive_fflush, PRIMITIVE(uninitialized_byte_array)
primitive_ftell, PRIMITIVE(vm_ptr)
primitive_fseek, PRIMITIVE(word)
primitive_fclose, PRIMITIVE(word_code)
primitive_wrapper, PRIMITIVE(wrapper)
primitive_clone,
primitive_string,
primitive_array_to_quotation,
primitive_quotation_xt,
primitive_tuple,
primitive_profiling,
primitive_become,
primitive_sleep,
primitive_tuple_boa,
primitive_callstack_to_array,
primitive_innermost_stack_frame_executing,
primitive_innermost_stack_frame_scan,
primitive_set_innermost_stack_frame_quot,
primitive_call_clear,
primitive_resize_byte_array,
primitive_dll_validp,
primitive_unimplemented,
primitive_jit_compile,
primitive_load_locals,
primitive_check_datastack,
primitive_mega_cache_miss,
primitive_lookup_method,
primitive_reset_dispatch_stats,
primitive_dispatch_stats,
primitive_optimized_p,
primitive_quot_compiled_p,
primitive_vm_ptr,
primitive_strip_stack_traces,
primitive_callback,
primitive_enable_gc_events,
primitive_disable_gc_events,
primitive_identity_hashcode,
primitive_compute_identity_hashcode,
};
} }

View File

@ -1,41 +1,162 @@
namespace factor namespace factor
{ {
extern "C" typedef void (*primitive_type)(factor_vm *parent); #define DECLARE_PRIMITIVE(name) VM_C_API void primitive_##name(factor_vm *parent);
#define PRIMITIVE(name) extern "C" void primitive_##name(factor_vm *parent)
#define PRIMITIVE_FORWARD(name) extern "C" void primitive_##name(factor_vm *parent) \
{ \
parent->primitive_##name(); \
}
extern const primitive_type primitives[]; /* Generated with PRIMITIVE in primitives.cpp */
DECLARE_PRIMITIVE(alien_address)
DECLARE_PRIMITIVE(all_instances)
DECLARE_PRIMITIVE(array)
DECLARE_PRIMITIVE(array_to_quotation)
DECLARE_PRIMITIVE(become)
DECLARE_PRIMITIVE(bignum_add)
DECLARE_PRIMITIVE(bignum_and)
DECLARE_PRIMITIVE(bignum_bitp)
DECLARE_PRIMITIVE(bignum_divint)
DECLARE_PRIMITIVE(bignum_divmod)
DECLARE_PRIMITIVE(bignum_eq)
DECLARE_PRIMITIVE(bignum_greater)
DECLARE_PRIMITIVE(bignum_greatereq)
DECLARE_PRIMITIVE(bignum_less)
DECLARE_PRIMITIVE(bignum_lesseq)
DECLARE_PRIMITIVE(bignum_log2)
DECLARE_PRIMITIVE(bignum_mod)
DECLARE_PRIMITIVE(bignum_multiply)
DECLARE_PRIMITIVE(bignum_not)
DECLARE_PRIMITIVE(bignum_or)
DECLARE_PRIMITIVE(bignum_shift)
DECLARE_PRIMITIVE(bignum_subtract)
DECLARE_PRIMITIVE(bignum_to_fixnum)
DECLARE_PRIMITIVE(bignum_to_float)
DECLARE_PRIMITIVE(bignum_xor)
DECLARE_PRIMITIVE(bits_double)
DECLARE_PRIMITIVE(bits_float)
DECLARE_PRIMITIVE(byte_array)
DECLARE_PRIMITIVE(byte_array_to_bignum)
DECLARE_PRIMITIVE(call_clear)
DECLARE_PRIMITIVE(callback)
DECLARE_PRIMITIVE(callstack)
DECLARE_PRIMITIVE(callstack_to_array)
DECLARE_PRIMITIVE(check_datastack)
DECLARE_PRIMITIVE(clone)
DECLARE_PRIMITIVE(code_room)
DECLARE_PRIMITIVE(compact_gc)
DECLARE_PRIMITIVE(compute_identity_hashcode)
DECLARE_PRIMITIVE(data_room)
DECLARE_PRIMITIVE(datastack)
DECLARE_PRIMITIVE(die)
DECLARE_PRIMITIVE(disable_gc_events)
DECLARE_PRIMITIVE(dispatch_stats)
DECLARE_PRIMITIVE(displaced_alien)
DECLARE_PRIMITIVE(dlclose)
DECLARE_PRIMITIVE(dll_validp)
DECLARE_PRIMITIVE(dlopen)
DECLARE_PRIMITIVE(dlsym)
DECLARE_PRIMITIVE(double_bits)
DECLARE_PRIMITIVE(enable_gc_events)
DECLARE_PRIMITIVE(existsp)
DECLARE_PRIMITIVE(exit)
DECLARE_PRIMITIVE(fclose)
DECLARE_PRIMITIVE(fflush)
DECLARE_PRIMITIVE(fgetc)
DECLARE_PRIMITIVE(fixnum_divint)
DECLARE_PRIMITIVE(fixnum_divmod)
DECLARE_PRIMITIVE(fixnum_shift)
DECLARE_PRIMITIVE(fixnum_to_bignum)
DECLARE_PRIMITIVE(fixnum_to_float)
DECLARE_PRIMITIVE(float_add)
DECLARE_PRIMITIVE(float_bits)
DECLARE_PRIMITIVE(float_divfloat)
DECLARE_PRIMITIVE(float_eq)
DECLARE_PRIMITIVE(float_greater)
DECLARE_PRIMITIVE(float_greatereq)
DECLARE_PRIMITIVE(float_less)
DECLARE_PRIMITIVE(float_lesseq)
DECLARE_PRIMITIVE(float_mod)
DECLARE_PRIMITIVE(float_multiply)
DECLARE_PRIMITIVE(float_subtract)
DECLARE_PRIMITIVE(float_to_bignum)
DECLARE_PRIMITIVE(float_to_fixnum)
DECLARE_PRIMITIVE(float_to_str)
DECLARE_PRIMITIVE(fopen)
DECLARE_PRIMITIVE(fputc)
DECLARE_PRIMITIVE(fread)
DECLARE_PRIMITIVE(fseek)
DECLARE_PRIMITIVE(ftell)
DECLARE_PRIMITIVE(full_gc)
DECLARE_PRIMITIVE(fwrite)
DECLARE_PRIMITIVE(identity_hashcode)
DECLARE_PRIMITIVE(innermost_stack_frame_executing)
DECLARE_PRIMITIVE(innermost_stack_frame_scan)
DECLARE_PRIMITIVE(jit_compile)
DECLARE_PRIMITIVE(load_locals)
DECLARE_PRIMITIVE(lookup_method)
DECLARE_PRIMITIVE(mega_cache_miss)
DECLARE_PRIMITIVE(minor_gc)
DECLARE_PRIMITIVE(modify_code_heap)
DECLARE_PRIMITIVE(nano_count)
DECLARE_PRIMITIVE(optimized_p)
DECLARE_PRIMITIVE(profiling)
DECLARE_PRIMITIVE(quot_compiled_p)
DECLARE_PRIMITIVE(quotation_code)
DECLARE_PRIMITIVE(reset_dispatch_stats)
DECLARE_PRIMITIVE(resize_array)
DECLARE_PRIMITIVE(resize_byte_array)
DECLARE_PRIMITIVE(resize_string)
DECLARE_PRIMITIVE(retainstack)
DECLARE_PRIMITIVE(save_image)
DECLARE_PRIMITIVE(save_image_and_exit)
DECLARE_PRIMITIVE(set_datastack)
DECLARE_PRIMITIVE(set_innermost_stack_frame_quot)
DECLARE_PRIMITIVE(set_retainstack)
DECLARE_PRIMITIVE(set_slot)
DECLARE_PRIMITIVE(set_special_object)
DECLARE_PRIMITIVE(set_string_nth_fast)
DECLARE_PRIMITIVE(set_string_nth_slow)
DECLARE_PRIMITIVE(size)
DECLARE_PRIMITIVE(sleep)
DECLARE_PRIMITIVE(special_object)
DECLARE_PRIMITIVE(str_to_float)
DECLARE_PRIMITIVE(string)
DECLARE_PRIMITIVE(string_nth)
DECLARE_PRIMITIVE(strip_stack_traces)
DECLARE_PRIMITIVE(system_micros)
DECLARE_PRIMITIVE(tuple)
DECLARE_PRIMITIVE(tuple_boa)
DECLARE_PRIMITIVE(unimplemented)
DECLARE_PRIMITIVE(uninitialized_byte_array)
DECLARE_PRIMITIVE(vm_ptr)
DECLARE_PRIMITIVE(word)
DECLARE_PRIMITIVE(word_code)
DECLARE_PRIMITIVE(wrapper)
/* These are generated with macros in alien.c */ /* These are generated with macros in alien.cpp, and not with PRIMIIVE in
PRIMITIVE(alien_signed_cell); primitives.cpp */
PRIMITIVE(set_alien_signed_cell); DECLARE_PRIMITIVE(alien_signed_cell)
PRIMITIVE(alien_unsigned_cell); DECLARE_PRIMITIVE(set_alien_signed_cell)
PRIMITIVE(set_alien_unsigned_cell); DECLARE_PRIMITIVE(alien_unsigned_cell)
PRIMITIVE(alien_signed_8); DECLARE_PRIMITIVE(set_alien_unsigned_cell)
PRIMITIVE(set_alien_signed_8); DECLARE_PRIMITIVE(alien_signed_8)
PRIMITIVE(alien_unsigned_8); DECLARE_PRIMITIVE(set_alien_signed_8)
PRIMITIVE(set_alien_unsigned_8); DECLARE_PRIMITIVE(alien_unsigned_8)
PRIMITIVE(alien_signed_4); DECLARE_PRIMITIVE(set_alien_unsigned_8)
PRIMITIVE(set_alien_signed_4); DECLARE_PRIMITIVE(alien_signed_4)
PRIMITIVE(alien_unsigned_4); DECLARE_PRIMITIVE(set_alien_signed_4)
PRIMITIVE(set_alien_unsigned_4); DECLARE_PRIMITIVE(alien_unsigned_4)
PRIMITIVE(alien_signed_2); DECLARE_PRIMITIVE(set_alien_unsigned_4)
PRIMITIVE(set_alien_signed_2); DECLARE_PRIMITIVE(alien_signed_2)
PRIMITIVE(alien_unsigned_2); DECLARE_PRIMITIVE(set_alien_signed_2)
PRIMITIVE(set_alien_unsigned_2); DECLARE_PRIMITIVE(alien_unsigned_2)
PRIMITIVE(alien_signed_1); DECLARE_PRIMITIVE(set_alien_unsigned_2)
PRIMITIVE(set_alien_signed_1); DECLARE_PRIMITIVE(alien_signed_1)
PRIMITIVE(alien_unsigned_1); DECLARE_PRIMITIVE(set_alien_signed_1)
PRIMITIVE(set_alien_unsigned_1); DECLARE_PRIMITIVE(alien_unsigned_1)
PRIMITIVE(alien_float); DECLARE_PRIMITIVE(set_alien_unsigned_1)
PRIMITIVE(set_alien_float); DECLARE_PRIMITIVE(alien_float)
PRIMITIVE(alien_double); DECLARE_PRIMITIVE(set_alien_float)
PRIMITIVE(set_alien_double); DECLARE_PRIMITIVE(alien_double)
PRIMITIVE(alien_cell); DECLARE_PRIMITIVE(set_alien_double)
PRIMITIVE(set_alien_cell); DECLARE_PRIMITIVE(alien_cell)
DECLARE_PRIMITIVE(set_alien_cell)
} }

View File

@ -52,7 +52,7 @@ void factor_vm::set_profiling(bool profiling)
word->counter = tag_fixnum(0); word->counter = tag_fixnum(0);
} }
update_word_xt(word.untagged()); update_word_entry_point(word.untagged());
} }
update_code_heap_words(); update_code_heap_words();

View File

@ -43,7 +43,7 @@ void quotation_jit::init_quotation(cell quot)
bool quotation_jit::primitive_call_p(cell i, cell length) bool quotation_jit::primitive_call_p(cell i, cell length)
{ {
return (i + 2) == length && array_nth(elements.untagged(),i + 1) == parent->special_objects[JIT_PRIMITIVE_WORD]; return (i + 2) <= length && array_nth(elements.untagged(),i + 1) == parent->special_objects[JIT_PRIMITIVE_WORD];
} }
bool quotation_jit::fast_if_p(cell i, cell length) bool quotation_jit::fast_if_p(cell i, cell length)
@ -178,7 +178,7 @@ void quotation_jit::iterate_quotation()
case WRAPPER_TYPE: case WRAPPER_TYPE:
push(obj.as<wrapper>()->object); push(obj.as<wrapper>()->object);
break; break;
case FIXNUM_TYPE: case BYTE_ARRAY_TYPE:
/* Primitive calls */ /* Primitive calls */
if(primitive_call_p(i,length)) if(primitive_call_p(i,length))
{ {
@ -189,6 +189,7 @@ void quotation_jit::iterate_quotation()
parameter(tag_fixnum(0)); parameter(tag_fixnum(0));
#endif #endif
parameter(obj.value()); parameter(obj.value());
parameter(false_object);
emit(parent->special_objects[JIT_PRIMITIVE]); emit(parent->special_objects[JIT_PRIMITIVE]);
i++; i++;
@ -267,10 +268,10 @@ void quotation_jit::iterate_quotation()
} }
} }
void factor_vm::set_quot_xt(quotation *quot, code_block *code) void factor_vm::set_quot_entry_point(quotation *quot, code_block *code)
{ {
quot->code = code; quot->code = code;
quot->xt = code->xt(); quot->entry_point = code->entry_point();
} }
/* Allocates memory */ /* Allocates memory */
@ -296,7 +297,7 @@ void factor_vm::jit_compile_quot(cell quot_, bool relocating)
if(!quot_compiled_p(quot.untagged())) if(!quot_compiled_p(quot.untagged()))
{ {
code_block *compiled = jit_compile_quot(quot.value(),quot.value(),relocating); code_block *compiled = jit_compile_quot(quot.value(),quot.value(),relocating);
set_quot_xt(quot.untagged(),compiled); set_quot_entry_point(quot.untagged(),compiled);
} }
} }
@ -318,15 +319,17 @@ void factor_vm::primitive_array_to_quotation()
quot->array = ctx->peek(); quot->array = ctx->peek();
quot->cached_effect = false_object; quot->cached_effect = false_object;
quot->cache_counter = false_object; quot->cache_counter = false_object;
set_quot_xt(quot,lazy_jit_compile_block()); set_quot_entry_point(quot,lazy_jit_compile_block());
ctx->replace(tag<quotation>(quot)); ctx->replace(tag<quotation>(quot));
} }
void factor_vm::primitive_quotation_xt() void factor_vm::primitive_quotation_code()
{ {
quotation *quot = untag_check<quotation>(ctx->peek()); quotation *quot = untag_check<quotation>(ctx->pop());
ctx->replace(allot_cell((cell)quot->xt));
ctx->push(allot_cell((cell)quot->code->entry_point()));
ctx->push(allot_cell((cell)quot->code + quot->code->size()));
} }
/* Allocates memory */ /* Allocates memory */
@ -346,7 +349,12 @@ fixnum factor_vm::quot_code_offset_to_scan(cell quot_, cell offset)
cell factor_vm::lazy_jit_compile(cell quot_) cell factor_vm::lazy_jit_compile(cell quot_)
{ {
data_root<quotation> quot(quot_,this); data_root<quotation> quot(quot_,this);
jit_compile_quot(quot.value(),true);
assert(!quot_compiled_p(quot.untagged()));
code_block *compiled = jit_compile_quot(quot.value(),quot.value(),true);
set_quot_entry_point(quot.untagged(),compiled);
return quot.value(); return quot.value();
} }
@ -381,7 +389,7 @@ void factor_vm::initialize_all_quotations()
{ {
data_root<quotation> quot(array_nth(quotations.untagged(),i),this); data_root<quotation> quot(array_nth(quotations.untagged(),i),this);
if(!quot->code) if(!quot->code)
set_quot_xt(quot.untagged(),lazy_jit_compile_block()); set_quot_entry_point(quot.untagged(),lazy_jit_compile_block());
} }
} }

View File

@ -393,8 +393,8 @@ struct factor_vm
//words //words
word *allot_word(cell name_, cell vocab_, cell hashcode_); word *allot_word(cell name_, cell vocab_, cell hashcode_);
void primitive_word(); void primitive_word();
void primitive_word_xt(); void primitive_word_code();
void update_word_xt(word *w_); void update_word_entry_point(word *w_);
void primitive_optimized_p(); void primitive_optimized_p();
void primitive_wrapper(); void primitive_wrapper();
void jit_compile_word(cell word_, cell def_, bool relocating); void jit_compile_word(cell word_, cell def_, bool relocating);
@ -503,17 +503,15 @@ struct factor_vm
void primitive_fclose(); void primitive_fclose();
//code_block //code_block
cell compute_xt_address(cell obj); cell compute_entry_point_address(cell obj);
cell compute_xt_pic_address(word *w, cell tagged_quot); cell compute_entry_point_pic_address(word *w, cell tagged_quot);
cell compute_xt_pic_address(cell w_); cell compute_entry_point_pic_address(cell w_);
cell compute_xt_pic_tail_address(cell w_); cell compute_entry_point_pic_tail_address(cell w_);
cell code_block_owner(code_block *compiled); cell code_block_owner(code_block *compiled);
void update_word_references(code_block *compiled); void update_word_references(code_block *compiled);
void check_code_address(cell address); void check_code_address(cell address);
cell compute_primitive_address(cell arg);
void undefined_symbol(); void undefined_symbol();
cell compute_dlsym_address(array *literals, cell index); cell compute_dlsym_address(array *literals, cell index);
cell compute_context_address();
cell compute_vm_address(cell arg); cell compute_vm_address(cell arg);
void store_external_address(instruction_operand op); void store_external_address(instruction_operand op);
cell compute_here_address(cell arg, cell offset, code_block *compiled); cell compute_here_address(cell arg, cell offset, code_block *compiled);
@ -600,8 +598,8 @@ struct factor_vm
void primitive_jit_compile(); void primitive_jit_compile();
code_block *lazy_jit_compile_block(); code_block *lazy_jit_compile_block();
void primitive_array_to_quotation(); void primitive_array_to_quotation();
void primitive_quotation_xt(); void primitive_quotation_code();
void set_quot_xt(quotation *quot, code_block *code); void set_quot_entry_point(quotation *quot, code_block *code);
code_block *jit_compile_quot(cell owner_, cell quot_, bool relocating); code_block *jit_compile_quot(cell owner_, cell quot_, bool relocating);
void jit_compile_quot(cell quot_, bool relocating); void jit_compile_quot(cell quot_, bool relocating);
fixnum quot_code_offset_to_scan(cell quot_, cell offset); fixnum quot_code_offset_to_scan(cell quot_, cell offset);

View File

@ -9,6 +9,11 @@ void factor_vm::jit_compile_word(cell word_, cell def_, bool relocating)
data_root<word> word(word_,this); data_root<word> word(word_,this);
data_root<quotation> def(def_,this); data_root<quotation> def(def_,this);
/* Refuse to compile this word more than once, because quot_compiled_p()
depends on the identity of its code block */
if(word->code && word.value() == special_objects[LAZY_JIT_COMPILE_WORD])
return;
code_block *compiled = jit_compile_quot(word.value(),def.value(),relocating); code_block *compiled = jit_compile_quot(word.value(),def.value(),relocating);
word->code = compiled; word->code = compiled;
@ -33,7 +38,7 @@ void factor_vm::compile_all_words()
if(!word->code || !word->code->optimized_p()) if(!word->code || !word->code->optimized_p())
jit_compile_word(word.value(),word->def,false); jit_compile_word(word.value(),word->def,false);
update_word_xt(word.untagged()); update_word_entry_point(word.untagged());
} }
} }
@ -64,7 +69,7 @@ word *factor_vm::allot_word(cell name_, cell vocab_, cell hashcode_)
initialize_code_block(new_word->profiling); initialize_code_block(new_word->profiling);
} }
update_word_xt(new_word.untagged()); update_word_entry_point(new_word.untagged());
return new_word.untagged(); return new_word.untagged();
} }
@ -78,30 +83,30 @@ void factor_vm::primitive_word()
ctx->push(tag<word>(allot_word(name,vocab,hashcode))); ctx->push(tag<word>(allot_word(name,vocab,hashcode)));
} }
/* word-xt ( word -- start end ) */ /* word-code ( word -- start end ) */
void factor_vm::primitive_word_xt() void factor_vm::primitive_word_code()
{ {
data_root<word> w(ctx->pop(),this); data_root<word> w(ctx->pop(),this);
w.untag_check(this); w.untag_check(this);
if(profiling_p) if(profiling_p)
{ {
ctx->push(allot_cell((cell)w->profiling->xt())); ctx->push(allot_cell((cell)w->profiling->entry_point()));
ctx->push(allot_cell((cell)w->profiling + w->profiling->size())); ctx->push(allot_cell((cell)w->profiling + w->profiling->size()));
} }
else else
{ {
ctx->push(allot_cell((cell)w->code->xt())); ctx->push(allot_cell((cell)w->code->entry_point()));
ctx->push(allot_cell((cell)w->code + w->code->size())); ctx->push(allot_cell((cell)w->code + w->code->size()));
} }
} }
void factor_vm::update_word_xt(word *w) void factor_vm::update_word_entry_point(word *w)
{ {
if(profiling_p && w->profiling) if(profiling_p && w->profiling)
w->xt = w->profiling->xt(); w->entry_point = w->profiling->entry_point();
else else
w->xt = w->code->xt(); w->entry_point = w->code->entry_point();
} }
void factor_vm::primitive_optimized_p() void factor_vm::primitive_optimized_p()