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

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

Conflicts:

	basis/compiler/tree/propagation/transforms/transforms.factor
release
Daniel Ehrenberg 2010-01-20 00:15:55 -06:00
parent aa1651032d 21c07397d2
commit d3590ea210
1538 changed files with 45794 additions and 10754 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
.gitignore vendored
View File

@ -8,6 +8,7 @@ Factor/factor
*.a
*.dll
*.lib
*.res
*.image
*.dylib
factor

223
GNUmakefile Executable file
View File

@ -0,0 +1,223 @@
ifdef CONFIG
CC = gcc
CPP = g++
AR = ar
LD = ld
VERSION = 0.92
BUNDLE = Factor.app
LIBPATH = -L/usr/X11R6/lib
CFLAGS = -Wall $(SITE_CFLAGS)
ifdef DEBUG
CFLAGS += -g -DFACTOR_DEBUG
else
CFLAGS += -O3
endif
include $(CONFIG)
ENGINE = $(DLL_PREFIX)factor$(DLL_SUFFIX)$(DLL_EXTENSION)
EXECUTABLE = factor$(EXE_SUFFIX)$(EXE_EXTENSION)
CONSOLE_EXECUTABLE = factor$(EXE_SUFFIX)$(CONSOLE_EXTENSION)
DLL_OBJS = $(PLAF_DLL_OBJS) \
vm/aging_collector.o \
vm/alien.o \
vm/arrays.o \
vm/bignum.o \
vm/booleans.o \
vm/byte_arrays.o \
vm/callbacks.o \
vm/callstack.o \
vm/code_blocks.o \
vm/code_heap.o \
vm/compaction.o \
vm/contexts.o \
vm/data_heap.o \
vm/data_heap_checker.o \
vm/debug.o \
vm/dispatch.o \
vm/entry_points.o \
vm/errors.o \
vm/factor.o \
vm/free_list.o \
vm/full_collector.o \
vm/gc.o \
vm/image.o \
vm/inline_cache.o \
vm/instruction_operands.o \
vm/io.o \
vm/jit.o \
vm/math.o \
vm/nursery_collector.o \
vm/object_start_map.o \
vm/objects.o \
vm/primitives.o \
vm/profiler.o \
vm/quotations.o \
vm/run.o \
vm/strings.o \
vm/to_tenured_collector.o \
vm/tuples.o \
vm/utilities.o \
vm/vm.o \
vm/words.o
EXE_OBJS = $(PLAF_EXE_OBJS)
FFI_TEST_LIBRARY = libfactor-ffi-test$(SHARED_DLL_EXTENSION)
TEST_OBJS = vm/ffi_test.o
endif
default:
$(MAKE) `./build-support/factor.sh make-target`
help:
@echo "Run '$(MAKE)' with one of the following parameters:"
@echo ""
@echo "freebsd-x86-32"
@echo "freebsd-x86-64"
@echo "linux-x86-32"
@echo "linux-x86-64"
@echo "linux-ppc"
@echo "linux-arm"
@echo "openbsd-x86-32"
@echo "openbsd-x86-64"
@echo "netbsd-x86-32"
@echo "netbsd-x86-64"
@echo "macosx-x86-32"
@echo "macosx-x86-64"
@echo "macosx-ppc"
@echo "solaris-x86-32"
@echo "solaris-x86-64"
@echo "wince-arm"
@echo "winnt-x86-32"
@echo "winnt-x86-64"
@echo ""
@echo "Additional modifiers:"
@echo ""
@echo "DEBUG=1 compile VM with debugging information"
@echo "SITE_CFLAGS=... additional optimization flags"
@echo "NO_UI=1 don't link with X11 libraries (ignored on Mac OS X)"
@echo "X11=1 force link with X11 libraries instead of Cocoa (only on Mac OS X)"
openbsd-x86-32:
$(MAKE) factor factor-ffi-test CONFIG=vm/Config.openbsd.x86.32
openbsd-x86-64:
$(MAKE) factor factor-ffi-test CONFIG=vm/Config.openbsd.x86.64
freebsd-x86-32:
$(MAKE) factor factor-ffi-test CONFIG=vm/Config.freebsd.x86.32
freebsd-x86-64:
$(MAKE) factor factor-ffi-test CONFIG=vm/Config.freebsd.x86.64
netbsd-x86-32:
$(MAKE) factor factor-ffi-test CONFIG=vm/Config.netbsd.x86.32
netbsd-x86-64:
$(MAKE) factor factor-ffi-test CONFIG=vm/Config.netbsd.x86.64
macosx-ppc:
$(MAKE) factor factor-ffi-test macosx.app CONFIG=vm/Config.macosx.ppc
macosx-x86-32:
$(MAKE) factor factor-ffi-test macosx.app CONFIG=vm/Config.macosx.x86.32
macosx-x86-64:
$(MAKE) factor factor-ffi-test macosx.app CONFIG=vm/Config.macosx.x86.64
linux-x86-32:
$(MAKE) factor factor-ffi-test CONFIG=vm/Config.linux.x86.32
linux-x86-64:
$(MAKE) factor factor-ffi-test CONFIG=vm/Config.linux.x86.64
linux-ppc:
$(MAKE) factor factor-ffi-test CONFIG=vm/Config.linux.ppc
linux-arm:
$(MAKE) factor factor-ffi-test CONFIG=vm/Config.linux.arm
solaris-x86-32:
$(MAKE) factor factor-ffi-test CONFIG=vm/Config.solaris.x86.32
solaris-x86-64:
$(MAKE) factor factor-ffi-test CONFIG=vm/Config.solaris.x86.64
winnt-x86-32:
$(MAKE) factor factor-ffi-test CONFIG=vm/Config.windows.nt.x86.32
$(MAKE) factor-console CONFIG=vm/Config.windows.nt.x86.32
winnt-x86-64:
$(MAKE) factor factor-ffi-test CONFIG=vm/Config.windows.nt.x86.64
$(MAKE) factor-console CONFIG=vm/Config.windows.nt.x86.64
wince-arm:
$(MAKE) factor factor-ffi-test CONFIG=vm/Config.windows.ce.arm
ifdef CONFIG
macosx.app: factor
mkdir -p $(BUNDLE)/Contents/MacOS
mkdir -p $(BUNDLE)/Contents/Frameworks
mv $(EXECUTABLE) $(BUNDLE)/Contents/MacOS/factor
ln -s Factor.app/Contents/MacOS/factor ./factor
cp $(ENGINE) $(BUNDLE)/Contents/Frameworks/$(ENGINE)
install_name_tool \
-change libfactor.dylib \
@executable_path/../Frameworks/libfactor.dylib \
Factor.app/Contents/MacOS/factor
$(ENGINE): $(DLL_OBJS)
$(TOOLCHAIN_PREFIX)$(LINKER) $(ENGINE) $(DLL_OBJS)
factor: $(EXE_OBJS) $(ENGINE)
$(TOOLCHAIN_PREFIX)$(CPP) $(LIBS) $(LIBPATH) -L. $(LINK_WITH_ENGINE) \
$(CFLAGS) -o $(EXECUTABLE) $(EXE_OBJS)
factor-console: $(EXE_OBJS) $(ENGINE)
$(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:
rm -f vm/*.o
rm -f factor.dll
rm -f libfactor.*
rm -f libfactor-ffi-test.*
rm -f Factor.app/Contents/Frameworks/libfactor.dylib
tags:
etags vm/*.{cpp,hpp,mm,S,c}
.PHONY: factor factor-console factor-ffi-test tags clean macosx.app

219
Makefile
View File

@ -1,219 +0,0 @@
CC = gcc
CPP = g++
AR = ar
LD = ld
EXECUTABLE = factor
CONSOLE_EXECUTABLE = factor-console
TEST_LIBRARY = factor-ffi-test
VERSION = 0.92
BUNDLE = Factor.app
LIBPATH = -L/usr/X11R6/lib
CFLAGS = -Wall
ifdef DEBUG
CFLAGS += -g -DFACTOR_DEBUG
else
CFLAGS += -O3
endif
ifdef REENTRANT
CFLAGS += -DFACTOR_REENTRANT
endif
CFLAGS += $(SITE_CFLAGS)
ENGINE = $(DLL_PREFIX)factor$(DLL_SUFFIX)$(DLL_EXTENSION)
ifdef CONFIG
include $(CONFIG)
endif
DLL_OBJS = $(PLAF_DLL_OBJS) \
vm/aging_collector.o \
vm/alien.o \
vm/arrays.o \
vm/bignum.o \
vm/booleans.o \
vm/byte_arrays.o \
vm/callbacks.o \
vm/callstack.o \
vm/code_block.o \
vm/code_heap.o \
vm/compaction.o \
vm/contexts.o \
vm/data_heap.o \
vm/debug.o \
vm/dispatch.o \
vm/errors.o \
vm/factor.o \
vm/free_list.o \
vm/full_collector.o \
vm/gc.o \
vm/image.o \
vm/inline_cache.o \
vm/io.o \
vm/jit.o \
vm/math.o \
vm/nursery_collector.o \
vm/object_start_map.o \
vm/primitives.o \
vm/profiler.o \
vm/quotations.o \
vm/run.o \
vm/strings.o \
vm/to_tenured_collector.o \
vm/tuples.o \
vm/utilities.o \
vm/vm.o \
vm/words.o
EXE_OBJS = $(PLAF_EXE_OBJS)
TEST_OBJS = vm/ffi_test.o
default:
$(MAKE) `./build-support/factor.sh make-target`
help:
@echo "Run '$(MAKE)' with one of the following parameters:"
@echo ""
@echo "freebsd-x86-32"
@echo "freebsd-x86-64"
@echo "linux-x86-32"
@echo "linux-x86-64"
@echo "linux-ppc"
@echo "linux-arm"
@echo "openbsd-x86-32"
@echo "openbsd-x86-64"
@echo "netbsd-x86-32"
@echo "netbsd-x86-64"
@echo "macosx-x86-32"
@echo "macosx-x86-64"
@echo "macosx-ppc"
@echo "solaris-x86-32"
@echo "solaris-x86-64"
@echo "wince-arm"
@echo "winnt-x86-32"
@echo "winnt-x86-64"
@echo ""
@echo "Additional modifiers:"
@echo ""
@echo "DEBUG=1 compile VM with debugging information"
@echo "SITE_CFLAGS=... additional optimization flags"
@echo "NO_UI=1 don't link with X11 libraries (ignored on Mac OS X)"
@echo "X11=1 force link with X11 libraries instead of Cocoa (only on Mac OS X)"
openbsd-x86-32:
$(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) CONFIG=vm/Config.openbsd.x86.32
openbsd-x86-64:
$(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) CONFIG=vm/Config.openbsd.x86.64
freebsd-x86-32:
$(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) CONFIG=vm/Config.freebsd.x86.32
freebsd-x86-64:
$(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) CONFIG=vm/Config.freebsd.x86.64
netbsd-x86-32:
$(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) CONFIG=vm/Config.netbsd.x86.32
netbsd-x86-64:
$(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) CONFIG=vm/Config.netbsd.x86.64
macosx-ppc:
$(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) macosx.app CONFIG=vm/Config.macosx.ppc
macosx-x86-32:
$(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) macosx.app CONFIG=vm/Config.macosx.x86.32
macosx-x86-64:
$(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) macosx.app CONFIG=vm/Config.macosx.x86.64
linux-x86-32:
$(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) CONFIG=vm/Config.linux.x86.32
linux-x86-64:
$(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) CONFIG=vm/Config.linux.x86.64
linux-ppc:
$(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) CONFIG=vm/Config.linux.ppc
linux-arm:
$(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) CONFIG=vm/Config.linux.arm
solaris-x86-32:
$(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) CONFIG=vm/Config.solaris.x86.32
solaris-x86-64:
$(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) CONFIG=vm/Config.solaris.x86.64
winnt-x86-32:
$(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) CONFIG=vm/Config.windows.nt.x86.32
$(MAKE) $(CONSOLE_EXECUTABLE) CONFIG=vm/Config.windows.nt.x86.32
winnt-x86-64:
$(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) CONFIG=vm/Config.windows.nt.x86.64
$(MAKE) $(CONSOLE_EXECUTABLE) CONFIG=vm/Config.windows.nt.x86.64
wince-arm:
$(MAKE) $(EXECUTABLE) $(TEST_LIBRARY) CONFIG=vm/Config.windows.ce.arm
macosx.app: factor
mkdir -p $(BUNDLE)/Contents/MacOS
mkdir -p $(BUNDLE)/Contents/Frameworks
mv $(EXECUTABLE) $(BUNDLE)/Contents/MacOS/factor
ln -s Factor.app/Contents/MacOS/factor ./factor
cp $(ENGINE) $(BUNDLE)/Contents/Frameworks/$(ENGINE)
install_name_tool \
-change libfactor.dylib \
@executable_path/../Frameworks/libfactor.dylib \
Factor.app/Contents/MacOS/factor
$(EXECUTABLE): $(DLL_OBJS) $(EXE_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)
$(TOOLCHAIN_PREFIX)$(LINKER) $(ENGINE) $(DLL_OBJS)
$(TOOLCHAIN_PREFIX)$(CPP) $(LIBS) $(LIBPATH) -L. $(LINK_WITH_ENGINE) \
$(CFLAGS) $(CFLAGS_CONSOLE) -o factor$(EXE_SUFFIX)$(CONSOLE_EXTENSION) $(EXE_OBJS)
$(TEST_LIBRARY): vm/ffi_test.o
$(TOOLCHAIN_PREFIX)$(CC) $(LIBPATH) $(CFLAGS) $(FFI_TEST_CFLAGS) $(SHARED_FLAG) -o libfactor-ffi-test$(SHARED_DLL_EXTENSION) $(TEST_OBJS)
clean:
rm -f vm/*.o
rm -f factor.dll
rm -f libfactor.*
rm -f libfactor-ffi-test.*
rm -f Factor.app/Contents/Frameworks/libfactor.dylib
tags:
etags vm/*.{cpp,hpp,mm,S,c}
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 $@ $<
.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

77
Nmakefile Executable file
View File

@ -0,0 +1,77 @@
LINK_FLAGS = /nologo shell32.lib
CL_FLAGS = /nologo /O2 /W3
EXE_OBJS = factor.dll.lib vm\main-windows-nt.obj vm\factor.res
DLL_OBJS = vm\os-windows-nt.obj \
vm\os-windows.obj \
vm\aging_collector.obj \
vm\alien.obj \
vm\arrays.obj \
vm\bignum.obj \
vm\booleans.obj \
vm\byte_arrays.obj \
vm\callbacks.obj \
vm\callstack.obj \
vm\code_blocks.obj \
vm\code_heap.obj \
vm\compaction.obj \
vm\contexts.obj \
vm\data_heap.obj \
vm\data_heap_checker.obj \
vm\debug.obj \
vm\dispatch.obj \
vm\entry_points.obj \
vm\errors.obj \
vm\factor.obj \
vm\free_list.obj \
vm\full_collector.obj \
vm\gc.obj \
vm\image.obj \
vm\inline_cache.obj \
vm\instruction_operands.obj \
vm\io.obj \
vm\jit.obj \
vm\math.obj \
vm\nursery_collector.obj \
vm\object_start_map.obj \
vm\objects.obj \
vm\primitives.obj \
vm\profiler.obj \
vm\quotations.obj \
vm\run.obj \
vm\strings.obj \
vm\to_tenured_collector.obj \
vm\tuples.obj \
vm\utilities.obj \
vm\vm.obj \
vm\words.obj
.cpp.obj:
cl /EHsc $(CL_FLAGS) /Fo$@ /c $<
.rs.res:
rc $<
all: factor.com factor.exe
factor.dll.lib: $(DLL_OBJS)
link $(LINK_FLAGS) /implib:factor.dll.lib /out:factor.dll /dll $(DLL_OBJS)
factor.com: $(EXE_OBJS)
link $(LINK_FLAGS) /out:factor.com /SUBSYSTEM:console $(EXE_OBJS)
factor.exe: $(EXE_OBJS)
link $(LINK_FLAGS) /out:factor.exe /SUBSYSTEM:windows $(EXE_OBJS)
clean:
del vm\*.obj
del factor.lib
del factor.com
del factor.exe
del factor.dll
del factor.dll.lib
.PHONY: all clean
.SUFFIXES: .rs

58
basis/alarms/alarms-docs.factor
View File

@ -1,16 +1,37 @@
USING: help.markup help.syntax calendar quotations system ;
IN: alarms
USING: help.markup help.syntax calendar quotations ;
HELP: alarm
{ $class-description "An alarm. Can be passed to " { $link cancel-alarm } "." } ;
HELP: current-alarm
{ $description "A symbol that contains the currently executing alarm, availble only to the alarm quotation. One use for this symbol is if a repeated alarm wishes to cancel itself from executing in the future."
}
{ $examples
{ $unchecked-example
"""USING: alarms calendar io threads ;"""
"""["""
""" "Hi, this should only get printed once..." print flush"""
""" current-alarm get cancel-alarm"""
"""] 1 seconds every"""
""
}
} ;
HELP: add-alarm
{ $values { "quot" quotation } { "time" timestamp } { "frequency" { $maybe duration } } { "alarm" alarm } }
{ $description "Creates and registers an alarm. If " { $snippet "frequency" } " is " { $link f } ", this will be a one-time alarm, otherwise it will fire with the given frequency. The quotation will be called from the alarm thread." } ;
{ $values { "quot" quotation } { "start" duration } { "interval" { $maybe "duration/f" } } { "alarm" alarm } }
{ $description "Creates and registers an alarm to start at " { $snippet "start" } " offset from the current time. If " { $snippet "interval" } " is " { $link f } ", this will be a one-time alarm, otherwise it will fire with the given frequency, with scheduling happening before the quotation is called in order to ensure that the next event will happen on time. The quotation will be called from a new thread spawned by the alarm thread. If a repeated alarm's quotation throws an exception, the alarm will not be rescheduled." } ;
HELP: later
{ $values { "quot" quotation } { "duration" duration } { "alarm" alarm } }
{ $description "Creates and registers an alarm which calls the quotation once at " { $snippet "time" } " from now." } ;
{ $description "Creates and registers an alarm which calls the quotation once at " { $snippet "duration" } " offset from now." }
{ $examples
{ $unchecked-example
"USING: alarms io calendar ;"
"""[ "Break's over!" print flush ] 15 minutes drop"""
""
}
} ;
HELP: cancel-alarm
{ $values { "alarm" alarm } }
@ -20,16 +41,29 @@ HELP: every
{ $values
{ "quot" quotation } { "duration" duration }
{ "alarm" alarm } }
{ $description "Creates and registers an alarm which calls the quotation repeatedly, using " { $snippet "dt" } " as the frequency." } ;
{ $description "Creates and registers an alarm which calls the quotation repeatedly, using " { $snippet "dt" } " as the frequency. If the quotation throws an exception that is not caught inside it, the alarm scheduler will cancel the alarm and will not reschedule it again." }
{ $examples
{ $unchecked-example
"USING: alarms io calendar ;"
"""[ "Hi Buddy." print flush ] 10 seconds every drop"""
""
}
} ;
ARTICLE: "alarms" "Alarms"
"The " { $vocab-link "alarms" } " vocabulary provides a lightweight way to schedule one-time and recurring tasks without spawning a new thread."
{ $subsections
alarm
add-alarm
later
cancel-alarm
}
"The " { $vocab-link "alarms" } " vocabulary provides a lightweight way to schedule one-time and recurring tasks without spawning a new thread. Alarms use " { $link nano-count } ", so they continue to work across system clock changes." $nl
"The alarm class:"
{ $subsections alarm }
"Register a recurring alarm:"
{ $subsections every }
"Register a one-time alarm:"
{ $subsections later }
"The currently executing alarm:"
{ $subsections current-alarm }
"Low-level interface to add alarms:"
{ $subsections add-alarm }
"Cancelling an alarm:"
{ $subsections cancel-alarm }
"Alarms do not persist across image saves. Saving and restoring an image has the effect of calling " { $link cancel-alarm } " on all " { $link alarm } " instances." ;
ABOUT: "alarms"

74
basis/alarms/alarms.factor
View File

@ -1,48 +1,66 @@
! Copyright (C) 2005, 2008 Slava Pestov, Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs boxes calendar
combinators.short-circuit fry heaps init kernel math.order
namespaces quotations threads ;
USING: accessors assocs boxes calendar combinators.short-circuit
continuations fry heaps init kernel math.order
namespaces quotations threads math system ;
IN: alarms
TUPLE: alarm
{ quot callable initial: [ ] }
{ time timestamp }
{ start integer }
interval
{ entry box } ;
<PRIVATE
SYMBOL: alarms
SYMBOL: alarm-thread
SYMBOL: current-alarm
: cancel-alarm ( alarm -- )
entry>> [ alarms get-global heap-delete ] if-box? ;
<PRIVATE
: notify-alarm-thread ( -- )
alarm-thread get-global interrupt ;
ERROR: bad-alarm-frequency frequency ;
: check-alarm ( frequency/f -- frequency/f )
dup { [ duration? ] [ not ] } 1|| [ bad-alarm-frequency ] unless ;
GENERIC: >nanoseconds ( obj -- duration/f )
M: f >nanoseconds ;
M: real >nanoseconds >integer ;
M: duration >nanoseconds duration>nanoseconds >integer ;
: <alarm> ( quot time frequency -- alarm )
check-alarm <box> alarm boa ;
: <alarm> ( quot start interval -- alarm )
alarm new
swap >nanoseconds >>interval
swap >nanoseconds nano-count + >>start
swap >>quot
<box> >>entry ;
: register-alarm ( alarm -- )
[ dup time>> alarms get-global heap-push* ]
[ dup start>> alarms get-global heap-push* ]
[ entry>> >box ] bi
notify-alarm-thread ;
: alarm-expired? ( alarm now -- ? )
[ time>> ] dip before=? ;
: alarm-expired? ( alarm n -- ? )
[ start>> ] dip <= ;
: reschedule-alarm ( alarm -- )
dup '[ _ interval>> time+ now max ] change-time register-alarm ;
dup interval>> nano-count + >>start register-alarm ;
: call-alarm ( alarm -- )
[ entry>> box> drop ]
[ quot>> "Alarm execution" spawn drop ]
[ dup interval>> [ reschedule-alarm ] [ drop ] if ] tri ;
[ dup interval>> [ reschedule-alarm ] [ drop ] if ]
[
[ ] [ quot>> ] [ ] tri
'[
_ current-alarm
[
_ [ _ dup interval>> [ cancel-alarm ] [ drop ] if rethrow ]
recover
] with-variable
] "Alarm execution" spawn drop
] tri ;
: (trigger-alarms) ( alarms now -- )
: (trigger-alarms) ( alarms n -- )
over heap-empty? [
2drop
] [
@ -54,11 +72,10 @@ ERROR: bad-alarm-frequency frequency ;
] if ;
: trigger-alarms ( alarms -- )
now (trigger-alarms) ;
nano-count (trigger-alarms) ;
: next-alarm ( alarms -- timestamp/f )
dup heap-empty?
[ drop f ] [ heap-peek drop time>> ] if ;
: next-alarm ( alarms -- nanos/f )
dup heap-empty? [ drop f ] [ heap-peek drop start>> ] if ;
: alarm-thread-loop ( -- )
alarms get-global
@ -75,18 +92,13 @@ ERROR: bad-alarm-frequency frequency ;
[ alarm-thread-loop t ] "Alarms" spawn-server
alarm-thread set-global ;
[ init-alarms ] "alarms" add-init-hook
[ init-alarms ] "alarms" add-startup-hook
PRIVATE>
: add-alarm ( quot time frequency -- alarm )
: add-alarm ( quot start interval -- alarm )
<alarm> [ register-alarm ] keep ;
: later ( quot duration -- alarm )
hence f add-alarm ;
: later ( quot duration -- alarm ) f add-alarm ;
: every ( quot duration -- alarm )
[ hence ] keep add-alarm ;
: cancel-alarm ( alarm -- )
entry>> [ alarms get-global heap-delete ] if-box? ;
: every ( quot duration -- alarm ) dup add-alarm ;

5
basis/alien/arrays/arrays.factor Executable file → Normal file
View File

@ -20,6 +20,8 @@ M: array heap-size unclip [ array-length ] [ heap-size ] bi* * ;
M: array c-type-align first c-type-align ;
M: array c-type-align-first first c-type-align-first ;
M: array c-type-stack-align? drop f ;
M: array unbox-parameter drop void* unbox-parameter ;
@ -55,6 +57,9 @@ M: string-type heap-size
M: string-type c-type-align
drop void* c-type-align ;
M: string-type c-type-align-first
drop void* c-type-align-first ;
M: string-type c-type-stack-align?
drop void* c-type-stack-align? ;

4
basis/alien/c-types/c-types-docs.factor Executable file → Normal file
View File

@ -66,12 +66,12 @@ HELP: unbox-return
{ $notes "This is an internal word used by the compiler when compiling callbacks." } ;
HELP: define-deref
{ $values { "name" "a word name" } }
{ $values { "c-type" "a C type" } }
{ $description "Defines a word " { $snippet "*name" } " with stack effect " { $snippet "( c-ptr -- value )" } " for reading a value with C type " { $snippet "name" } " stored at an alien pointer." }
{ $notes "This is an internal word called when defining C types, there is no need to call it on your own." } ;
HELP: define-out
{ $values { "name" "a word name" } }
{ $values { "c-type" "a C type" } }
{ $description "Defines a word " { $snippet "<" { $emphasis "name" } ">" } " with stack effect " { $snippet "( value -- array )" } ". This word allocates a byte array large enough to hold a value with C type " { $snippet "name" } ", and writes the value at the top of the stack to the array." }
{ $notes "This is an internal word called when defining C types, there is no need to call it on your own." } ;

0
basis/alien/c-types/c-types-tests.factor Executable file → Normal file
View File

99
basis/alien/c-types/c-types.factor Executable file → Normal file
View File

@ -30,8 +30,9 @@ TUPLE: abstract-c-type
{ unboxer-quot callable }
{ getter callable }
{ setter callable }
size
align ;
{ size integer }
{ align integer }
{ align-first integer } ;
TUPLE: c-type < abstract-c-type
boxer
@ -104,10 +105,9 @@ M: word c-type
GENERIC: c-struct? ( c-type -- ? )
M: object c-struct?
drop f ;
M: c-type-name c-struct?
dup void? [ drop f ] [ c-type c-struct? ] if ;
M: object c-struct? drop f ;
M: c-type-name c-struct? dup void? [ drop f ] [ c-type c-struct? ] if ;
! These words being foldable means that words need to be
! recompiled if a C type is redefined. Even so, folding the
@ -172,6 +172,12 @@ M: abstract-c-type c-type-align align>> ;
M: c-type-name c-type-align c-type c-type-align ;
GENERIC: c-type-align-first ( name -- n )
M: c-type-name c-type-align-first c-type c-type-align-first ;
M: abstract-c-type c-type-align-first align-first>> ;
GENERIC: c-type-stack-align? ( name -- ? )
M: c-type c-type-stack-align? stack-align?>> ;
@ -212,13 +218,13 @@ M: c-type-name unbox-return c-type unbox-return ;
: little-endian? ( -- ? ) 1 <int> *char 1 = ; foldable
GENERIC: heap-size ( name -- size ) foldable
GENERIC: heap-size ( name -- size )
M: c-type-name heap-size c-type heap-size ;
M: abstract-c-type heap-size size>> ;
GENERIC: stack-size ( name -- size ) foldable
GENERIC: stack-size ( name -- size )
M: c-type-name stack-size c-type stack-size ;
@ -291,20 +297,17 @@ M: long-long-type box-parameter ( n c-type -- )
M: long-long-type box-return ( c-type -- )
f swap box-parameter ;
: define-deref ( name -- )
[ CHAR: * prefix "alien.c-types" create ] [ c-getter 0 prefix ] bi
: define-deref ( c-type -- )
[ name>> CHAR: * prefix "alien.c-types" create ] [ c-getter 0 prefix ] bi
(( c-ptr -- value )) define-inline ;
: define-out ( name -- )
[ "alien.c-types" constructor-word ]
: define-out ( c-type -- )
[ name>> "alien.c-types" constructor-word ]
[ dup c-setter '[ _ heap-size (byte-array) [ 0 @ ] keep ] ] bi
(( value -- c-ptr )) define-inline ;
: define-primitive-type ( c-type name -- )
[ typedef ]
[ name>> define-deref ]
[ name>> define-out ]
tri ;
[ typedef ] [ define-deref ] [ define-out ] tri ;
: if-void ( c-type true false -- )
pick void? [ drop nip call ] [ nip call ] if ; inline
@ -324,6 +327,13 @@ SYMBOLS:
ptrdiff_t intptr_t uintptr_t size_t
char* uchar* ;
: 8-byte-alignment ( c-type -- c-type )
{
{ [ cpu ppc? os macosx? and ] [ 4 >>align 8 >>align-first ] }
{ [ cpu x86.32? os windows? not and ] [ 4 >>align 4 >>align-first ] }
[ 8 >>align 8 >>align-first ]
} cond ;
[
<c-type>
c-ptr >>class
@ -332,8 +342,9 @@ SYMBOLS:
[ [ >c-ptr ] 2dip set-alien-cell ] >>setter
bootstrap-cell >>size
bootstrap-cell >>align
bootstrap-cell >>align-first
[ >c-ptr ] >>unboxer-quot
"box_alien" >>boxer
"allot_alien" >>boxer
"alien_offset" >>unboxer
\ void* define-primitive-type
@ -343,8 +354,8 @@ SYMBOLS:
[ alien-signed-8 ] >>getter
[ set-alien-signed-8 ] >>setter
8 >>size
cpu x86.32? os windows? not and 4 8 ? >>align
"box_signed_8" >>boxer
8-byte-alignment
"from_signed_8" >>boxer
"to_signed_8" >>unboxer
\ longlong define-primitive-type
@ -354,8 +365,8 @@ SYMBOLS:
[ alien-unsigned-8 ] >>getter
[ set-alien-unsigned-8 ] >>setter
8 >>size
cpu x86.32? os windows? not and 4 8 ? >>align
"box_unsigned_8" >>boxer
8-byte-alignment
"from_unsigned_8" >>boxer
"to_unsigned_8" >>unboxer
\ ulonglong define-primitive-type
@ -366,7 +377,8 @@ SYMBOLS:
[ set-alien-signed-cell ] >>setter
bootstrap-cell >>size
bootstrap-cell >>align
"box_signed_cell" >>boxer
bootstrap-cell >>align-first
"from_signed_cell" >>boxer
"to_fixnum" >>unboxer
\ long define-primitive-type
@ -377,7 +389,8 @@ SYMBOLS:
[ set-alien-unsigned-cell ] >>setter
bootstrap-cell >>size
bootstrap-cell >>align
"box_unsigned_cell" >>boxer
bootstrap-cell >>align-first
"from_unsigned_cell" >>boxer
"to_cell" >>unboxer
\ ulong define-primitive-type
@ -388,7 +401,8 @@ SYMBOLS:
[ set-alien-signed-4 ] >>setter
4 >>size
4 >>align
"box_signed_4" >>boxer
4 >>align-first
"from_signed_4" >>boxer
"to_fixnum" >>unboxer
\ int define-primitive-type
@ -399,7 +413,8 @@ SYMBOLS:
[ set-alien-unsigned-4 ] >>setter
4 >>size
4 >>align
"box_unsigned_4" >>boxer
4 >>align-first
"from_unsigned_4" >>boxer
"to_cell" >>unboxer
\ uint define-primitive-type
@ -410,7 +425,8 @@ SYMBOLS:
[ set-alien-signed-2 ] >>setter
2 >>size
2 >>align
"box_signed_2" >>boxer
2 >>align-first
"from_signed_2" >>boxer
"to_fixnum" >>unboxer
\ short define-primitive-type
@ -421,7 +437,8 @@ SYMBOLS:
[ set-alien-unsigned-2 ] >>setter
2 >>size
2 >>align
"box_unsigned_2" >>boxer
2 >>align-first
"from_unsigned_2" >>boxer
"to_cell" >>unboxer
\ ushort define-primitive-type
@ -432,7 +449,8 @@ SYMBOLS:
[ set-alien-signed-1 ] >>setter
1 >>size
1 >>align
"box_signed_1" >>boxer
1 >>align-first
"from_signed_1" >>boxer
"to_fixnum" >>unboxer
\ char define-primitive-type
@ -443,7 +461,8 @@ SYMBOLS:
[ set-alien-unsigned-1 ] >>setter
1 >>size
1 >>align
"box_unsigned_1" >>boxer
1 >>align-first
"from_unsigned_1" >>boxer
"to_cell" >>unboxer
\ uchar define-primitive-type
@ -453,7 +472,8 @@ SYMBOLS:
[ [ >c-bool ] 2dip set-alien-unsigned-4 ] >>setter
4 >>size
4 >>align
"box_boolean" >>boxer
4 >>align-first
"from_boolean" >>boxer
"to_boolean" >>unboxer
] [
<c-type>
@ -461,10 +481,11 @@ SYMBOLS:
[ [ >c-bool ] 2dip set-alien-unsigned-1 ] >>setter
1 >>size
1 >>align
"box_boolean" >>boxer
1 >>align-first
"from_boolean" >>boxer
"to_boolean" >>unboxer
\ bool define-primitive-type
] if
\ bool define-primitive-type
<c-type>
math:float >>class
@ -473,7 +494,8 @@ SYMBOLS:
[ [ >float ] 2dip set-alien-float ] >>setter
4 >>size
4 >>align
"box_float" >>boxer
4 >>align-first
"from_float" >>boxer
"to_float" >>unboxer
float-rep >>rep
[ >float ] >>unboxer-quot
@ -485,8 +507,8 @@ SYMBOLS:
[ alien-double ] >>getter
[ [ >float ] 2dip set-alien-double ] >>setter
8 >>size
cpu x86.32? os windows? not and 4 8 ? >>align
"box_double" >>boxer
8-byte-alignment
"from_double" >>boxer
"to_double" >>unboxer
double-rep >>rep
[ >float ] >>unboxer-quot
@ -516,6 +538,9 @@ M: ulonglong-2-rep rep-component-type drop ulonglong ;
M: float-4-rep rep-component-type drop float ;
M: double-2-rep rep-component-type drop double ;
: rep-length ( rep -- n )
16 swap rep-component-type heap-size /i ; foldable
: (unsigned-interval) ( bytes -- from to ) [ 0 ] dip 8 * 2^ 1 - ; foldable
: unsigned-interval ( c-type -- from to ) heap-size (unsigned-interval) ; foldable
: (signed-interval) ( bytes -- from to ) 8 * 1 - 2^ [ neg ] [ 1 - ] bi ; foldable
@ -528,4 +553,6 @@ M: double-2-rep rep-component-type drop double ;
{ [ dup { uchar ushort uint ulong ulonglong } member-eq? ] [ unsigned-interval ] }
} cond ; foldable
: c-type-clamp ( value c-type -- value' ) c-type-interval clamp ; inline
: c-type-clamp ( value c-type -- value' )
dup { float double } member-eq?
[ drop ] [ c-type-interval clamp ] if ; inline

0
basis/alien/destructors/destructors.factor Executable file → Normal file
View File

0
basis/alien/libraries/libraries-docs.factor Executable file → Normal file
View File

0
basis/alien/libraries/libraries.factor Executable file → Normal file
View File

6
basis/alien/remote-control/remote-control.factor
View File

@ -19,8 +19,8 @@ IN: alien.remote-control
dup optimized? [ execute ] [ drop f ] if ; inline
: init-remote-control ( -- )
\ eval-callback ?callback 16 setenv
\ yield-callback ?callback 17 setenv
\ sleep-callback ?callback 18 setenv ;
\ eval-callback ?callback 16 set-special-object
\ yield-callback ?callback 17 set-special-object
\ sleep-callback ?callback 18 set-special-object ;
MAIN: init-remote-control

5
basis/base64/base64.factor
View File

@ -13,7 +13,8 @@ ERROR: malformed-base64 ;
read1 2dup swap member? [ drop read1-ignoring ] [ nip ] if ;
: read-ignoring ( ignoring n -- str )
[ drop read1-ignoring ] with map harvest
[ drop read1-ignoring ] with { } map-integers
[ { f 0 } member? not ] filter
[ f ] [ >string ] if-empty ;
: ch>base64 ( ch -- ch )
@ -42,7 +43,7 @@ SYMBOL: column
[ write1-lines ] each ;
: encode3 ( seq -- )
be> 4 <reversed> [
be> 4 iota <reversed> [
-6 * shift HEX: 3f bitand ch>base64 write1-lines
] with each ; inline

4
basis/binary-search/binary-search-tests.factor
View File

@ -1,4 +1,4 @@
USING: binary-search math.order vectors kernel tools.test ;
USING: binary-search math.order sequences kernel tools.test ;
IN: binary-search.tests
[ f ] [ 3 { } [ <=> ] with search drop ] unit-test
@ -7,7 +7,7 @@ IN: binary-search.tests
[ 3 ] [ 4 { 1 2 3 4 5 6 } [ <=> ] with search drop ] unit-test
[ 2 ] [ 3.5 { 1 2 3 4 5 6 7 8 } [ <=> ] with search drop ] unit-test
[ 4 ] [ 5.5 { 1 2 3 4 5 6 7 8 } [ <=> ] with search drop ] unit-test
[ 10 ] [ 10 20 >vector [ <=> ] with search drop ] unit-test
[ 10 ] [ 10 20 iota [ <=> ] with search drop ] unit-test
[ t ] [ "hello" { "alligator" "cat" "fish" "hello" "ikarus" "java" } sorted-member? ] unit-test
[ 3 ] [ "hey" { "alligator" "cat" "fish" "hello" "ikarus" "java" } sorted-index ] unit-test

2
basis/bit-arrays/bit-arrays-tests.factor
View File

@ -40,7 +40,7 @@ IN: bit-arrays.tests
100 [
drop 100 [ 2 random zero? ] replicate
dup >bit-array >array =
] all?
] all-integers?
] unit-test
[ ?{ f } ] [

6
basis/bit-arrays/bit-arrays.factor
View File

@ -1,4 +1,4 @@
! Copyright (C) 2007, 2008 Slava Pestov.
! Copyright (C) 2007, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: alien.c-types alien.data accessors math alien.accessors kernel
kernel.private sequences sequences.private byte-arrays
@ -25,7 +25,7 @@ TUPLE: bit-array
: (set-bits) ( bit-array n -- )
[ [ length bits>cells ] keep ] dip swap underlying>>
'[ 2 shift [ _ _ ] dip set-alien-unsigned-4 ] each ; inline
'[ 2 shift [ _ _ ] dip set-alien-unsigned-4 ] each-integer ; inline
: clean-up ( bit-array -- )
! Zero bits after the end.
@ -99,7 +99,7 @@ SYNTAX: ?{ \ } [ >bit-array ] parse-literal ;
] if ;
: bit-array>integer ( bit-array -- n )
0 swap underlying>> dup length <reversed> [
0 swap underlying>> dup length iota <reversed> [
alien-unsigned-1 swap 8 shift bitor
] with each ;

2
basis/bit-vectors/bit-vectors-tests.factor
View File

@ -4,7 +4,7 @@ IN: bit-vectors.tests
[ 0 ] [ 123 <bit-vector> length ] unit-test
: do-it ( seq -- )
1234 swap [ [ even? ] dip push ] curry each ;
1234 swap [ [ even? ] dip push ] curry each-integer ;
[ t ] [
3 <bit-vector> dup do-it

3
basis/bootstrap/bootstrap-error.factor
View File

@ -2,7 +2,8 @@ USING: continuations kernel io debugger vocabs words system namespaces ;
:c
:error
"listener" vocab
[ restarts. vocab-main execute ]
[ die ] if*
[ error get die ] if*
1 exit

2
basis/bootstrap/compiler/compiler.factor Executable file → Normal file
View File

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

4
basis/bootstrap/finish-bootstrap.factor
View File

@ -3,7 +3,7 @@ namespaces eval kernel vocabs.loader io ;
[
boot
do-init-hooks
do-startup-hooks
[
(command-line) parse-command-line
load-vocab-roots
@ -14,4 +14,4 @@ namespaces eval kernel vocabs.loader io ;
output-stream get [ stream-flush ] when*
0 exit
] [ print-error 1 exit ] recover
] set-boot-quot
] set-startup-quot

7
basis/bootstrap/finish-staging.factor
View File

@ -1,11 +1,10 @@
USING: init command-line system namespaces kernel vocabs.loader
io ;
USING: init command-line system namespaces kernel vocabs.loader io ;
[
boot
do-init-hooks
do-startup-hooks
(command-line) parse-command-line
"run" get run
output-stream get [ stream-flush ] when*
0 exit
] set-boot-quot
] set-startup-quot

169
basis/bootstrap/image/image.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2004, 2009 Slava Pestov.
! Copyright (C) 2004, 2010 Slava Pestov.
! 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 io.binary io.files io.encodings.binary
io.pathnames kernel kernel.private math namespaces make parser
prettyprint sequences strings sbufs vectors words quotations
@ -10,7 +10,7 @@ vocabs.loader source-files definitions debugger
quotations.private combinators combinators.short-circuit
math.order math.private accessors slots.private
generic.single.private compiler.units compiler.constants fry
bootstrap.image.syntax ;
locals bootstrap.image.syntax generalizations ;
IN: bootstrap.image
: arch ( os cpu -- arch )
@ -71,6 +71,9 @@ C: <eq-wrapper> eq-wrapper
M: eq-wrapper equal?
over eq-wrapper? [ [ obj>> ] bi@ eq? ] [ 2drop f ] if ;
M: eq-wrapper hashcode*
nip obj>> identity-hashcode ;
SYMBOL: objects
: cache-eql-object ( obj quot -- value )
@ -90,7 +93,7 @@ CONSTANT: image-version 4
CONSTANT: data-base 1024
CONSTANT: userenv-size 70
CONSTANT: special-objects-size 70
CONSTANT: header-size 10
@ -104,31 +107,62 @@ SYMBOL: sub-primitives
SYMBOL: jit-relocations
: compute-offset ( rc -- offset )
[ building get length ] dip rc-absolute-cell = bootstrap-cell 4 ? - ;
SYMBOL: jit-offset
: compute-offset ( -- offset )
building get length jit-offset get + ;
: jit-rel ( rc rt -- )
over compute-offset 3array jit-relocations get push-all ;
compute-offset 3array jit-relocations get push-all ;
SYMBOL: jit-parameters
: jit-parameter ( parameter -- )
jit-parameters get push ;
SYMBOL: jit-literals
: jit-literal ( literal -- )
jit-literals get push ;
: make-jit ( quot -- jit-literals jit-data )
: jit-vm ( offset rc -- )
[ jit-parameter ] dip rt-vm jit-rel ;
: jit-dlsym ( name library rc -- )
rt-dlsym jit-rel [ string>symbol jit-parameter ] bi@ ;
:: jit-conditional ( test-quot false-quot -- )
[ 0 test-quot call ] B{ } make length :> len
building get length jit-offset get + len +
[ jit-offset set false-quot call ] B{ } make
[ length test-quot call ] [ % ] bi ; inline
: make-jit ( quot -- jit-parameters jit-literals jit-code )
[
0 jit-offset set
V{ } clone jit-parameters set
V{ } clone jit-literals set
V{ } clone jit-relocations set
call( -- )
jit-parameters get >array
jit-literals get >array
jit-relocations get >array
] B{ } make prefix ;
: jit-define ( quot name -- )
[ make-jit nip ] dip set ;
[ make-jit 2nip ] dip set ;
: define-sub-primitive ( quot word -- )
[ make-jit 2array ] dip sub-primitives get set-at ;
[ make-jit 3array ] dip sub-primitives get set-at ;
: define-combinator-primitive ( quot non-tail-quot tail-quot word -- )
[
[ make-jit ]
[ make-jit 2nip ]
[ make-jit 2nip ]
tri* 5 narray
] dip
sub-primitives get set-at ;
! The image being constructed; a vector of word-size integers
SYMBOL: image
@ -142,57 +176,58 @@ SYMBOL: architecture
RESET
! Boot quotation, set in stage1.factor
USERENV: bootstrap-boot-quot 20
SPECIAL-OBJECT: bootstrap-startup-quot 20
! Bootstrap global namesapce
USERENV: bootstrap-global 21
SPECIAL-OBJECT: bootstrap-global 21
! JIT parameters
USERENV: jit-prolog 23
USERENV: jit-primitive-word 24
USERENV: jit-primitive 25
USERENV: jit-word-jump 26
USERENV: jit-word-call 27
USERENV: jit-word-special 28
USERENV: jit-if-word 29
USERENV: jit-if 30
USERENV: jit-epilog 31
USERENV: jit-return 32
USERENV: jit-profiling 33
USERENV: jit-push-immediate 34
USERENV: jit-dip-word 35
USERENV: jit-dip 36
USERENV: jit-2dip-word 37
USERENV: jit-2dip 38
USERENV: jit-3dip-word 39
USERENV: jit-3dip 40
USERENV: jit-execute-word 41
USERENV: jit-execute-jump 42
USERENV: jit-execute-call 43
USERENV: jit-declare-word 44
SPECIAL-OBJECT: jit-prolog 23
SPECIAL-OBJECT: jit-primitive-word 24
SPECIAL-OBJECT: jit-primitive 25
SPECIAL-OBJECT: jit-word-jump 26
SPECIAL-OBJECT: jit-word-call 27
SPECIAL-OBJECT: jit-if-word 28
SPECIAL-OBJECT: jit-if 29
SPECIAL-OBJECT: jit-epilog 30
SPECIAL-OBJECT: jit-return 31
SPECIAL-OBJECT: jit-profiling 32
SPECIAL-OBJECT: jit-push 33
SPECIAL-OBJECT: jit-dip-word 34
SPECIAL-OBJECT: jit-dip 35
SPECIAL-OBJECT: jit-2dip-word 36
SPECIAL-OBJECT: jit-2dip 37
SPECIAL-OBJECT: jit-3dip-word 38
SPECIAL-OBJECT: jit-3dip 39
SPECIAL-OBJECT: jit-execute 40
SPECIAL-OBJECT: jit-declare-word 41
USERENV: callback-stub 45
SPECIAL-OBJECT: c-to-factor-word 42
SPECIAL-OBJECT: lazy-jit-compile-word 43
SPECIAL-OBJECT: unwind-native-frames-word 44
SPECIAL-OBJECT: callback-stub 48
! PIC stubs
USERENV: pic-load 47
USERENV: pic-tag 48
USERENV: pic-tuple 49
USERENV: pic-check-tag 50
USERENV: pic-check-tuple 51
USERENV: pic-hit 52
USERENV: pic-miss-word 53
USERENV: pic-miss-tail-word 54
SPECIAL-OBJECT: pic-load 49
SPECIAL-OBJECT: pic-tag 50
SPECIAL-OBJECT: pic-tuple 51
SPECIAL-OBJECT: pic-check-tag 52
SPECIAL-OBJECT: pic-check-tuple 53
SPECIAL-OBJECT: pic-hit 54
SPECIAL-OBJECT: pic-miss-word 55
SPECIAL-OBJECT: pic-miss-tail-word 56
! Megamorphic dispatch
USERENV: mega-lookup 57
USERENV: mega-lookup-word 58
USERENV: mega-miss-word 59
SPECIAL-OBJECT: mega-lookup 57
SPECIAL-OBJECT: mega-lookup-word 58
SPECIAL-OBJECT: mega-miss-word 59
! Default definition for undefined words
USERENV: undefined-quot 60
SPECIAL-OBJECT: undefined-quot 60
: userenv-offset ( symbol -- n )
userenvs get at header-size + ;
: special-object-offset ( symbol -- n )
special-objects get at header-size + ;
: emit ( cell -- ) image get push ;
@ -208,7 +243,7 @@ USERENV: undefined-quot 60
: fixup ( value offset -- ) image get set-nth ;
: heap-size ( -- size )
image get length header-size - userenv-size -
image get length header-size - special-objects-size -
bootstrap-cells ;
: here ( -- size ) heap-size data-base + ;
@ -224,9 +259,11 @@ USERENV: undefined-quot 60
: emit-fixnum ( n -- ) tag-fixnum emit ;
: emit-header ( n -- ) tag-header emit ;
: emit-object ( class quot -- addr )
[ type-number ] dip over here-as
[ swap tag-fixnum emit call align-here ] dip ;
[ swap emit-header call align-here ] dip ;
inline
! Write an object to the image.
@ -234,7 +271,7 @@ GENERIC: ' ( obj -- ptr )
! Image header
: emit-header ( -- )
: emit-image-header ( -- )
image-magic emit
image-version emit
data-base emit ! relocation base at end of header
@ -245,10 +282,10 @@ GENERIC: ' ( obj -- ptr )
0 emit ! pointer to bignum 0
0 emit ! pointer to bignum 1
0 emit ! pointer to bignum -1
userenv-size [ f ' emit ] times ;
special-objects-size [ f ' emit ] times ;
: emit-userenv ( symbol -- )
[ get ' ] [ userenv-offset ] bi fixup ;
: emit-special-object ( symbol -- )
[ get ' ] [ special-object-offset ] bi fixup ;
! Bignums
@ -501,16 +538,18 @@ M: quotation '
\ dip jit-dip-word set
\ 2dip jit-2dip-word set
\ 3dip jit-3dip-word set
\ (execute) jit-execute-word set
\ inline-cache-miss \ pic-miss-word set
\ inline-cache-miss-tail \ pic-miss-tail-word set
\ mega-cache-lookup \ mega-lookup-word set
\ mega-cache-miss \ mega-miss-word set
\ inline-cache-miss pic-miss-word set
\ inline-cache-miss-tail pic-miss-tail-word set
\ mega-cache-lookup mega-lookup-word set
\ mega-cache-miss mega-miss-word set
\ declare jit-declare-word set
\ c-to-factor c-to-factor-word set
\ lazy-jit-compile lazy-jit-compile-word set
\ unwind-native-frames unwind-native-frames-word set
[ undefined ] undefined-quot set ;
: emit-userenvs ( -- )
userenvs get keys [ emit-userenv ] each ;
: emit-special-objects ( -- )
special-objects get keys [ emit-special-object ] each ;
: fixup-header ( -- )
heap-size data-heap-size-offset fixup ;
@ -518,7 +557,7 @@ M: quotation '
: build-image ( -- image )
800000 <vector> image set
20000 <hashtable> objects set
emit-header t, 0, 1, -1,
emit-image-header t, 0, 1, -1,
"Building generic words..." print flush
remake-generics
"Serializing words..." print flush
@ -527,8 +566,8 @@ M: quotation '
emit-jit-data
"Serializing global namespace..." print flush
emit-global
"Serializing user environment..." print flush
emit-userenvs
"Serializing special object table..." print flush
emit-special-objects
"Performing word fixups..." print flush
fixup-words
"Performing header fixups..." print flush

10
basis/bootstrap/image/syntax/syntax.factor
View File

@ -1,14 +1,14 @@
! Copyright (C) 2009 Slava Pestov.
! Copyright (C) 2009, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: parser kernel namespaces assocs words.symbol ;
IN: bootstrap.image.syntax
SYMBOL: userenvs
SYMBOL: special-objects
SYNTAX: RESET H{ } clone userenvs set-global ;
SYNTAX: RESET H{ } clone special-objects set-global ;
SYNTAX: USERENV:
SYNTAX: SPECIAL-OBJECT:
CREATE-WORD scan-word
[ swap userenvs get set-at ]
[ swap special-objects get set-at ]
[ drop define-symbol ]
2bi ;

11
basis/bootstrap/stage2.factor
View File

@ -35,8 +35,8 @@ SYMBOL: bootstrap-time
: count-words ( pred -- )
all-words swap count number>string write ; inline
: print-time ( ms -- )
1000 /i
: print-time ( us -- )
1,000,000,000 /i
60 /mod swap
number>string write
" minutes and " write number>string write " seconds." print ;
@ -56,9 +56,10 @@ SYMBOL: bootstrap-time
error-continuation set-global
error set-global ; inline
[
! We time bootstrap
millis
nano-count
default-image-name "output-image" set-global
@ -83,14 +84,14 @@ SYMBOL: bootstrap-time
load-components
millis over - core-bootstrap-time set-global
nano-count over - core-bootstrap-time set-global
run-bootstrap-init
f error set-global
f error-continuation set-global
millis swap - bootstrap-time set-global
nano-count swap - bootstrap-time set-global
print-report
"deploy-vocab" get [

0
basis/bootstrap/ui/ui.factor Executable file → Normal file
View File

2
basis/cairo/cairo.factor Executable file → Normal file
View File

@ -16,7 +16,7 @@ ERROR: cairo-error message ;
: check-surface ( surface -- ) cairo_surface_status (check-cairo) ;
: width>stride ( width -- stride ) "uint" heap-size * ; inline
: width>stride ( width -- stride ) uint heap-size * ; inline
: <image-surface> ( data dim -- surface )
[ CAIRO_FORMAT_ARGB32 ] dip first2 over width>stride

26
basis/calendar/calendar-docs.factor
View File

@ -32,7 +32,7 @@ HELP: month-names
{ $warning "Do not use this array for looking up a month name directly. Use month-name instead." } ;
HELP: month-name
{ $values { "n" integer } { "string" string } }
{ $values { "obj" { $or integer timestamp } } { "string" string } }
{ $description "Looks up the month name and returns it as a string. January has an index of 1 instead of zero." } ;
HELP: month-abbreviations
@ -46,11 +46,11 @@ HELP: month-abbreviation
HELP: day-names
{ $values { "array" array } }
{ $values { "value" array } }
{ $description "Returns an array with the English names of the days of the week." } ;
HELP: day-name
{ $values { "n" integer } { "string" string } }
{ $values { "obj" { $or integer timestamp } } { "string" string } }
{ $description "Looks up the day name and returns it as a string." } ;
HELP: day-abbreviations2
@ -355,7 +355,7 @@ HELP: before
HELP: <zero>
{ $values { "timestamp" timestamp } }
{ $description "Outputs a zero timestamp that consists of zeros for every slot. Used to see if timestamps are valid." } ;
{ $description "Returns a zero timestamp that consists of zeros for every slot. Used to see if timestamps are valid." } ;
HELP: valid-timestamp?
{ $values { "timestamp" timestamp } { "?" "a boolean" } }
@ -363,7 +363,7 @@ HELP: valid-timestamp?
HELP: unix-1970
{ $values { "timestamp" timestamp } }
{ $description "Outputs the beginning of UNIX time, or midnight, January 1, 1970." } ;
{ $description "Returns the beginning of UNIX time, or midnight, January 1, 1970." } ;
HELP: micros>timestamp
{ $values { "x" number } { "timestamp" timestamp } }
@ -377,13 +377,13 @@ HELP: micros>timestamp
HELP: gmt
{ $values { "timestamp" timestamp } }
{ $description "Outputs the time right now, but in the GMT timezone." } ;
{ $description "Returns the time right now, but in the GMT timezone." } ;
{ gmt now } related-words
HELP: now
{ $values { "timestamp" timestamp } }
{ $description "Outputs the time right now in your computer's timezone." }
{ $description "Returns the time right now in your computer's timezone." }
{ $examples
{ $unchecked-example "USING: calendar prettyprint ;"
"now ."
@ -490,23 +490,23 @@ HELP: saturday
HELP: midnight
{ $values { "timestamp" timestamp } { "new-timestamp" timestamp } }
{ $description "Returns a timestamp that represents today at midnight, or the beginning of the day." } ;
{ $description "Returns a new timestamp that represents today at midnight, or the beginning of the day." } ;
HELP: noon
{ $values { "timestamp" timestamp } { "new-timestamp" timestamp } }
{ $description "Returns a timestamp that represents today at noon, or the middle of the day." } ;
{ $description "Returns a new timestamp that represents today at noon, or the middle of the day." } ;
HELP: beginning-of-month
{ $values { "timestamp" timestamp } { "new-timestamp" timestamp } }
{ $description "Outputs a timestamp with the day set to one." } ;
{ $description "Returns a new timestamp with the day set to one." } ;
HELP: beginning-of-week
{ $values { "timestamp" timestamp } { "new-timestamp" timestamp } }
{ $description "Outputs a timestamp where the day of the week is Sunday." } ;
{ $description "Returns a new timestamp where the day of the week is Sunday." } ;
HELP: beginning-of-year
{ $values { "timestamp" timestamp } { "new-timestamp" timestamp } }
{ $description "Outputs a timestamp with the month and day set to one, or January 1 of the input timestamp." } ;
{ $values { "object" object } { "new-timestamp" timestamp } }
{ $description "Returns a new timestamp with the month and day set to one, or January 1 of the input timestamp, given a year or a timestamp." } ;
HELP: time-since-midnight
{ $values { "timestamp" timestamp } { "duration" duration } }

10
basis/calendar/calendar-tests.factor
View File

@ -1,5 +1,6 @@
USING: arrays calendar kernel math sequences tools.test
continuations system math.order threads accessors ;
continuations system math.order threads accessors
random ;
IN: calendar.tests
[ f ] [ 2004 12 32 0 0 0 instant <timestamp> valid-timestamp? ] unit-test
@ -139,7 +140,7 @@ IN: calendar.tests
[ +gt+ ] [ 2005 1 1 12 30 0 instant <timestamp>
2004 1 1 13 30 0 instant <timestamp> <=> ] unit-test
[ t ] [ now timestamp>micros micros - 1000000 < ] unit-test
[ t ] [ now timestamp>micros system-micros - 1000000 < ] unit-test
[ t ] [ 0 micros>timestamp unix-1970 = ] unit-test
[ t ] [ 123456789000000 [ micros>timestamp timestamp>micros ] keep = ] unit-test
[ t ] [ 123456789123456000 [ micros>timestamp timestamp>micros ] keep = ] unit-test
@ -170,3 +171,8 @@ IN: calendar.tests
[ f ] [ now dup midnight eq? ] unit-test
[ f ] [ now dup easter eq? ] unit-test
[ f ] [ now dup beginning-of-year eq? ] unit-test
[ t ] [ 1325376000 unix-time>timestamp 2012 <year-gmt> = ] unit-test
[ t ] [ 1356998399 unix-time>timestamp 2013 <year-gmt> 1 seconds time- = ] unit-test
[ t ] [ 1500000000 random [ unix-time>timestamp timestamp>unix-time ] keep = ] unit-test

182
basis/calendar/calendar.factor
View File

@ -17,6 +17,8 @@ TUPLE: duration
C: <duration> duration
: instant ( -- duration ) 0 0 0 0 0 0 <duration> ;
TUPLE: timestamp
{ year integer }
{ month integer }
@ -34,6 +36,15 @@ C: <timestamp> timestamp
: <date> ( year month day -- timestamp )
0 0 0 gmt-offset-duration <timestamp> ;
: <date-gmt> ( year month day -- timestamp )
0 0 0 instant <timestamp> ;
: <year> ( year -- timestamp )
1 1 <date> ;
: <year-gmt> ( year -- timestamp )
1 1 <date-gmt> ;
ERROR: not-a-month ;
M: not-a-month summary
drop "Months are indexed starting at 1" ;
@ -51,8 +62,16 @@ CONSTANT: month-names
"July" "August" "September" "October" "November" "December"
}
: month-name ( n -- string )
check-month 1 - month-names nth ;
<PRIVATE
: (month-name) ( n -- string ) 1 - month-names nth ;
PRIVATE>
GENERIC: month-name ( obj -- string )
M: integer month-name check-month 1 - month-names nth ;
M: timestamp month-name month>> 1 - month-names nth ;
CONSTANT: month-abbreviations
{
@ -65,12 +84,8 @@ CONSTANT: month-abbreviations
CONSTANT: day-counts { 0 31 28 31 30 31 30 31 31 30 31 30 31 }
: day-names ( -- array )
{
"Sunday" "Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday"
} ;
: day-name ( n -- string ) day-names nth ;
CONSTANT: day-names
{ "Sunday" "Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday" }
CONSTANT: day-abbreviations2
{ "Su" "Mo" "Tu" "We" "Th" "Fr" "Sa" }
@ -128,8 +143,7 @@ GENERIC: easter ( obj -- obj' )
32 2 e * + 2 i * + h - k - 7 mod :> l
a 11 h * + 22 l * + 451 /i :> m
h l + 7 m * - 114 + 31 /mod 1 + :> ( month day )
month day ;
h l + 7 m * - 114 + 31 /mod 1 + ;
M: integer easter ( year -- timestamp )
dup easter-month-day <date> ;
@ -145,7 +159,6 @@ M: timestamp easter ( timestamp -- timestamp )
: >time< ( timestamp -- hour minute second )
[ hour>> ] [ minute>> ] [ second>> ] tri ;
: instant ( -- duration ) 0 0 0 0 0 0 <duration> ;
: years ( x -- duration ) instant clone swap >>year ;
: months ( x -- duration ) instant clone swap >>month ;
: days ( x -- duration ) instant clone swap >>day ;
@ -157,6 +170,18 @@ M: timestamp easter ( timestamp -- timestamp )
: microseconds ( x -- duration ) 1000000 / seconds ;
: nanoseconds ( x -- duration ) 1000000000 / seconds ;
GENERIC: year ( obj -- n )
M: integer year ;
M: timestamp year year>> ;
GENERIC: month ( obj -- n )
M: integer month ;
M: timestamp month month>> ;
GENERIC: day ( obj -- n )
M: integer day ;
M: timestamp day day>> ;
GENERIC: leap-year? ( obj -- ? )
M: integer leap-year? ( year -- ? )
@ -305,6 +330,9 @@ GENERIC: time- ( time1 time2 -- time3 )
M: timestamp <=> ( ts1 ts2 -- n )
[ >gmt tuple-slots ] compare ;
: same-day? ( ts1 ts2 -- ? )
[ >gmt >date< <date> ] bi@ = ;
: (time-) ( timestamp timestamp -- n )
[ >gmt ] bi@
[ [ >date< julian-day-number ] bi@ - 86400 * ] 2keep
@ -357,7 +385,7 @@ M: duration time-
: gmt ( -- timestamp )
#! GMT time, right now
unix-1970 micros microseconds time+ ;
unix-1970 system-micros microseconds time+ ;
: now ( -- timestamp ) gmt >local-time ;
: hence ( duration -- timestamp ) now swap time+ ;
@ -387,6 +415,10 @@ M: timestamp days-in-year ( timestamp -- n ) year>> days-in-year ;
: day-of-week ( timestamp -- n )
>date< zeller-congruence ;
GENERIC: day-name ( obj -- string )
M: integer day-name day-names nth ;
M: timestamp day-name day-of-week day-names nth ;
:: (day-of-year) ( year month day -- n )
day-counts month head-slice sum day +
year leap-year? [
@ -398,22 +430,6 @@ M: timestamp days-in-year ( timestamp -- n ) year>> days-in-year ;
: day-of-year ( timestamp -- n )
>date< (day-of-year) ;
<PRIVATE
: day-offset ( timestamp m -- timestamp n )
over day-of-week - ; inline
: day-this-week ( timestamp n -- timestamp )
day-offset days time+ ;
PRIVATE>
: sunday ( timestamp -- new-timestamp ) 0 day-this-week ;
: monday ( timestamp -- new-timestamp ) 1 day-this-week ;
: tuesday ( timestamp -- new-timestamp ) 2 day-this-week ;
: wednesday ( timestamp -- new-timestamp ) 3 day-this-week ;
: thursday ( timestamp -- new-timestamp ) 4 day-this-week ;
: friday ( timestamp -- new-timestamp ) 5 day-this-week ;
: saturday ( timestamp -- new-timestamp ) 6 day-this-week ;
: midnight ( timestamp -- new-timestamp )
clone 0 >>hour 0 >>minute 0 >>second ; inline
@ -423,11 +439,108 @@ PRIVATE>
: beginning-of-month ( timestamp -- new-timestamp )
midnight 1 >>day ;
: end-of-month ( timestamp -- new-timestamp )
[ midnight ] [ days-in-month ] bi >>day ;
<PRIVATE
: day-offset ( timestamp m -- new-timestamp n )
over day-of-week - ; inline
: day-this-week ( timestamp n -- new-timestamp )
day-offset days time+ ;
:: nth-day-this-month ( timestamp n day -- new-timestamp )
timestamp beginning-of-month day day-this-week
dup timestamp [ month>> ] bi@ = [ 1 weeks time+ ] unless
n 1 - [ weeks time+ ] unless-zero ;
: last-day-this-month ( timestamp day -- new-timestamp )
[ 1 months time+ 1 ] dip nth-day-this-month 1 weeks time- ;
PRIVATE>
GENERIC: january ( obj -- timestamp )
GENERIC: february ( obj -- timestamp )
GENERIC: march ( obj -- timestamp )
GENERIC: april ( obj -- timestamp )
GENERIC: may ( obj -- timestamp )
GENERIC: june ( obj -- timestamp )
GENERIC: july ( obj -- timestamp )
GENERIC: august ( obj -- timestamp )
GENERIC: september ( obj -- timestamp )
GENERIC: october ( obj -- timestamp )
GENERIC: november ( obj -- timestamp )
GENERIC: december ( obj -- timestamp )
M: integer january 1 1 <date> ;
M: integer february 2 1 <date> ;
M: integer march 3 1 <date> ;
M: integer april 4 1 <date> ;
M: integer may 5 1 <date> ;
M: integer june 6 1 <date> ;
M: integer july 7 1 <date> ;
M: integer august 8 1 <date> ;
M: integer september 9 1 <date> ;
M: integer october 10 1 <date> ;
M: integer november 11 1 <date> ;
M: integer december 12 1 <date> ;
M: timestamp january clone 1 >>month ;
M: timestamp february clone 2 >>month ;
M: timestamp march clone 3 >>month ;
M: timestamp april clone 4 >>month ;
M: timestamp may clone 5 >>month ;
M: timestamp june clone 6 >>month ;
M: timestamp july clone 7 >>month ;
M: timestamp august clone 8 >>month ;
M: timestamp september clone 9 >>month ;
M: timestamp october clone 10 >>month ;
M: timestamp november clone 11 >>month ;
M: timestamp december clone 12 >>month ;
: sunday ( timestamp -- new-timestamp ) 0 day-this-week ;
: monday ( timestamp -- new-timestamp ) 1 day-this-week ;
: tuesday ( timestamp -- new-timestamp ) 2 day-this-week ;
: wednesday ( timestamp -- new-timestamp ) 3 day-this-week ;
: thursday ( timestamp -- new-timestamp ) 4 day-this-week ;
: friday ( timestamp -- new-timestamp ) 5 day-this-week ;
: saturday ( timestamp -- new-timestamp ) 6 day-this-week ;
: sunday? ( timestamp -- ? ) day-of-week 0 = ;
: monday? ( timestamp -- ? ) day-of-week 1 = ;
: tuesday? ( timestamp -- ? ) day-of-week 2 = ;
: wednesday? ( timestamp -- ? ) day-of-week 3 = ;
: thursday? ( timestamp -- ? ) day-of-week 4 = ;
: friday? ( timestamp -- ? ) day-of-week 5 = ;
: saturday? ( timestamp -- ? ) day-of-week 6 = ;
: sunday-of-month ( timestamp n -- new-timestamp ) 0 nth-day-this-month ;
: monday-of-month ( timestamp n -- new-timestamp ) 1 nth-day-this-month ;
: tuesday-of-month ( timestamp n -- new-timestamp ) 2 nth-day-this-month ;
: wednesday-of-month ( timestamp n -- new-timestamp ) 3 nth-day-this-month ;
: thursday-of-month ( timestamp n -- new-timestamp ) 4 nth-day-this-month ;
: friday-of-month ( timestamp n -- new-timestamp ) 5 nth-day-this-month ;
: saturday-of-month ( timestamp n -- new-timestamp ) 6 nth-day-this-month ;
: last-sunday-of-month ( timestamp -- new-timestamp ) 0 last-day-this-month ;
: last-monday-of-month ( timestamp -- new-timestamp ) 1 last-day-this-month ;
: last-tuesday-of-month ( timestamp -- new-timestamp ) 2 last-day-this-month ;
: last-wednesday-of-month ( timestamp -- new-timestamp ) 3 last-day-this-month ;
: last-thursday-of-month ( timestamp -- new-timestamp ) 4 last-day-this-month ;
: last-friday-of-month ( timestamp -- new-timestamp ) 5 last-day-this-month ;
: last-saturday-of-month ( timestamp -- new-timestamp ) 6 last-day-this-month ;
: beginning-of-week ( timestamp -- new-timestamp )
midnight sunday ;
: beginning-of-year ( timestamp -- new-timestamp )
beginning-of-month 1 >>month ;
GENERIC: beginning-of-year ( object -- new-timestamp )
M: timestamp beginning-of-year beginning-of-month 1 >>month ;
M: integer beginning-of-year <year> ;
GENERIC: end-of-year ( object -- new-timestamp )
M: timestamp end-of-year 12 >>month 31 >>day ;
M: integer end-of-year 12 31 <date> ;
: time-since-midnight ( timestamp -- duration )
dup midnight time- ;
@ -435,9 +548,14 @@ PRIVATE>
: since-1970 ( duration -- timestamp )
unix-1970 time+ >local-time ;
M: timestamp sleep-until timestamp>micros sleep-until ;
: timestamp>unix-time ( timestamp -- seconds )
unix-1970 time- second>> ;
M: duration sleep hence sleep-until ;
: unix-time>timestamp ( seconds -- timestamp )
seconds unix-1970 time+ ;
M: duration sleep
duration>nanoseconds >integer nano-count + sleep-until ;
{
{ [ os unix? ] [ "calendar.unix" ] }

6
basis/calendar/format/format.factor
View File

@ -1,4 +1,4 @@
! Copyright (C) 2008 Slava Pestov.
! Copyright (C) 2008, 2010 Slava Pestov, Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: math math.order math.parser math.functions kernel
sequences io accessors arrays io.streams.string splitting
@ -70,7 +70,7 @@ M: array month. ( pair -- )
[
[ 1 + day. ] keep
1 + + 7 mod zero? [ nl ] [ bl ] if
] with each nl ;
] with each-integer nl ;
M: timestamp month. ( timestamp -- )
[ year>> ] [ month>> ] bi 2array month. ;
@ -78,7 +78,7 @@ M: timestamp month. ( timestamp -- )
GENERIC: year. ( obj -- )
M: integer year. ( n -- )
12 [ 1 + 2array month. nl ] with each ;
12 [ 1 + 2array month. nl ] with each-integer ;
M: timestamp year. ( timestamp -- )
year>> year. ;

2
basis/calendar/model/model.factor
View File

@ -16,4 +16,4 @@ SYMBOL: time
] "Time model update" spawn drop ;
f <model> time set-global
[ time-thread ] "calendar.model" add-init-hook
[ time-thread ] "calendar.model" add-startup-hook

3
basis/calendar/unix/unix.factor
View File

@ -14,6 +14,9 @@ IN: calendar.unix
: timespec>seconds ( timespec -- seconds )
[ sec>> seconds ] [ nsec>> nanoseconds ] bi time+ ;
: timespec>nanoseconds ( timespec -- seconds )
[ sec>> 1000000000 * ] [ nsec>> ] bi + ;
: timespec>unix-time ( timespec -- timestamp )
timespec>seconds since-1970 ;

2
basis/channels/remote/remote.factor
View File

@ -69,4 +69,4 @@ M: remote-channel from ( remote-channel -- value )
[
H{ } clone \ remote-channels set-global
start-channel-node
] "channel-registry" add-init-hook
] "channel-registry" add-startup-hook

0
basis/checksums/hmac/hmac-tests.factor Executable file → Normal file
View File

0
basis/checksums/hmac/hmac.factor Executable file → Normal file
View File

4
basis/checksums/sha/sha.factor
View File

@ -301,7 +301,7 @@ GENERIC: pad-initial-bytes ( string sha2 -- padded-string )
M cloned-H sha2 T1-256
cloned-H T2-256
cloned-H update-H
] each
] each-integer
sha2 [ cloned-H [ w+ ] 2map ] change-H drop ; inline
M: sha2-short checksum-block
@ -391,7 +391,7 @@ M: sha-256 checksum-stream ( stream checksum -- byte-array )
b H nth-unsafe 30 bitroll-32 c H set-nth-unsafe
a H nth-unsafe b H set-nth-unsafe
a H set-nth-unsafe
] each
] each-integer
state [ H [ w+ ] 2map ] change-H drop ; inline
M:: sha1-state checksum-block ( bytes state -- )

21
basis/circular/circular-docs.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: help.markup help.syntax io.streams.string sequences
math kernel ;
math kernel quotations ;
IN: circular
HELP: <circular-string>
@ -33,12 +33,12 @@ HELP: circular
HELP: growing-circular
{ $description "A circular sequence that is growable." } ;
HELP: push-circular
HELP: circular-push
{ $values
{ "elt" object } { "circular" circular } }
{ $description "Pushes an element to a " { $link circular } " object." } ;
HELP: push-growing-circular
HELP: growing-circular-push
{ $values
{ "elt" object } { "circular" circular } }
{ $description "Pushes an element onto a " { $link growing-circular } " object." } ;
@ -48,6 +48,13 @@ HELP: rotate-circular
{ "circular" circular } }
{ $description "Advances the start index of a circular object by one." } ;
HELP: circular-while
{ $values
{ "circular" circular }
{ "quot" quotation }
}
{ $description "Calls " { $snippet "quot" } " on each element of the sequence until each call yields " { $link f } " in succession." } ;
ARTICLE: "circular" "Circular sequences"
"The " { $vocab-link "circular" } " vocabulary implements the " { $link "sequence-protocol" } " to allow an arbitrary start index and wrap-around indexing." $nl
"Creating a new circular object:"
@ -63,8 +70,10 @@ ARTICLE: "circular" "Circular sequences"
}
"Pushing new elements:"
{ $subsections
push-circular
push-growing-circular
} ;
circular-push
growing-circular-push
}
"Iterating over a circular until a stop condition:"
{ $subsections circular-while } ;
ABOUT: "circular"

8
basis/circular/circular-tests.factor
View File

@ -23,7 +23,7 @@ IN: circular.tests
[ "boo" ] [ "foo" <circular> CHAR: b 3 pick set-nth-unsafe >string ] unit-test
[ "ornact" ] [ "factor" <circular> 4 over change-circular-start CHAR: n 2 pick set-nth >string ] unit-test
[ "bcd" ] [ 3 <circular-string> "abcd" [ over push-circular ] each >string ] unit-test
[ "bcd" ] [ 3 <circular-string> "abcd" [ over circular-push ] each >string ] unit-test
[ { 0 0 } ] [ { 0 0 } <circular> -1 over change-circular-start >array ] unit-test
@ -34,11 +34,11 @@ IN: circular.tests
[ { } ] [ 3 <growing-circular> >array ] unit-test
[ { 1 2 } ] [
3 <growing-circular>
[ 1 swap push-growing-circular ] keep
[ 2 swap push-growing-circular ] keep >array
[ 1 swap growing-circular-push ] keep
[ 2 swap growing-circular-push ] keep >array
] unit-test
[ { 3 4 5 } ] [
3 <growing-circular> dup { 1 2 3 4 5 } [
swap push-growing-circular
swap growing-circular-push
] with each >array
] unit-test

58
basis/circular/circular.factor
View File

@ -1,57 +1,79 @@
! Copyright (C) 2005, 2006 Alex Chapman, Daniel Ehrenberg
! See http;//factorcode.org/license.txt for BSD license
USING: kernel sequences math sequences.private strings
accessors ;
accessors locals fry ;
IN: circular
! a circular sequence wraps another sequence, but begins at an
! arbitrary element in the underlying sequence.
TUPLE: circular seq start ;
TUPLE: circular { seq read-only } { start integer } ;
: <circular> ( seq -- circular )
0 circular boa ;
0 circular boa ; inline
<PRIVATE
: circular-wrap ( n circular -- n circular )
[ start>> + ] keep
[ seq>> length rem ] keep ; inline
PRIVATE>
M: circular length seq>> length ;
M: circular length seq>> length ; inline
M: circular virtual@ circular-wrap seq>> ;
M: circular virtual@ circular-wrap seq>> ; inline
M: circular virtual-seq seq>> ;
M: circular virtual-exemplar seq>> ; inline
: change-circular-start ( n circular -- )
#! change start to (start + n) mod length
circular-wrap (>>start) ;
circular-wrap (>>start) ; inline
: rotate-circular ( circular -- )
[ 1 ] dip change-circular-start ;
[ 1 ] dip change-circular-start ; inline
: push-circular ( elt circular -- )
: circular-push ( elt circular -- )
[ set-first ] [ rotate-circular ] bi ;
: <circular-string> ( n -- circular )
0 <string> <circular> ;
0 <string> <circular> ; inline
INSTANCE: circular virtual-sequence
TUPLE: growing-circular < circular length ;
TUPLE: growing-circular < circular { length integer } ;
M: growing-circular length length>> ;
M: growing-circular length length>> ; inline
<PRIVATE
: full? ( circular -- ? )
[ length ] [ seq>> length ] bi = ;
[ length ] [ seq>> length ] bi = ; inline
PRIVATE>
: push-growing-circular ( elt circular -- )
dup full? [ push-circular ]
: growing-circular-push ( elt circular -- )
dup full? [ circular-push ]
[ [ 1 + ] change-length set-last ] if ;
: <growing-circular> ( capacity -- growing-circular )
{ } new-sequence 0 0 growing-circular boa ;
{ } new-sequence 0 0 growing-circular boa ; inline
TUPLE: circular-iterator
{ circular read-only } { n integer } { last-start integer } ;
: <circular-iterator> ( circular -- obj )
0 0 circular-iterator boa ; inline
<PRIVATE
: (circular-while) ( iterator quot: ( obj -- ? ) -- )
[ [ [ n>> ] [ circular>> ] bi nth ] dip call ] 2keep
rot [ [ dup n>> >>last-start ] dip ] when
over [ n>> ] [ [ last-start>> ] [ circular>> length ] bi + 1 - ] bi = [
2drop
] [
[ [ 1 + ] change-n ] dip (circular-while)
] if ; inline recursive
PRIVATE>
: circular-while ( circular quot: ( obj -- ? ) -- )
[ clone ] dip [ <circular-iterator> ] dip (circular-while) ; inline

3
basis/classes/struct/bit-accessors/bit-accessors-tests.factor
View File

@ -1,6 +1,7 @@
! Copyright (C) 2009 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
USING: classes.struct.bit-accessors tools.test effects kernel random stack-checker ;
USING: classes.struct.bit-accessors tools.test effects kernel
sequences random stack-checker ;
IN: classes.struct.bit-accessors.test
[ t ] [ 20 random 20 random bit-reader infer (( alien -- n )) effect= ] unit-test

15
basis/classes/struct/struct-tests.factor Executable file → Normal file
View File

@ -365,3 +365,18 @@ STRUCT: bit-field-test
[ -2 ] [ bit-field-test <struct> 2 >>b b>> ] unit-test
[ 1 ] [ bit-field-test <struct> 257 >>c c>> ] unit-test
[ 3 ] [ bit-field-test heap-size ] unit-test
cpu ppc? [
STRUCT: ppc-align-test-1
{ x longlong }
{ y int } ;
[ 16 ] [ ppc-align-test-1 heap-size ] unit-test
STRUCT: ppc-align-test-2
{ y int }
{ x longlong } ;
[ 12 ] [ ppc-align-test-2 heap-size ] unit-test
[ 4 ] [ "x" ppc-align-test-2 offset-of ] unit-test
] when

41
basis/classes/struct/struct.factor Executable file → Normal file
View File

@ -189,9 +189,6 @@ M: struct-c-type c-struct? drop t ;
\ cleave [ ] 2sequence
\ output>array [ ] 2sequence ;
: define-inline-method ( class generic quot -- )
[ create-method-in ] dip [ define ] [ drop make-inline ] 2bi ;
: (define-struct-slot-values-method) ( class -- )
[ \ struct-slot-values ] [ struct-slot-values-quot ] bi
define-inline-method ;
@ -211,27 +208,32 @@ M: struct-c-type c-struct? drop t ;
slots >>fields
size >>size
align >>align
align >>align-first
class (unboxer-quot) >>unboxer-quot
class (boxer-quot) >>boxer-quot ;
GENERIC: align-offset ( offset class -- offset' )
GENERIC: compute-slot-offset ( offset class -- offset' )
M: struct-slot-spec align-offset
[ type>> c-type-align 8 * align ] keep
: c-type-align-at ( class offset -- n )
0 = [ c-type-align-first ] [ c-type-align ] if ;
M: struct-slot-spec compute-slot-offset
[ type>> over c-type-align-at 8 * align ] keep
[ [ 8 /i ] dip (>>offset) ] [ type>> heap-size 8 * + ] 2bi ;
M: struct-bit-slot-spec align-offset
M: struct-bit-slot-spec compute-slot-offset
[ (>>offset) ] [ bits>> + ] 2bi ;
: struct-offsets ( slots -- size )
0 [ align-offset ] reduce 8 align 8 /i ;
: compute-struct-offsets ( slots -- size )
0 [ compute-slot-offset ] reduce 8 align 8 /i ;
: union-struct-offsets ( slots -- size )
: compute-union-offsets ( slots -- size )
1 [ 0 >>offset type>> heap-size max ] reduce ;
: struct-align ( slots -- align )
: struct-alignment ( slots -- align )
[ struct-bit-slot-spec? not ] filter
1 [ type>> c-type-align max ] reduce ;
1 [ [ type>> ] [ offset>> ] bi c-type-align-at max ] reduce ;
PRIVATE>
M: struct byte-length class "struct-size" word-prop ; foldable
@ -243,10 +245,8 @@ GENERIC: binary-zero? ( value -- ? )
M: object binary-zero? drop f ;
M: f binary-zero? drop t ;
M: number binary-zero? zero? ;
M: struct binary-zero?
[ byte-length iota ] [ >c-ptr ] bi
[ <displaced-alien> *uchar zero? ] curry all? ;
M: number binary-zero? 0 = ;
M: struct binary-zero? >c-ptr [ 0 = ] all? ;
: struct-needs-prototype? ( class -- ? )
struct-slots [ initial>> binary-zero? ] all? not ;
@ -278,8 +278,9 @@ M: struct binary-zero?
slots empty? [ struct-must-have-slots ] when
class redefine-struct-tuple-class
slots make-slots dup check-struct-slots :> slot-specs
slot-specs struct-align :> alignment
slot-specs offsets-quot call alignment align :> size
slot-specs offsets-quot call :> unaligned-size
slot-specs struct-alignment :> alignment
unaligned-size alignment align :> size
class slot-specs size alignment c-type-for-class :> c-type
@ -291,10 +292,10 @@ M: struct binary-zero?
PRIVATE>
: define-struct-class ( class slots -- )
[ struct-offsets ] (define-struct-class) ;
[ compute-struct-offsets ] (define-struct-class) ;
: define-union-struct-class ( class slots -- )
[ union-struct-offsets ] (define-struct-class) ;
[ compute-union-offsets ] (define-struct-class) ;
M: struct-class reset-class
[ call-next-method ] [ name>> c-types get delete-at ] bi ;

2
basis/cocoa/application/application.factor
View File

@ -49,7 +49,7 @@ TUPLE: objc-error alien reason ;
M: objc-error summary ( error -- )
drop "Objective C exception" ;
[ [ objc-error ] 19 setenv ] "cocoa.application" add-init-hook
[ [ objc-error ] 19 set-special-object ] "cocoa.application" add-startup-hook
: running.app? ( -- ? )
#! Test if we're running a .app.

2
basis/cocoa/cocoa.factor
View File

@ -27,7 +27,7 @@ SYMBOL: frameworks
frameworks [ V{ } clone ] initialize
[ frameworks get [ load-framework ] each ] "cocoa" add-init-hook
[ frameworks get [ load-framework ] each ] "cocoa" add-startup-hook
SYNTAX: FRAMEWORK: scan [ load-framework ] [ frameworks get push ] bi ;

0
basis/cocoa/enumeration/enumeration.factor Executable file → Normal file
View File

12
basis/cocoa/messages/messages.factor Executable file → Normal file
View File

@ -1,4 +1,4 @@
! Copyright (C) 2006, 2009 Slava Pestov.
! Copyright (C) 2006, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien alien.c-types alien.strings arrays assocs
classes.struct continuations combinators compiler compiler.alien
@ -76,13 +76,13 @@ MACRO: (send) ( selector super? -- quot )
: super-send ( receiver args... selector -- return... ) t (send) ; inline
! Runtime introspection
SYMBOL: class-init-hooks
SYMBOL: class-startup-hooks
class-init-hooks [ H{ } clone ] initialize
class-startup-hooks [ H{ } clone ] initialize
: (objc-class) ( name word -- class )
2dup execute dup [ 2nip ] [
drop over class-init-hooks get at [ call( -- ) ] when*
drop over class-startup-hooks get at [ call( -- ) ] when*
2dup execute dup [ 2nip ] [
2drop "No such class: " prepend throw
] if
@ -202,7 +202,7 @@ ERROR: no-objc-type name ;
(free) ;
: method-arg-types ( method -- args )
dup method_getNumberOfArguments
dup method_getNumberOfArguments iota
[ method-arg-type ] with map ;
: method-return-type ( method -- ctype )
@ -229,7 +229,7 @@ ERROR: no-objc-type name ;
: class-exists? ( string -- class ) objc_getClass >boolean ;
: define-objc-class-word ( quot name -- )
[ class-init-hooks get set-at ]
[ class-startup-hooks get set-at ]
[
[ "cocoa.classes" create ] [ '[ _ objc-class ] ] bi
(( -- class )) define-declared

2
basis/columns/columns-tests.factor
View File

@ -7,3 +7,5 @@ IN: columns.tests
[ { 1 4 7 } ] [ "seq" get 0 <column> >array ] unit-test
[ ] [ "seq" get 1 <column> [ sq ] map! drop ] unit-test
[ { 4 25 64 } ] [ "seq" get 1 <column> >array ] unit-test
[ { { 1 3 } { 2 4 } } ] [ { { 1 2 } { 3 4 } } <flipped> [ >array ] map ] unit-test

6
basis/columns/columns.factor
View File

@ -1,4 +1,4 @@
! Copyright (C) 2005, 2008 Slava Pestov, Daniel Ehrenberg.
! Copyright (C) 2005, 2010 Slava Pestov, Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
USING: sequences kernel accessors ;
IN: columns
@ -8,11 +8,11 @@ TUPLE: column seq col ;
C: <column> column
M: column virtual-seq seq>> ;
M: column virtual-exemplar seq>> ;
M: column virtual@ [ col>> swap ] [ seq>> ] bi nth bounds-check ;
M: column length seq>> length ;
INSTANCE: column virtual-sequence
: <flipped> ( seq -- seq' )
dup empty? [ dup first length [ <column> ] with map ] unless ;
dup empty? [ dup first length [ <column> ] with { } map-integers ] unless ;

6
basis/combinators/smart/smart-tests.factor
View File

@ -47,3 +47,9 @@ IN: combinators.smart.tests
[ { { 1 2 } { 3 4 } } ] [ nested-smart-combo-test ] unit-test
[ 14 ] [ [ 1 2 3 ] [ sq ] [ + ] map-reduce-outputs ] unit-test
{ 2 3 } [ [ + ] preserving ] must-infer-as
{ 2 0 } [ [ + ] nullary ] must-infer-as
{ 2 2 } [ [ [ + ] nullary ] preserving ] must-infer-as

21
basis/combinators/smart/smart.factor
View File

@ -5,46 +5,49 @@ stack-checker math sequences ;
IN: combinators.smart
MACRO: drop-outputs ( quot -- quot' )
dup infer out>> '[ @ _ ndrop ] ;
dup outputs '[ @ _ ndrop ] ;
MACRO: keep-inputs ( quot -- quot' )
dup infer in>> '[ _ _ nkeep ] ;
dup inputs '[ _ _ nkeep ] ;
MACRO: output>sequence ( quot exemplar -- newquot )
[ dup infer out>> ] dip
[ dup outputs ] dip
'[ @ _ _ nsequence ] ;
MACRO: output>array ( quot -- newquot )
'[ _ { } output>sequence ] ;
MACRO: input<sequence ( quot -- newquot )
[ infer in>> ] keep
[ inputs ] keep
'[ _ firstn @ ] ;
MACRO: input<sequence-unsafe ( quot -- newquot )
[ infer in>> ] keep
[ inputs ] keep
'[ _ firstn-unsafe @ ] ;
MACRO: reduce-outputs ( quot operation -- newquot )
[ dup infer out>> 1 [-] ] dip n*quot compose ;
[ dup outputs 1 [-] ] dip n*quot compose ;
MACRO: sum-outputs ( quot -- n )
'[ _ [ + ] reduce-outputs ] ;
MACRO: map-reduce-outputs ( quot mapper reducer -- newquot )
[ dup infer out>> ] 2dip
[ dup outputs ] 2dip
[ swap '[ _ _ napply ] ]
[ [ 1 [-] ] dip n*quot ] bi-curry* bi
'[ @ @ @ ] ;
MACRO: append-outputs-as ( quot exemplar -- newquot )
[ dup infer out>> ] dip '[ @ _ _ nappend-as ] ;
[ dup outputs ] dip '[ @ _ _ nappend-as ] ;
MACRO: append-outputs ( quot -- seq )
'[ _ { } append-outputs-as ] ;
MACRO: preserving ( quot -- )
[ infer in>> length ] keep '[ _ ndup @ ] ;
[ inputs ] keep '[ _ ndup @ ] ;
MACRO: nullary ( quot -- quot' )
dup outputs '[ @ _ ndrop ] ;
MACRO: smart-if ( pred true false -- )
'[ _ preserving _ _ if ] ; inline

5
basis/command-line/command-line.factor
View File

@ -8,7 +8,8 @@ IN: command-line
SYMBOL: script
SYMBOL: command-line
: (command-line) ( -- args ) 10 getenv sift [ alien>native-string ] map ;
: (command-line) ( -- args )
10 special-object sift [ alien>native-string ] map ;
: rc-path ( name -- path )
os windows? [ "." prepend ] unless
@ -69,4 +70,4 @@ SYMBOL: main-vocab-hook
: ignore-cli-args? ( -- ? )
os macosx? "run" get "ui" = and ;
[ default-cli-args ] "command-line" add-init-hook
[ default-cli-args ] "command-line" add-startup-hook

6
basis/compiler/cfg/build-stack-frame/build-stack-frame.factor
View File

@ -1,4 +1,4 @@
! Copyright (C) 2008, 2009 Slava Pestov.
! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: namespaces accessors math.order assocs kernel sequences
combinators make classes words cpu.architecture layouts
@ -17,13 +17,13 @@ GENERIC: compute-stack-frame* ( insn -- )
UNION: stack-frame-insn
##alien-invoke
##alien-indirect
##alien-assembly
##alien-callback ;
M: stack-frame-insn compute-stack-frame*
stack-frame>> request-stack-frame ;
M: ##call compute-stack-frame*
word>> sub-primitive>> [ frame-required? on ] unless ;
M: ##call compute-stack-frame* drop frame-required? on ;
M: ##gc compute-stack-frame*
frame-required? on

15
basis/compiler/cfg/builder/builder.factor Executable file → Normal file
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.
USING: accessors arrays assocs combinators hashtables kernel
math fry namespaces make sequences words byte-arrays
@ -45,6 +45,12 @@ SYMBOL: loops
end-stack-analysis
] with-scope ; inline
: with-dummy-cfg-builder ( node quot -- )
[
[ V{ } clone procedures ] 2dip
'[ _ t t [ _ call( node -- ) ] with-cfg-builder ] with-variable
] { } make drop ;
GENERIC: emit-node ( node -- )
: emit-nodes ( nodes -- )
@ -230,13 +236,16 @@ M: #alien-invoke emit-node
M: #alien-indirect emit-node
[ ##alien-indirect ] emit-alien-node ;
M: #alien-assembly emit-node
[ ##alien-assembly ] emit-alien-node ;
M: #alien-callback emit-node
dup params>> xt>> dup
[
##prologue
dup [ ##alien-callback ] emit-alien-node
[ ##alien-callback ] emit-alien-node
##epilogue
params>> ##callback-return
##return
] with-cfg-builder ;
! No-op nodes

8
basis/compiler/cfg/cfg.factor
View File

@ -10,14 +10,14 @@ number
{ successors vector }
{ predecessors vector } ;
M: basic-block hashcode* nip id>> ;
: <basic-block> ( -- bb )
basic-block new
\ basic-block counter >>id
V{ } clone >>instructions
V{ } clone >>successors
V{ } clone >>predecessors
\ basic-block counter >>id ;
V{ } clone >>predecessors ;
M: basic-block hashcode* nip id>> ;
TUPLE: cfg { entry basic-block } word label
spill-area-size reps

4
basis/compiler/cfg/checker/checker.factor
View File

@ -1,4 +1,4 @@
! Copyright (C) 2009 Slava Pestov.
! Copyright (C) 2009, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel combinators.short-circuit accessors math sequences
sets assocs compiler.cfg.instructions compiler.cfg.rpo
@ -14,7 +14,7 @@ ERROR: bad-kill-block bb ;
dup instructions>> dup penultimate ##epilogue? [
{
[ length 2 = ]
[ last { [ ##return? ] [ ##callback-return? ] [ ##jump? ] } 1|| ]
[ last { [ ##return? ] [ ##jump? ] } 1|| ]
} 1&&
] [ last ##branch? ] if
[ drop ] [ bad-kill-block ] if ;

39
basis/compiler/cfg/instructions/instructions.factor
View File

@ -1,4 +1,4 @@
! Copyright (C) 2008, 2009 Slava Pestov.
! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: assocs accessors arrays kernel sequences namespaces words
math math.order layouts classes.algebra classes.union
@ -382,6 +382,16 @@ def: dst
use: src1 src2
literal: rep ;
PURE-INSN: ##mul-high-vector
def: dst
use: src1 src2
literal: rep ;
PURE-INSN: ##mul-horizontal-add-vector
def: dst
use: src1 src2
literal: rep ;
PURE-INSN: ##saturated-mul-vector
def: dst
use: src1 src2
@ -402,19 +412,29 @@ def: dst
use: src1 src2
literal: rep ;
PURE-INSN: ##avg-vector
def: dst
use: src1 src2
literal: rep ;
PURE-INSN: ##dot-vector
def: dst/scalar-rep
use: src1 src2
literal: rep ;
PURE-INSN: ##sad-vector
def: dst
use: src1 src2
literal: rep ;
PURE-INSN: ##horizontal-add-vector
def: dst/scalar-rep
use: src
def: dst
use: src1 src2
literal: rep ;
PURE-INSN: ##horizontal-sub-vector
def: dst/scalar-rep
use: src
def: dst
use: src1 src2
literal: rep ;
PURE-INSN: ##horizontal-shl-vector-imm
@ -651,11 +671,11 @@ literal: params stack-frame ;
INSN: ##alien-indirect
literal: params stack-frame ;
INSN: ##alien-callback
INSN: ##alien-assembly
literal: params stack-frame ;
INSN: ##callback-return
literal: params ;
INSN: ##alien-callback
literal: params stack-frame ;
! Instructions used by CFG IR only.
INSN: ##prologue ;
@ -728,8 +748,7 @@ temp: temp1/int-rep temp2/int-rep
literal: size data-values tagged-values uninitialized-locs ;
INSN: ##save-context
temp: temp1/int-rep temp2/int-rep
literal: callback-allowed? ;
temp: temp1/int-rep temp2/int-rep ;
! Instructions used by machine IR only.
INSN: _prologue

6
basis/compiler/cfg/instructions/syntax/syntax.factor
View File

@ -1,4 +1,4 @@
! Copyright (C) 2008, 2009 Slava Pestov.
! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: classes.tuple classes.tuple.parser kernel words
make fry sequences parser accessors effects namespaces
@ -61,14 +61,14 @@ TUPLE: insn-slot-spec type name rep ;
"pure-insn" "compiler.cfg.instructions" lookup ;
: insn-effect ( word -- effect )
boa-effect in>> but-last f <effect> ;
boa-effect in>> but-last { } <effect> ;
: define-insn-tuple ( class superclass specs -- )
[ name>> ] map "insn#" suffix define-tuple-class ;
: define-insn-ctor ( class specs -- )
[ dup '[ _ ] [ f ] [ boa , ] surround ] dip
[ name>> ] map f <effect> define-declared ;
[ name>> ] map { } <effect> define-declared ;
: define-insn ( class superclass specs -- )
parse-insn-slot-specs {

4
basis/compiler/cfg/intrinsics/allot/allot.factor
View File

@ -1,4 +1,4 @@
! Copyright (C) 2008, 2009 Slava Pestov.
! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math math.order sequences accessors arrays
byte-arrays layouts classes.tuple.private fry locals
@ -34,7 +34,7 @@ IN: compiler.cfg.intrinsics.allot
[ [ ^^load-literal ] dip 1 ] dip type-number ##set-slot-imm ;
:: store-initial-element ( len reg elt class -- )
len [ [ elt reg ] dip 2 + class type-number ##set-slot-imm ] each ;
len [ [ elt reg ] dip 2 + class type-number ##set-slot-imm ] each-integer ;
: expand-<array>? ( obj -- ? )
dup integer? [ 0 8 between? ] [ drop f ] if ;

64
basis/compiler/cfg/intrinsics/intrinsics.factor
View File

@ -7,7 +7,6 @@ compiler.cfg.intrinsics.alien
compiler.cfg.intrinsics.allot
compiler.cfg.intrinsics.fixnum
compiler.cfg.intrinsics.float
compiler.cfg.intrinsics.simd
compiler.cfg.intrinsics.slots
compiler.cfg.intrinsics.misc
compiler.cfg.comparisons ;
@ -23,7 +22,6 @@ QUALIFIED: classes.tuple.private
QUALIFIED: math.private
QUALIFIED: math.integers.private
QUALIFIED: math.floats.private
QUALIFIED: math.vectors.simd.intrinsics
QUALIFIED: math.libm
IN: compiler.cfg.intrinsics
@ -32,7 +30,8 @@ IN: compiler.cfg.intrinsics
{
{ kernel.private:tag [ drop emit-tag ] }
{ kernel.private:getenv [ emit-getenv ] }
{ kernel.private:special-object [ emit-special-object ] }
{ kernel.private:(identity-hashcode) [ drop emit-identity-hashcode ] }
{ math.private:both-fixnums? [ drop emit-both-fixnums? ] }
{ math.private:fixnum+ [ drop emit-fixnum+ ] }
{ math.private:fixnum- [ drop emit-fixnum- ] }
@ -151,64 +150,5 @@ IN: compiler.cfg.intrinsics
{ math.integers.private:fixnum-log2 [ drop emit-fixnum-log2 ] }
} enable-intrinsics ;
: enable-simd ( -- )
{
{ math.vectors.simd.intrinsics:assert-positive [ drop ] }
{ math.vectors.simd.intrinsics:(simd-v+) [ [ ^^add-vector ] emit-binary-vector-op ] }
{ math.vectors.simd.intrinsics:(simd-vs+) [ [ ^^saturated-add-vector ] emit-binary-vector-op ] }
{ math.vectors.simd.intrinsics:(simd-v+-) [ [ ^^add-sub-vector ] emit-binary-vector-op ] }
{ math.vectors.simd.intrinsics:(simd-v-) [ [ ^^sub-vector ] emit-binary-vector-op ] }
{ math.vectors.simd.intrinsics:(simd-vs-) [ [ ^^saturated-sub-vector ] emit-binary-vector-op ] }
{ math.vectors.simd.intrinsics:(simd-vneg) [ [ generate-neg-vector ] emit-unary-vector-op ] }
{ math.vectors.simd.intrinsics:(simd-v*) [ [ ^^mul-vector ] emit-binary-vector-op ] }
{ math.vectors.simd.intrinsics:(simd-vs*) [ [ ^^saturated-mul-vector ] emit-binary-vector-op ] }
{ math.vectors.simd.intrinsics:(simd-v/) [ [ ^^div-vector ] emit-binary-vector-op ] }
{ math.vectors.simd.intrinsics:(simd-vmin) [ [ generate-min-vector ] emit-binary-vector-op ] }
{ math.vectors.simd.intrinsics:(simd-vmax) [ [ generate-max-vector ] emit-binary-vector-op ] }
{ math.vectors.simd.intrinsics:(simd-v.) [ [ ^^dot-vector ] emit-binary-vector-op ] }
{ math.vectors.simd.intrinsics:(simd-vabs) [ [ generate-abs-vector ] emit-unary-vector-op ] }
{ math.vectors.simd.intrinsics:(simd-vsqrt) [ [ ^^sqrt-vector ] emit-unary-vector-op ] }
{ math.vectors.simd.intrinsics:(simd-vbitand) [ [ ^^and-vector ] emit-binary-vector-op ] }
{ math.vectors.simd.intrinsics:(simd-vbitandn) [ [ ^^andn-vector ] emit-binary-vector-op ] }
{ math.vectors.simd.intrinsics:(simd-vbitor) [ [ ^^or-vector ] emit-binary-vector-op ] }
{ math.vectors.simd.intrinsics:(simd-vbitxor) [ [ ^^xor-vector ] emit-binary-vector-op ] }
{ math.vectors.simd.intrinsics:(simd-vbitnot) [ [ generate-not-vector ] emit-unary-vector-op ] }
{ math.vectors.simd.intrinsics:(simd-vand) [ [ ^^and-vector ] emit-binary-vector-op ] }
{ math.vectors.simd.intrinsics:(simd-vandn) [ [ ^^andn-vector ] emit-binary-vector-op ] }
{ math.vectors.simd.intrinsics:(simd-vor) [ [ ^^or-vector ] emit-binary-vector-op ] }
{ math.vectors.simd.intrinsics:(simd-vxor) [ [ ^^xor-vector ] emit-binary-vector-op ] }
{ math.vectors.simd.intrinsics:(simd-vnot) [ [ generate-not-vector ] emit-unary-vector-op ] }
{ math.vectors.simd.intrinsics:(simd-v<=) [ [ cc<= generate-compare-vector ] emit-binary-vector-op ] }
{ math.vectors.simd.intrinsics:(simd-v<) [ [ cc< generate-compare-vector ] emit-binary-vector-op ] }
{ math.vectors.simd.intrinsics:(simd-v=) [ [ cc= generate-compare-vector ] emit-binary-vector-op ] }
{ math.vectors.simd.intrinsics:(simd-v>) [ [ cc> generate-compare-vector ] emit-binary-vector-op ] }
{ math.vectors.simd.intrinsics:(simd-v>=) [ [ cc>= generate-compare-vector ] emit-binary-vector-op ] }
{ math.vectors.simd.intrinsics:(simd-vunordered?) [ [ cc/<>= generate-compare-vector ] emit-binary-vector-op ] }
{ math.vectors.simd.intrinsics:(simd-vany?) [ [ vcc-any ^^test-vector ] emit-unary-vector-op ] }
{ math.vectors.simd.intrinsics:(simd-vall?) [ [ vcc-all ^^test-vector ] emit-unary-vector-op ] }
{ math.vectors.simd.intrinsics:(simd-vnone?) [ [ vcc-none ^^test-vector ] emit-unary-vector-op ] }
{ math.vectors.simd.intrinsics:(simd-vlshift) [ [ ^^shl-vector-imm ] [ ^^shl-vector ] emit-shift-vector-op ] }
{ math.vectors.simd.intrinsics:(simd-vrshift) [ [ ^^shr-vector-imm ] [ ^^shr-vector ] emit-shift-vector-op ] }
{ math.vectors.simd.intrinsics:(simd-hlshift) [ [ ^^horizontal-shl-vector-imm ] emit-shift-vector-imm-op ] }
{ math.vectors.simd.intrinsics:(simd-hrshift) [ [ ^^horizontal-shr-vector-imm ] emit-shift-vector-imm-op ] }
{ math.vectors.simd.intrinsics:(simd-with) [ [ ^^with-vector ] emit-unary-vector-op ] }
{ math.vectors.simd.intrinsics:(simd-gather-2) [ emit-gather-vector-2 ] }
{ math.vectors.simd.intrinsics:(simd-gather-4) [ emit-gather-vector-4 ] }
{ math.vectors.simd.intrinsics:(simd-vshuffle-elements) [ emit-shuffle-vector ] }
{ math.vectors.simd.intrinsics:(simd-vshuffle-bytes) [ emit-shuffle-vector-var ] }
{ math.vectors.simd.intrinsics:(simd-(vmerge-head)) [ [ ^^merge-vector-head ] emit-binary-vector-op ] }
{ math.vectors.simd.intrinsics:(simd-(vmerge-tail)) [ [ ^^merge-vector-tail ] emit-binary-vector-op ] }
{ math.vectors.simd.intrinsics:(simd-(v>float)) [ [ ^^integer>float-vector ] emit-unary-vector-op ] }
{ math.vectors.simd.intrinsics:(simd-(v>integer)) [ [ ^^float>integer-vector ] emit-unary-vector-op ] }
{ math.vectors.simd.intrinsics:(simd-(vpack-signed)) [ [ ^^signed-pack-vector ] emit-binary-vector-op ] }
{ math.vectors.simd.intrinsics:(simd-(vpack-unsigned)) [ [ ^^unsigned-pack-vector ] emit-binary-vector-op ] }
{ math.vectors.simd.intrinsics:(simd-(vunpack-head)) [ [ generate-unpack-vector-head ] emit-unary-vector-op ] }
{ math.vectors.simd.intrinsics:(simd-(vunpack-tail)) [ [ generate-unpack-vector-tail ] emit-unary-vector-op ] }
{ math.vectors.simd.intrinsics:(simd-select) [ emit-select-vector ] }
{ math.vectors.simd.intrinsics:(simd-sum) [ [ ^^horizontal-add-vector ] emit-unary-vector-op ] }
{ math.vectors.simd.intrinsics:alien-vector [ emit-alien-vector ] }
{ math.vectors.simd.intrinsics:set-alien-vector [ emit-set-alien-vector ] }
} enable-intrinsics ;
: emit-intrinsic ( node word -- )
"intrinsic" word-prop call( node -- ) ;

18
basis/compiler/cfg/intrinsics/misc/misc.factor
View File

@ -1,16 +1,22 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: namespaces layouts sequences kernel
accessors compiler.tree.propagation.info
compiler.cfg.stacks compiler.cfg.hats
compiler.cfg.instructions compiler.cfg.utilities ;
USING: namespaces layouts sequences kernel math accessors
compiler.tree.propagation.info compiler.cfg.stacks
compiler.cfg.hats compiler.cfg.instructions
compiler.cfg.utilities ;
IN: compiler.cfg.intrinsics.misc
: emit-tag ( -- )
ds-pop tag-mask get ^^and-imm ^^tag-fixnum ds-push ;
: emit-getenv ( node -- )
"userenv" ^^vm-field-ptr
: emit-special-object ( node -- )
"special-objects" ^^vm-field-ptr
swap node-input-infos first literal>>
[ ds-drop 0 ^^slot-imm ] [ ds-pop ^^offset>slot ^^slot ] if*
ds-push ;
: emit-identity-hashcode ( -- )
ds-pop tag-mask get bitnot ^^load-immediate ^^and 0 0 ^^slot-imm
hashcode-shift ^^shr-imm
^^tag-fixnum
ds-push ;

206
basis/compiler/cfg/intrinsics/simd/backend/backend.factor Normal file
View File

@ -0,0 +1,206 @@
! (c)2009 Joe Groff bsd license
USING: accessors arrays assocs classes combinators
combinators.short-circuit compiler.cfg.builder.blocks
compiler.cfg.registers compiler.cfg.stacks
compiler.cfg.stacks.local compiler.tree.propagation.info
cpu.architecture effects fry generalizations
kernel locals macros math namespaces quotations sequences
splitting stack-checker words ;
IN: compiler.cfg.intrinsics.simd.backend
! Selection of implementation based on available CPU instructions
: can-has? ( quot -- ? )
[ t \ can-has? ] dip '[ @ drop \ can-has? get ] with-variable ; inline
: can-has-rep? ( rep reps -- )
member? \ can-has? [ and ] change ; inline
GENERIC: create-can-has ( word -- word' )
PREDICATE: hat-word < word
{
[ name>> { [ "^" head? ] [ "##" head? ] } 1|| ]
[ vocabulary>> { "compiler.cfg.intrinsics.simd" "compiler.cfg.hats" } member? ]
} 1&& ;
PREDICATE: vector-op-word < hat-word
name>> "-vector" swap subseq? ;
: reps-word ( word -- word' )
name>> "^^" ?head drop "##" ?head drop
"%" "-reps" surround "cpu.architecture" lookup ;
SYMBOL: blub
:: can-has-^^-quot ( word def effect -- quot )
effect in>> { "rep" } split1 [ length ] bi@ 1 +
word reps-word 1quotation
effect out>> length blub <array> >quotation
'[ [ _ ndrop ] _ ndip @ can-has-rep? @ ] ;
:: can-has-^-quot ( word def effect -- quot )
def create-can-has first ;
: map-concat-like ( seq quot -- seq' )
'[ _ map ] [ concat-as ] bi ; inline
M: object create-can-has 1quotation ;
M: array create-can-has
[ create-can-has ] map-concat-like 1quotation ;
M: callable create-can-has
[ create-can-has ] map-concat-like 1quotation ;
: (can-has-word) ( word -- word' )
name>> "can-has-" prepend "compiler.cfg.intrinsics.simd.backend" lookup ;
: (can-has-quot) ( word -- quot )
[ ] [ def>> ] [ stack-effect ] tri {
{ [ pick name>> "^^" head? ] [ can-has-^^-quot ] }
{ [ pick name>> "##" head? ] [ can-has-^^-quot ] }
{ [ pick name>> "^" head? ] [ can-has-^-quot ] }
} cond ;
: (can-has-nop-quot) ( word -- quot )
stack-effect in>> length '[ _ ndrop blub ] ;
DEFER: can-has-words
M: word create-can-has
can-has-words ?at drop 1quotation ;
M: hat-word create-can-has
(can-has-nop-quot) ;
M: vector-op-word create-can-has
dup (can-has-word) [ 1quotation ] [ (can-has-quot) ] ?if ;
GENERIC# >can-has-cond 2 ( quot #pick #dup -- quotpair )
M:: callable >can-has-cond ( quot #pick #dup -- quotpair )
#dup quot create-can-has '[ _ ndup @ can-has? ] quot 2array ;
M:: pair >can-has-cond ( pair #pick #dup -- quotpair )
pair first2 :> ( class quot )
#pick class #dup quot create-can-has
'[ _ npick _ instance? [ _ ndup @ can-has? ] dip and ]
quot 2array ;
MACRO: v-vector-op ( trials -- )
[ 1 2 >can-has-cond ] map '[ _ cond ] ;
MACRO: vl-vector-op ( trials -- )
[ 1 3 >can-has-cond ] map '[ _ cond ] ;
MACRO: vv-vector-op ( trials -- )
[ 1 3 >can-has-cond ] map '[ _ cond ] ;
MACRO: vv-cc-vector-op ( trials -- )
[ 2 4 >can-has-cond ] map '[ _ cond ] ;
MACRO: vvvv-vector-op ( trials -- )
[ 1 5 >can-has-cond ] map '[ _ cond ] ;
! Special-case conditional instructions
: can-has-^(compare-vector) ( src1 src2 rep cc -- dst )
[ 2drop ] 2dip %compare-vector-reps member?
\ can-has? [ and ] change
blub ;
: can-has-^^test-vector ( src rep vcc -- dst )
[ drop ] 2dip drop %test-vector-reps member?
\ can-has? [ and ] change
blub ;
MACRO: can-has-case ( cases -- )
dup first second inputs 1 +
'[ _ ndrop f ] suffix '[ _ case ] ;
GENERIC# >can-has-trial 1 ( obj #pick -- quot )
M: callable >can-has-trial
drop '[ _ can-has? ] ;
M: pair >can-has-trial
swap first2 dup inputs
'[ _ npick _ instance? [ _ can-has? ] [ _ ndrop blub ] if ] ;
MACRO: can-has-vector-op ( trials #pick #dup -- )
[ '[ _ >can-has-trial ] map ] dip '[ _ _ n|| \ can-has? [ and ] change blub ] ;
: can-has-v-vector-op ( trials -- ? )
1 2 can-has-vector-op ; inline
: can-has-vv-vector-op ( trials -- ? )
1 3 can-has-vector-op ; inline
: can-has-vv-cc-vector-op ( trials -- ? )
2 4 can-has-vector-op ; inline
: can-has-vvvv-vector-op ( trials -- ? )
1 5 can-has-vector-op ; inline
CONSTANT: can-has-words
H{
{ case can-has-case }
{ v-vector-op can-has-v-vector-op }
{ vl-vector-op can-has-vv-vector-op }
{ vv-vector-op can-has-vv-vector-op }
{ vv-cc-vector-op can-has-vv-cc-vector-op }
{ vvvv-vector-op can-has-vvvv-vector-op }
}
! Intrinsic code emission
MACRO: check-elements ( quots -- )
[ length '[ _ firstn ] ]
[ '[ _ spread ] ]
[ length 1 - \ and <repetition> [ ] like ]
tri 3append ;
ERROR: bad-simd-intrinsic node ;
MACRO: if-literals-match ( quots -- )
[ length ] [ ] [ length ] tri
! n quots n
'[
! node quot
[
dup node-input-infos
_ tail-slice* [ literal>> ] map
dup _ check-elements
] dip
swap [
! node literals quot
[ _ firstn ] dip call
drop
] [ 2drop bad-simd-intrinsic ] if
] ;
CONSTANT: [unary] [ ds-drop ds-pop ]
CONSTANT: [unary/param] [ [ -2 inc-d ds-pop ] dip ]
CONSTANT: [binary] [ ds-drop 2inputs ]
CONSTANT: [quaternary]
[
ds-drop
D 3 peek-loc
D 2 peek-loc
D 1 peek-loc
D 0 peek-loc
-4 inc-d
]
:: [emit-vector-op] ( trials params-quot op-quot literal-preds -- quot )
params-quot trials op-quot literal-preds
'[ [ _ dip _ @ ds-push ] _ if-literals-match ] ;
MACRO: emit-v-vector-op ( trials -- )
[unary] [ v-vector-op ] { [ representation? ] } [emit-vector-op] ;
MACRO: emit-vl-vector-op ( trials literal-pred -- )
[ [unary/param] [ vl-vector-op ] { [ representation? ] } ] dip prefix [emit-vector-op] ;
MACRO: emit-vv-vector-op ( trials -- )
[binary] [ vv-vector-op ] { [ representation? ] } [emit-vector-op] ;
MACRO: emit-vvvv-vector-op ( trials -- )
[quaternary] [ vvvv-vector-op ] { [ representation? ] } [emit-vector-op] ;
MACRO:: emit-vv-or-vl-vector-op ( var-trials imm-trials literal-pred -- )
literal-pred imm-trials literal-pred var-trials
'[
dup node-input-infos 2 tail-slice* first literal>> @
[ _ _ emit-vl-vector-op ]
[ _ emit-vv-vector-op ] if
] ;

536
basis/compiler/cfg/intrinsics/simd/simd-tests.factor Normal file
View File

@ -0,0 +1,536 @@
! (c)2009 Joe Groff bsd license
USING: arrays assocs biassocs byte-arrays byte-arrays.hex
classes compiler.cfg compiler.cfg.comparisons compiler.cfg.instructions
compiler.cfg.intrinsics.simd compiler.cfg.intrinsics.simd.backend
compiler.cfg.registers compiler.cfg.stacks.height
compiler.cfg.stacks.local compiler.tree compiler.tree.propagation.info
cpu.architecture fry hashtables kernel locals make namespaces sequences
system tools.test words ;
IN: compiler.cfg.intrinsics.simd.tests
:: test-node ( rep -- node )
T{ #call
{ in-d { 1 2 3 4 } }
{ out-d { 5 } }
{ info H{
{ 1 T{ value-info { class byte-array } } }
{ 2 T{ value-info { class byte-array } } }
{ 3 T{ value-info { class byte-array } } }
{ 4 T{ value-info { class word } { literal? t } { literal rep } } }
{ 5 T{ value-info { class byte-array } } }
} }
} ;
:: test-node-literal ( lit rep -- node )
lit class :> lit-class
T{ #call
{ in-d { 1 2 3 4 } }
{ out-d { 5 } }
{ info H{
{ 1 T{ value-info { class byte-array } } }
{ 2 T{ value-info { class byte-array } } }
{ 3 T{ value-info { class lit-class } { literal? t } { literal lit } } }
{ 4 T{ value-info { class word } { literal? t } { literal rep } } }
{ 5 T{ value-info { class byte-array } } }
} }
} ;
: test-node-nonliteral-rep ( -- node )
T{ #call
{ in-d { 1 2 3 4 } }
{ out-d { 5 } }
{ info H{
{ 1 T{ value-info { class byte-array } } }
{ 2 T{ value-info { class byte-array } } }
{ 3 T{ value-info { class byte-array } } }
{ 4 T{ value-info { class object } } }
{ 5 T{ value-info { class byte-array } } }
} }
} ;
: test-compiler-env ( -- x )
H{ } clone
T{ basic-block { id 0 } }
[ \ basic-block pick set-at ]
[ 0 swap associate \ ds-heights pick set-at ]
[ 0 swap associate \ rs-heights pick set-at ] tri
T{ current-height { d 0 } { r 0 } { emit-d 0 } { emit-r 0 } } \ current-height pick set-at
H{ } clone \ local-peek-set pick set-at
H{ } clone \ replace-mapping pick set-at
H{ } <biassoc> \ locs>vregs pick set-at
H{ } clone \ peek-sets pick set-at
H{ } clone \ replace-sets pick set-at
H{ } clone \ kill-sets pick set-at ;
: make-classes ( quot -- seq )
{ } make [ class ] map ; inline
: test-emit ( cpu rep quot -- node )
[
[ new \ cpu ] 2dip '[
test-compiler-env [ _ test-node @ ] bind
] with-variable
] make-classes ; inline
: test-emit-literal ( cpu lit rep quot -- node )
[
[ new \ cpu ] 3dip '[
test-compiler-env [ _ _ test-node-literal @ ] bind
] with-variable
] make-classes ; inline
: test-emit-nonliteral-rep ( cpu quot -- node )
[
[ new \ cpu ] dip '[
test-compiler-env [ test-node-nonliteral-rep @ ] bind
] with-variable
] make-classes ; inline
CONSTANT: signed-reps
{ char-16-rep short-8-rep int-4-rep longlong-2-rep float-4-rep double-2-rep }
CONSTANT: all-reps
{
char-16-rep short-8-rep int-4-rep longlong-2-rep float-4-rep double-2-rep
uchar-16-rep ushort-8-rep uint-4-rep ulonglong-2-rep
}
TUPLE: scalar-cpu ;
TUPLE: simple-ops-cpu ;
M: simple-ops-cpu %zero-vector-reps all-reps ;
M: simple-ops-cpu %fill-vector-reps all-reps ;
M: simple-ops-cpu %add-vector-reps all-reps ;
M: simple-ops-cpu %sub-vector-reps all-reps ;
M: simple-ops-cpu %mul-vector-reps all-reps ;
M: simple-ops-cpu %div-vector-reps all-reps ;
M: simple-ops-cpu %andn-vector-reps all-reps ;
M: simple-ops-cpu %and-vector-reps all-reps ;
M: simple-ops-cpu %or-vector-reps all-reps ;
M: simple-ops-cpu %xor-vector-reps all-reps ;
M: simple-ops-cpu %merge-vector-reps all-reps ;
M: simple-ops-cpu %sqrt-vector-reps all-reps ;
M: simple-ops-cpu %test-vector-reps all-reps ;
M: simple-ops-cpu %signed-pack-vector-reps all-reps ;
M: simple-ops-cpu %unsigned-pack-vector-reps all-reps ;
M: simple-ops-cpu %gather-vector-2-reps { longlong-2-rep ulonglong-2-rep double-2-rep } ;
M: simple-ops-cpu %gather-vector-4-reps { int-4-rep uint-4-rep float-4-rep } ;
M: simple-ops-cpu %alien-vector-reps all-reps ;
! v+
[ { ##add-vector } ]
[ simple-ops-cpu float-4-rep [ emit-simd-v+ ] test-emit ]
unit-test
! v-
[ { ##sub-vector } ]
[ simple-ops-cpu float-4-rep [ emit-simd-v- ] test-emit ]
unit-test
! vneg
[ { ##load-constant ##sub-vector } ]
[ simple-ops-cpu float-4-rep [ emit-simd-vneg ] test-emit ]
unit-test
[ { ##zero-vector ##sub-vector } ]
[ simple-ops-cpu int-4-rep [ emit-simd-vneg ] test-emit ]
unit-test
! v*
[ { ##mul-vector } ]
[ simple-ops-cpu float-4-rep [ emit-simd-v* ] test-emit ]
unit-test
! v/
[ { ##div-vector } ]
[ simple-ops-cpu float-4-rep [ emit-simd-v/ ] test-emit ]
unit-test
TUPLE: addsub-cpu < simple-ops-cpu ;
M: addsub-cpu %add-sub-vector-reps { int-4-rep float-4-rep } ;
! v+-
[ { ##add-sub-vector } ]
[ addsub-cpu float-4-rep [ emit-simd-v+- ] test-emit ]
unit-test
[ { ##load-constant ##xor-vector ##add-vector } ]
[ simple-ops-cpu float-4-rep [ emit-simd-v+- ] test-emit ]
unit-test
[ { ##load-constant ##xor-vector ##sub-vector ##add-vector } ]
[ simple-ops-cpu int-4-rep [ emit-simd-v+- ] test-emit ]
unit-test
TUPLE: saturating-cpu < simple-ops-cpu ;
M: saturating-cpu %saturated-add-vector-reps { int-4-rep } ;
M: saturating-cpu %saturated-sub-vector-reps { int-4-rep } ;
M: saturating-cpu %saturated-mul-vector-reps { int-4-rep } ;
! vs+
[ { ##add-vector } ]
[ simple-ops-cpu float-4-rep [ emit-simd-vs+ ] test-emit ]
unit-test
[ { ##add-vector } ]
[ saturating-cpu float-4-rep [ emit-simd-vs+ ] test-emit ]
unit-test
[ { ##saturated-add-vector } ]
[ saturating-cpu int-4-rep [ emit-simd-vs+ ] test-emit ]
unit-test
! vs-
[ { ##sub-vector } ]
[ simple-ops-cpu float-4-rep [ emit-simd-vs- ] test-emit ]
unit-test
[ { ##sub-vector } ]
[ saturating-cpu float-4-rep [ emit-simd-vs- ] test-emit ]
unit-test
[ { ##saturated-sub-vector } ]
[ saturating-cpu int-4-rep [ emit-simd-vs- ] test-emit ]
unit-test
! vs*
[ { ##mul-vector } ]
[ simple-ops-cpu float-4-rep [ emit-simd-vs* ] test-emit ]
unit-test
[ { ##mul-vector } ]
[ saturating-cpu float-4-rep [ emit-simd-vs* ] test-emit ]
unit-test
[ { ##saturated-mul-vector } ]
[ saturating-cpu int-4-rep [ emit-simd-vs* ] test-emit ]
unit-test
TUPLE: minmax-cpu < simple-ops-cpu ;
M: minmax-cpu %min-vector-reps signed-reps ;
M: minmax-cpu %max-vector-reps signed-reps ;
M: minmax-cpu %compare-vector-reps { cc= cc/= } member? [ signed-reps ] [ { } ] if ;
M: minmax-cpu %compare-vector-ccs nip f 2array 1array f ;
TUPLE: compare-cpu < simple-ops-cpu ;
M: compare-cpu %compare-vector-reps drop signed-reps ;
M: compare-cpu %compare-vector-ccs nip f 2array 1array f ;
! vmin
[ { ##min-vector } ]
[ minmax-cpu float-4-rep [ emit-simd-vmin ] test-emit ]
unit-test
[ { ##compare-vector ##and-vector ##andn-vector ##or-vector } ]
[ compare-cpu float-4-rep [ emit-simd-vmin ] test-emit ]
unit-test
! vmax
[ { ##max-vector } ]
[ minmax-cpu float-4-rep [ emit-simd-vmax ] test-emit ]
unit-test
[ { ##compare-vector ##and-vector ##andn-vector ##or-vector } ]
[ compare-cpu float-4-rep [ emit-simd-vmax ] test-emit ]
unit-test
TUPLE: dot-cpu < simple-ops-cpu ;
M: dot-cpu %dot-vector-reps { float-4-rep } ;
TUPLE: horizontal-cpu < simple-ops-cpu ;
M: horizontal-cpu %horizontal-add-vector-reps signed-reps ;
M: horizontal-cpu %unpack-vector-head-reps signed-reps ;
M: horizontal-cpu %unpack-vector-tail-reps signed-reps ;
! v.
[ { ##dot-vector } ]
[ dot-cpu float-4-rep [ emit-simd-v. ] test-emit ]
unit-test
[ { ##mul-vector ##horizontal-add-vector ##horizontal-add-vector ##vector>scalar } ]
[ horizontal-cpu float-4-rep [ emit-simd-v. ] test-emit ]
unit-test
[ {
##mul-vector
##merge-vector-head ##merge-vector-tail ##add-vector
##merge-vector-head ##merge-vector-tail ##add-vector
##vector>scalar
} ]
[ simple-ops-cpu float-4-rep [ emit-simd-v. ] test-emit ]
unit-test
! vsqrt
[ { ##sqrt-vector } ]
[ simple-ops-cpu float-4-rep [ emit-simd-vsqrt ] test-emit ]
unit-test
! sum
[ { ##horizontal-add-vector ##vector>scalar } ]
[ horizontal-cpu double-2-rep [ emit-simd-sum ] test-emit ]
unit-test
[ { ##horizontal-add-vector ##horizontal-add-vector ##vector>scalar } ]
[ horizontal-cpu float-4-rep [ emit-simd-sum ] test-emit ]
unit-test
[ {
##unpack-vector-head ##unpack-vector-tail ##add-vector
##horizontal-add-vector ##horizontal-add-vector
##vector>scalar
} ]
[ horizontal-cpu short-8-rep [ emit-simd-sum ] test-emit ]
unit-test
[ {
##unpack-vector-head ##unpack-vector-tail ##add-vector
##horizontal-add-vector ##horizontal-add-vector ##horizontal-add-vector
##vector>scalar
} ]
[ horizontal-cpu char-16-rep [ emit-simd-sum ] test-emit ]
unit-test
TUPLE: abs-cpu < simple-ops-cpu ;
M: abs-cpu %abs-vector-reps signed-reps ;
! vabs
[ { } ]
[ simple-ops-cpu uint-4-rep [ emit-simd-vabs ] test-emit ]
unit-test
[ { ##abs-vector } ]
[ abs-cpu float-4-rep [ emit-simd-vabs ] test-emit ]
unit-test
[ { ##load-constant ##andn-vector } ]
[ simple-ops-cpu float-4-rep [ emit-simd-vabs ] test-emit ]
unit-test
[ { ##zero-vector ##sub-vector ##compare-vector ##and-vector ##andn-vector ##or-vector } ]
[ compare-cpu int-4-rep [ emit-simd-vabs ] test-emit ]
unit-test
! vand
[ { ##and-vector } ]
[ simple-ops-cpu float-4-rep [ emit-simd-vand ] test-emit ]
unit-test
! vandn
[ { ##andn-vector } ]
[ simple-ops-cpu float-4-rep [ emit-simd-vandn ] test-emit ]
unit-test
! vor
[ { ##or-vector } ]
[ simple-ops-cpu float-4-rep [ emit-simd-vor ] test-emit ]
unit-test
! vxor
[ { ##xor-vector } ]
[ simple-ops-cpu float-4-rep [ emit-simd-vxor ] test-emit ]
unit-test
TUPLE: not-cpu < simple-ops-cpu ;
M: not-cpu %not-vector-reps signed-reps ;
! vnot
[ { ##not-vector } ]
[ not-cpu float-4-rep [ emit-simd-vnot ] test-emit ]
unit-test
[ { ##fill-vector ##xor-vector } ]
[ simple-ops-cpu float-4-rep [ emit-simd-vnot ] test-emit ]
unit-test
TUPLE: shift-cpu < simple-ops-cpu ;
M: shift-cpu %shl-vector-reps signed-reps ;
M: shift-cpu %shr-vector-reps signed-reps ;
TUPLE: shift-imm-cpu < simple-ops-cpu ;
M: shift-imm-cpu %shl-vector-imm-reps signed-reps ;
M: shift-imm-cpu %shr-vector-imm-reps signed-reps ;
TUPLE: horizontal-shift-cpu < simple-ops-cpu ;
M: horizontal-shift-cpu %horizontal-shl-vector-imm-reps signed-reps ;
M: horizontal-shift-cpu %horizontal-shr-vector-imm-reps signed-reps ;
! vlshift
[ { ##shl-vector-imm } ]
[ shift-imm-cpu 2 int-4-rep [ emit-simd-vlshift ] test-emit-literal ]
unit-test
[ { ##shl-vector } ]
[ shift-cpu int-4-rep [ emit-simd-vlshift ] test-emit ]
unit-test
! vrshift
[ { ##shr-vector-imm } ]
[ shift-imm-cpu 2 int-4-rep [ emit-simd-vrshift ] test-emit-literal ]
unit-test
[ { ##shr-vector } ]
[ shift-cpu int-4-rep [ emit-simd-vrshift ] test-emit ]
unit-test
! hlshift
[ { ##horizontal-shl-vector-imm } ]
[ horizontal-shift-cpu 2 int-4-rep [ emit-simd-hlshift ] test-emit-literal ]
unit-test
! hrshift
[ { ##horizontal-shr-vector-imm } ]
[ horizontal-shift-cpu 2 int-4-rep [ emit-simd-hrshift ] test-emit-literal ]
unit-test
TUPLE: shuffle-imm-cpu < simple-ops-cpu ;
M: shuffle-imm-cpu %shuffle-vector-imm-reps signed-reps ;
TUPLE: shuffle-cpu < simple-ops-cpu ;
M: shuffle-cpu %shuffle-vector-reps signed-reps ;
! vshuffle-elements
[ { ##load-constant ##shuffle-vector } ]
[ shuffle-cpu { 0 1 2 3 } int-4-rep [ emit-simd-vshuffle-elements ] test-emit-literal ]
unit-test
[ { ##shuffle-vector-imm } ]
[ shuffle-imm-cpu { 0 1 2 3 } int-4-rep [ emit-simd-vshuffle-elements ] test-emit-literal ]
unit-test
! vshuffle-bytes
[ { ##shuffle-vector } ]
[ shuffle-cpu int-4-rep [ emit-simd-vshuffle-bytes ] test-emit ]
unit-test
! vmerge-head
[ { ##merge-vector-head } ]
[ simple-ops-cpu float-4-rep [ emit-simd-vmerge-head ] test-emit ]
unit-test
! vmerge-tail
[ { ##merge-vector-tail } ]
[ simple-ops-cpu float-4-rep [ emit-simd-vmerge-tail ] test-emit ]
unit-test
! v<= etc.
[ { ##compare-vector } ]
[ compare-cpu int-4-rep [ emit-simd-v<= ] test-emit ]
unit-test
[ { ##min-vector ##compare-vector } ]
[ minmax-cpu int-4-rep [ emit-simd-v<= ] test-emit ]
unit-test
[ { ##load-constant ##xor-vector ##xor-vector ##compare-vector } ]
[ compare-cpu uint-4-rep [ emit-simd-v<= ] test-emit ]
unit-test
! vany? etc.
[ { ##test-vector } ]
[ simple-ops-cpu int-4-rep [ emit-simd-vany? ] test-emit ]
unit-test
TUPLE: convert-cpu < simple-ops-cpu ;
M: convert-cpu %integer>float-vector-reps { int-4-rep } ;
M: convert-cpu %float>integer-vector-reps { float-4-rep } ;
! v>float
[ { } ]
[ convert-cpu float-4-rep [ emit-simd-v>float ] test-emit ]
unit-test
[ { ##integer>float-vector } ]
[ convert-cpu int-4-rep [ emit-simd-v>float ] test-emit ]
unit-test
! v>integer
[ { } ]
[ convert-cpu int-4-rep [ emit-simd-v>integer ] test-emit ]
unit-test
[ { ##float>integer-vector } ]
[ convert-cpu float-4-rep [ emit-simd-v>integer ] test-emit ]
unit-test
! vpack-signed
[ { ##signed-pack-vector } ]
[ simple-ops-cpu int-4-rep [ emit-simd-vpack-signed ] test-emit ]
unit-test
! vpack-unsigned
[ { ##unsigned-pack-vector } ]
[ simple-ops-cpu int-4-rep [ emit-simd-vpack-unsigned ] test-emit ]
unit-test
TUPLE: unpack-head-cpu < simple-ops-cpu ;
M: unpack-head-cpu %unpack-vector-head-reps all-reps ;
TUPLE: unpack-cpu < unpack-head-cpu ;
M: unpack-cpu %unpack-vector-tail-reps all-reps ;
! vunpack-head
[ { ##unpack-vector-head } ]
[ unpack-head-cpu int-4-rep [ emit-simd-vunpack-head ] test-emit ]
unit-test
[ { ##zero-vector ##merge-vector-head } ]
[ simple-ops-cpu uint-4-rep [ emit-simd-vunpack-head ] test-emit ]
unit-test
[ { ##merge-vector-head ##shr-vector-imm } ]
[ shift-imm-cpu int-4-rep [ emit-simd-vunpack-head ] test-emit ]
unit-test
[ { ##zero-vector ##compare-vector ##merge-vector-head } ]
[ compare-cpu int-4-rep [ emit-simd-vunpack-head ] test-emit ]
unit-test
! vunpack-tail
[ { ##unpack-vector-tail } ]
[ unpack-cpu int-4-rep [ emit-simd-vunpack-tail ] test-emit ]
unit-test
[ { ##tail>head-vector ##unpack-vector-head } ]
[ unpack-head-cpu int-4-rep [ emit-simd-vunpack-tail ] test-emit ]
unit-test
[ { ##zero-vector ##merge-vector-tail } ]
[ simple-ops-cpu uint-4-rep [ emit-simd-vunpack-tail ] test-emit ]
unit-test
[ { ##merge-vector-tail ##shr-vector-imm } ]
[ shift-imm-cpu int-4-rep [ emit-simd-vunpack-tail ] test-emit ]
unit-test
[ { ##zero-vector ##compare-vector ##merge-vector-tail } ]
[ compare-cpu int-4-rep [ emit-simd-vunpack-tail ] test-emit ]
unit-test
! with
[ { ##scalar>vector ##shuffle-vector-imm } ]
[ shuffle-imm-cpu float-4-rep [ emit-simd-with ] test-emit ]
unit-test
! gather-2
[ { ##gather-vector-2 } ]
[ simple-ops-cpu double-2-rep [ emit-simd-gather-2 ] test-emit ]
unit-test
! gather-4
[ { ##gather-vector-4 } ]
[ simple-ops-cpu float-4-rep [ emit-simd-gather-4 ] test-emit ]
unit-test
! select
[ { ##shuffle-vector-imm ##vector>scalar } ]
[ shuffle-imm-cpu 1 float-4-rep [ emit-simd-select ] test-emit-literal ]
unit-test
! test with nonliteral/invalid reps
[ simple-ops-cpu [ emit-simd-v+ ] test-emit-nonliteral-rep ]
[ bad-simd-intrinsic? ] must-fail-with
[ simple-ops-cpu f [ emit-simd-v+ ] test-emit ]
[ bad-simd-intrinsic? ] must-fail-with
[ simple-ops-cpu 3 [ emit-simd-v+ ] test-emit ]
[ bad-simd-intrinsic? ] must-fail-with

923
basis/compiler/cfg/intrinsics/simd/simd.factor
View File

@ -1,189 +1,26 @@
! Copyright (C) 2009 Slava Pestov.
! Copyright (C) 2009 Slava Pestov, Joe Groff.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien byte-arrays fry classes.algebra
cpu.architecture kernel math sequences math.vectors
math.vectors.simd.intrinsics macros generalizations combinators
combinators.short-circuit arrays locals
compiler.tree.propagation.info compiler.cfg.builder.blocks
USING: accessors alien alien.c-types byte-arrays fry
classes.algebra cpu.architecture kernel layouts math sequences
math.vectors math.vectors.simd.intrinsics
macros generalizations combinators combinators.short-circuit
arrays locals compiler.tree.propagation.info
compiler.cfg.builder.blocks
compiler.cfg.comparisons
compiler.cfg.stacks compiler.cfg.stacks.local compiler.cfg.hats
compiler.cfg.instructions compiler.cfg.registers
compiler.cfg.intrinsics
compiler.cfg.intrinsics.alien
compiler.cfg.intrinsics.simd.backend
specialized-arrays ;
FROM: alien.c-types => heap-size uchar ushort uint ulonglong float double ;
SPECIALIZED-ARRAYS: uchar ushort uint ulonglong float double ;
FROM: alien.c-types => heap-size char short int longlong float double ;
SPECIALIZED-ARRAYS: char uchar short ushort int uint longlong ulonglong float double ;
IN: compiler.cfg.intrinsics.simd
MACRO: check-elements ( quots -- )
[ length '[ _ firstn ] ]
[ '[ _ spread ] ]
[ length 1 - \ and <repetition> [ ] like ]
tri 3append ;
MACRO: if-literals-match ( quots -- )
[ length ] [ ] [ length ] tri
! n quots n
'[
! node quot
[
dup node-input-infos
_ tail-slice* [ literal>> ] map
dup _ check-elements
] dip
swap [
! node literals quot
[ _ firstn ] dip call
drop
] [ 2drop emit-primitive ] if
] ;
: emit-vector-op ( node quot: ( rep -- ) -- )
{ [ representation? ] } if-literals-match ; inline
: [binary] ( quot -- quot' )
'[ [ ds-drop 2inputs ] dip @ ds-push ] ; inline
: emit-binary-vector-op ( node quot -- )
[binary] emit-vector-op ; inline
: [unary] ( quot -- quot' )
'[ [ ds-drop ds-pop ] dip @ ds-push ] ; inline
: emit-unary-vector-op ( node quot -- )
[unary] emit-vector-op ; inline
: [unary/param] ( quot -- quot' )
'[ [ -2 inc-d ds-pop ] 2dip @ ds-push ] ; inline
: emit-shift-vector-imm-op ( node quot -- )
[unary/param]
{ [ integer? ] [ representation? ] } if-literals-match ; inline
:: emit-shift-vector-op ( node imm-quot var-quot -- )
node node-input-infos 2 tail-slice* first literal>> integer?
[ node imm-quot emit-shift-vector-imm-op ]
[ node var-quot emit-binary-vector-op ] if ; inline
: emit-gather-vector-2 ( node -- )
[ ^^gather-vector-2 ] emit-binary-vector-op ;
: emit-gather-vector-4 ( node -- )
[
ds-drop
[
D 3 peek-loc
D 2 peek-loc
D 1 peek-loc
D 0 peek-loc
-4 inc-d
] dip
^^gather-vector-4
ds-push
] emit-vector-op ;
: shuffle? ( obj -- ? ) { [ array? ] [ [ integer? ] all? ] } 1&& ;
: >variable-shuffle ( shuffle rep -- shuffle' )
rep-component-type heap-size
[ dup <repetition> >byte-array ]
[ iota >byte-array ] bi
'[ _ n*v _ v+ ] map concat ;
: generate-shuffle-vector-imm ( src shuffle rep -- dst )
dup %shuffle-vector-imm-reps member?
[ ^^shuffle-vector-imm ]
[
[ >variable-shuffle ^^load-constant ] keep
^^shuffle-vector
] if ;
: emit-shuffle-vector-imm ( node -- )
! Pad the permutation with zeroes if it's too short, since we
! can't throw an error at this point.
[ [ rep-components 0 pad-tail ] keep generate-shuffle-vector-imm ] [unary/param]
{ [ shuffle? ] [ representation? ] } if-literals-match ;
: emit-shuffle-vector-var ( node -- )
[ ^^shuffle-vector ] [binary]
{ [ %shuffle-vector-reps member? ] } if-literals-match ;
: emit-shuffle-vector ( node -- )
dup node-input-infos {
[ length 3 = ]
[ first class>> byte-array class<= ]
[ second class>> byte-array class<= ]
[ third literal>> representation? ]
} 1&& [ emit-shuffle-vector-var ] [ emit-shuffle-vector-imm ] if ;
: ^^broadcast-vector ( src n rep -- dst )
[ rep-components swap <array> ] keep
generate-shuffle-vector-imm ;
: emit-broadcast-vector ( node -- )
[ ^^broadcast-vector ] [unary/param]
{ [ integer? ] [ representation? ] } if-literals-match ;
: ^^with-vector ( src rep -- dst )
[ ^^scalar>vector ] keep [ 0 ] dip ^^broadcast-vector ;
: ^^select-vector ( src n rep -- dst )
[ ^^broadcast-vector ] keep ^^vector>scalar ;
: emit-select-vector ( node -- )
[ ^^select-vector ] [unary/param]
{ [ integer? ] [ representation? ] } if-literals-match ; inline
: emit-alien-vector-op ( node quot: ( rep -- ) -- )
{ [ %alien-vector-reps member? ] } if-literals-match ; inline
: emit-alien-vector ( node -- )
dup [
'[
ds-drop prepare-alien-getter
_ ^^alien-vector ds-push
]
[ inline-alien-getter? ] inline-alien
] with emit-alien-vector-op ;
: emit-set-alien-vector ( node -- )
dup [
'[
ds-drop prepare-alien-setter ds-pop
_ ##set-alien-vector
]
[ byte-array inline-alien-setter? ]
inline-alien
] with emit-alien-vector-op ;
: generate-not-vector ( src rep -- dst )
dup %not-vector-reps member?
[ ^^not-vector ]
[ [ ^^fill-vector ] [ ^^xor-vector ] bi ] if ;
:: ((generate-compare-vector)) ( src1 src2 rep {cc,swap} -- dst )
{cc,swap} first2 :> ( cc swap? )
swap?
[ src2 src1 rep cc ^^compare-vector ]
[ src1 src2 rep cc ^^compare-vector ] if ;
:: (generate-compare-vector) ( src1 src2 rep orig-cc -- dst )
rep orig-cc %compare-vector-ccs :> ( ccs not? )
ccs empty?
[ rep not? [ ^^fill-vector ] [ ^^zero-vector ] if ]
[
ccs unclip :> ( rest-ccs first-cc )
src1 src2 rep first-cc ((generate-compare-vector)) :> first-dst
rest-ccs first-dst
[ [ src1 src2 rep ] dip ((generate-compare-vector)) rep ^^or-vector ]
reduce
not? [ rep generate-not-vector ] when
] if ;
! compound vector ops
: sign-bit-mask ( rep -- byte-array )
unsign-rep {
signed-rep {
{ char-16-rep [ uchar-array{
HEX: 80 HEX: 80 HEX: 80 HEX: 80
HEX: 80 HEX: 80 HEX: 80 HEX: 80
@ -204,150 +41,628 @@ MACRO: if-literals-match ( quots -- )
} underlying>> ] }
} case ;
:: (generate-minmax-compare-vector) ( src1 src2 rep orig-cc -- dst )
orig-cc order-cc {
{ cc< [ src1 src2 rep ^^max-vector src1 rep cc/= (generate-compare-vector) ] }
{ cc<= [ src1 src2 rep ^^min-vector src1 rep cc= (generate-compare-vector) ] }
{ cc> [ src1 src2 rep ^^min-vector src1 rep cc/= (generate-compare-vector) ] }
{ cc>= [ src1 src2 rep ^^max-vector src1 rep cc= (generate-compare-vector) ] }
} case ;
:: generate-compare-vector ( src1 src2 rep orig-cc -- dst )
: ^load-neg-zero-vector ( rep -- dst )
{
{
[ rep orig-cc %compare-vector-reps member? ]
[ src1 src2 rep orig-cc (generate-compare-vector) ]
}
{
[ rep %min-vector-reps member? ]
[ src1 src2 rep orig-cc (generate-minmax-compare-vector) ]
}
{
[ rep unsign-rep orig-cc %compare-vector-reps member? ]
[
rep sign-bit-mask ^^load-constant :> sign-bits
src1 sign-bits rep ^^xor-vector
src2 sign-bits rep ^^xor-vector
rep unsign-rep orig-cc (generate-compare-vector)
]
}
} cond ;
:: generate-unpack-vector-head ( src rep -- dst )
{
{
[ rep %unpack-vector-head-reps member? ]
[ src rep ^^unpack-vector-head ]
}
{
[ rep unsigned-int-vector-rep? ]
[
rep ^^zero-vector :> zero
src zero rep ^^merge-vector-head
]
}
{
[ rep widen-vector-rep %shr-vector-imm-reps member? ]
[
src src rep ^^merge-vector-head
rep rep-component-type
heap-size 8 * rep widen-vector-rep ^^shr-vector-imm
]
}
[
rep ^^zero-vector :> zero
zero src rep cc> ^^compare-vector :> sign
src sign rep ^^merge-vector-head
]
} cond ;
:: generate-unpack-vector-tail ( src rep -- dst )
{
{
[ rep %unpack-vector-tail-reps member? ]
[ src rep ^^unpack-vector-tail ]
}
{
[ rep %unpack-vector-head-reps member? ]
[
src rep ^^tail>head-vector :> tail
tail rep ^^unpack-vector-head
]
}
{
[ rep unsigned-int-vector-rep? ]
[
rep ^^zero-vector :> zero
src zero rep ^^merge-vector-tail
]
}
{
[ rep widen-vector-rep %shr-vector-imm-reps member? ]
[
src src rep ^^merge-vector-tail
rep rep-component-type
heap-size 8 * rep widen-vector-rep ^^shr-vector-imm
]
}
[
rep ^^zero-vector :> zero
zero src rep cc> ^^compare-vector :> sign
src sign rep ^^merge-vector-tail
]
} cond ;
:: generate-load-neg-zero-vector ( rep -- dst )
rep {
{ float-4-rep [ float-array{ -0.0 -0.0 -0.0 -0.0 } underlying>> ^^load-constant ] }
{ double-2-rep [ double-array{ -0.0 -0.0 } underlying>> ^^load-constant ] }
[ drop rep ^^zero-vector ]
} case ;
:: generate-neg-vector ( src rep -- dst )
rep generate-load-neg-zero-vector
src rep ^^sub-vector ;
: ^load-add-sub-vector ( rep -- dst )
signed-rep {
{ float-4-rep [ float-array{ -0.0 0.0 -0.0 0.0 } underlying>> ^^load-constant ] }
{ double-2-rep [ double-array{ -0.0 0.0 } underlying>> ^^load-constant ] }
{ char-16-rep [ char-array{ -1 0 -1 0 -1 0 -1 0 -1 0 -1 0 -1 0 -1 0 } underlying>> ^^load-constant ] }
{ short-8-rep [ short-array{ -1 0 -1 0 -1 0 -1 0 } underlying>> ^^load-constant ] }
{ int-4-rep [ int-array{ -1 0 -1 0 } underlying>> ^^load-constant ] }
{ longlong-2-rep [ longlong-array{ -1 0 } underlying>> ^^load-constant ] }
} case ;
:: generate-blend-vector ( mask true false rep -- dst )
mask true rep ^^and-vector
: ^load-half-vector ( rep -- dst )
{
{ float-4-rep [ float-array{ 0.5 0.5 0.5 0.5 } underlying>> ^^load-constant ] }
{ double-2-rep [ double-array{ 0.5 0.5 } underlying>> ^^load-constant ] }
} case ;
: >variable-shuffle ( shuffle rep -- shuffle' )
rep-component-type heap-size
[ dup <repetition> >byte-array ]
[ iota >byte-array ] bi
'[ _ n*v _ v+ ] map concat ;
: ^load-immediate-shuffle ( shuffle rep -- dst )
>variable-shuffle ^^load-constant ;
:: ^blend-vector ( mask true false rep -- dst )
true mask rep ^^and-vector
mask false rep ^^andn-vector
rep ^^or-vector ;
:: generate-abs-vector ( src rep -- dst )
: ^not-vector ( src rep -- dst )
{
{
[ rep unsigned-int-vector-rep? ]
[ src ]
}
{
[ rep %abs-vector-reps member? ]
[ src rep ^^abs-vector ]
}
{
[ rep float-vector-rep? ]
[ ^^not-vector ]
[ [ ^^fill-vector ] [ ^^xor-vector ] bi ]
} v-vector-op ;
:: ^((compare-vector)) ( src1 src2 rep {cc,swap} -- dst )
{cc,swap} first2 :> ( cc swap? )
swap?
[ src2 src1 rep cc ^^compare-vector ]
[ src1 src2 rep cc ^^compare-vector ] if ;
:: ^(compare-vector) ( src1 src2 rep orig-cc -- dst )
rep orig-cc %compare-vector-ccs :> ( ccs not? )
ccs empty?
[ rep not? [ ^^fill-vector ] [ ^^zero-vector ] if ]
[
rep generate-load-neg-zero-vector
src rep ^^andn-vector
ccs unclip :> ( rest-ccs first-cc )
src1 src2 rep first-cc ^((compare-vector)) :> first-dst
rest-ccs first-dst
[ [ src1 src2 rep ] dip ^((compare-vector)) rep ^^or-vector ]
reduce
not? [ rep ^not-vector ] when
] if ;
:: ^minmax-compare-vector ( src1 src2 rep cc -- dst )
cc order-cc {
{ cc< [ src1 src2 rep ^^max-vector src1 rep cc/= ^(compare-vector) ] }
{ cc<= [ src1 src2 rep ^^min-vector src1 rep cc= ^(compare-vector) ] }
{ cc> [ src1 src2 rep ^^min-vector src1 rep cc/= ^(compare-vector) ] }
{ cc>= [ src1 src2 rep ^^max-vector src1 rep cc= ^(compare-vector) ] }
} case ;
: ^compare-vector ( src1 src2 rep cc -- dst )
{
[ ^(compare-vector) ]
[ ^minmax-compare-vector ]
{ unsigned-int-vector-rep [| src1 src2 rep cc |
rep sign-bit-mask ^^load-constant :> sign-bits
src1 sign-bits rep ^^xor-vector
src2 sign-bits rep ^^xor-vector
rep signed-rep cc ^(compare-vector)
] }
} vv-cc-vector-op ;
: ^unpack-vector-head ( src rep -- dst )
{
[ ^^unpack-vector-head ]
{ unsigned-int-vector-rep [ [ ^^zero-vector ] [ ^^merge-vector-head ] bi ] }
{ signed-int-vector-rep [| src rep |
src src rep ^^merge-vector-head :> merged
rep rep-component-type heap-size 8 * :> bits
merged bits rep widen-vector-rep ^^shr-vector-imm
] }
{ signed-int-vector-rep [| src rep |
rep ^^zero-vector :> zero
zero src rep cc> ^compare-vector :> sign
src sign rep ^^merge-vector-head
] }
} v-vector-op ;
: ^unpack-vector-tail ( src rep -- dst )
{
[ ^^unpack-vector-tail ]
[ [ ^^tail>head-vector ] [ ^^unpack-vector-head ] bi ]
{ unsigned-int-vector-rep [ [ ^^zero-vector ] [ ^^merge-vector-tail ] bi ] }
{ signed-int-vector-rep [| src rep |
src src rep ^^merge-vector-tail :> merged
rep rep-component-type heap-size 8 * :> bits
merged bits rep widen-vector-rep ^^shr-vector-imm
] }
{ signed-int-vector-rep [| src rep |
rep ^^zero-vector :> zero
zero src rep cc> ^compare-vector :> sign
src sign rep ^^merge-vector-tail
] }
} v-vector-op ;
PREDICATE: fixnum-vector-rep < int-vector-rep
rep-component-type heap-size cell < ;
: ^(sum-vector-2) ( src rep -- dst )
{
[ dupd ^^horizontal-add-vector ]
[| src rep |
src src rep ^^merge-vector-head :> head
src src rep ^^merge-vector-tail :> tail
head tail rep ^^add-vector
]
}
} v-vector-op ;
: ^(sum-vector-4) ( src rep -- dst )
{
[
[ dupd ^^horizontal-add-vector ]
[ dupd ^^horizontal-add-vector ] bi
]
[| src rep |
src src rep ^^merge-vector-head :> head
src src rep ^^merge-vector-tail :> tail
head tail rep ^^add-vector :> src'
rep widen-vector-rep :> rep'
src' src' rep' ^^merge-vector-head :> head'
src' src' rep' ^^merge-vector-tail :> tail'
head' tail' rep ^^add-vector
]
} v-vector-op ;
: ^(sum-vector-8) ( src rep -- dst )
{
[
[ dupd ^^horizontal-add-vector ]
[ dupd ^^horizontal-add-vector ]
[ dupd ^^horizontal-add-vector ] tri
]
[| src rep |
src src rep ^^merge-vector-head :> head
src src rep ^^merge-vector-tail :> tail
head tail rep ^^add-vector :> src'
rep widen-vector-rep :> rep'
src' src' rep' ^^merge-vector-head :> head'
src' src' rep' ^^merge-vector-tail :> tail'
head' tail' rep ^^add-vector :> src''
rep' widen-vector-rep :> rep''
src'' src'' rep'' ^^merge-vector-head :> head''
src'' src'' rep'' ^^merge-vector-tail :> tail''
head'' tail'' rep ^^add-vector
]
} v-vector-op ;
: ^(sum-vector-16) ( src rep -- dst )
{
[
{
[ dupd ^^horizontal-add-vector ]
[ dupd ^^horizontal-add-vector ]
[ dupd ^^horizontal-add-vector ]
[ dupd ^^horizontal-add-vector ]
} cleave
]
[| src rep |
src src rep ^^merge-vector-head :> head
src src rep ^^merge-vector-tail :> tail
head tail rep ^^add-vector :> src'
rep widen-vector-rep :> rep'
src' src' rep' ^^merge-vector-head :> head'
src' src' rep' ^^merge-vector-tail :> tail'
head' tail' rep ^^add-vector :> src''
rep' widen-vector-rep :> rep''
src'' src'' rep'' ^^merge-vector-head :> head''
src'' src'' rep'' ^^merge-vector-tail :> tail''
head'' tail'' rep ^^add-vector :> src'''
rep'' widen-vector-rep :> rep'''
src''' src''' rep''' ^^merge-vector-head :> head'''
src''' src''' rep''' ^^merge-vector-tail :> tail'''
head''' tail''' rep ^^add-vector
]
} v-vector-op ;
: ^(sum-vector) ( src rep -- dst )
[
dup rep-length {
{ 2 [ ^(sum-vector-2) ] }
{ 4 [ ^(sum-vector-4) ] }
{ 8 [ ^(sum-vector-8) ] }
{ 16 [ ^(sum-vector-16) ] }
} case
] [ ^^vector>scalar ] bi ;
: ^sum-vector ( src rep -- dst )
{
{ float-vector-rep [ ^(sum-vector) ] }
{ fixnum-vector-rep [| src rep |
src rep ^unpack-vector-head :> head
src rep ^unpack-vector-tail :> tail
rep widen-vector-rep :> wide-rep
head tail wide-rep ^^add-vector wide-rep
^(sum-vector)
] }
} v-vector-op ;
: shuffle? ( obj -- ? ) { [ array? ] [ [ integer? ] all? ] } 1&& ;
: ^shuffle-vector-imm ( src1 shuffle rep -- dst )
[ rep-length 0 pad-tail ] keep {
[ ^^shuffle-vector-imm ]
[ [ ^load-immediate-shuffle ] [ ^^shuffle-vector ] bi ]
} vl-vector-op ;
: ^broadcast-vector ( src n rep -- dst )
[ rep-length swap <array> ] keep
^shuffle-vector-imm ;
: ^with-vector ( src rep -- dst )
[ ^^scalar>vector ] keep [ 0 ] dip ^broadcast-vector ;
: ^select-vector ( src n rep -- dst )
[ ^broadcast-vector ] keep ^^vector>scalar ;
! intrinsic emitters
: emit-simd-v+ ( node -- )
{
[ ^^add-vector ]
} emit-vv-vector-op ;
: emit-simd-v- ( node -- )
{
[ ^^sub-vector ]
} emit-vv-vector-op ;
: emit-simd-vneg ( node -- )
{
{ float-vector-rep [ [ ^load-neg-zero-vector swap ] [ ^^sub-vector ] bi ] }
{ int-vector-rep [ [ ^^zero-vector swap ] [ ^^sub-vector ] bi ] }
} emit-v-vector-op ;
: emit-simd-v+- ( node -- )
{
[ ^^add-sub-vector ]
{ float-vector-rep [| src1 src2 rep |
rep ^load-add-sub-vector :> signs
src2 signs rep ^^xor-vector :> src2'
src1 src2' rep ^^add-vector
] }
{ int-vector-rep [| src1 src2 rep |
rep ^load-add-sub-vector :> signs
src2 signs rep ^^xor-vector :> src2'
src2' signs rep ^^sub-vector :> src2''
src1 src2'' rep ^^add-vector
] }
} emit-vv-vector-op ;
: emit-simd-vs+ ( node -- )
{
{ float-vector-rep [ ^^add-vector ] }
{ int-vector-rep [ ^^saturated-add-vector ] }
} emit-vv-vector-op ;
: emit-simd-vs- ( node -- )
{
{ float-vector-rep [ ^^sub-vector ] }
{ int-vector-rep [ ^^saturated-sub-vector ] }
} emit-vv-vector-op ;
: emit-simd-vs* ( node -- )
{
{ float-vector-rep [ ^^mul-vector ] }
{ int-vector-rep [ ^^saturated-mul-vector ] }
} emit-vv-vector-op ;
: emit-simd-v* ( node -- )
{
[ ^^mul-vector ]
} emit-vv-vector-op ;
: emit-simd-v*high ( node -- )
{
[ ^^mul-high-vector ]
} emit-vv-vector-op ;
: emit-simd-v*hs+ ( node -- )
{
[ ^^mul-horizontal-add-vector ]
} emit-vv-vector-op ;
: emit-simd-v/ ( node -- )
{
[ ^^div-vector ]
} emit-vv-vector-op ;
: emit-simd-vmin ( node -- )
{
[ ^^min-vector ]
[
[ cc< ^compare-vector ]
[ ^blend-vector ] 3bi
]
} emit-vv-vector-op ;
: emit-simd-vmax ( node -- )
{
[ ^^max-vector ]
[
[ cc> ^compare-vector ]
[ ^blend-vector ] 3bi
]
} emit-vv-vector-op ;
: emit-simd-vavg ( node -- )
{
[ ^^avg-vector ]
{ float-vector-rep [| src1 src2 rep |
src1 src2 rep ^^add-vector
rep ^load-half-vector rep ^^mul-vector
] }
} emit-vv-vector-op ;
: emit-simd-v. ( node -- )
{
[ ^^dot-vector ]
{ float-vector-rep [ [ ^^mul-vector ] [ ^sum-vector ] bi ] }
} emit-vv-vector-op ;
: emit-simd-vsad ( node -- )
{
[
[ ^^sad-vector dup { 2 3 0 1 } int-4-rep ^^shuffle-vector-imm int-4-rep ^^add-vector ]
[ widen-vector-rep ^^vector>scalar ] bi
]
} emit-vv-vector-op ;
: emit-simd-vsqrt ( node -- )
{
[ ^^sqrt-vector ]
} emit-v-vector-op ;
: emit-simd-sum ( node -- )
{
[ ^sum-vector ]
} emit-v-vector-op ;
: emit-simd-vabs ( node -- )
{
{ unsigned-int-vector-rep [ drop ] }
[ ^^abs-vector ]
{ float-vector-rep [ [ ^load-neg-zero-vector ] [ swapd ^^andn-vector ] bi ] }
{ int-vector-rep [| src rep |
rep ^^zero-vector :> zero
zero src rep ^^sub-vector :> -src
zero src rep cc> ^^compare-vector :> sign
sign -src src rep generate-blend-vector
zero src rep cc> ^compare-vector :> sign
sign -src src rep ^blend-vector
] }
} emit-v-vector-op ;
: emit-simd-vand ( node -- )
{
[ ^^and-vector ]
} emit-vv-vector-op ;
: emit-simd-vandn ( node -- )
{
[ ^^andn-vector ]
} emit-vv-vector-op ;
: emit-simd-vor ( node -- )
{
[ ^^or-vector ]
} emit-vv-vector-op ;
: emit-simd-vxor ( node -- )
{
[ ^^xor-vector ]
} emit-vv-vector-op ;
: emit-simd-vnot ( node -- )
{
[ ^not-vector ]
} emit-v-vector-op ;
: emit-simd-vlshift ( node -- )
{
[ ^^shl-vector ]
} {
[ ^^shl-vector-imm ]
} [ integer? ] emit-vv-or-vl-vector-op ;
: emit-simd-vrshift ( node -- )
{
[ ^^shr-vector ]
} {
[ ^^shr-vector-imm ]
} [ integer? ] emit-vv-or-vl-vector-op ;
: emit-simd-hlshift ( node -- )
{
[ ^^horizontal-shl-vector-imm ]
} [ integer? ] emit-vl-vector-op ;
: emit-simd-hrshift ( node -- )
{
[ ^^horizontal-shr-vector-imm ]
} [ integer? ] emit-vl-vector-op ;
: emit-simd-vshuffle-elements ( node -- )
{
[ ^shuffle-vector-imm ]
} [ shuffle? ] emit-vl-vector-op ;
: emit-simd-vshuffle-bytes ( node -- )
{
[ ^^shuffle-vector ]
} emit-vv-vector-op ;
: emit-simd-vmerge-head ( node -- )
{
[ ^^merge-vector-head ]
} emit-vv-vector-op ;
: emit-simd-vmerge-tail ( node -- )
{
[ ^^merge-vector-tail ]
} emit-vv-vector-op ;
: emit-simd-v<= ( node -- )
{
[ cc<= ^compare-vector ]
} emit-vv-vector-op ;
: emit-simd-v< ( node -- )
{
[ cc< ^compare-vector ]
} emit-vv-vector-op ;
: emit-simd-v= ( node -- )
{
[ cc= ^compare-vector ]
} emit-vv-vector-op ;
: emit-simd-v> ( node -- )
{
[ cc> ^compare-vector ]
} emit-vv-vector-op ;
: emit-simd-v>= ( node -- )
{
[ cc>= ^compare-vector ]
} emit-vv-vector-op ;
: emit-simd-vunordered? ( node -- )
{
[ cc/<>= ^compare-vector ]
} emit-vv-vector-op ;
: emit-simd-vany? ( node -- )
{
[ vcc-any ^^test-vector ]
} emit-v-vector-op ;
: emit-simd-vall? ( node -- )
{
[ vcc-all ^^test-vector ]
} emit-v-vector-op ;
: emit-simd-vnone? ( node -- )
{
[ vcc-none ^^test-vector ]
} emit-v-vector-op ;
: emit-simd-v>float ( node -- )
{
{ float-vector-rep [ drop ] }
{ int-vector-rep [ ^^integer>float-vector ] }
} emit-v-vector-op ;
: emit-simd-v>integer ( node -- )
{
{ float-vector-rep [ ^^float>integer-vector ] }
{ int-vector-rep [ drop ] }
} emit-v-vector-op ;
: emit-simd-vpack-signed ( node -- )
{
[ ^^signed-pack-vector ]
} emit-vv-vector-op ;
: emit-simd-vpack-unsigned ( node -- )
{
[ ^^unsigned-pack-vector ]
} emit-vv-vector-op ;
: emit-simd-vunpack-head ( node -- )
{
[ ^unpack-vector-head ]
} emit-v-vector-op ;
: emit-simd-vunpack-tail ( node -- )
{
[ ^unpack-vector-tail ]
} emit-v-vector-op ;
: emit-simd-with ( node -- )
{
{ fixnum-vector-rep [ ^with-vector ] }
{ float-vector-rep [ ^with-vector ] }
} emit-v-vector-op ;
: emit-simd-gather-2 ( node -- )
{
{ fixnum-vector-rep [ ^^gather-vector-2 ] }
{ float-vector-rep [ ^^gather-vector-2 ] }
} emit-vv-vector-op ;
: emit-simd-gather-4 ( node -- )
{
{ fixnum-vector-rep [ ^^gather-vector-4 ] }
{ float-vector-rep [ ^^gather-vector-4 ] }
} emit-vvvv-vector-op ;
: emit-simd-select ( node -- )
{
{ fixnum-vector-rep [ ^select-vector ] }
{ float-vector-rep [ ^select-vector ] }
} [ integer? ] emit-vl-vector-op ;
: emit-alien-vector ( node -- )
dup [
'[
ds-drop prepare-alien-getter
_ ^^alien-vector ds-push
]
} cond ;
[ inline-alien-getter? ] inline-alien
] with { [ %alien-vector-reps member? ] } if-literals-match ;
: generate-min-vector ( src1 src2 rep -- dst )
dup %min-vector-reps member?
[ ^^min-vector ] [
[ cc< generate-compare-vector ]
[ generate-blend-vector ] 3bi
] if ;
: emit-set-alien-vector ( node -- )
dup [
'[
ds-drop prepare-alien-setter ds-pop
_ ##set-alien-vector
]
[ byte-array inline-alien-setter? ]
inline-alien
] with { [ %alien-vector-reps member? ] } if-literals-match ;
: generate-max-vector ( src1 src2 rep -- dst )
dup %max-vector-reps member?
[ ^^max-vector ] [
[ cc> generate-compare-vector ]
[ generate-blend-vector ] 3bi
] if ;
: enable-simd ( -- )
{
{ (simd-v+) [ emit-simd-v+ ] }
{ (simd-v-) [ emit-simd-v- ] }
{ (simd-vneg) [ emit-simd-vneg ] }
{ (simd-v+-) [ emit-simd-v+- ] }
{ (simd-vs+) [ emit-simd-vs+ ] }
{ (simd-vs-) [ emit-simd-vs- ] }
{ (simd-vs*) [ emit-simd-vs* ] }
{ (simd-v*) [ emit-simd-v* ] }
{ (simd-v*high) [ emit-simd-v*high ] }
{ (simd-v*hs+) [ emit-simd-v*hs+ ] }
{ (simd-v/) [ emit-simd-v/ ] }
{ (simd-vmin) [ emit-simd-vmin ] }
{ (simd-vmax) [ emit-simd-vmax ] }
{ (simd-vavg) [ emit-simd-vavg ] }
{ (simd-v.) [ emit-simd-v. ] }
{ (simd-vsad) [ emit-simd-vsad ] }
{ (simd-vsqrt) [ emit-simd-vsqrt ] }
{ (simd-sum) [ emit-simd-sum ] }
{ (simd-vabs) [ emit-simd-vabs ] }
{ (simd-vbitand) [ emit-simd-vand ] }
{ (simd-vbitandn) [ emit-simd-vandn ] }
{ (simd-vbitor) [ emit-simd-vor ] }
{ (simd-vbitxor) [ emit-simd-vxor ] }
{ (simd-vbitnot) [ emit-simd-vnot ] }
{ (simd-vand) [ emit-simd-vand ] }
{ (simd-vandn) [ emit-simd-vandn ] }
{ (simd-vor) [ emit-simd-vor ] }
{ (simd-vxor) [ emit-simd-vxor ] }
{ (simd-vnot) [ emit-simd-vnot ] }
{ (simd-vlshift) [ emit-simd-vlshift ] }
{ (simd-vrshift) [ emit-simd-vrshift ] }
{ (simd-hlshift) [ emit-simd-hlshift ] }
{ (simd-hrshift) [ emit-simd-hrshift ] }
{ (simd-vshuffle-elements) [ emit-simd-vshuffle-elements ] }
{ (simd-vshuffle-bytes) [ emit-simd-vshuffle-bytes ] }
{ (simd-vmerge-head) [ emit-simd-vmerge-head ] }
{ (simd-vmerge-tail) [ emit-simd-vmerge-tail ] }
{ (simd-v<=) [ emit-simd-v<= ] }
{ (simd-v<) [ emit-simd-v< ] }
{ (simd-v=) [ emit-simd-v= ] }
{ (simd-v>) [ emit-simd-v> ] }
{ (simd-v>=) [ emit-simd-v>= ] }
{ (simd-vunordered?) [ emit-simd-vunordered? ] }
{ (simd-vany?) [ emit-simd-vany? ] }
{ (simd-vall?) [ emit-simd-vall? ] }
{ (simd-vnone?) [ emit-simd-vnone? ] }
{ (simd-v>float) [ emit-simd-v>float ] }
{ (simd-v>integer) [ emit-simd-v>integer ] }
{ (simd-vpack-signed) [ emit-simd-vpack-signed ] }
{ (simd-vpack-unsigned) [ emit-simd-vpack-unsigned ] }
{ (simd-vunpack-head) [ emit-simd-vunpack-head ] }
{ (simd-vunpack-tail) [ emit-simd-vunpack-tail ] }
{ (simd-with) [ emit-simd-with ] }
{ (simd-gather-2) [ emit-simd-gather-2 ] }
{ (simd-gather-4) [ emit-simd-gather-4 ] }
{ (simd-select) [ emit-simd-select ] }
{ alien-vector [ emit-alien-vector ] }
{ set-alien-vector [ emit-set-alien-vector ] }
} enable-intrinsics ;
enable-simd

11
basis/compiler/cfg/intrinsics/slots/slots.factor
View File

@ -1,14 +1,17 @@
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: layouts namespaces kernel accessors sequences math
classes.algebra locals combinators cpu.architecture
compiler.tree.propagation.info compiler.cfg.stacks
compiler.cfg.hats compiler.cfg.registers
classes.algebra classes.builtin locals combinators
cpu.architecture compiler.tree.propagation.info
compiler.cfg.stacks compiler.cfg.hats compiler.cfg.registers
compiler.cfg.instructions compiler.cfg.utilities
compiler.cfg.builder.blocks compiler.constants ;
IN: compiler.cfg.intrinsics.slots
: value-tag ( info -- n ) class>> class-type ; inline
: class-tag ( class -- tag/f )
builtins get [ class<= ] with find drop ;
: value-tag ( info -- n ) class>> class-tag ;
: ^^tag-offset>slot ( slot tag -- vreg' )
[ ^^offset>slot ] dip ^^sub-imm ;

0
basis/compiler/cfg/linearization/linearization.factor Executable file → Normal file
View File

2
basis/compiler/cfg/save-contexts/save-contexts-tests.factor
View File

@ -15,7 +15,7 @@ V{
[
V{
T{ ##save-context f 1 2 f }
T{ ##save-context f 1 2 }
T{ ##unary-float-function f 2 3 "sqrt" }
T{ ##branch }
}

12
basis/compiler/cfg/save-contexts/save-contexts.factor
View File

@ -1,4 +1,4 @@
! Copyright (C) 2009 Slava Pestov.
! Copyright (C) 2009, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors combinators.short-circuit
compiler.cfg.instructions compiler.cfg.registers
@ -14,14 +14,7 @@ IN: compiler.cfg.save-contexts
[ ##binary-float-function? ]
[ ##alien-invoke? ]
[ ##alien-indirect? ]
} 1||
] any? ;
: needs-callback-context? ( insns -- ? )
[
{
[ ##alien-invoke? ]
[ ##alien-indirect? ]
[ ##alien-assembly? ]
} 1||
] any? ;
@ -29,7 +22,6 @@ IN: compiler.cfg.save-contexts
dup instructions>> dup needs-save-context? [
int-rep next-vreg-rep
int-rep next-vreg-rep
pick needs-callback-context?
\ ##save-context new-insn prefix
>>instructions drop
] [ 2drop ] if ;

4
basis/compiler/cfg/stacks/stacks.factor Executable file → Normal file
View File

@ -1,4 +1,4 @@
! Copyright (C) 2008, 2009 Slava Pestov.
! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: math sequences kernel namespaces accessors biassocs compiler.cfg
compiler.cfg.instructions compiler.cfg.registers compiler.cfg.hats
@ -33,7 +33,7 @@ IN: compiler.cfg.stacks
: ds-load ( n -- vregs )
dup 0 =
[ drop f ]
[ [ <reversed> [ <ds-loc> peek-loc ] map ] [ neg inc-d ] bi ] if ;
[ [ iota <reversed> [ <ds-loc> peek-loc ] map ] [ neg inc-d ] bi ] if ;
: ds-store ( vregs -- )
[

4
basis/compiler/cfg/stacks/uninitialized/uninitialized.factor
View File

@ -1,4 +1,4 @@
! Copyright (C) 2009 Slava Pestov.
! Copyright (C) 2009, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences byte-arrays namespaces accessors classes math
math.order fry arrays combinators compiler.cfg.registers
@ -55,7 +55,7 @@ M: insn visit-insn drop ;
2dup [ length ] bi@ max '[ _ 1 pad-tail ] bi@ [ bitand ] 2map ;
: (uninitialized-locs) ( seq quot -- seq' )
[ dup length [ drop 0 = ] pusher [ 2each ] dip ] dip map ; inline
[ [ drop 0 = ] pusher [ each-index ] dip ] dip map ; inline
PRIVATE>

3
basis/compiler/cfg/value-numbering/expressions/expressions.factor
View File

@ -27,6 +27,9 @@ C: <reference> reference-expr
M: reference-expr equal?
over reference-expr? [ [ value>> ] bi@ eq? ] [ 2drop f ] if ;
M: reference-expr hashcode*
nip value>> identity-hashcode ;
: constant>vn ( constant -- vn ) <constant> expr>vn ; inline
GENERIC: >expr ( insn -- expr )

103
basis/compiler/cfg/value-numbering/rewrite/rewrite.factor Executable file → Normal file
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: accessors combinators combinators.short-circuit arrays
fry kernel layouts math namespaces sequences cpu.architecture
math.bitwise math.order math.vectors.simd.intrinsics classes
math.bitwise math.order classes
vectors locals make alien.c-types io.binary grouping
compiler.cfg
compiler.cfg.registers
@ -42,6 +42,14 @@ M: insn rewrite drop f ;
] [ drop f ] if ; inline
: general-compare-expr? ( insn -- ? )
{
[ compare-expr? ]
[ compare-imm-expr? ]
[ compare-float-unordered-expr? ]
[ compare-float-ordered-expr? ]
} 1|| ;
: general-or-vector-compare-expr? ( insn -- ? )
{
[ compare-expr? ]
[ compare-imm-expr? ]
@ -52,7 +60,7 @@ M: insn rewrite drop f ;
: rewrite-boolean-comparison? ( insn -- ? )
dup ##branch-t? [
src1>> vreg>expr general-compare-expr?
src1>> vreg>expr general-or-vector-compare-expr?
] [ drop f ] if ; inline
: >compare-expr< ( expr -- in1 in2 cc )
@ -463,100 +471,9 @@ M: ##alien-signed-2 rewrite rewrite-alien-addressing ;
M: ##alien-signed-4 rewrite rewrite-alien-addressing ;
M: ##alien-float rewrite rewrite-alien-addressing ;
M: ##alien-double rewrite rewrite-alien-addressing ;
M: ##alien-vector rewrite rewrite-alien-addressing ;
M: ##set-alien-integer-1 rewrite rewrite-alien-addressing ;
M: ##set-alien-integer-2 rewrite rewrite-alien-addressing ;
M: ##set-alien-integer-4 rewrite rewrite-alien-addressing ;
M: ##set-alien-float rewrite rewrite-alien-addressing ;
M: ##set-alien-double rewrite rewrite-alien-addressing ;
M: ##set-alien-vector rewrite rewrite-alien-addressing ;
! Some lame constant folding for SIMD intrinsics. Eventually this
! should be redone completely.
: rewrite-shuffle-vector-imm ( insn expr -- insn' )
2dup [ rep>> ] bi@ eq? [
[ [ dst>> ] [ src>> vn>vreg ] bi* ]
[ [ shuffle>> ] bi@ nths ]
[ drop rep>> ]
2tri \ ##shuffle-vector-imm new-insn
] [ 2drop f ] if ;
: (fold-shuffle-vector-imm) ( shuffle bytes -- bytes' )
2dup length swap length /i group nths concat ;
: fold-shuffle-vector-imm ( insn expr -- insn' )
[ [ dst>> ] [ shuffle>> ] bi ] dip value>>
(fold-shuffle-vector-imm) \ ##load-constant new-insn ;
M: ##shuffle-vector-imm rewrite
dup src>> vreg>expr {
{ [ dup shuffle-vector-imm-expr? ] [ rewrite-shuffle-vector-imm ] }
{ [ dup reference-expr? ] [ fold-shuffle-vector-imm ] }
{ [ dup constant-expr? ] [ fold-shuffle-vector-imm ] }
[ 2drop f ]
} cond ;
: (fold-scalar>vector) ( insn bytes -- insn' )
[ [ dst>> ] [ rep>> rep-components ] bi ] dip <repetition> concat
\ ##load-constant new-insn ;
: fold-scalar>vector ( insn expr -- insn' )
value>> over rep>> {
{ float-4-rep [ float>bits 4 >le (fold-scalar>vector) ] }
{ double-2-rep [ double>bits 8 >le (fold-scalar>vector) ] }
[ [ untag-fixnum ] dip rep-component-type heap-size >le (fold-scalar>vector) ]
} case ;
M: ##scalar>vector rewrite
dup src>> vreg>expr dup constant-expr?
[ fold-scalar>vector ] [ 2drop f ] if ;
M: ##xor-vector rewrite
dup [ src1>> vreg>vn ] [ src2>> vreg>vn ] bi eq?
[ [ dst>> ] [ rep>> ] bi \ ##zero-vector new-insn ] [ drop f ] if ;
: vector-not? ( expr -- ? )
{
[ not-vector-expr? ]
[ {
[ xor-vector-expr? ]
[ [ src1>> ] [ src2>> ] bi [ vn>expr fill-vector-expr? ] either? ]
} 1&& ]
} 1|| ;
GENERIC: vector-not-src ( expr -- vreg )
M: not-vector-expr vector-not-src src>> vn>vreg ;
M: xor-vector-expr vector-not-src
dup src1>> vn>expr fill-vector-expr? [ src2>> ] [ src1>> ] if vn>vreg ;
M: ##and-vector rewrite
{
{ [ dup src1>> vreg>expr vector-not? ] [
{
[ dst>> ]
[ src1>> vreg>expr vector-not-src ]
[ src2>> ]
[ rep>> ]
} cleave \ ##andn-vector new-insn
] }
{ [ dup src2>> vreg>expr vector-not? ] [
{
[ dst>> ]
[ src2>> vreg>expr vector-not-src ]
[ src1>> ]
[ rep>> ]
} cleave \ ##andn-vector new-insn
] }
[ drop f ]
} cond ;
M: ##andn-vector rewrite
dup src1>> vreg>expr vector-not? [
{
[ dst>> ]
[ src1>> vreg>expr vector-not-src ]
[ src2>> ]
[ rep>> ]
} cleave \ ##and-vector new-insn
] [ drop f ] if ;

120
basis/compiler/cfg/value-numbering/simd/simd.factor Normal file
View File

@ -0,0 +1,120 @@
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors combinators combinators.short-circuit arrays
fry kernel layouts math namespaces sequences cpu.architecture
math.bitwise math.order classes
vectors locals make alien.c-types io.binary grouping
math.vectors.simd.intrinsics
compiler.cfg
compiler.cfg.registers
compiler.cfg.comparisons
compiler.cfg.instructions
compiler.cfg.value-numbering.expressions
compiler.cfg.value-numbering.graph
compiler.cfg.value-numbering.rewrite
compiler.cfg.value-numbering.simplify ;
IN: compiler.cfg.value-numbering.simd
M: ##alien-vector rewrite rewrite-alien-addressing ;
M: ##set-alien-vector rewrite rewrite-alien-addressing ;
! Some lame constant folding for SIMD intrinsics. Eventually this
! should be redone completely.
: rewrite-shuffle-vector-imm ( insn expr -- insn' )
2dup [ rep>> ] bi@ eq? [
[ [ dst>> ] [ src>> vn>vreg ] bi* ]
[ [ shuffle>> ] bi@ nths ]
[ drop rep>> ]
2tri \ ##shuffle-vector-imm new-insn
] [ 2drop f ] if ;
: (fold-shuffle-vector-imm) ( shuffle bytes -- bytes' )
2dup length swap length /i group nths concat ;
: fold-shuffle-vector-imm ( insn expr -- insn' )
[ [ dst>> ] [ shuffle>> ] bi ] dip value>>
(fold-shuffle-vector-imm) \ ##load-constant new-insn ;
M: ##shuffle-vector-imm rewrite
dup src>> vreg>expr {
{ [ dup shuffle-vector-imm-expr? ] [ rewrite-shuffle-vector-imm ] }
{ [ dup reference-expr? ] [ fold-shuffle-vector-imm ] }
{ [ dup constant-expr? ] [ fold-shuffle-vector-imm ] }
[ 2drop f ]
} cond ;
: (fold-scalar>vector) ( insn bytes -- insn' )
[ [ dst>> ] [ rep>> rep-length ] bi ] dip <repetition> concat
\ ##load-constant new-insn ;
: fold-scalar>vector ( insn expr -- insn' )
value>> over rep>> {
{ float-4-rep [ float>bits 4 >le (fold-scalar>vector) ] }
{ double-2-rep [ double>bits 8 >le (fold-scalar>vector) ] }
[ [ untag-fixnum ] dip rep-component-type heap-size >le (fold-scalar>vector) ]
} case ;
M: ##scalar>vector rewrite
dup src>> vreg>expr dup constant-expr?
[ fold-scalar>vector ] [ 2drop f ] if ;
M: ##xor-vector rewrite
dup [ src1>> vreg>vn ] [ src2>> vreg>vn ] bi eq?
[ [ dst>> ] [ rep>> ] bi \ ##zero-vector new-insn ] [ drop f ] if ;
: vector-not? ( expr -- ? )
{
[ not-vector-expr? ]
[ {
[ xor-vector-expr? ]
[ [ src1>> ] [ src2>> ] bi [ vn>expr fill-vector-expr? ] either? ]
} 1&& ]
} 1|| ;
GENERIC: vector-not-src ( expr -- vreg )
M: not-vector-expr vector-not-src src>> vn>vreg ;
M: xor-vector-expr vector-not-src
dup src1>> vn>expr fill-vector-expr? [ src2>> ] [ src1>> ] if vn>vreg ;
M: ##and-vector rewrite
{
{ [ dup src1>> vreg>expr vector-not? ] [
{
[ dst>> ]
[ src1>> vreg>expr vector-not-src ]
[ src2>> ]
[ rep>> ]
} cleave \ ##andn-vector new-insn
] }
{ [ dup src2>> vreg>expr vector-not? ] [
{
[ dst>> ]
[ src2>> vreg>expr vector-not-src ]
[ src1>> ]
[ rep>> ]
} cleave \ ##andn-vector new-insn
] }
[ drop f ]
} cond ;
M: ##andn-vector rewrite
dup src1>> vreg>expr vector-not? [
{
[ dst>> ]
[ src1>> vreg>expr vector-not-src ]
[ src2>> ]
[ rep>> ]
} cleave \ ##and-vector new-insn
] [ drop f ] if ;
M: scalar>vector-expr simplify*
src>> vn>expr {
{ [ dup vector>scalar-expr? ] [ src>> ] }
[ drop f ]
} cond ;
M: shuffle-vector-imm-expr simplify*
[ src>> ] [ shuffle>> ] [ rep>> rep-length iota ] tri
sequence= [ drop f ] unless ;

12
basis/compiler/cfg/value-numbering/simplify/simplify.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors combinators classes math layouts
sequences math.vectors.simd.intrinsics
sequences
compiler.cfg.instructions
compiler.cfg.value-numbering.graph
compiler.cfg.value-numbering.expressions ;
@ -130,16 +130,6 @@ M: box-displaced-alien-expr simplify*
[ 2drop f ]
} cond ;
M: scalar>vector-expr simplify*
src>> vn>expr {
{ [ dup vector>scalar-expr? ] [ src>> ] }
[ drop f ]
} cond ;
M: shuffle-vector-imm-expr simplify*
[ src>> ] [ shuffle>> ] [ rep>> rep-components iota ] tri
sequence= [ drop f ] unless ;
M: expr simplify* drop f ;
: simplify ( expr -- vn )

2
basis/compiler/cfg/value-numbering/value-numbering-tests.factor
View File

@ -4,7 +4,7 @@ cpu.architecture tools.test kernel math combinators.short-circuit
accessors sequences compiler.cfg.predecessors locals compiler.cfg.dce
compiler.cfg.ssa.destruction compiler.cfg.loop-detection
compiler.cfg.representations compiler.cfg assocs vectors arrays
layouts literals namespaces alien ;
layouts literals namespaces alien compiler.cfg.value-numbering.simd ;
IN: compiler.cfg.value-numbering.tests
: trim-temps ( insns -- insns )

41
basis/compiler/codegen/codegen.factor Executable file → Normal file
View File

@ -1,4 +1,4 @@
! Copyright (C) 2008, 2009 Slava Pestov.
! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: namespaces make math math.order math.parser sequences accessors
kernel kernel.private layouts assocs words summary arrays
@ -40,7 +40,7 @@ SYMBOL: labels
V{ } clone calls set ;
: generate-insns ( asm -- code )
dup word>> [
dup label>> [
init-generator
instructions>> [
[ class insn-counts get inc-at ]
@ -61,9 +61,7 @@ SYMBOL: labels
! Special cases
M: ##no-tco generate-insn drop ;
M: ##call generate-insn
word>> dup sub-primitive>>
[ second first % ] [ [ add-call ] [ %call ] bi ] ?if ;
M: ##call generate-insn word>> [ add-call ] [ %call ] bi ;
M: ##jump generate-insn word>> [ add-call ] [ %jump ] bi ;
@ -173,11 +171,15 @@ CODEGEN: ##add-sub-vector %add-sub-vector
CODEGEN: ##sub-vector %sub-vector
CODEGEN: ##saturated-sub-vector %saturated-sub-vector
CODEGEN: ##mul-vector %mul-vector
CODEGEN: ##mul-high-vector %mul-high-vector
CODEGEN: ##mul-horizontal-add-vector %mul-horizontal-add-vector
CODEGEN: ##saturated-mul-vector %saturated-mul-vector
CODEGEN: ##div-vector %div-vector
CODEGEN: ##min-vector %min-vector
CODEGEN: ##max-vector %max-vector
CODEGEN: ##avg-vector %avg-vector
CODEGEN: ##dot-vector %dot-vector
CODEGEN: ##sad-vector %sad-vector
CODEGEN: ##sqrt-vector %sqrt-vector
CODEGEN: ##horizontal-add-vector %horizontal-add-vector
CODEGEN: ##horizontal-sub-vector %horizontal-sub-vector
@ -281,7 +283,7 @@ M: ##gc generate-insn
[ [ uninitialized-locs>> ] [ temp1>> ] bi wipe-locs ]
[ data-values>> save-data-regs ]
[ [ tagged-values>> ] [ temp1>> ] bi save-gc-roots ]
[ [ temp1>> ] [ temp2>> ] bi t %save-context ]
[ [ temp1>> ] [ temp2>> ] bi %save-context ]
[ [ tagged-values>> length ] [ temp1>> ] bi %call-gc ]
[ [ tagged-values>> ] [ temp1>> ] bi load-gc-roots ]
[ data-values>> load-data-regs ]
@ -378,11 +380,11 @@ M: c-type-name flatten-value-type c-type flatten-value-type ;
[ [ parameter-offsets nip ] keep ] dip 2reverse-each ; inline
: prepare-unbox-parameters ( parameters -- offsets types indices )
[ parameter-offsets nip ] [ ] [ length iota reverse ] tri ;
[ parameter-offsets nip ] [ ] [ length iota <reversed> ] tri ;
: unbox-parameters ( offset node -- )
parameters>> swap
'[ prepare-unbox-parameters [ %prepare-unbox [ _ + ] dip unbox-parameter ] 3each ]
'[ prepare-unbox-parameters [ %pop-stack [ _ + ] dip unbox-parameter ] 3each ]
[ length neg %inc-d ]
bi ;
@ -405,7 +407,7 @@ M: c-type-name flatten-value-type c-type flatten-value-type ;
] with-param-regs ;
: box-return* ( node -- )
return>> [ ] [ box-return ] if-void ;
return>> [ ] [ box-return %push-stack ] if-void ;
: check-dlsym ( symbols dll -- )
dup dll-valid? [
@ -434,6 +436,16 @@ M: ##alien-invoke generate-insn
dup %cleanup
box-return* ;
M: ##alien-assembly generate-insn
params>>
! Unbox parameters
dup objects>registers
%prepare-var-args
! Generate assembly
dup quot>> call( -- )
! Box return value
box-return* ;
! ##alien-indirect
M: ##alien-indirect generate-insn
params>>
@ -450,7 +462,7 @@ M: ##alien-indirect generate-insn
! ##alien-callback
: box-parameters ( params -- )
alien-parameters [ box-parameter ] each-parameter ;
alien-parameters [ box-parameter %push-context-stack ] each-parameter ;
: registers>objects ( node -- )
! Generate code for boxing input parameters in a callback.
@ -462,7 +474,7 @@ M: ##alien-indirect generate-insn
TUPLE: callback-context ;
: current-callback ( -- id ) 2 getenv ;
: current-callback ( -- id ) 2 special-object ;
: wait-to-return ( token -- )
dup current-callback eq? [
@ -473,7 +485,7 @@ TUPLE: callback-context ;
: do-callback ( quot token -- )
init-catchstack
[ 2 setenv call ] keep
[ 2 set-special-object call ] keep
wait-to-return ; inline
: callback-return-quot ( ctype -- quot )
@ -494,11 +506,6 @@ TUPLE: callback-context ;
[ callback-context new do-callback ] %
] [ ] make ;
M: ##callback-return generate-insn
#! All the extra book-keeping for %unwind is only for x86.
#! On other platforms its an alias for %return.
params>> %callback-return ;
M: ##alien-callback generate-insn
params>>
[ registers>objects ]

43
basis/compiler/codegen/fixup/fixup.factor Executable file → Normal file
View File

@ -1,15 +1,20 @@
! Copyright (C) 2007, 2009 Slava Pestov.
! Copyright (C) 2007, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays byte-arrays byte-vectors generic assocs hashtables
io.binary kernel kernel.private math namespaces make sequences
words quotations strings alien.accessors alien.strings layouts
system combinators math.bitwise math.order
accessors growable fry generalizations compiler.constants ;
system combinators math.bitwise math.order generalizations
accessors growable fry compiler.constants memoize ;
IN: compiler.codegen.fixup
! Owner
SYMBOL: compiling-word
! Parameter table
SYMBOL: parameter-table
: add-parameter ( obj -- ) parameter-table get push ;
! Literal table
SYMBOL: literal-table
@ -29,13 +34,10 @@ TUPLE: label offset ;
dup label? [ get ] unless
compiled-offset >>offset drop ;
: offset-for-class ( class -- n )
rc-absolute-cell = cell 4 ? compiled-offset swap - ;
TUPLE: label-fixup { label label } { class integer } { offset integer } ;
: label-fixup ( label class -- )
dup offset-for-class \ label-fixup boa label-table get push ;
compiled-offset \ label-fixup boa label-table get push ;
! Relocation table
SYMBOL: relocation-table
@ -48,28 +50,28 @@ SYMBOL: relocation-table
{ 0 24 28 } bitfield relocation-table get push-4 ;
: rel-fixup ( class type -- )
swap dup offset-for-class add-relocation-entry ;
swap compiled-offset add-relocation-entry ;
: add-dlsym-literals ( symbol dll -- )
[ string>symbol add-literal ] [ add-literal ] bi* ;
! Caching common symbol names reduces image size a bit
MEMO: cached-string>symbol ( symbol -- obj ) string>symbol ;
: add-dlsym-parameters ( symbol dll -- )
[ cached-string>symbol add-parameter ] [ add-parameter ] bi* ;
: rel-dlsym ( name dll class -- )
[ add-dlsym-literals ] dip rt-dlsym rel-fixup ;
[ add-dlsym-parameters ] dip rt-dlsym rel-fixup ;
: rel-word ( word class -- )
[ add-literal ] dip rt-xt rel-fixup ;
[ add-literal ] dip rt-entry-point rel-fixup ;
: 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 -- )
[ add-literal ] dip rt-xt-pic-tail rel-fixup ;
: rel-primitive ( word class -- )
[ def>> first add-literal ] dip rt-primitive rel-fixup ;
[ add-literal ] dip rt-entry-point-pic-tail rel-fixup ;
: rel-immediate ( literal class -- )
[ add-literal ] dip rt-immediate rel-fixup ;
[ add-literal ] dip rt-literal rel-fixup ;
: rel-this ( class -- )
rt-this rel-fixup ;
@ -78,7 +80,7 @@ SYMBOL: relocation-table
[ add-literal ] dip rt-here rel-fixup ;
: rel-vm ( offset class -- )
[ add-literal ] dip rt-vm rel-fixup ;
[ add-parameter ] dip rt-vm rel-fixup ;
: rel-cards-offset ( class -- )
rt-cards-offset rel-fixup ;
@ -105,6 +107,7 @@ SYMBOL: relocation-table
: init-fixup ( word -- )
compiling-word set
V{ } clone parameter-table set
V{ } clone literal-table set
V{ } clone label-table set
BV{ } clone relocation-table set ;
@ -114,7 +117,7 @@ SYMBOL: relocation-table
init-fixup
@
label-table [ resolve-labels ] change
compiling-word get
parameter-table get >array
literal-table get >array
relocation-table get >byte-array
label-table get

39
basis/compiler/compiler.factor Executable file → Normal file
View File

@ -5,13 +5,16 @@ continuations vocabs assocs dlists definitions math graphs generic
generic.single combinators deques search-deques macros
source-files.errors combinators.short-circuit
stack-checker stack-checker.state stack-checker.inlining stack-checker.errors
stack-checker stack-checker.dependencies stack-checker.inlining
stack-checker.errors
compiler.errors compiler.units compiler.utilities
compiler.tree.builder
compiler.tree.optimizer
compiler.crossref
compiler.cfg
compiler.cfg.builder
compiler.cfg.optimizer
@ -29,7 +32,6 @@ SYMBOL: compiled
[ "forgotten" word-prop ]
[ compiled get key? ]
[ inlined-block? ]
[ primitive? ]
} 1|| not ;
: queue-compile ( word -- )
@ -60,17 +62,23 @@ M: method-body no-compile? "method-generic" word-prop no-compile? ;
M: predicate-engine-word no-compile? "owner-generic" word-prop no-compile? ;
M: word no-compile?
{
[ macro? ]
[ inline? ]
[ "special" word-prop ]
[ "no-compile" word-prop ]
} 1|| ;
{ [ macro? ] [ "special" word-prop ] [ "no-compile" word-prop ] } 1|| ;
GENERIC: combinator? ( word -- ? )
M: method-body combinator? "method-generic" word-prop combinator? ;
M: predicate-engine-word combinator? "owner-generic" word-prop combinator? ;
M: word combinator? inline? ;
: ignore-error? ( word error -- ? )
#! Ignore some errors on inline combinators, macros, and special
#! words such as 'call'.
[ no-compile? ] [ { [ do-not-compile? ] [ literal-expected? ] } 1|| ] bi* and ;
{
[ drop no-compile? ]
[ [ combinator? ] [ unknown-macro-input? ] bi* and ]
} 2|| ;
: finish ( word -- )
#! Recompile callers if the word's stack effect changed, then
@ -117,7 +125,10 @@ M: word no-compile?
} cond ;
: optimize? ( word -- ? )
single-generic? not ;
{
[ single-generic? ]
[ primitive? ]
} 1|| not ;
: contains-breakpoints? ( -- ? )
dependencies get keys [ "break?" word-prop ] any? ;
@ -193,6 +204,14 @@ M: optimizing-compiler recompile ( words -- alist )
] with-scope
"--- compile done" compiler-message ;
M: optimizing-compiler to-recompile ( -- words )
changed-definitions get compiled-usages
changed-generics get compiled-generic-usages
append assoc-combine keys ;
M: optimizing-compiler process-forgotten-words
[ delete-compiled-xref ] each ;
: with-optimizer ( quot -- )
[ optimizing-compiler compiler-impl ] dip with-variable ; inline

41
basis/compiler/constants/constants.factor
View File

@ -1,4 +1,4 @@
! Copyright (C) 2008, 2009 Slava Pestov.
! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: math kernel layouts system strings words quotations byte-arrays
alien arrays literals sequences ;
@ -20,11 +20,18 @@ CONSTANT: deck-bits 18
: alien-offset ( -- n ) 4 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
: word-xt-offset ( -- n ) 10 \ word type-number slot-offset ; inline
: quot-xt-offset ( -- n ) 4 quotation type-number slot-offset ; inline
: word-entry-point-offset ( -- n ) 10 \ word 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
: array-start-offset ( -- n ) 2 array type-number slot-offset ; inline
: compiled-header-size ( -- n ) 4 bootstrap-cells ; inline
: callstack-length-offset ( -- n ) 1 \ callstack type-number slot-offset ; inline
: callstack-top-offset ( -- n ) 2 \ callstack type-number slot-offset ; inline
: vm-context-offset ( -- n ) 0 bootstrap-cells ; inline
: context-callstack-top-offset ( -- n ) 0 bootstrap-cells ; inline
: context-callstack-bottom-offset ( -- n ) 1 bootstrap-cells ; inline
: context-datastack-offset ( -- n ) 2 bootstrap-cells ; inline
: context-retainstack-offset ( -- n ) 3 bootstrap-cells ; inline
! Relocation classes
CONSTANT: rc-absolute-cell 0
@ -37,23 +44,21 @@ CONSTANT: rc-relative-ppc-3 6
CONSTANT: rc-relative-arm-3 7
CONSTANT: rc-indirect-arm 8
CONSTANT: rc-indirect-arm-pc 9
CONSTANT: rc-absolute-2 10
! Relocation types
CONSTANT: rt-primitive 0
CONSTANT: rt-dlsym 1
CONSTANT: rt-dispatch 2
CONSTANT: rt-xt 3
CONSTANT: rt-xt-pic 4
CONSTANT: rt-xt-pic-tail 5
CONSTANT: rt-here 6
CONSTANT: rt-this 7
CONSTANT: rt-immediate 8
CONSTANT: rt-stack-chain 9
CONSTANT: rt-untagged 10
CONSTANT: rt-megamorphic-cache-hits 11
CONSTANT: rt-vm 12
CONSTANT: rt-cards-offset 13
CONSTANT: rt-decks-offset 14
CONSTANT: rt-dlsym 0
CONSTANT: rt-entry-point 1
CONSTANT: rt-entry-point-pic 2
CONSTANT: rt-entry-point-pic-tail 3
CONSTANT: rt-here 4
CONSTANT: rt-this 5
CONSTANT: rt-literal 6
CONSTANT: rt-untagged 7
CONSTANT: rt-megamorphic-cache-hits 8
CONSTANT: rt-vm 9
CONSTANT: rt-cards-offset 10
CONSTANT: rt-decks-offset 11
: rc-absolute? ( n -- ? )
${ rc-absolute-ppc-2/2 rc-absolute-cell rc-absolute } member? ;

0
basis/cords/authors.txt → basis/compiler/crossref/authors.txt
View File

68
basis/compiler/crossref/crossref.factor Normal file
View File

@ -0,0 +1,68 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: assocs classes.algebra compiler.units definitions graphs
grouping kernel namespaces sequences words
stack-checker.dependencies ;
IN: compiler.crossref
SYMBOL: compiled-crossref
compiled-crossref [ H{ } clone ] initialize
SYMBOL: compiled-generic-crossref
compiled-generic-crossref [ H{ } clone ] initialize
: compiled-usage ( word -- assoc )
compiled-crossref get at ;
: (compiled-usages) ( word -- assoc )
#! If the word is not flushable anymore, we have to recompile
#! all words which flushable away a call (presumably when the
#! word was still flushable). If the word is flushable, we
#! don't have to recompile words that folded this away.
[ compiled-usage ]
[ "flushable" word-prop inlined-dependency flushed-dependency ? ] bi
[ dependency>= nip ] curry assoc-filter ;
: compiled-usages ( seq -- assocs )
[ drop word? ] assoc-filter
[ [ drop (compiled-usages) ] { } assoc>map ] keep suffix ;
: compiled-generic-usage ( word -- assoc )
compiled-generic-crossref get at ;
: (compiled-generic-usages) ( generic class -- assoc )
[ compiled-generic-usage ] dip
[
2dup [ valid-class? ] both?
[ classes-intersect? ] [ 2drop f ] if nip
] curry assoc-filter ;
: compiled-generic-usages ( assoc -- assocs )
[ (compiled-generic-usages) ] { } assoc>map ;
: (compiled-xref) ( word dependencies word-prop variable -- )
[ [ concat ] dip set-word-prop ] [ get add-vertex* ] bi-curry* 2bi ;
: compiled-xref ( word dependencies generic-dependencies -- )
[ [ drop crossref? ] { } assoc-filter-as ] bi@
[ "compiled-uses" compiled-crossref (compiled-xref) ]
[ "compiled-generic-uses" compiled-generic-crossref (compiled-xref) ]
bi-curry* bi ;
: (compiled-unxref) ( word word-prop variable -- )
[ [ [ dupd word-prop 2 <groups> ] dip get remove-vertex* ] 2curry ]
[ drop [ remove-word-prop ] curry ]
2bi bi ;
: compiled-unxref ( word -- )
[ "compiled-uses" compiled-crossref (compiled-unxref) ]
[ "compiled-generic-uses" compiled-generic-crossref (compiled-unxref) ]
bi ;
: delete-compiled-xref ( word -- )
[ compiled-unxref ]
[ compiled-crossref get delete-at ]
[ compiled-generic-crossref get delete-at ]
tri ;

18
basis/compiler/tests/alien.factor Executable file → Normal file
View File

@ -94,6 +94,8 @@ FUNCTION: TINY ffi_test_17 int x ;
{ 1 1 } [ indirect-test-1 ] must-infer-as
[ B{ } indirect-test-1 ] [ { "kernel-error" 3 6 B{ } } = ] must-fail-with
[ 3 ] [ &: ffi_test_1 indirect-test-1 ] unit-test
: indirect-test-1' ( ptr -- )
@ -162,7 +164,7 @@ FUNCTION: void ffi_test_20 double x1, double x2, double x3,
{ int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int }
alien-invoke gc 3 ;
[ 861 3 ] [ 42 [ ] each ffi_test_31 ] unit-test
[ 861 3 ] [ 42 [ ] each-integer ffi_test_31 ] unit-test
: ffi_test_31_point_5 ( a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a -- result )
float
@ -170,7 +172,7 @@ FUNCTION: void ffi_test_20 double x1, double x2, double x3,
{ float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float }
alien-invoke ;
[ 861.0 ] [ 42 [ >float ] each ffi_test_31_point_5 ] unit-test
[ 861.0 ] [ 42 [ >float ] each-integer ffi_test_31_point_5 ] unit-test
FUNCTION: longlong ffi_test_21 long x long y ;
@ -314,7 +316,7 @@ FUNCTION: ulonglong ffi_test_38 ( ulonglong x, ulonglong y ) ;
: callback-1 ( -- callback ) void { } "cdecl" [ ] alien-callback ;
[ 0 1 ] [ [ callback-1 ] infer [ in>> ] [ out>> ] bi ] unit-test
[ 0 1 ] [ [ callback-1 ] infer [ in>> length ] [ out>> length ] bi ] unit-test
[ t ] [ callback-1 alien? ] unit-test
@ -375,9 +377,7 @@ FUNCTION: ulonglong ffi_test_38 ( ulonglong x, ulonglong y ) ;
[ f ] [ namespace global eq? ] unit-test
: callback-8 ( -- callback )
void { } "cdecl" [
[ continue ] callcc0
] alien-callback ;
void { } "cdecl" [ [ ] in-thread yield ] alien-callback ;
[ ] [ callback-8 callback_test_1 ] unit-test
@ -588,5 +588,9 @@ FUNCTION: short ffi_test_48 ( bool-field-test x ) ;
! Regression: calling an undefined function would raise a protection fault
FUNCTION: void this_does_not_exist ( ) ;
[ this_does_not_exist ] [ { "kernel-error" 10 f f } = ] must-fail-with
[ this_does_not_exist ] [ { "kernel-error" 9 f f } = ] must-fail-with
! More alien-assembly tests are in cpu.* vocabs
: assembly-test-1 ( -- ) void { } "cdecl" [ ] alien-assembly ;
[ ] [ assembly-test-1 ] unit-test

4
basis/compiler/tests/codegen.factor
View File

@ -116,7 +116,7 @@ unit-test
1 1.0 2.5 try-breaking-dispatch "bye" = [ 3.5 = ] dip and ;
[ t ] [
10000000 [ drop try-breaking-dispatch-2 ] all?
10000000 [ drop try-breaking-dispatch-2 ] all-integers?
] unit-test
! Regression
@ -314,7 +314,7 @@ cell 4 = [
! Bug with ##return node construction
: return-recursive-bug ( nodes -- ? )
{ fixnum } declare [
{ fixnum } declare iota [
dup 3 bitand 1 = [ drop t ] [
dup 3 bitand 2 = [
return-recursive-bug

27
basis/compiler/tests/float.factor
View File

@ -1,5 +1,5 @@
USING: compiler.units compiler kernel kernel.private memory math
math.private tools.test math.floats.private ;
math.private tools.test math.floats.private math.order fry ;
IN: compiler.tests.float
[ 5.0 ] [ [ 5.0 ] compile-call gc gc gc ] unit-test
@ -84,11 +84,6 @@ IN: compiler.tests.float
[ 315 315.0 ] [ 313 [ 2 fixnum+fast dup fixnum>float ] compile-call ] unit-test
[ 17.5 ] [ -11.3 17.5 [ float-max ] compile-call ] unit-test
[ 17.5 ] [ 17.5 -11.3 [ float-max ] compile-call ] unit-test
[ -11.3 ] [ -11.3 17.5 [ float-min ] compile-call ] unit-test
[ -11.3 ] [ 17.5 -11.3 [ float-min ] compile-call ] unit-test
[ t ] [ 0/0. 0/0. [ float-unordered? ] compile-call ] unit-test
[ t ] [ 0/0. 1.0 [ float-unordered? ] compile-call ] unit-test
[ t ] [ 1.0 0/0. [ float-unordered? ] compile-call ] unit-test
@ -100,3 +95,23 @@ IN: compiler.tests.float
[ 1 ] [ 1.0 0/0. [ float-unordered? [ 1 ] [ 2 ] if ] compile-call ] unit-test
[ 2 ] [ 3.0 1.0 [ float-unordered? [ 1 ] [ 2 ] if ] compile-call ] unit-test
[ 2 ] [ 1.0 3.0 [ float-unordered? [ 1 ] [ 2 ] if ] compile-call ] unit-test
! Ensure that float-min and min, and float-max and max, have
! consistent behavior with respect to NaNs
: two-floats ( a b -- a b ) { float float } declare ; inline
[ -11.3 ] [ -11.3 17.5 [ two-floats min ] compile-call ] unit-test
[ -11.3 ] [ 17.5 -11.3 [ two-floats min ] compile-call ] unit-test
[ 17.5 ] [ -11.3 17.5 [ two-floats max ] compile-call ] unit-test
[ 17.5 ] [ 17.5 -11.3 [ two-floats max ] compile-call ] unit-test
: check-compiled-binary-op ( a b word -- )
[ '[ [ [ two-floats _ execute ] compile-call ] call( a b -- c ) ] ]
[ '[ _ execute ] ]
bi 2bi fp-bitwise= ; inline
[ t ] [ 0/0. 3.0 \ min check-compiled-binary-op ] unit-test
[ t ] [ 3.0 0/0. \ min check-compiled-binary-op ] unit-test
[ t ] [ 0/0. 3.0 \ max check-compiled-binary-op ] unit-test
[ t ] [ 3.0 0/0. \ max check-compiled-binary-op ] unit-test

15
basis/compiler/tests/intrinsics.factor Executable file → Normal file
View File

@ -21,7 +21,6 @@ IN: compiler.tests.intrinsics
[ 2 1 3 ] [ 1 2 3 [ swapd ] compile-call ] unit-test
[ 2 ] [ 1 2 [ nip ] compile-call ] unit-test
[ 3 ] [ 1 2 3 [ 2nip ] compile-call ] unit-test
[ 2 1 2 ] [ 1 2 [ tuck ] compile-call ] unit-test
[ 1 2 1 ] [ 1 2 [ over ] compile-call ] unit-test
[ 1 2 3 1 ] [ 1 2 3 [ pick ] compile-call ] unit-test
[ 2 1 ] [ 1 2 [ swap ] compile-call ] unit-test
@ -55,8 +54,8 @@ IN: compiler.tests.intrinsics
[ HEX: 123456 ] [ 1 [ "a\u123456c" string-nth ] compile-call ] unit-test
[ HEX: 123456 ] [ [ 1 "a\u123456c" string-nth ] compile-call ] unit-test
[ ] [ [ 0 getenv ] compile-call drop ] unit-test
[ ] [ 1 getenv [ 1 setenv ] compile-call ] unit-test
[ ] [ [ 0 special-object ] compile-call drop ] unit-test
[ ] [ 1 special-object [ 1 set-special-object ] compile-call ] unit-test
[ ] [ 1 [ drop ] compile-call ] unit-test
[ ] [ [ 1 drop ] compile-call ] unit-test
@ -338,7 +337,7 @@ ERROR: bug-in-fixnum* x y a b ;
[ ] [
10000 [
5 random [ drop 32 random-bits ] map product >bignum
5 random iota [ drop 32 random-bits ] map product >bignum
dup [ bignum>fixnum ] keep compiled-bignum>fixnum =
[ drop ] [ "Oops" throw ] if
] times
@ -586,16 +585,16 @@ TUPLE: alien-accessor-regression { b byte-array } { i fixnum } ;
swap [
{ tuple } declare 1 slot
] [
0 slot
1 slot
] if ;
[ t ] [ f B{ } mutable-value-bug-1 byte-array type-number = ] unit-test
[ 0 ] [ f { } mutable-value-bug-1 ] unit-test
: mutable-value-bug-2 ( a b -- c )
swap [
0 slot
1 slot
] [
{ tuple } declare 1 slot
] if ;
[ t ] [ t B{ } mutable-value-bug-2 byte-array type-number = ] unit-test
[ 0 ] [ t { } mutable-value-bug-2 ] unit-test

24
basis/compiler/tests/optimizer.factor
View File

@ -4,7 +4,7 @@ sbufs strings tools.test vectors words sequences.private
quotations classes classes.algebra classes.tuple.private
continuations growable namespaces hints alien.accessors
compiler.tree.builder compiler.tree.optimizer sequences.deep
compiler definitions generic.single shuffle ;
compiler definitions generic.single shuffle math.order ;
IN: compiler.tests.optimizer
GENERIC: xyz ( obj -- obj )
@ -90,7 +90,7 @@ TUPLE: pred-test ;
: double-label-2 ( a -- b )
dup array? [ ] [ ] if 0 t double-label-1 ;
[ 0 ] [ 10 double-label-2 ] unit-test
[ 0 ] [ 10 iota double-label-2 ] unit-test
! regression
GENERIC: void-generic ( obj -- * )
@ -208,7 +208,7 @@ USE: binary-search.private
] if ; inline recursive
[ 10 ] [
10 20 >vector <flat-slice>
10 20 iota <flat-slice>
[ [ - ] swap old-binsearch ] compile-call 2nip
] unit-test
@ -349,7 +349,7 @@ TUPLE: some-tuple x ;
[ 5 ] [ { 1 2 { 3 { 4 5 } } } deep-find-test ] unit-test
[ f ] [ { 1 2 { 3 { 4 } } } deep-find-test ] unit-test
[ B{ 0 1 2 3 4 5 6 7 } ] [ [ 8 [ ] B{ } map-as ] compile-call ] unit-test
[ B{ 0 1 2 3 4 5 6 7 } ] [ [ 8 iota [ ] B{ } map-as ] compile-call ] unit-test
[ 0 ] [ 1234 [ { fixnum } declare -64 shift ] compile-call ] unit-test
@ -445,5 +445,17 @@ M: object bad-dispatch-position-test* ;
[ 1024 bignum ] [ 10 [ 1 >bignum swap >fixnum shift ] compile-call dup class ] unit-test
! Not sure if I want to fix this...
! [ t [ [ f ] [ 3 ] if >fixnum ] compile-call ] [ no-method? ] must-fail-with
TUPLE: grid-mesh-tuple { length read-only } { step read-only } ;
: grid-mesh-test-case ( -- vertices )
1.0 1.0 { 2 } first /f [ /i 1 + ] keep grid-mesh-tuple boa
1 f <array>
[
[ drop length>> >fixnum 2 min ] 2keep
[
[ step>> 1 * ] dip
0 swap set-nth-unsafe
] 2curry times
] keep ;
[ { 0.5 } ] [ grid-mesh-test-case ] unit-test

17
basis/compiler/tests/redefine3.factor
View File

@ -1,6 +1,6 @@
USING: accessors compiler compiler.units tools.test math parser
kernel sequences sequences.private classes.mixin generic
definitions arrays words assocs eval ;
definitions arrays words assocs eval grouping ;
IN: compiler.tests.redefine3
GENERIC: sheeple ( obj -- x )
@ -13,20 +13,23 @@ M: empty-mixin sheeple drop "wake up" ; inline
: sheeple-test ( -- string ) { } sheeple ;
: compiled-use? ( key word -- ? )
"compiled-uses" word-prop 2 <groups> key? ;
[ "sheeple" ] [ sheeple-test ] unit-test
[ t ] [ \ sheeple-test optimized? ] unit-test
[ t ] [ object \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test
[ f ] [ empty-mixin \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test
[ t ] [ object \ sheeple method \ sheeple-test compiled-use? ] unit-test
[ f ] [ empty-mixin \ sheeple method \ sheeple-test compiled-use? ] unit-test
[ ] [ "IN: compiler.tests.redefine3 USE: arrays INSTANCE: array empty-mixin" eval( -- ) ] unit-test
[ "wake up" ] [ sheeple-test ] unit-test
[ f ] [ object \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test
[ t ] [ empty-mixin \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test
[ f ] [ object \ sheeple method \ sheeple-test compiled-use? ] unit-test
[ t ] [ empty-mixin \ sheeple method \ sheeple-test compiled-use? ] unit-test
[ ] [ [ array empty-mixin remove-mixin-instance ] with-compilation-unit ] unit-test
[ "sheeple" ] [ sheeple-test ] unit-test
[ t ] [ \ sheeple-test optimized? ] unit-test
[ t ] [ object \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test
[ f ] [ empty-mixin \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test
[ t ] [ object \ sheeple method \ sheeple-test compiled-use? ] unit-test
[ f ] [ empty-mixin \ sheeple method \ sheeple-test compiled-use? ] unit-test

0
basis/compiler/tests/stack-trace.factor Executable file → Normal file
View File

0
basis/compiler/tree/builder/builder-tests.factor Executable file → Normal file
View File

2
basis/compiler/tree/builder/builder.factor
View File

@ -39,7 +39,7 @@ M: word (build-tree)
[
<recursive-state> recursive-state set
V{ } clone stack-visitor set
[ [ >vector \ meta-d set ] [ length d-in set ] bi ]
[ [ >vector \ meta-d set ] [ length input-count set ] bi ]
[ (build-tree) ]
bi*
] with-infer nip ;

4
basis/compiler/tree/checker/checker.factor Executable file → Normal file
View File

@ -185,9 +185,7 @@ M: #recursive check-stack-flow*
M: #copy check-stack-flow* [ check-in-d ] [ check-out-d ] bi ;
M: #alien-invoke check-stack-flow* [ check-in-d ] [ check-out-d ] bi ;
M: #alien-indirect check-stack-flow* [ check-in-d ] [ check-out-d ] bi ;
M: #alien-node check-stack-flow* [ check-in-d ] [ check-out-d ] bi ;
M: #alien-callback check-stack-flow* drop ;

15
basis/compiler/tree/cleanup/cleanup-tests.factor Executable file → Normal file
View File

@ -339,28 +339,23 @@ cell-bits 32 = [
] unit-test
[ t ] [
[ { fixnum } declare length [ drop ] each-integer ]
[ { fixnum } declare iota [ drop ] each ]
{ < <-integer-fixnum +-integer-fixnum + } inlined?
] unit-test
[ t ] [
[ { fixnum } declare [ drop ] each ]
{ < <-integer-fixnum +-integer-fixnum + } inlined?
] unit-test
[ t ] [
[ { fixnum } declare 0 [ + ] reduce ]
[ { fixnum } declare iota 0 [ + ] reduce ]
{ < <-integer-fixnum nth-unsafe } inlined?
] unit-test
[ f ] [
[ { fixnum } declare 0 [ + ] reduce ]
[ { fixnum } declare iota 0 [ + ] reduce ]
\ +-integer-fixnum inlined?
] unit-test
[ f ] [
[
{ integer } declare [ ] map
{ integer } declare iota [ ] map
] \ >fixnum inlined?
] unit-test
@ -403,7 +398,7 @@ cell-bits 32 = [
[ t ] [
[
{ integer } declare [ 0 >= ] map
{ integer } declare iota [ 0 >= ] map
] { >= fixnum>= } inlined?
] unit-test

2
basis/compiler/tree/cleanup/cleanup.factor
View File

@ -3,7 +3,7 @@
USING: kernel accessors sequences combinators fry
classes.algebra namespaces assocs words math math.private
math.partial-dispatch math.intervals classes classes.tuple
classes.tuple.private layouts definitions stack-checker.state
classes.tuple.private layouts definitions stack-checker.dependencies
stack-checker.branches
compiler.utilities
compiler.tree

0
basis/compiler/tree/combinators/combinators.factor Executable file → Normal file
View File

4
basis/compiler/tree/dead-code/branches/branches.factor
View File

@ -1,4 +1,4 @@
! Copyright (C) 2008 Slava Pestov.
! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: sequences namespaces kernel accessors assocs sets fry
arrays combinators columns stack-checker.backend
@ -36,7 +36,7 @@ M: #branch remove-dead-code*
: drop-indexed-values ( values indices -- node )
[ drop filter-live ] [ swap nths ] 2bi
[ make-values ] keep
[ length make-values ] keep
[ drop ] [ zip ] 2bi
#data-shuffle ;

6
basis/compiler/tree/dead-code/recursive/recursive.factor
View File

@ -1,4 +1,4 @@
! Copyright (C) 2008 Slava Pestov.
! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs sequences kernel locals fry
combinators stack-checker.backend
@ -24,7 +24,7 @@ M: #call-recursive compute-live-values*
:: drop-dead-inputs ( inputs outputs -- #shuffle )
inputs filter-live
outputs inputs filter-corresponding make-values
outputs inputs filter-corresponding length make-values
outputs
inputs
drop-values ;
@ -39,7 +39,7 @@ M: #enter-recursive remove-dead-code*
2bi ;
:: (drop-call-recursive-outputs) ( inputs outputs -- #shuffle )
inputs outputs filter-corresponding make-values :> new-live-outputs
inputs outputs filter-corresponding length make-values :> new-live-outputs
outputs filter-live :> live-outputs
new-live-outputs
live-outputs

19
basis/compiler/tree/dead-code/simple/simple.factor Executable file → Normal file
View File

@ -1,8 +1,8 @@
! Copyright (C) 2008 Slava Pestov.
! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors words assocs sequences arrays namespaces
fry locals definitions classes classes.algebra generic
stack-checker.state
stack-checker.dependencies
stack-checker.backend
compiler.tree
compiler.tree.propagation.info
@ -28,9 +28,7 @@ M: method-body flushable? "method-generic" word-prop flushable? ;
M: #call mark-live-values*
dup flushable-call? [ drop ] [ look-at-inputs ] if ;
M: #alien-invoke mark-live-values* look-at-inputs ;
M: #alien-indirect mark-live-values* look-at-inputs ;
M: #alien-node mark-live-values* look-at-inputs ;
M: #return mark-live-values* look-at-inputs ;
@ -47,9 +45,7 @@ M: #call compute-live-values* nip look-at-inputs ;
M: #shuffle compute-live-values*
mapping>> at look-at-value ;
M: #alien-invoke compute-live-values* nip look-at-inputs ;
M: #alien-indirect compute-live-values* nip look-at-inputs ;
M: #alien-node compute-live-values* nip look-at-inputs ;
: filter-mapping ( assoc -- assoc' )
live-values get '[ drop _ key? ] assoc-filter ;
@ -71,7 +67,7 @@ M: #alien-indirect compute-live-values* nip look-at-inputs ;
filter-corresponding zip #data-shuffle ; inline
:: drop-dead-values ( outputs -- #shuffle )
outputs make-values :> new-outputs
outputs length make-values :> new-outputs
outputs filter-live :> live-outputs
new-outputs
live-outputs
@ -127,8 +123,5 @@ M: #terminate remove-dead-code*
[ filter-live ] change-in-d
[ filter-live ] change-in-r ;
M: #alien-invoke remove-dead-code*
maybe-drop-dead-outputs ;
M: #alien-indirect remove-dead-code*
M: #alien-node remove-dead-code*
maybe-drop-dead-outputs ;

7
basis/compiler/tree/debugger/debugger.factor
View File

@ -1,4 +1,4 @@
! Copyright (C) 2006, 2009 Slava Pestov.
! Copyright (C) 2006, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel assocs match fry accessors namespaces make effects
sequences sequences.private quotations generic macros arrays
@ -51,7 +51,6 @@ MATCH-VARS: ?a ?b ?c ;
{ { { ?b ?a } { ?a ?b } } [ swap ] }
{ { { ?b ?a ?c } { ?a ?b ?c } } [ swapd ] }
{ { { ?a ?b } { ?a ?a ?b } } [ dupd ] }
{ { { ?a ?b } { ?b ?a ?b } } [ tuck ] }
{ { { ?a ?b ?c } { ?a ?b ?c ?a } } [ pick ] }
{ { { ?a ?b ?c } { ?c ?a ?b } } [ -rot ] }
{ { { ?a ?b ?c } { ?b ?c ?a } } [ rot ] }
@ -65,7 +64,7 @@ TUPLE: shuffle-node { effect effect } ;
M: shuffle-node pprint* effect>> effect>string text ;
: (shuffle-effect) ( in out #shuffle -- effect )
mapping>> '[ _ at ] map <effect> ;
mapping>> '[ _ at ] map [ >array ] bi@ <effect> ;
: shuffle-effect ( #shuffle -- effect )
[ in-d>> ] [ out-d>> ] [ ] tri (shuffle-effect) ;
@ -127,6 +126,8 @@ M: #alien-invoke node>quot params>> , \ #alien-invoke , ;
M: #alien-indirect node>quot params>> , \ #alien-indirect , ;
M: #alien-assembly node>quot params>> , \ #alien-assembly , ;
M: #alien-callback node>quot params>> , \ #alien-callback , ;
M: node node>quot drop ;

22
basis/compiler/tree/escape-analysis/escape-analysis-tests.factor
View File

@ -7,7 +7,7 @@ math.private kernel tools.test accessors slots.private
quotations.private prettyprint classes.tuple.private classes
classes.tuple namespaces
compiler.tree.propagation.info stack-checker.errors
compiler.tree.checker
compiler.tree.checker compiler.tree.def-use compiler.tree.dead-code
kernel.private vectors ;
IN: compiler.tree.escape-analysis.tests
@ -37,6 +37,8 @@ M: node count-unboxed-allocations* drop ;
cleanup
escape-analysis
dup check-nodes
compute-def-use
remove-dead-code
0 swap [ count-unboxed-allocations* ] each-node ;
[ 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
] unit-test
[ 2 ] [
[
1 2 cons boa 10 [ 2drop 1 2 cons boa ] each-integer car>>
] count-unboxed-allocations
] unit-test
[ 0 ] [
[
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
: 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 ] [
[ dup -1 over >= [ 0 >= [ "A" throw ] unless ] [ drop ] if ]
count-unboxed-allocations
@ -322,10 +310,6 @@ C: <ro-box> ro-box
count-unboxed-allocations
] unit-test
[ 0 ] [
[ { null } declare [ 1 ] [ 2 ] if ] count-unboxed-allocations
] unit-test
! Doug found a regression
TUPLE: empty-tuple ;

Some files were not shown because too many files have changed in this diff Show More