Merge branch 'master' into irc
Bruno Deferrari
commit
53413a049e
|
|
@ -1,4 +1,5 @@
|
|||
CC = gcc
|
||||
CPP = g++
|
||||
AR = ar
|
||||
LD = ld
|
||||
|
||||
|
|
@ -10,14 +11,15 @@ VERSION = 0.92
|
|||
BUNDLE = Factor.app
|
||||
LIBPATH = -L/usr/X11R6/lib
|
||||
CFLAGS = -Wall
|
||||
FFI_TEST_CFLAGS = -fPIC
|
||||
|
||||
ifdef DEBUG
|
||||
CFLAGS += -g
|
||||
CFLAGS += -g -DFACTOR_DEBUG
|
||||
else
|
||||
CFLAGS += -O3 $(SITE_CFLAGS)
|
||||
CFLAGS += -O3
|
||||
endif
|
||||
|
||||
CFLAGS += $(SITE_CFLAGS)
|
||||
|
||||
ENGINE = $(DLL_PREFIX)factor$(DLL_SUFFIX)$(DLL_EXTENSION)
|
||||
|
||||
ifdef CONFIG
|
||||
|
|
@ -26,25 +28,36 @@ endif
|
|||
|
||||
DLL_OBJS = $(PLAF_DLL_OBJS) \
|
||||
vm/alien.o \
|
||||
vm/arrays.o \
|
||||
vm/bignum.o \
|
||||
vm/booleans.o \
|
||||
vm/byte_arrays.o \
|
||||
vm/callstack.o \
|
||||
vm/code_block.o \
|
||||
vm/code_gc.o \
|
||||
vm/code_heap.o \
|
||||
vm/contexts.o \
|
||||
vm/data_gc.o \
|
||||
vm/data_heap.o \
|
||||
vm/debug.o \
|
||||
vm/dispatch.o \
|
||||
vm/errors.o \
|
||||
vm/factor.o \
|
||||
vm/image.o \
|
||||
vm/inline_cache.o \
|
||||
vm/io.o \
|
||||
vm/jit.o \
|
||||
vm/local_roots.o \
|
||||
vm/math.o \
|
||||
vm/primitives.o \
|
||||
vm/profiler.o \
|
||||
vm/quotations.o \
|
||||
vm/run.o \
|
||||
vm/types.o \
|
||||
vm/utilities.o
|
||||
vm/strings.o \
|
||||
vm/tuples.o \
|
||||
vm/utilities.o \
|
||||
vm/words.o \
|
||||
vm/write_barrier.o
|
||||
|
||||
EXE_OBJS = $(PLAF_EXE_OBJS)
|
||||
|
||||
|
|
@ -152,12 +165,12 @@ macosx.app: factor
|
|||
|
||||
$(EXECUTABLE): $(DLL_OBJS) $(EXE_OBJS)
|
||||
$(LINKER) $(ENGINE) $(DLL_OBJS)
|
||||
$(CC) $(LIBS) $(LIBPATH) -L. $(LINK_WITH_ENGINE) \
|
||||
$(CPP) $(LIBS) $(LIBPATH) -L. $(LINK_WITH_ENGINE) \
|
||||
$(CFLAGS) -o $@$(EXE_SUFFIX)$(EXE_EXTENSION) $(EXE_OBJS)
|
||||
|
||||
$(CONSOLE_EXECUTABLE): $(DLL_OBJS) $(EXE_OBJS)
|
||||
$(LINKER) $(ENGINE) $(DLL_OBJS)
|
||||
$(CC) $(LIBS) $(LIBPATH) -L. $(LINK_WITH_ENGINE) \
|
||||
$(CPP) $(LIBS) $(LIBPATH) -L. $(LINK_WITH_ENGINE) \
|
||||
$(CFLAGS) $(CFLAGS_CONSOLE) -o factor$(EXE_SUFFIX)$(CONSOLE_EXTENSION) $(EXE_OBJS)
|
||||
|
||||
$(TEST_LIBRARY): vm/ffi_test.o
|
||||
|
|
@ -165,7 +178,13 @@ $(TEST_LIBRARY): vm/ffi_test.o
|
|||
|
||||
clean:
|
||||
rm -f vm/*.o
|
||||
rm -f factor*.dll libfactor.{a,so,dylib} libfactor-ffi-test.{a,so,dylib} Factor.app/Contents/Frameworks/libfactor.dylib
|
||||
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:
|
||||
$(WINDRES) vm/factor.rs vm/resources.o
|
||||
|
|
@ -176,10 +195,15 @@ vm/ffi_test.o: vm/ffi_test.c
|
|||
.c.o:
|
||||
$(CC) -c $(CFLAGS) -o $@ $<
|
||||
|
||||
.cpp.o:
|
||||
$(CPP) -c $(CFLAGS) -o $@ $<
|
||||
|
||||
.S.o:
|
||||
$(CC) -x assembler-with-cpp -c $(CFLAGS) -o $@ $<
|
||||
|
||||
.m.o:
|
||||
$(CC) -c $(CFLAGS) -o $@ $<
|
||||
|
||||
.PHONY: factor
|
||||
.mm.o:
|
||||
$(CPP) -c $(CFLAGS) -o $@ $<
|
||||
|
||||
.PHONY: factor tags clean
|
||||
|
||||
.SUFFIXES: .mm
|
||||
|
|
|
|||
19
README.txt
19
README.txt
|
|
@ -20,25 +20,18 @@ implementation. It is not an introduction to the language itself.
|
|||
|
||||
* Compiling the Factor VM
|
||||
|
||||
The Factor runtime is written in GNU C99, and is built with GNU make and
|
||||
gcc.
|
||||
|
||||
Factor supports various platforms. For an up-to-date list, see
|
||||
<http://factorcode.org>.
|
||||
|
||||
Factor requires gcc 3.4 or later.
|
||||
|
||||
On x86, Factor /will not/ build using gcc 3.3 or earlier.
|
||||
|
||||
If you are using gcc 4.3, you might get an unusable Factor binary unless
|
||||
you add 'SITE_CFLAGS=-fno-forward-propagate' to the command-line
|
||||
arguments for make.
|
||||
The Factor VM is written in C++ and uses GNU extensions. When compiling
|
||||
with GCC 3.x, boost::unordered_map must be installed. On GCC 4.x, Factor
|
||||
uses std::tr1::unordered_map which is shipped as part of GCC.
|
||||
|
||||
Run 'make' ('gmake' on *BSD) with no parameters to build the Factor VM.
|
||||
|
||||
* Bootstrapping the Factor image
|
||||
|
||||
Once you have compiled the Factor runtime, you must bootstrap the Factor
|
||||
Once you have compiled the Factor VM, you must bootstrap the Factor
|
||||
system using the image that corresponds to your CPU architecture.
|
||||
|
||||
Boot images can be obtained from <http://factorcode.org/images/latest/>.
|
||||
|
|
@ -97,7 +90,7 @@ When compiling Factor, pass the X11=1 parameter:
|
|||
|
||||
Then bootstrap with the following switches:
|
||||
|
||||
./factor -i=boot.<cpu>.image -ui-backend=x11 -ui-text-backend=pango
|
||||
./factor -i=boot.<cpu>.image -ui-backend=x11
|
||||
|
||||
Now if $DISPLAY is set, running ./factor will start the UI.
|
||||
|
||||
|
|
@ -138,7 +131,7 @@ usage documentation, enter the following in the UI listener:
|
|||
The Factor source tree is organized as follows:
|
||||
|
||||
build-support/ - scripts used for compiling Factor
|
||||
vm/ - sources for the Factor VM, written in C
|
||||
vm/ - Factor VM
|
||||
core/ - Factor core library
|
||||
basis/ - Factor basis library, compiler, tools
|
||||
extra/ - more libraries and applications
|
||||
|
|
|
|||
|
|
@ -71,7 +71,7 @@ ERROR: bad-alarm-frequency frequency ;
|
|||
] when* ;
|
||||
|
||||
: init-alarms ( -- )
|
||||
alarms global [ cancel-alarms <min-heap> ] change-at
|
||||
alarms [ cancel-alarms <min-heap> ] change-global
|
||||
[ alarm-thread-loop t ] "Alarms" spawn-server
|
||||
alarm-thread set-global ;
|
||||
|
||||
|
|
|
|||
|
|
@ -1,7 +1,8 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! Copyright (C) 2008, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien arrays alien.c-types alien.structs
|
||||
sequences math kernel namespaces fry libc cpu.architecture ;
|
||||
USING: alien alien.strings alien.c-types alien.accessors alien.structs
|
||||
arrays words sequences math kernel namespaces fry libc cpu.architecture
|
||||
io.encodings.utf8 io.encodings.utf16n ;
|
||||
IN: alien.arrays
|
||||
|
||||
UNION: value-type array struct-type ;
|
||||
|
|
@ -38,3 +39,61 @@ M: value-type c-type-getter
|
|||
M: value-type c-type-setter ( type -- quot )
|
||||
[ c-type-getter ] [ c-type-unboxer-quot ] [ heap-size ] tri
|
||||
'[ @ swap @ _ memcpy ] ;
|
||||
|
||||
PREDICATE: string-type < pair
|
||||
first2 [ "char*" = ] [ word? ] bi* and ;
|
||||
|
||||
M: string-type c-type ;
|
||||
|
||||
M: string-type c-type-class
|
||||
drop object ;
|
||||
|
||||
M: string-type heap-size
|
||||
drop "void*" heap-size ;
|
||||
|
||||
M: string-type c-type-align
|
||||
drop "void*" c-type-align ;
|
||||
|
||||
M: string-type c-type-stack-align?
|
||||
drop "void*" c-type-stack-align? ;
|
||||
|
||||
M: string-type unbox-parameter
|
||||
drop "void*" unbox-parameter ;
|
||||
|
||||
M: string-type unbox-return
|
||||
drop "void*" unbox-return ;
|
||||
|
||||
M: string-type box-parameter
|
||||
drop "void*" box-parameter ;
|
||||
|
||||
M: string-type box-return
|
||||
drop "void*" box-return ;
|
||||
|
||||
M: string-type stack-size
|
||||
drop "void*" stack-size ;
|
||||
|
||||
M: string-type c-type-reg-class
|
||||
drop int-regs ;
|
||||
|
||||
M: string-type c-type-boxer
|
||||
drop "void*" c-type-boxer ;
|
||||
|
||||
M: string-type c-type-unboxer
|
||||
drop "void*" c-type-unboxer ;
|
||||
|
||||
M: string-type c-type-boxer-quot
|
||||
second '[ _ alien>string ] ;
|
||||
|
||||
M: string-type c-type-unboxer-quot
|
||||
second '[ _ string>alien ] ;
|
||||
|
||||
M: string-type c-type-getter
|
||||
drop [ alien-cell ] ;
|
||||
|
||||
M: string-type c-type-setter
|
||||
drop [ set-alien-cell ] ;
|
||||
|
||||
{ "char*" utf8 } "char*" typedef
|
||||
"char*" "uchar*" typedef
|
||||
{ "char*" utf16n } "wchar_t*" typedef
|
||||
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
IN: alien.c-types
|
||||
USING: alien help.syntax help.markup libc kernel.private
|
||||
byte-arrays math strings hashtables alien.syntax
|
||||
debugger destructors ;
|
||||
byte-arrays math strings hashtables alien.syntax alien.strings sequences
|
||||
io.encodings.string debugger destructors ;
|
||||
|
||||
HELP: <c-type>
|
||||
{ $values { "type" hashtable } }
|
||||
|
|
@ -114,6 +114,38 @@ HELP: define-out
|
|||
{ $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." } ;
|
||||
|
||||
{ string>alien alien>string malloc-string } related-words
|
||||
|
||||
HELP: malloc-string
|
||||
{ $values { "string" string } { "encoding" "an encoding descriptor" } { "alien" c-ptr } }
|
||||
{ $description "Encodes a string together with a trailing null code point using the given encoding, and stores the resulting bytes in a freshly-allocated unmanaged memory block." }
|
||||
{ $warning "Don't forget to deallocate the memory with a call to " { $link free } "." }
|
||||
{ $errors "Throws an error if one of the following conditions occurs:"
|
||||
{ $list
|
||||
"the string contains null code points"
|
||||
"the string contains characters not representable using the encoding specified"
|
||||
"memory allocation fails"
|
||||
}
|
||||
} ;
|
||||
|
||||
ARTICLE: "c-strings" "C strings"
|
||||
"C string types are arrays with shape " { $snippet "{ \"char*\" encoding }" } ", where " { $snippet "encoding" } " is an encoding descriptor. The type " { $snippet "\"char*\"" } " is an alias for " { $snippet "{ \"char*\" utf8 }" } ". See " { $link "encodings-descriptors" } " for information about encoding descriptors."
|
||||
$nl
|
||||
"Passing a Factor string to a C function expecting a C string allocates a " { $link byte-array } " in the Factor heap; the string is then converted to the requested format and a raw pointer is passed to the function."
|
||||
$nl
|
||||
"If the conversion fails, for example if the string contains null bytes or characters with values higher than 255, a " { $link c-string-error. } " is thrown."
|
||||
$nl
|
||||
"Care must be taken if the C function expects a " { $snippet "char*" } " with a length in bytes, rather than a null-terminated " { $snippet "char*" } "; passing the result of calling " { $link length } " on the string object will not suffice. This is because a Factor string of " { $emphasis "n" } " characters will not necessarily encode to " { $emphasis "n" } " bytes. The correct idiom for C functions which take a string with a length is to first encode the string using " { $link encode } ", and then pass the resulting byte array together with the length of this byte array."
|
||||
$nl
|
||||
"Sometimes a C function has a parameter type of " { $snippet "void*" } ", and various data types, among them strings, can be passed in. In this case, strings are not automatically converted to aliens, and instead you must call one of these words:"
|
||||
{ $subsection string>alien }
|
||||
{ $subsection malloc-string }
|
||||
"The first allocates " { $link byte-array } "s, and the latter allocates manually-managed memory which is not moved by the garbage collector and has to be explicitly freed by calling " { $link free } ". See " { $link "byte-arrays-gc" } " for a discussion of the two approaches."
|
||||
$nl
|
||||
"A word to read strings from arbitrary addresses:"
|
||||
{ $subsection alien>string }
|
||||
"For example, if a C function returns a " { $snippet "char*" } " but stipulates that the caller must deallocate the memory afterward, you must define the function as returning " { $snippet "void*" } ", and call one of the above words before passing the pointer to " { $link free } "." ;
|
||||
|
||||
ARTICLE: "byte-arrays-gc" "Byte arrays and the garbage collector"
|
||||
"The Factor garbage collector can move byte arrays around, and it is only safe to pass byte arrays to C functions if the garbage collector will not run while C code still has a reference to the data."
|
||||
$nl
|
||||
|
|
|
|||
|
|
@ -2,9 +2,10 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: byte-arrays arrays assocs kernel kernel.private libc math
|
||||
namespaces make parser sequences strings words assocs splitting
|
||||
math.parser cpu.architecture alien alien.accessors quotations
|
||||
layouts system compiler.units io.files io.encodings.binary
|
||||
accessors combinators effects continuations fry classes ;
|
||||
math.parser cpu.architecture alien alien.accessors alien.strings
|
||||
quotations layouts system compiler.units io io.files
|
||||
io.encodings.binary io.streams.memory accessors combinators effects
|
||||
continuations fry classes ;
|
||||
IN: alien.c-types
|
||||
|
||||
DEFER: <int>
|
||||
|
|
@ -213,6 +214,15 @@ M: f byte-length drop 0 ;
|
|||
: memory>byte-array ( alien len -- byte-array )
|
||||
[ nip (byte-array) dup ] 2keep memcpy ;
|
||||
|
||||
: malloc-string ( string encoding -- alien )
|
||||
string>alien malloc-byte-array ;
|
||||
|
||||
M: memory-stream stream-read
|
||||
[
|
||||
[ index>> ] [ alien>> ] bi <displaced-alien>
|
||||
swap memory>byte-array
|
||||
] [ [ + ] change-index drop ] 2bi ;
|
||||
|
||||
: byte-array>memory ( byte-array base -- )
|
||||
swap dup byte-length memcpy ;
|
||||
|
||||
|
|
@ -399,10 +409,10 @@ CONSTANT: primitive-types
|
|||
"uchar" define-primitive-type
|
||||
|
||||
<c-type>
|
||||
[ alien-unsigned-4 zero? not ] >>getter
|
||||
[ [ 1 0 ? ] 2dip set-alien-unsigned-4 ] >>setter
|
||||
4 >>size
|
||||
4 >>align
|
||||
[ alien-unsigned-1 zero? not ] >>getter
|
||||
[ [ 1 0 ? ] 2dip set-alien-unsigned-1 ] >>setter
|
||||
1 >>size
|
||||
1 >>align
|
||||
"box_boolean" >>boxer
|
||||
"to_boolean" >>unboxer
|
||||
"bool" define-primitive-type
|
||||
|
|
|
|||
|
|
@ -15,7 +15,7 @@ HELP: libraries
|
|||
{ $description "A global hashtable that keeps a list of open libraries. Use the " { $link add-library } " word to construct a library and add it with a single call." } ;
|
||||
|
||||
HELP: library
|
||||
{ $values { "name" "a string" } { "library" "a hashtable" } }
|
||||
{ $values { "name" "a string" } { "library" assoc } }
|
||||
{ $description "Looks up a library by its logical name. The library object is a hashtable with the following keys:"
|
||||
{ $list
|
||||
{ { $snippet "name" } " - the full path of the C library binary" }
|
||||
|
|
|
|||
|
|
@ -1,8 +1,12 @@
|
|||
! Copyright (C) 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors alien assocs io.backend kernel namespaces ;
|
||||
USING: accessors alien alien.strings assocs io.backend kernel namespaces ;
|
||||
IN: alien.libraries
|
||||
|
||||
: dlopen ( path -- dll ) native-string>alien (dlopen) ;
|
||||
|
||||
: dlsym ( name dll -- alien ) [ string>symbol ] dip (dlsym) ;
|
||||
|
||||
SYMBOL: libraries
|
||||
|
||||
libraries [ H{ } clone ] initialize
|
||||
|
|
@ -18,4 +22,4 @@ TUPLE: library path abi dll ;
|
|||
library dup [ dll>> ] when ;
|
||||
|
||||
: add-library ( name path abi -- )
|
||||
<library> swap libraries get set-at ;
|
||||
<library> swap libraries get set-at ;
|
||||
|
|
@ -15,7 +15,7 @@ IN: alien.remote-control
|
|||
"void" { "long" } "cdecl" [ sleep ] alien-callback ;
|
||||
|
||||
: ?callback ( word -- alien )
|
||||
dup optimized>> [ execute ] [ drop f ] if ; inline
|
||||
dup optimized? [ execute ] [ drop f ] if ; inline
|
||||
|
||||
: init-remote-control ( -- )
|
||||
\ eval-callback ?callback 16 setenv
|
||||
|
|
|
|||
|
|
@ -1,52 +0,0 @@
|
|||
USING: help.markup help.syntax strings byte-arrays alien libc
|
||||
debugger io.encodings.string sequences ;
|
||||
IN: alien.strings
|
||||
|
||||
HELP: string>alien
|
||||
{ $values { "string" string } { "encoding" "an encoding descriptor" } { "byte-array" byte-array } }
|
||||
{ $description "Encodes a string together with a trailing null code point using the given encoding, and stores the resulting bytes in a freshly-allocated byte array." }
|
||||
{ $errors "Throws an error if the string contains null characters, or characters not representable in the given encoding." } ;
|
||||
|
||||
{ string>alien alien>string malloc-string } related-words
|
||||
|
||||
HELP: alien>string
|
||||
{ $values { "c-ptr" c-ptr } { "encoding" "an encoding descriptor" } { "string/f" "a string or " { $link f } } }
|
||||
{ $description "Reads a null-terminated C string from the specified address with the given encoding." } ;
|
||||
|
||||
HELP: malloc-string
|
||||
{ $values { "string" string } { "encoding" "an encoding descriptor" } { "alien" c-ptr } }
|
||||
{ $description "Encodes a string together with a trailing null code point using the given encoding, and stores the resulting bytes in a freshly-allocated unmanaged memory block." }
|
||||
{ $warning "Don't forget to deallocate the memory with a call to " { $link free } "." }
|
||||
{ $errors "Throws an error if one of the following conditions occurs:"
|
||||
{ $list
|
||||
"the string contains null code points"
|
||||
"the string contains characters not representable using the encoding specified"
|
||||
"memory allocation fails"
|
||||
}
|
||||
} ;
|
||||
|
||||
HELP: string>symbol
|
||||
{ $values { "str" string } { "alien" alien } }
|
||||
{ $description "Converts the string to a format which is a valid symbol name for the Factor VM's compiled code linker. By performing this conversion ahead of time, the image loader can run without allocating memory."
|
||||
$nl
|
||||
"On Windows CE, symbols are represented as UCS2 strings, and on all other platforms they are ASCII strings." } ;
|
||||
|
||||
ARTICLE: "c-strings" "C strings"
|
||||
"C string types are arrays with shape " { $snippet "{ \"char*\" encoding }" } ", where " { $snippet "encoding" } " is an encoding descriptor. The type " { $snippet "\"char*\"" } " is an alias for " { $snippet "{ \"char*\" utf8 }" } ". See " { $link "encodings-descriptors" } " for information about encoding descriptors."
|
||||
$nl
|
||||
"Passing a Factor string to a C function expecting a C string allocates a " { $link byte-array } " in the Factor heap; the string is then converted to the requested format and a raw pointer is passed to the function."
|
||||
$nl
|
||||
"If the conversion fails, for example if the string contains null bytes or characters with values higher than 255, a " { $link c-string-error. } " is thrown."
|
||||
$nl
|
||||
"Care must be taken if the C function expects a " { $snippet "char*" } " with a length in bytes, rather than a null-terminated " { $snippet "char*" } "; passing the result of calling " { $link length } " on the string object will not suffice. This is because a Factor string of " { $emphasis "n" } " characters will not necessarily encode to " { $emphasis "n" } " bytes. The correct idiom for C functions which take a string with a length is to first encode the string using " { $link encode } ", and then pass the resulting byte array together with the length of this byte array."
|
||||
$nl
|
||||
"Sometimes a C function has a parameter type of " { $snippet "void*" } ", and various data types, among them strings, can be passed in. In this case, strings are not automatically converted to aliens, and instead you must call one of these words:"
|
||||
{ $subsection string>alien }
|
||||
{ $subsection malloc-string }
|
||||
"The first allocates " { $link byte-array } "s, and the latter allocates manually-managed memory which is not moved by the garbage collector and has to be explicitly freed by calling " { $link free } ". See " { $link "byte-arrays-gc" } " for a discussion of the two approaches."
|
||||
$nl
|
||||
"A word to read strings from arbitrary addresses:"
|
||||
{ $subsection alien>string }
|
||||
"For example, if a C function returns a " { $snippet "char*" } " but stipulates that the caller must deallocate the memory afterward, you must define the function as returning " { $snippet "void*" } ", and call one of the above words before passing the pointer to " { $link free } "." ;
|
||||
|
||||
ABOUT: "c-strings"
|
||||
|
|
@ -1,109 +0,0 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays sequences kernel accessors math alien.accessors
|
||||
alien.c-types byte-arrays words io io.encodings
|
||||
io.encodings.utf8 io.streams.byte-array io.streams.memory system
|
||||
alien strings cpu.architecture fry vocabs.loader combinators ;
|
||||
IN: alien.strings
|
||||
|
||||
GENERIC# alien>string 1 ( c-ptr encoding -- string/f )
|
||||
|
||||
M: c-ptr alien>string
|
||||
[ <memory-stream> ] [ <decoder> ] bi*
|
||||
"\0" swap stream-read-until drop ;
|
||||
|
||||
M: f alien>string
|
||||
drop ;
|
||||
|
||||
ERROR: invalid-c-string string ;
|
||||
|
||||
: check-string ( string -- )
|
||||
0 over memq? [ invalid-c-string ] [ drop ] if ;
|
||||
|
||||
GENERIC# string>alien 1 ( string encoding -- byte-array )
|
||||
|
||||
M: c-ptr string>alien drop ;
|
||||
|
||||
M: string string>alien
|
||||
over check-string
|
||||
<byte-writer>
|
||||
[ stream-write ]
|
||||
[ 0 swap stream-write1 ]
|
||||
[ stream>> >byte-array ]
|
||||
tri ;
|
||||
|
||||
: malloc-string ( string encoding -- alien )
|
||||
string>alien malloc-byte-array ;
|
||||
|
||||
PREDICATE: string-type < pair
|
||||
first2 [ "char*" = ] [ word? ] bi* and ;
|
||||
|
||||
M: string-type c-type ;
|
||||
|
||||
M: string-type c-type-class
|
||||
drop object ;
|
||||
|
||||
M: string-type heap-size
|
||||
drop "void*" heap-size ;
|
||||
|
||||
M: string-type c-type-align
|
||||
drop "void*" c-type-align ;
|
||||
|
||||
M: string-type c-type-stack-align?
|
||||
drop "void*" c-type-stack-align? ;
|
||||
|
||||
M: string-type unbox-parameter
|
||||
drop "void*" unbox-parameter ;
|
||||
|
||||
M: string-type unbox-return
|
||||
drop "void*" unbox-return ;
|
||||
|
||||
M: string-type box-parameter
|
||||
drop "void*" box-parameter ;
|
||||
|
||||
M: string-type box-return
|
||||
drop "void*" box-return ;
|
||||
|
||||
M: string-type stack-size
|
||||
drop "void*" stack-size ;
|
||||
|
||||
M: string-type c-type-reg-class
|
||||
drop int-regs ;
|
||||
|
||||
M: string-type c-type-boxer
|
||||
drop "void*" c-type-boxer ;
|
||||
|
||||
M: string-type c-type-unboxer
|
||||
drop "void*" c-type-unboxer ;
|
||||
|
||||
M: string-type c-type-boxer-quot
|
||||
second '[ _ alien>string ] ;
|
||||
|
||||
M: string-type c-type-unboxer-quot
|
||||
second '[ _ string>alien ] ;
|
||||
|
||||
M: string-type c-type-getter
|
||||
drop [ alien-cell ] ;
|
||||
|
||||
M: string-type c-type-setter
|
||||
drop [ set-alien-cell ] ;
|
||||
|
||||
HOOK: alien>native-string os ( alien -- string )
|
||||
|
||||
HOOK: native-string>alien os ( string -- alien )
|
||||
|
||||
: dll-path ( dll -- string )
|
||||
path>> alien>native-string ;
|
||||
|
||||
: string>symbol ( str -- alien )
|
||||
dup string?
|
||||
[ native-string>alien ]
|
||||
[ [ native-string>alien ] map ] if ;
|
||||
|
||||
{ "char*" utf8 } "char*" typedef
|
||||
"char*" "uchar*" typedef
|
||||
|
||||
{
|
||||
{ [ os windows? ] [ "alien.strings.windows" require ] }
|
||||
{ [ os unix? ] [ "alien.strings.unix" require ] }
|
||||
} cond
|
||||
|
|
@ -1 +0,0 @@
|
|||
Default string encoding on Unix
|
||||
|
|
@ -1,8 +0,0 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien.strings io.encodings.utf8 system ;
|
||||
IN: alien.strings.unix
|
||||
|
||||
M: unix alien>native-string utf8 alien>string ;
|
||||
|
||||
M: unix native-string>alien utf8 string>alien ;
|
||||
|
|
@ -1 +0,0 @@
|
|||
Default string encoding on Windows
|
||||
|
|
@ -1,13 +0,0 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien.strings alien.c-types io.encodings.utf8
|
||||
io.encodings.utf16n system ;
|
||||
IN: alien.strings.windows
|
||||
|
||||
M: windows alien>native-string utf16n alien>string ;
|
||||
|
||||
M: wince native-string>alien utf16n string>alien ;
|
||||
|
||||
M: winnt native-string>alien utf8 string>alien ;
|
||||
|
||||
{ "char*" utf16n } "wchar_t*" typedef
|
||||
|
|
@ -5,7 +5,7 @@ sequences namespaces parser kernel kernel.private classes
|
|||
classes.private arrays hashtables vectors classes.tuple sbufs
|
||||
hashtables.private sequences.private math classes.tuple.private
|
||||
growable namespaces.private assocs words command-line vocabs io
|
||||
io.encodings.string libc splitting math.parser
|
||||
io.encodings.string libc splitting math.parser memory
|
||||
compiler.units math.order compiler.tree.builder
|
||||
compiler.tree.optimizer compiler.cfg.optimizer ;
|
||||
IN: bootstrap.compiler
|
||||
|
|
@ -23,10 +23,13 @@ IN: bootstrap.compiler
|
|||
|
||||
"cpu." cpu name>> append require
|
||||
|
||||
enable-compiler
|
||||
enable-optimizer
|
||||
|
||||
! Push all tuple layouts to tenured space to improve method caching
|
||||
gc
|
||||
|
||||
: compile-unoptimized ( words -- )
|
||||
[ optimized>> not ] filter compile ;
|
||||
[ optimized? not ] filter compile ;
|
||||
|
||||
nl
|
||||
"Compiling..." write flush
|
||||
|
|
@ -38,7 +41,7 @@ nl
|
|||
! which are also quick to compile are replaced by
|
||||
! compiled definitions as soon as possible.
|
||||
{
|
||||
roll -roll declare not
|
||||
not
|
||||
|
||||
array? hashtable? vector?
|
||||
tuple? sbuf? tombstone?
|
||||
|
|
|
|||
|
|
@ -3,14 +3,13 @@
|
|||
USING: alien arrays byte-arrays generic assocs hashtables assocs
|
||||
hashtables.private io io.binary io.files io.encodings.binary
|
||||
io.pathnames kernel kernel.private math namespaces make parser
|
||||
prettyprint sequences sequences.private strings sbufs
|
||||
vectors words quotations assocs system layouts splitting
|
||||
grouping growable classes classes.builtin classes.tuple
|
||||
classes.tuple.private words.private vocabs
|
||||
vocabs.loader source-files definitions debugger
|
||||
quotations.private sequences.private combinators
|
||||
math.order math.private accessors
|
||||
slots.private compiler.units fry ;
|
||||
prettyprint sequences sequences.private strings sbufs vectors words
|
||||
quotations assocs system layouts splitting grouping growable classes
|
||||
classes.builtin classes.tuple classes.tuple.private vocabs
|
||||
vocabs.loader source-files definitions debugger quotations.private
|
||||
sequences.private combinators math.order math.private accessors
|
||||
slots.private generic.single.private compiler.units compiler.constants
|
||||
fry bootstrap.image.syntax ;
|
||||
IN: bootstrap.image
|
||||
|
||||
: arch ( os cpu -- arch )
|
||||
|
|
@ -53,6 +52,9 @@ GENERIC: (eql?) ( obj1 obj2 -- ? )
|
|||
|
||||
M: integer (eql?) = ;
|
||||
|
||||
M: float (eql?)
|
||||
over float? [ fp-bitwise= ] [ 2drop f ] if ;
|
||||
|
||||
M: sequence (eql?)
|
||||
over sequence? [
|
||||
2dup [ length ] bi@ =
|
||||
|
|
@ -94,13 +96,25 @@ CONSTANT: -1-offset 9
|
|||
|
||||
SYMBOL: sub-primitives
|
||||
|
||||
: make-jit ( quot rc rt offset -- quad )
|
||||
[ [ call( -- ) ] { } make ] 3dip 4array ;
|
||||
SYMBOL: jit-relocations
|
||||
|
||||
: jit-define ( quot rc rt offset name -- )
|
||||
: compute-offset ( rc -- offset )
|
||||
[ building get length ] dip rc-absolute-cell = bootstrap-cell 4 ? - ;
|
||||
|
||||
: jit-rel ( rc rt -- )
|
||||
over compute-offset 3array jit-relocations get push-all ;
|
||||
|
||||
: make-jit ( quot -- jit-data )
|
||||
[
|
||||
V{ } clone jit-relocations set
|
||||
call( -- )
|
||||
jit-relocations get >array
|
||||
] B{ } make prefix ;
|
||||
|
||||
: jit-define ( quot name -- )
|
||||
[ make-jit ] dip set ;
|
||||
|
||||
: define-sub-primitive ( quot rc rt offset word -- )
|
||||
: define-sub-primitive ( quot word -- )
|
||||
[ make-jit ] dip sub-primitives get set-at ;
|
||||
|
||||
! The image being constructed; a vector of word-size integers
|
||||
|
|
@ -112,72 +126,59 @@ SYMBOL: big-endian
|
|||
! Bootstrap architecture name
|
||||
SYMBOL: architecture
|
||||
|
||||
! Bootstrap global namesapce
|
||||
SYMBOL: bootstrap-global
|
||||
RESET
|
||||
|
||||
! Boot quotation, set in stage1.factor
|
||||
SYMBOL: bootstrap-boot-quot
|
||||
USERENV: bootstrap-boot-quot 20
|
||||
|
||||
! Bootstrap global namesapce
|
||||
USERENV: bootstrap-global 21
|
||||
|
||||
! JIT parameters
|
||||
SYMBOL: jit-code-format
|
||||
SYMBOL: jit-prolog
|
||||
SYMBOL: jit-primitive-word
|
||||
SYMBOL: jit-primitive
|
||||
SYMBOL: jit-word-jump
|
||||
SYMBOL: jit-word-call
|
||||
SYMBOL: jit-push-immediate
|
||||
SYMBOL: jit-if-word
|
||||
SYMBOL: jit-if-1
|
||||
SYMBOL: jit-if-2
|
||||
SYMBOL: jit-dispatch-word
|
||||
SYMBOL: jit-dispatch
|
||||
SYMBOL: jit-dip-word
|
||||
SYMBOL: jit-dip
|
||||
SYMBOL: jit-2dip-word
|
||||
SYMBOL: jit-2dip
|
||||
SYMBOL: jit-3dip-word
|
||||
SYMBOL: jit-3dip
|
||||
SYMBOL: jit-epilog
|
||||
SYMBOL: jit-return
|
||||
SYMBOL: jit-profiling
|
||||
SYMBOL: jit-declare-word
|
||||
SYMBOL: jit-save-stack
|
||||
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
|
||||
|
||||
! PIC stubs
|
||||
USERENV: pic-load 47
|
||||
USERENV: pic-tag 48
|
||||
USERENV: pic-hi-tag 49
|
||||
USERENV: pic-tuple 50
|
||||
USERENV: pic-hi-tag-tuple 51
|
||||
USERENV: pic-check-tag 52
|
||||
USERENV: pic-check 53
|
||||
USERENV: pic-hit 54
|
||||
USERENV: pic-miss-word 55
|
||||
USERENV: pic-miss-tail-word 56
|
||||
|
||||
! Megamorphic dispatch
|
||||
USERENV: mega-lookup 57
|
||||
USERENV: mega-lookup-word 58
|
||||
USERENV: mega-miss-word 59
|
||||
|
||||
! Default definition for undefined words
|
||||
SYMBOL: undefined-quot
|
||||
|
||||
: userenvs ( -- assoc )
|
||||
H{
|
||||
{ bootstrap-boot-quot 20 }
|
||||
{ bootstrap-global 21 }
|
||||
{ jit-code-format 22 }
|
||||
{ jit-prolog 23 }
|
||||
{ jit-primitive-word 24 }
|
||||
{ jit-primitive 25 }
|
||||
{ jit-word-jump 26 }
|
||||
{ jit-word-call 27 }
|
||||
{ jit-if-word 28 }
|
||||
{ jit-if-1 29 }
|
||||
{ jit-if-2 30 }
|
||||
{ jit-dispatch-word 31 }
|
||||
{ jit-dispatch 32 }
|
||||
{ jit-epilog 33 }
|
||||
{ jit-return 34 }
|
||||
{ jit-profiling 35 }
|
||||
{ jit-push-immediate 36 }
|
||||
{ jit-declare-word 42 }
|
||||
{ jit-save-stack 43 }
|
||||
{ jit-dip-word 44 }
|
||||
{ jit-dip 45 }
|
||||
{ jit-2dip-word 46 }
|
||||
{ jit-2dip 47 }
|
||||
{ jit-3dip-word 48 }
|
||||
{ jit-3dip 49 }
|
||||
{ undefined-quot 60 }
|
||||
} ; inline
|
||||
USERENV: undefined-quot 60
|
||||
|
||||
: userenv-offset ( symbol -- n )
|
||||
userenvs at header-size + ;
|
||||
userenvs get at header-size + ;
|
||||
|
||||
: emit ( cell -- ) image get push ;
|
||||
|
||||
|
|
@ -205,8 +206,8 @@ SYMBOL: undefined-quot
|
|||
|
||||
: emit-fixnum ( n -- ) tag-fixnum emit ;
|
||||
|
||||
: emit-object ( header tag quot -- addr )
|
||||
swap here-as [ swap tag-fixnum emit call align-here ] dip ;
|
||||
: emit-object ( class quot -- addr )
|
||||
over tag-number here-as [ swap type-number tag-fixnum emit call align-here ] dip ;
|
||||
inline
|
||||
|
||||
! Write an object to the image.
|
||||
|
|
@ -251,7 +252,7 @@ GENERIC: ' ( obj -- ptr )
|
|||
|
||||
M: bignum '
|
||||
[
|
||||
bignum tag-number dup [ emit-bignum ] emit-object
|
||||
bignum [ emit-bignum ] emit-object
|
||||
] cache-object ;
|
||||
|
||||
! Fixnums
|
||||
|
|
@ -274,7 +275,7 @@ M: fake-bignum ' n>> tag-fixnum ;
|
|||
|
||||
M: float '
|
||||
[
|
||||
float tag-number dup [
|
||||
float [
|
||||
align-here double>bits emit-64
|
||||
] emit-object
|
||||
] cache-object ;
|
||||
|
|
@ -309,7 +310,8 @@ M: f '
|
|||
[ vocabulary>> , ]
|
||||
[ def>> , ]
|
||||
[ props>> , ]
|
||||
[ drop f , ]
|
||||
[ pic-def>> , ]
|
||||
[ pic-tail-def>> , ]
|
||||
[ drop 0 , ] ! count
|
||||
[ word-sub-primitive , ]
|
||||
[ drop 0 , ] ! xt
|
||||
|
|
@ -318,8 +320,7 @@ M: f '
|
|||
} cleave
|
||||
] { } make [ ' ] map
|
||||
] bi
|
||||
\ word type-number object tag-number
|
||||
[ emit-seq ] emit-object
|
||||
\ word [ emit-seq ] emit-object
|
||||
] keep put-object ;
|
||||
|
||||
: word-error ( word msg -- * )
|
||||
|
|
@ -340,8 +341,7 @@ M: word ' ;
|
|||
! Wrappers
|
||||
|
||||
M: wrapper '
|
||||
wrapped>> ' wrapper type-number object tag-number
|
||||
[ emit ] emit-object ;
|
||||
wrapped>> ' wrapper [ emit ] emit-object ;
|
||||
|
||||
! Strings
|
||||
: native> ( object -- object )
|
||||
|
|
@ -370,7 +370,7 @@ M: wrapper '
|
|||
|
||||
: emit-string ( string -- ptr )
|
||||
[ length ] [ extended-part ' ] [ ] tri
|
||||
string type-number object tag-number [
|
||||
string [
|
||||
[ emit-fixnum ]
|
||||
[ emit ]
|
||||
[ f ' emit ascii-part pad-bytes emit-bytes ]
|
||||
|
|
@ -387,12 +387,11 @@ M: string '
|
|||
|
||||
: emit-dummy-array ( obj type -- ptr )
|
||||
[ assert-empty ] [
|
||||
type-number object tag-number
|
||||
[ 0 emit-fixnum ] emit-object
|
||||
] bi* ;
|
||||
|
||||
M: byte-array '
|
||||
byte-array type-number object tag-number [
|
||||
byte-array [
|
||||
dup length emit-fixnum
|
||||
pad-bytes emit-bytes
|
||||
] emit-object ;
|
||||
|
|
@ -406,7 +405,7 @@ ERROR: tuple-removed class ;
|
|||
: (emit-tuple) ( tuple -- pointer )
|
||||
[ tuple-slots ]
|
||||
[ class transfer-word require-tuple-layout ] bi prefix [ ' ] map
|
||||
tuple type-number dup [ emit-seq ] emit-object ;
|
||||
tuple [ emit-seq ] emit-object ;
|
||||
|
||||
: emit-tuple ( tuple -- pointer )
|
||||
dup class name>> "tombstone" =
|
||||
|
|
@ -421,8 +420,7 @@ M: tombstone '
|
|||
|
||||
! Arrays
|
||||
: emit-array ( array -- offset )
|
||||
[ ' ] map array type-number object tag-number
|
||||
[ [ length emit-fixnum ] [ emit-seq ] bi ] emit-object ;
|
||||
[ ' ] map array [ [ length emit-fixnum ] [ emit-seq ] bi ] emit-object ;
|
||||
|
||||
M: array ' emit-array ;
|
||||
|
||||
|
|
@ -448,7 +446,7 @@ M: tuple-layout-array '
|
|||
M: quotation '
|
||||
[
|
||||
array>> '
|
||||
quotation type-number object tag-number [
|
||||
quotation [
|
||||
emit ! array
|
||||
f ' emit ! compiled
|
||||
f ' emit ! cached-effect
|
||||
|
|
@ -472,47 +470,23 @@ M: quotation '
|
|||
class<=-cache class-not-cache classes-intersect-cache
|
||||
class-and-cache class-or-cache next-method-quot-cache
|
||||
} [ H{ } clone ] H{ } map>assoc assoc-union
|
||||
bootstrap-global set
|
||||
bootstrap-global emit-userenv ;
|
||||
|
||||
: emit-boot-quot ( -- )
|
||||
bootstrap-boot-quot emit-userenv ;
|
||||
bootstrap-global set ;
|
||||
|
||||
: emit-jit-data ( -- )
|
||||
\ if jit-if-word set
|
||||
\ dispatch jit-dispatch-word set
|
||||
\ do-primitive jit-primitive-word set
|
||||
\ declare jit-declare-word set
|
||||
\ dip jit-dip-word set
|
||||
\ 2dip jit-2dip-word set
|
||||
\ 3dip jit-3dip-word set
|
||||
[ undefined ] undefined-quot set
|
||||
{
|
||||
jit-code-format
|
||||
jit-prolog
|
||||
jit-primitive-word
|
||||
jit-primitive
|
||||
jit-word-jump
|
||||
jit-word-call
|
||||
jit-push-immediate
|
||||
jit-if-word
|
||||
jit-if-1
|
||||
jit-if-2
|
||||
jit-dispatch-word
|
||||
jit-dispatch
|
||||
jit-dip-word
|
||||
jit-dip
|
||||
jit-2dip-word
|
||||
jit-2dip
|
||||
jit-3dip-word
|
||||
jit-3dip
|
||||
jit-epilog
|
||||
jit-return
|
||||
jit-profiling
|
||||
jit-declare-word
|
||||
jit-save-stack
|
||||
undefined-quot
|
||||
} [ emit-userenv ] each ;
|
||||
\ (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
|
||||
[ undefined ] undefined-quot set ;
|
||||
|
||||
: emit-userenvs ( -- )
|
||||
userenvs get keys [ emit-userenv ] each ;
|
||||
|
||||
: fixup-header ( -- )
|
||||
heap-size data-heap-size-offset fixup ;
|
||||
|
|
@ -529,8 +503,8 @@ M: quotation '
|
|||
emit-jit-data
|
||||
"Serializing global namespace..." print flush
|
||||
emit-global
|
||||
"Serializing boot quotation..." print flush
|
||||
emit-boot-quot
|
||||
"Serializing user environment..." print flush
|
||||
emit-userenvs
|
||||
"Performing word fixups..." print flush
|
||||
fixup-words
|
||||
"Performing header fixups..." print flush
|
||||
|
|
|
|||
|
|
@ -0,0 +1 @@
|
|||
Slava Pestov
|
||||
|
|
@ -0,0 +1,14 @@
|
|||
! Copyright (C) 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: parser kernel namespaces assocs words.symbol ;
|
||||
IN: bootstrap.image.syntax
|
||||
|
||||
SYMBOL: userenvs
|
||||
|
||||
SYNTAX: RESET H{ } clone userenvs set-global ;
|
||||
|
||||
SYNTAX: USERENV:
|
||||
CREATE-WORD scan-word
|
||||
[ swap userenvs get set-at ]
|
||||
[ drop define-symbol ]
|
||||
2bi ;
|
||||
|
|
@ -35,10 +35,6 @@ SYMBOL: bootstrap-time
|
|||
"Core bootstrap completed in " write core-bootstrap-time get print-time
|
||||
"Bootstrap completed in " write bootstrap-time get print-time
|
||||
|
||||
[ optimized>> ] count-words " compiled words" print
|
||||
[ symbol? ] count-words " symbol words" print
|
||||
[ ] count-words " words total" print
|
||||
|
||||
"Bootstrapping is complete." print
|
||||
"Now, you can run Factor:" print
|
||||
vm write " -i=" write "output-image" get print flush ;
|
||||
|
|
@ -69,7 +65,6 @@ SYMBOL: bootstrap-time
|
|||
"stage2: deployment mode" print
|
||||
] [
|
||||
"debugger" require
|
||||
"alien.prettyprint" require
|
||||
"inspector" require
|
||||
"tools.errors" require
|
||||
"listener" require
|
||||
|
|
|
|||
|
|
@ -14,7 +14,8 @@ IN: bootstrap.tools
|
|||
"tools.test"
|
||||
"tools.time"
|
||||
"tools.threads"
|
||||
"tools.vocabs"
|
||||
"tools.vocabs.monitor"
|
||||
"vocabs.hierarchy"
|
||||
"vocabs.refresh"
|
||||
"vocabs.refresh.monitor"
|
||||
"editors"
|
||||
} [ require ] each
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
USING: calendar namespaces alien.c-types system windows
|
||||
windows.kernel32 kernel math combinators ;
|
||||
USING: calendar namespaces alien.c-types system
|
||||
windows.kernel32 kernel math combinators windows.errors ;
|
||||
IN: calendar.windows
|
||||
|
||||
M: windows gmt-offset ( -- hours minutes seconds )
|
||||
|
|
|
|||
|
|
@ -9,6 +9,9 @@ SYMBOL: bytes-read
|
|||
: calculate-pad-length ( length -- length' )
|
||||
[ 56 < 55 119 ? ] keep - ;
|
||||
|
||||
: calculate-pad-length-long ( length -- length' )
|
||||
[ 120 < 119 247 ? ] keep - ;
|
||||
|
||||
: pad-last-block ( str big-endian? length -- str )
|
||||
[
|
||||
[ % ] 2dip HEX: 80 ,
|
||||
|
|
|
|||
|
|
@ -1,7 +1,42 @@
|
|||
USING: arrays kernel math namespaces sequences tools.test checksums.sha2 checksums ;
|
||||
[ "e3b0c44298fc1c149afbf4c8996fb92427ae41e4649b934ca495991b7852b855" ] [ "" sha-256 checksum-bytes hex-string ] unit-test
|
||||
[ "ba7816bf8f01cfea414140de5dae2223b00361a396177a9cb410ff61f20015ad" ] [ "abc" sha-256 checksum-bytes hex-string ] unit-test
|
||||
[ "f7846f55cf23e14eebeab5b4e1550cad5b509e3348fbc4efa3a1413d393cb650" ] [ "message digest" sha-256 checksum-bytes hex-string ] unit-test
|
||||
[ "71c480df93d6ae2f1efad1447c66c9525e316218cf51fc8d9ed832f2daf18b73" ] [ "abcdefghijklmnopqrstuvwxyz" sha-256 checksum-bytes hex-string ] unit-test
|
||||
[ "db4bfcbd4da0cd85a60c3c37d3fbd8805c77f15fc6b1fdfe614ee0a7c8fdb4c0" ] [ "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789" sha-256 checksum-bytes hex-string ] unit-test
|
||||
[ "f371bc4a311f2b009eef952dd83ca80e2b60026c8e935592d0f9c308453c813e" ] [ "12345678901234567890123456789012345678901234567890123456789012345678901234567890" sha-256 checksum-bytes hex-string ] unit-test
|
||||
USING: arrays kernel math namespaces sequences tools.test
|
||||
checksums.sha2 checksums ;
|
||||
IN: checksums.sha2.tests
|
||||
|
||||
: test-checksum ( text identifier -- checksum )
|
||||
checksum-bytes hex-string ;
|
||||
|
||||
[ "75388b16512776cc5dba5da1fd890150b0c6455cb4f58b1952522525" ]
|
||||
[
|
||||
"abcdbcdecdefdefgefghfghighijhijkijkljklmklmnlmnomnopnopq"
|
||||
sha-224 test-checksum
|
||||
] unit-test
|
||||
|
||||
[ "e3b0c44298fc1c149afbf4c8996fb92427ae41e4649b934ca495991b7852b855" ]
|
||||
[ "" sha-256 test-checksum ] unit-test
|
||||
|
||||
[ "ba7816bf8f01cfea414140de5dae2223b00361a396177a9cb410ff61f20015ad" ]
|
||||
[ "abc" sha-256 test-checksum ] unit-test
|
||||
|
||||
[ "f7846f55cf23e14eebeab5b4e1550cad5b509e3348fbc4efa3a1413d393cb650" ]
|
||||
[ "message digest" sha-256 test-checksum ] unit-test
|
||||
|
||||
[ "71c480df93d6ae2f1efad1447c66c9525e316218cf51fc8d9ed832f2daf18b73" ]
|
||||
[ "abcdefghijklmnopqrstuvwxyz" sha-256 test-checksum ] unit-test
|
||||
|
||||
[ "db4bfcbd4da0cd85a60c3c37d3fbd8805c77f15fc6b1fdfe614ee0a7c8fdb4c0" ]
|
||||
[
|
||||
"ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789"
|
||||
sha-256 test-checksum
|
||||
] unit-test
|
||||
|
||||
[ "f371bc4a311f2b009eef952dd83ca80e2b60026c8e935592d0f9c308453c813e" ]
|
||||
[
|
||||
"12345678901234567890123456789012345678901234567890123456789012345678901234567890"
|
||||
sha-256 test-checksum
|
||||
] unit-test
|
||||
|
||||
|
||||
|
||||
|
||||
! [ "8e959b75dae313da8cf4f72814fc143f8f7779c6eb9f7fa17299aeadb6889018501d289e4900f7e4331b99dec4b5433ac7d329eeb6dd26545e96e55b874be909" ]
|
||||
! [ "abcdefghbcdefghicdefghijdefghijkefghijklfghijklmghijklmnhijklmnoijklmnopjklmnopqklmnopqrlmnopqrsmnopqrstnopqrstu" sha-512 test-checksum ] unit-test
|
||||
|
|
|
|||
|
|
@ -2,12 +2,27 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel splitting grouping math sequences namespaces make
|
||||
io.binary math.bitwise checksums checksums.common
|
||||
sbufs strings ;
|
||||
sbufs strings combinators.smart math.ranges fry combinators
|
||||
accessors locals ;
|
||||
IN: checksums.sha2
|
||||
|
||||
<PRIVATE
|
||||
SINGLETON: sha-224
|
||||
SINGLETON: sha-256
|
||||
|
||||
SYMBOLS: vars M K H S0 S1 process-M word-size block-size ;
|
||||
INSTANCE: sha-224 checksum
|
||||
INSTANCE: sha-256 checksum
|
||||
|
||||
TUPLE: sha2-state K H word-size block-size ;
|
||||
|
||||
TUPLE: sha2-short < sha2-state ;
|
||||
|
||||
TUPLE: sha2-long < sha2-state ;
|
||||
|
||||
TUPLE: sha-224-state < sha2-short ;
|
||||
|
||||
TUPLE: sha-256-state < sha2-short ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
CONSTANT: a 0
|
||||
CONSTANT: b 1
|
||||
|
|
@ -18,13 +33,43 @@ CONSTANT: f 5
|
|||
CONSTANT: g 6
|
||||
CONSTANT: h 7
|
||||
|
||||
: initial-H-256 ( -- seq )
|
||||
CONSTANT: initial-H-224
|
||||
{
|
||||
HEX: c1059ed8 HEX: 367cd507 HEX: 3070dd17 HEX: f70e5939
|
||||
HEX: ffc00b31 HEX: 68581511 HEX: 64f98fa7 HEX: befa4fa4
|
||||
}
|
||||
|
||||
CONSTANT: initial-H-256
|
||||
{
|
||||
HEX: 6a09e667 HEX: bb67ae85 HEX: 3c6ef372 HEX: a54ff53a
|
||||
HEX: 510e527f HEX: 9b05688c HEX: 1f83d9ab HEX: 5be0cd19
|
||||
} ;
|
||||
}
|
||||
|
||||
: K-256 ( -- seq )
|
||||
CONSTANT: initial-H-384
|
||||
{
|
||||
HEX: cbbb9d5dc1059ed8
|
||||
HEX: 629a292a367cd507
|
||||
HEX: 9159015a3070dd17
|
||||
HEX: 152fecd8f70e5939
|
||||
HEX: 67332667ffc00b31
|
||||
HEX: 8eb44a8768581511
|
||||
HEX: db0c2e0d64f98fa7
|
||||
HEX: 47b5481dbefa4fa4
|
||||
}
|
||||
|
||||
CONSTANT: initial-H-512
|
||||
{
|
||||
HEX: 6a09e667f3bcc908
|
||||
HEX: bb67ae8584caa73b
|
||||
HEX: 3c6ef372fe94f82b
|
||||
HEX: a54ff53a5f1d36f1
|
||||
HEX: 510e527fade682d1
|
||||
HEX: 9b05688c2b3e6c1f
|
||||
HEX: 1f83d9abfb41bd6b
|
||||
HEX: 5be0cd19137e2179
|
||||
}
|
||||
|
||||
CONSTANT: K-256
|
||||
{
|
||||
HEX: 428a2f98 HEX: 71374491 HEX: b5c0fbcf HEX: e9b5dba5
|
||||
HEX: 3956c25b HEX: 59f111f1 HEX: 923f82a4 HEX: ab1c5ed5
|
||||
|
|
@ -42,62 +87,163 @@ CONSTANT: h 7
|
|||
HEX: 391c0cb3 HEX: 4ed8aa4a HEX: 5b9cca4f HEX: 682e6ff3
|
||||
HEX: 748f82ee HEX: 78a5636f HEX: 84c87814 HEX: 8cc70208
|
||||
HEX: 90befffa HEX: a4506ceb HEX: bef9a3f7 HEX: c67178f2
|
||||
} ;
|
||||
}
|
||||
|
||||
CONSTANT: K-384
|
||||
{
|
||||
|
||||
HEX: 428a2f98d728ae22 HEX: 7137449123ef65cd HEX: b5c0fbcfec4d3b2f HEX: e9b5dba58189dbbc
|
||||
HEX: 3956c25bf348b538 HEX: 59f111f1b605d019 HEX: 923f82a4af194f9b HEX: ab1c5ed5da6d8118
|
||||
HEX: d807aa98a3030242 HEX: 12835b0145706fbe HEX: 243185be4ee4b28c HEX: 550c7dc3d5ffb4e2
|
||||
HEX: 72be5d74f27b896f HEX: 80deb1fe3b1696b1 HEX: 9bdc06a725c71235 HEX: c19bf174cf692694
|
||||
HEX: e49b69c19ef14ad2 HEX: efbe4786384f25e3 HEX: 0fc19dc68b8cd5b5 HEX: 240ca1cc77ac9c65
|
||||
HEX: 2de92c6f592b0275 HEX: 4a7484aa6ea6e483 HEX: 5cb0a9dcbd41fbd4 HEX: 76f988da831153b5
|
||||
HEX: 983e5152ee66dfab HEX: a831c66d2db43210 HEX: b00327c898fb213f HEX: bf597fc7beef0ee4
|
||||
HEX: c6e00bf33da88fc2 HEX: d5a79147930aa725 HEX: 06ca6351e003826f HEX: 142929670a0e6e70
|
||||
HEX: 27b70a8546d22ffc HEX: 2e1b21385c26c926 HEX: 4d2c6dfc5ac42aed HEX: 53380d139d95b3df
|
||||
HEX: 650a73548baf63de HEX: 766a0abb3c77b2a8 HEX: 81c2c92e47edaee6 HEX: 92722c851482353b
|
||||
HEX: a2bfe8a14cf10364 HEX: a81a664bbc423001 HEX: c24b8b70d0f89791 HEX: c76c51a30654be30
|
||||
HEX: d192e819d6ef5218 HEX: d69906245565a910 HEX: f40e35855771202a HEX: 106aa07032bbd1b8
|
||||
HEX: 19a4c116b8d2d0c8 HEX: 1e376c085141ab53 HEX: 2748774cdf8eeb99 HEX: 34b0bcb5e19b48a8
|
||||
HEX: 391c0cb3c5c95a63 HEX: 4ed8aa4ae3418acb HEX: 5b9cca4f7763e373 HEX: 682e6ff3d6b2b8a3
|
||||
HEX: 748f82ee5defb2fc HEX: 78a5636f43172f60 HEX: 84c87814a1f0ab72 HEX: 8cc702081a6439ec
|
||||
HEX: 90befffa23631e28 HEX: a4506cebde82bde9 HEX: bef9a3f7b2c67915 HEX: c67178f2e372532b
|
||||
HEX: ca273eceea26619c HEX: d186b8c721c0c207 HEX: eada7dd6cde0eb1e HEX: f57d4f7fee6ed178
|
||||
HEX: 06f067aa72176fba HEX: 0a637dc5a2c898a6 HEX: 113f9804bef90dae HEX: 1b710b35131c471b
|
||||
HEX: 28db77f523047d84 HEX: 32caab7b40c72493 HEX: 3c9ebe0a15c9bebc HEX: 431d67c49c100d4c
|
||||
HEX: 4cc5d4becb3e42b6 HEX: 597f299cfc657e2a HEX: 5fcb6fab3ad6faec HEX: 6c44198c4a475817
|
||||
}
|
||||
|
||||
ALIAS: K-512 K-384
|
||||
|
||||
: s0-256 ( x -- x' )
|
||||
[ -7 bitroll-32 ] keep
|
||||
[ -18 bitroll-32 ] keep
|
||||
-3 shift bitxor bitxor ; inline
|
||||
[
|
||||
[ -7 bitroll-32 ]
|
||||
[ -18 bitroll-32 ]
|
||||
[ -3 shift ] tri
|
||||
] [ bitxor ] reduce-outputs ; inline
|
||||
|
||||
: s1-256 ( x -- x' )
|
||||
[ -17 bitroll-32 ] keep
|
||||
[ -19 bitroll-32 ] keep
|
||||
-10 shift bitxor bitxor ; inline
|
||||
|
||||
: process-M-256 ( seq n -- )
|
||||
[ 16 - swap nth ] 2keep
|
||||
[ 15 - swap nth s0-256 ] 2keep
|
||||
[ 7 - swap nth ] 2keep
|
||||
[ 2 - swap nth s1-256 ] 2keep
|
||||
[ + + w+ ] 2dip swap set-nth ; inline
|
||||
|
||||
: prepare-message-schedule ( seq -- w-seq )
|
||||
word-size get group [ be> ] map block-size get 0 pad-tail
|
||||
dup 16 64 dup <slice> [
|
||||
process-M-256
|
||||
] with each ;
|
||||
|
||||
: ch ( x y z -- x' )
|
||||
[ bitxor bitand ] keep bitxor ;
|
||||
|
||||
: maj ( x y z -- x' )
|
||||
[ [ bitand ] 2keep bitor ] dip bitand bitor ;
|
||||
[
|
||||
[ -17 bitroll-32 ]
|
||||
[ -19 bitroll-32 ]
|
||||
[ -10 shift ] tri
|
||||
] [ bitxor ] reduce-outputs ; inline
|
||||
|
||||
: S0-256 ( x -- x' )
|
||||
[ -2 bitroll-32 ] keep
|
||||
[ -13 bitroll-32 ] keep
|
||||
-22 bitroll-32 bitxor bitxor ; inline
|
||||
[
|
||||
[ -2 bitroll-32 ]
|
||||
[ -13 bitroll-32 ]
|
||||
[ -22 bitroll-32 ] tri
|
||||
] [ bitxor ] reduce-outputs ; inline
|
||||
|
||||
: S1-256 ( x -- x' )
|
||||
[ -6 bitroll-32 ] keep
|
||||
[ -11 bitroll-32 ] keep
|
||||
-25 bitroll-32 bitxor bitxor ; inline
|
||||
[
|
||||
[ -6 bitroll-32 ]
|
||||
[ -11 bitroll-32 ]
|
||||
[ -25 bitroll-32 ] tri
|
||||
] [ bitxor ] reduce-outputs ; inline
|
||||
|
||||
: slice3 ( n seq -- a b c ) [ dup 3 + ] dip <slice> first3 ; inline
|
||||
: s0-512 ( x -- x' )
|
||||
[
|
||||
[ -1 bitroll-64 ]
|
||||
[ -8 bitroll-64 ]
|
||||
[ -7 shift ] tri
|
||||
] [ bitxor ] reduce-outputs ; inline
|
||||
|
||||
: T1 ( W n -- T1 )
|
||||
[ swap nth ] keep
|
||||
K get nth +
|
||||
e vars get slice3 ch +
|
||||
e vars get nth S1-256 +
|
||||
h vars get nth w+ ;
|
||||
: s1-512 ( x -- x' )
|
||||
[
|
||||
[ -19 bitroll-64 ]
|
||||
[ -61 bitroll-64 ]
|
||||
[ -6 shift ] tri
|
||||
] [ bitxor ] reduce-outputs ; inline
|
||||
|
||||
: T2 ( -- T2 )
|
||||
a vars get nth S0-256
|
||||
a vars get slice3 maj w+ ;
|
||||
: S0-512 ( x -- x' )
|
||||
[
|
||||
[ -28 bitroll-64 ]
|
||||
[ -34 bitroll-64 ]
|
||||
[ -39 bitroll-64 ] tri
|
||||
] [ bitxor ] reduce-outputs ; inline
|
||||
|
||||
: update-vars ( T1 T2 -- )
|
||||
vars get
|
||||
: S1-512 ( x -- x' )
|
||||
[
|
||||
[ -14 bitroll-64 ]
|
||||
[ -18 bitroll-64 ]
|
||||
[ -41 bitroll-64 ] tri
|
||||
] [ bitxor ] reduce-outputs ; inline
|
||||
|
||||
: process-M-256 ( n seq -- )
|
||||
{
|
||||
[ [ 16 - ] dip nth ]
|
||||
[ [ 15 - ] dip nth s0-256 ]
|
||||
[ [ 7 - ] dip nth ]
|
||||
[ [ 2 - ] dip nth s1-256 w+ w+ w+ ]
|
||||
[ ]
|
||||
} 2cleave set-nth ; inline
|
||||
|
||||
: process-M-512 ( n seq -- )
|
||||
{
|
||||
[ [ 16 - ] dip nth ]
|
||||
[ [ 15 - ] dip nth s0-512 ]
|
||||
[ [ 7 - ] dip nth ]
|
||||
[ [ 2 - ] dip nth s1-512 w+ w+ w+ ]
|
||||
[ ]
|
||||
} 2cleave set-nth ; inline
|
||||
|
||||
: ch ( x y z -- x' )
|
||||
[ bitxor bitand ] keep bitxor ; inline
|
||||
|
||||
: maj ( x y z -- x' )
|
||||
[ [ bitand ] [ bitor ] 2bi ] dip bitand bitor ; inline
|
||||
|
||||
: slice3 ( n seq -- a b c )
|
||||
[ dup 3 + ] dip <slice> first3 ; inline
|
||||
|
||||
GENERIC: pad-initial-bytes ( string sha2 -- padded-string )
|
||||
|
||||
M: sha2-short pad-initial-bytes ( string sha2 -- padded-string )
|
||||
drop
|
||||
dup [
|
||||
HEX: 80 ,
|
||||
length
|
||||
[ 64 mod calculate-pad-length 0 <string> % ]
|
||||
[ 3 shift 8 >be % ] bi
|
||||
] "" make append ;
|
||||
|
||||
M: sha2-long pad-initial-bytes ( string sha2 -- padded-string )
|
||||
drop dup [
|
||||
HEX: 80 ,
|
||||
length
|
||||
[ 128 mod calculate-pad-length-long 0 <string> % ]
|
||||
[ 3 shift 8 >be % ] bi
|
||||
] "" make append ;
|
||||
|
||||
: seq>byte-array ( seq n -- string )
|
||||
'[ _ >be ] map B{ } join ;
|
||||
|
||||
:: T1-256 ( n M H sha2 -- T1 )
|
||||
n M nth
|
||||
n sha2 K>> nth +
|
||||
e H slice3 ch w+
|
||||
e H nth S1-256 w+
|
||||
h H nth w+ ; inline
|
||||
|
||||
: T2-256 ( H -- T2 )
|
||||
[ a swap nth S0-256 ]
|
||||
[ a swap slice3 maj w+ ] bi ; inline
|
||||
|
||||
:: T1-512 ( n M H sha2 -- T1 )
|
||||
n M nth
|
||||
n sha2 K>> nth +
|
||||
e H slice3 ch w+
|
||||
e H nth S1-512 w+
|
||||
h H nth w+ ; inline
|
||||
|
||||
: T2-512 ( H -- T2 )
|
||||
[ a swap nth S0-512 ]
|
||||
[ a swap slice3 maj w+ ] bi ; inline
|
||||
|
||||
: update-H ( T1 T2 H -- )
|
||||
h g pick exchange
|
||||
g f pick exchange
|
||||
f e pick exchange
|
||||
|
|
@ -105,42 +251,56 @@ CONSTANT: h 7
|
|||
d c pick exchange
|
||||
c b pick exchange
|
||||
b a pick exchange
|
||||
[ w+ a ] dip set-nth ;
|
||||
[ w+ a ] dip set-nth ; inline
|
||||
|
||||
: process-chunk ( M -- )
|
||||
H get clone vars set
|
||||
prepare-message-schedule block-size get [
|
||||
T1 T2 update-vars
|
||||
] with each vars get H get [ w+ ] 2map H set ;
|
||||
: prepare-message-schedule ( seq sha2 -- w-seq )
|
||||
[ word-size>> <sliced-groups> [ be> ] map ]
|
||||
[
|
||||
block-size>> [ 0 pad-tail 16 ] keep [a,b) over
|
||||
'[ _ process-M-256 ] each
|
||||
] bi ; inline
|
||||
|
||||
: seq>byte-array ( n seq -- string )
|
||||
[ swap [ >be % ] curry each ] B{ } make ;
|
||||
:: process-chunk ( M block-size cloned-H sha2 -- )
|
||||
block-size [
|
||||
M cloned-H sha2 T1-256
|
||||
cloned-H T2-256
|
||||
cloned-H update-H
|
||||
] each
|
||||
cloned-H sha2 H>> [ w+ ] 2map sha2 (>>H) ; inline
|
||||
|
||||
: preprocess-plaintext ( string big-endian? -- padded-string )
|
||||
#! pad 0x80 then 00 til 8 bytes left, then 64bit length in bits
|
||||
[ >sbuf ] dip over [
|
||||
HEX: 80 ,
|
||||
dup length HEX: 3f bitand
|
||||
calculate-pad-length 0 <string> %
|
||||
length 3 shift 8 rot [ >be ] [ >le ] if %
|
||||
] "" make over push-all ;
|
||||
: sha2-steps ( sliced-groups state -- )
|
||||
'[
|
||||
_
|
||||
[ prepare-message-schedule ]
|
||||
[ [ block-size>> ] [ H>> clone ] [ ] tri process-chunk ] bi
|
||||
] each ;
|
||||
|
||||
: byte-array>sha2 ( byte-array -- string )
|
||||
t preprocess-plaintext
|
||||
block-size get group [ process-chunk ] each
|
||||
4 H get seq>byte-array ;
|
||||
: byte-array>sha2 ( bytes state -- )
|
||||
[ [ pad-initial-bytes ] [ nip block-size>> ] 2bi <sliced-groups> ]
|
||||
[ sha2-steps ] bi ;
|
||||
|
||||
: <sha-224-state> ( -- sha2-state )
|
||||
sha-224-state new
|
||||
K-256 >>K
|
||||
initial-H-224 >>H
|
||||
4 >>word-size
|
||||
64 >>block-size ;
|
||||
|
||||
: <sha-256-state> ( -- sha2-state )
|
||||
sha-256-state new
|
||||
K-256 >>K
|
||||
initial-H-256 >>H
|
||||
4 >>word-size
|
||||
64 >>block-size ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
SINGLETON: sha-256
|
||||
|
||||
INSTANCE: sha-256 checksum
|
||||
M: sha-224 checksum-bytes
|
||||
drop <sha-224-state>
|
||||
[ byte-array>sha2 ]
|
||||
[ H>> 7 head 4 seq>byte-array ] bi ;
|
||||
|
||||
M: sha-256 checksum-bytes
|
||||
drop [
|
||||
K-256 K set
|
||||
initial-H-256 H set
|
||||
4 word-size set
|
||||
64 block-size set
|
||||
byte-array>sha2
|
||||
] with-scope ;
|
||||
drop <sha-256-state>
|
||||
[ byte-array>sha2 ]
|
||||
[ H>> 4 seq>byte-array ] bi ;
|
||||
|
|
|
|||
|
|
@ -14,7 +14,7 @@ NSApplicationDelegateReplyCancel
|
|||
NSApplicationDelegateReplyFailure ;
|
||||
|
||||
: with-autorelease-pool ( quot -- )
|
||||
NSAutoreleasePool -> new slip -> release ; inline
|
||||
NSAutoreleasePool -> new [ call ] [ -> release ] bi* ; inline
|
||||
|
||||
: NSApp ( -- app ) NSApplication -> sharedApplication ;
|
||||
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
! Copyright (C) 2006 Slava Pestov
|
||||
! Copyright (C) 2006, 2009 Slava Pestov
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: compiler io kernel cocoa.runtime cocoa.subclassing
|
||||
cocoa.messages cocoa.types sequences words vocabs parser
|
||||
|
|
@ -7,7 +7,7 @@ compiler.units lexer init ;
|
|||
IN: cocoa
|
||||
|
||||
: (remember-send) ( selector variable -- )
|
||||
global [ dupd ?set-at ] change-at ;
|
||||
[ dupd ?set-at ] change-global ;
|
||||
|
||||
SYMBOL: sent-messages
|
||||
|
||||
|
|
@ -27,22 +27,16 @@ SYMBOL: frameworks
|
|||
|
||||
frameworks [ V{ } clone ] initialize
|
||||
|
||||
[ frameworks get [ load-framework ] each ] "cocoa.messages" add-init-hook
|
||||
[ frameworks get [ load-framework ] each ] "cocoa" add-init-hook
|
||||
|
||||
SYNTAX: FRAMEWORK: scan [ load-framework ] [ frameworks get push ] bi ;
|
||||
|
||||
SYNTAX: IMPORT: scan [ ] import-objc-class ;
|
||||
|
||||
"Compiling Objective C bridge..." print
|
||||
"Importing Cocoa classes..." print
|
||||
|
||||
"cocoa.classes" create-vocab drop
|
||||
|
||||
{
|
||||
"cocoa" "cocoa.runtime" "cocoa.messages" "cocoa.subclassing"
|
||||
} [ words ] map concat compile
|
||||
|
||||
"Importing Cocoa classes..." print
|
||||
|
||||
[
|
||||
{
|
||||
"NSApplication"
|
||||
|
|
|
|||
|
|
@ -12,6 +12,9 @@ IN: cocoa.dialogs
|
|||
dup 1 -> setResolvesAliases:
|
||||
dup 1 -> setAllowsMultipleSelection: ;
|
||||
|
||||
: <NSDirPanel> ( -- panel ) <NSOpenPanel>
|
||||
dup 1 -> setCanChooseDirectories: ;
|
||||
|
||||
: <NSSavePanel> ( -- panel )
|
||||
NSSavePanel -> savePanel
|
||||
dup 1 -> setCanChooseFiles:
|
||||
|
|
@ -21,10 +24,12 @@ IN: cocoa.dialogs
|
|||
CONSTANT: NSOKButton 1
|
||||
CONSTANT: NSCancelButton 0
|
||||
|
||||
: open-panel ( -- paths )
|
||||
<NSOpenPanel>
|
||||
: (open-panel) ( panel -- paths )
|
||||
dup -> runModal NSOKButton =
|
||||
[ -> filenames CF>string-array ] [ drop f ] if ;
|
||||
|
||||
: open-panel ( -- paths ) <NSOpenPanel> (open-panel) ;
|
||||
: open-dir-panel ( -- paths ) <NSDirPanel> (open-panel) ;
|
||||
|
||||
: split-path ( path -- dir file )
|
||||
"/" split1-last [ <NSString> ] bi@ ;
|
||||
|
|
|
|||
|
|
@ -4,7 +4,7 @@
|
|||
USING: strings arrays hashtables assocs sequences fry macros
|
||||
cocoa.messages cocoa.classes cocoa.application cocoa kernel
|
||||
namespaces io.backend math cocoa.enumeration byte-arrays
|
||||
combinators alien.c-types words core-foundation
|
||||
combinators alien.c-types words core-foundation quotations
|
||||
core-foundation.data core-foundation.utilities ;
|
||||
IN: cocoa.plists
|
||||
|
||||
|
|
@ -41,10 +41,16 @@ DEFER: plist>
|
|||
*void* [ -> release "read-plist failed" throw ] when* ;
|
||||
|
||||
MACRO: objc-class-case ( alist -- quot )
|
||||
[ [ '[ dup _ execute -> isKindOfClass: c-bool> ] ] dip ] assoc-map '[ _ cond ] ;
|
||||
[
|
||||
dup callable?
|
||||
[ first2 [ '[ dup _ execute -> isKindOfClass: c-bool> ] ] dip 2array ]
|
||||
unless
|
||||
] map '[ _ cond ] ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
ERROR: invalid-plist-object object ;
|
||||
|
||||
: plist> ( plist -- value )
|
||||
{
|
||||
{ NSString [ (plist-NSString>) ] }
|
||||
|
|
@ -53,6 +59,7 @@ PRIVATE>
|
|||
{ NSArray [ (plist-NSArray>) ] }
|
||||
{ NSDictionary [ (plist-NSDictionary>) ] }
|
||||
{ NSObject [ ] }
|
||||
[ invalid-plist-object ]
|
||||
} objc-class-case ;
|
||||
|
||||
: read-plist ( path -- assoc )
|
||||
|
|
|
|||
|
|
@ -1,13 +1,9 @@
|
|||
USING: help.syntax help.markup ;
|
||||
USING: help.syntax help.markup ui.pixel-formats ;
|
||||
IN: cocoa.views
|
||||
|
||||
HELP: <PixelFormat>
|
||||
{ $values { "attributes" "a sequence of attributes" } { "pixelfmt" "an " { $snippet "NSOpenGLPixelFormat" } } }
|
||||
{ $description "Creates an " { $snippet "NSOpenGLPixelFormat" } " with some reasonable defaults." } ;
|
||||
|
||||
HELP: <GLView>
|
||||
{ $values { "class" "an subclass of " { $snippet "NSOpenGLView" } } { "dim" "a pair of real numbers" } { "view" "a new " { $snippet "NSOpenGLView" } } }
|
||||
{ $description "Creates a new instance of the specified class, giving it a default pixel format and the given size." } ;
|
||||
{ $values { "class" "an subclass of " { $snippet "NSOpenGLView" } } { "dim" "a pair of real numbers" } { "pixel-format" pixel-format } { "view" "a new " { $snippet "NSOpenGLView" } } }
|
||||
{ $description "Creates a new instance of the specified class, giving it the specified pixel format and size." } ;
|
||||
|
||||
HELP: view-dim
|
||||
{ $values { "view" "an " { $snippet "NSView" } } { "dim" "a pair of real numbers" } }
|
||||
|
|
@ -18,7 +14,6 @@ HELP: mouse-location
|
|||
{ $description "Outputs the current mouse location." } ;
|
||||
|
||||
ARTICLE: "cocoa-view-utils" "Cocoa view utilities"
|
||||
{ $subsection <PixelFormat> }
|
||||
{ $subsection <GLView> }
|
||||
{ $subsection view-dim }
|
||||
{ $subsection mouse-location } ;
|
||||
|
|
|
|||
|
|
@ -42,39 +42,10 @@ CONSTANT: NSOpenGLPFAAllowOfflineRenderers 96
|
|||
CONSTANT: NSOpenGLPFAVirtualScreenCount 128
|
||||
CONSTANT: NSOpenGLCPSwapInterval 222
|
||||
|
||||
<PRIVATE
|
||||
|
||||
SYMBOL: software-renderer?
|
||||
SYMBOL: multisample?
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: with-software-renderer ( quot -- )
|
||||
[ t software-renderer? ] dip with-variable ; inline
|
||||
|
||||
: with-multisample ( quot -- )
|
||||
[ t multisample? ] dip with-variable ; inline
|
||||
|
||||
: <PixelFormat> ( attributes -- pixelfmt )
|
||||
NSOpenGLPixelFormat -> alloc swap [
|
||||
%
|
||||
NSOpenGLPFADepthSize , 16 ,
|
||||
software-renderer? get [
|
||||
NSOpenGLPFARendererID , kCGLRendererGenericFloatID ,
|
||||
] when
|
||||
multisample? get [
|
||||
NSOpenGLPFASupersample ,
|
||||
NSOpenGLPFASampleBuffers , 1 ,
|
||||
NSOpenGLPFASamples , 8 ,
|
||||
] when
|
||||
0 ,
|
||||
] int-array{ } make
|
||||
-> initWithAttributes:
|
||||
-> autorelease ;
|
||||
|
||||
: <GLView> ( class dim -- view )
|
||||
[ -> alloc 0 0 ] dip first2 <CGRect>
|
||||
NSOpenGLPFAWindow NSOpenGLPFADoubleBuffer 2array <PixelFormat>
|
||||
: <GLView> ( class dim pixel-format -- view )
|
||||
[ -> alloc ]
|
||||
[ [ 0 0 ] dip first2 <CGRect> ]
|
||||
[ handle>> ] tri*
|
||||
-> initWithFrame:pixelFormat:
|
||||
dup 1 -> setPostsBoundsChangedNotifications:
|
||||
dup 1 -> setPostsFrameChangedNotifications: ;
|
||||
|
|
|
|||
|
|
@ -18,6 +18,10 @@ MACRO: input<sequence ( quot -- newquot )
|
|||
[ infer in>> ] keep
|
||||
'[ _ firstn @ ] ;
|
||||
|
||||
MACRO: input<sequence-unsafe ( quot -- newquot )
|
||||
[ infer in>> ] keep
|
||||
'[ _ firstn-unsafe @ ] ;
|
||||
|
||||
MACRO: reduce-outputs ( quot operation -- newquot )
|
||||
[ dup infer out>> 1 [-] ] dip n*quot compose ;
|
||||
|
||||
|
|
|
|||
|
|
@ -1,5 +1,4 @@
|
|||
USING: help.markup help.syntax parser vocabs.loader strings
|
||||
command-line.private ;
|
||||
USING: help.markup help.syntax parser vocabs.loader strings ;
|
||||
IN: command-line
|
||||
|
||||
HELP: run-bootstrap-init
|
||||
|
|
@ -53,6 +52,7 @@ ARTICLE: "runtime-cli-args" "Command line switches for the VM"
|
|||
{ { $snippet "-aging=" { $emphasis "n" } } "Size of aging generation (1), megabytes" }
|
||||
{ { $snippet "-tenured=" { $emphasis "n" } } "Size of oldest generation (2), megabytes" }
|
||||
{ { $snippet "-codeheap=" { $emphasis "n" } } "Code heap size, megabytes" }
|
||||
{ { $snippet "-pic=" { $emphasis "n" } } "Maximum inline cache size. Setting of 0 disables inline caching, > 1 enables polymorphic inline caching" }
|
||||
{ { $snippet "-securegc" } "If specified, unused portions of the data heap will be zeroed out after every garbage collection" }
|
||||
}
|
||||
"If an " { $snippet "-i=" } " switch is not present, the default image file is used, which is usually a file named " { $snippet "factor.image" } " in the same directory as the runtime executable (on Windows and Mac OS X) or the current directory (on Unix)." ;
|
||||
|
|
|
|||
|
|
@ -1,14 +1,14 @@
|
|||
! Copyright (C) 2003, 2008 Slava Pestov.
|
||||
! Copyright (C) 2003, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: init continuations hashtables io io.encodings.utf8
|
||||
io.files io.pathnames kernel kernel.private namespaces parser
|
||||
sequences strings system splitting vocabs.loader ;
|
||||
sequences strings system splitting vocabs.loader alien.strings ;
|
||||
IN: command-line
|
||||
|
||||
SYMBOL: script
|
||||
SYMBOL: command-line
|
||||
|
||||
: (command-line) ( -- args ) 10 getenv sift ;
|
||||
: (command-line) ( -- args ) 10 getenv sift [ alien>native-string ] map ;
|
||||
|
||||
: rc-path ( name -- path )
|
||||
os windows? [ "." prepend ] unless
|
||||
|
|
|
|||
|
|
@ -27,11 +27,11 @@ IN: compiler.cfg.intrinsics.allot
|
|||
[ tuple ##set-slots ] [ ds-push drop ] 2bi
|
||||
] [ drop emit-primitive ] if ;
|
||||
|
||||
: store-length ( len reg -- )
|
||||
[ ^^load-literal ] dip 1 object tag-number ##set-slot-imm ;
|
||||
: store-length ( len reg class -- )
|
||||
[ [ ^^load-literal ] dip 1 ] dip tag-number ##set-slot-imm ;
|
||||
|
||||
: store-initial-element ( elt reg len -- )
|
||||
[ 2 + object tag-number ##set-slot-imm ] with with each ;
|
||||
:: store-initial-element ( len reg elt class -- )
|
||||
len [ [ elt reg ] dip 2 + class tag-number ##set-slot-imm ] each ;
|
||||
|
||||
: expand-<array>? ( obj -- ? )
|
||||
dup integer? [ 0 8 between? ] [ drop f ] if ;
|
||||
|
|
@ -42,8 +42,8 @@ IN: compiler.cfg.intrinsics.allot
|
|||
[let | elt [ ds-pop ]
|
||||
reg [ len ^^allot-array ] |
|
||||
ds-drop
|
||||
len reg store-length
|
||||
elt reg len store-initial-element
|
||||
len reg array store-length
|
||||
len reg elt array store-initial-element
|
||||
reg ds-push
|
||||
]
|
||||
] [ node emit-primitive ] if
|
||||
|
|
@ -57,16 +57,16 @@ IN: compiler.cfg.intrinsics.allot
|
|||
: emit-allot-byte-array ( len -- dst )
|
||||
ds-drop
|
||||
dup ^^allot-byte-array
|
||||
[ store-length ] [ ds-push ] [ ] tri ;
|
||||
[ byte-array store-length ] [ ds-push ] [ ] tri ;
|
||||
|
||||
: emit-(byte-array) ( node -- )
|
||||
dup node-input-infos first literal>> dup expand-<byte-array>?
|
||||
[ nip emit-allot-byte-array drop ] [ drop emit-primitive ] if ;
|
||||
|
||||
: emit-<byte-array> ( node -- )
|
||||
dup node-input-infos first literal>> dup expand-<byte-array>? [
|
||||
nip
|
||||
[ 0 ^^load-literal ] dip
|
||||
[ emit-allot-byte-array ] keep
|
||||
bytes>cells store-initial-element
|
||||
] [ drop emit-primitive ] if ;
|
||||
:: emit-<byte-array> ( node -- )
|
||||
node node-input-infos first literal>> dup expand-<byte-array>? [
|
||||
:> len
|
||||
0 ^^load-literal :> elt
|
||||
len emit-allot-byte-array :> reg
|
||||
len reg elt byte-array store-initial-element
|
||||
] [ drop node emit-primitive ] if ;
|
||||
|
|
|
|||
|
|
@ -52,8 +52,6 @@ IN: compiler.cfg.intrinsics
|
|||
arrays:<array>
|
||||
byte-arrays:<byte-array>
|
||||
byte-arrays:(byte-array)
|
||||
math.private:<complex>
|
||||
math.private:<ratio>
|
||||
kernel:<wrapper>
|
||||
alien.accessors:alien-unsigned-1
|
||||
alien.accessors:set-alien-unsigned-1
|
||||
|
|
@ -140,8 +138,6 @@ IN: compiler.cfg.intrinsics
|
|||
{ \ arrays:<array> [ emit-<array> iterate-next ] }
|
||||
{ \ byte-arrays:<byte-array> [ emit-<byte-array> iterate-next ] }
|
||||
{ \ byte-arrays:(byte-array) [ emit-(byte-array) iterate-next ] }
|
||||
{ \ math.private:<complex> [ emit-simple-allot iterate-next ] }
|
||||
{ \ math.private:<ratio> [ emit-simple-allot iterate-next ] }
|
||||
{ \ kernel:<wrapper> [ emit-simple-allot iterate-next ] }
|
||||
{ \ alien.accessors:alien-unsigned-1 [ 1 emit-alien-unsigned-getter iterate-next ] }
|
||||
{ \ alien.accessors:set-alien-unsigned-1 [ 1 emit-alien-integer-setter iterate-next ] }
|
||||
|
|
|
|||
|
|
@ -92,7 +92,7 @@ sequences ;
|
|||
T{ ##load-reference f V int-regs 1 + }
|
||||
T{ ##peek f V int-regs 2 D 0 }
|
||||
T{ ##compare f V int-regs 4 V int-regs 2 V int-regs 1 cc> }
|
||||
T{ ##compare-imm f V int-regs 6 V int-regs 4 7 cc/= }
|
||||
T{ ##compare-imm f V int-regs 6 V int-regs 4 5 cc/= }
|
||||
T{ ##replace f V int-regs 6 D 0 }
|
||||
} value-numbering trim-temps
|
||||
] unit-test
|
||||
|
|
@ -110,7 +110,7 @@ sequences ;
|
|||
T{ ##load-reference f V int-regs 1 + }
|
||||
T{ ##peek f V int-regs 2 D 0 }
|
||||
T{ ##compare f V int-regs 4 V int-regs 2 V int-regs 1 cc<= }
|
||||
T{ ##compare-imm f V int-regs 6 V int-regs 4 7 cc= }
|
||||
T{ ##compare-imm f V int-regs 6 V int-regs 4 5 cc= }
|
||||
T{ ##replace f V int-regs 6 D 0 }
|
||||
} value-numbering trim-temps
|
||||
] unit-test
|
||||
|
|
@ -132,7 +132,7 @@ sequences ;
|
|||
T{ ##unbox-float f V double-float-regs 10 V int-regs 8 }
|
||||
T{ ##unbox-float f V double-float-regs 11 V int-regs 9 }
|
||||
T{ ##compare-float f V int-regs 12 V double-float-regs 10 V double-float-regs 11 cc< }
|
||||
T{ ##compare-imm f V int-regs 14 V int-regs 12 7 cc= }
|
||||
T{ ##compare-imm f V int-regs 14 V int-regs 12 5 cc= }
|
||||
T{ ##replace f V int-regs 14 D 0 }
|
||||
} value-numbering trim-temps
|
||||
] unit-test
|
||||
|
|
@ -149,6 +149,6 @@ sequences ;
|
|||
T{ ##peek f V int-regs 29 D -1 }
|
||||
T{ ##peek f V int-regs 30 D -2 }
|
||||
T{ ##compare f V int-regs 33 V int-regs 29 V int-regs 30 cc<= }
|
||||
T{ ##compare-imm-branch f V int-regs 33 7 cc/= }
|
||||
T{ ##compare-imm-branch f V int-regs 33 5 cc/= }
|
||||
} value-numbering trim-temps
|
||||
] unit-test
|
||||
|
|
|
|||
|
|
@ -3,7 +3,7 @@
|
|||
USING: namespaces make math math.order math.parser sequences accessors
|
||||
kernel kernel.private layouts assocs words summary arrays
|
||||
combinators classes.algebra alien alien.c-types alien.structs
|
||||
alien.strings alien.arrays alien.complex sets libc alien.libraries
|
||||
alien.strings alien.arrays alien.complex alien.libraries sets libc
|
||||
continuations.private fry cpu.architecture
|
||||
source-files.errors
|
||||
compiler.errors
|
||||
|
|
@ -44,7 +44,7 @@ SYMBOL: calls
|
|||
|
||||
SYMBOL: compiling-word
|
||||
|
||||
: compiled-stack-traces? ( -- ? ) 59 getenv ;
|
||||
: compiled-stack-traces? ( -- ? ) 67 getenv ;
|
||||
|
||||
! Mapping _label IDs to label instances
|
||||
SYMBOL: labels
|
||||
|
|
@ -88,7 +88,7 @@ M: ##call generate-insn
|
|||
word>> dup sub-primitive>>
|
||||
[ first % ] [ [ add-call ] [ %call ] bi ] ?if ;
|
||||
|
||||
M: ##jump generate-insn word>> [ add-call ] [ %jump-label ] bi ;
|
||||
M: ##jump generate-insn word>> [ add-call ] [ %jump ] bi ;
|
||||
|
||||
M: ##return generate-insn drop %return ;
|
||||
|
||||
|
|
@ -444,8 +444,7 @@ TUPLE: callback-context ;
|
|||
|
||||
: do-callback ( quot token -- )
|
||||
init-catchstack
|
||||
dup 2 setenv
|
||||
slip
|
||||
[ 2 setenv call ] keep
|
||||
wait-to-return ; inline
|
||||
|
||||
: callback-return-quot ( ctype -- quot )
|
||||
|
|
|
|||
|
|
@ -3,15 +3,13 @@
|
|||
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 words.private math.order
|
||||
system combinators math.bitwise math.order
|
||||
accessors growable cpu.architecture compiler.constants ;
|
||||
IN: compiler.codegen.fixup
|
||||
|
||||
GENERIC: fixup* ( obj -- )
|
||||
|
||||
: code-format ( -- n ) 22 getenv ;
|
||||
|
||||
: compiled-offset ( -- n ) building get length code-format * ;
|
||||
: compiled-offset ( -- n ) building get length ;
|
||||
|
||||
SYMBOL: relocation-table
|
||||
SYMBOL: label-table
|
||||
|
|
@ -25,7 +23,7 @@ TUPLE: label-fixup label class ;
|
|||
M: label-fixup fixup*
|
||||
dup class>> rc-absolute?
|
||||
[ "Absolute labels not supported" throw ] when
|
||||
[ label>> ] [ class>> ] bi compiled-offset 4 - rot
|
||||
[ class>> ] [ label>> ] bi compiled-offset 4 - swap
|
||||
3array label-table get push ;
|
||||
|
||||
TUPLE: rel-fixup class type ;
|
||||
|
|
@ -58,6 +56,12 @@ SYMBOL: literal-table
|
|||
: rel-word ( word class -- )
|
||||
[ add-literal ] dip rt-xt rel-fixup ;
|
||||
|
||||
: rel-word-pic ( word class -- )
|
||||
[ add-literal ] dip rt-xt-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 ;
|
||||
|
||||
|
|
@ -88,4 +92,4 @@ SYMBOL: literal-table
|
|||
literal-table get >array
|
||||
relocation-table get >byte-array
|
||||
label-table get resolve-labels
|
||||
] { } make 4array ;
|
||||
] B{ } make 4array ;
|
||||
|
|
|
|||
|
|
@ -1,19 +1,19 @@
|
|||
USING: assocs compiler.cfg.builder compiler.cfg.optimizer
|
||||
compiler.errors compiler.tree.builder compiler.tree.optimizer
|
||||
compiler.units help.markup help.syntax io parser quotations
|
||||
sequences words words.private ;
|
||||
sequences words ;
|
||||
IN: compiler
|
||||
|
||||
HELP: enable-compiler
|
||||
HELP: enable-optimizer
|
||||
{ $description "Enables the optimizing compiler." } ;
|
||||
|
||||
HELP: disable-compiler
|
||||
HELP: disable-optimizer
|
||||
{ $description "Disable the optimizing compiler." } ;
|
||||
|
||||
ARTICLE: "compiler-usage" "Calling the optimizing compiler"
|
||||
"Normally, new word definitions are recompiled automatically. This can be changed:"
|
||||
{ $subsection disable-compiler }
|
||||
{ $subsection enable-compiler }
|
||||
{ $subsection disable-optimizer }
|
||||
{ $subsection enable-optimizer }
|
||||
"Removing a word's optimized definition:"
|
||||
{ $subsection decompile }
|
||||
"Compiling a single quotation:"
|
||||
|
|
|
|||
|
|
@ -2,19 +2,20 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors kernel namespaces arrays sequences io words fry
|
||||
continuations vocabs assocs dlists definitions math graphs generic
|
||||
combinators deques search-deques macros io source-files.errors
|
||||
stack-checker stack-checker.state stack-checker.inlining
|
||||
stack-checker.errors combinators.short-circuit compiler.errors
|
||||
compiler.units compiler.tree.builder compiler.tree.optimizer
|
||||
compiler.cfg.builder compiler.cfg.optimizer compiler.cfg.linearization
|
||||
compiler.cfg.two-operand compiler.cfg.linear-scan
|
||||
compiler.cfg.stack-frame compiler.codegen compiler.utilities ;
|
||||
generic.single combinators deques search-deques macros io
|
||||
source-files.errors stack-checker stack-checker.state
|
||||
stack-checker.inlining stack-checker.errors combinators.short-circuit
|
||||
compiler.errors compiler.units compiler.tree.builder
|
||||
compiler.tree.optimizer compiler.cfg.builder compiler.cfg.optimizer
|
||||
compiler.cfg.linearization compiler.cfg.two-operand
|
||||
compiler.cfg.linear-scan compiler.cfg.stack-frame compiler.codegen
|
||||
compiler.utilities ;
|
||||
IN: compiler
|
||||
|
||||
SYMBOL: compile-queue
|
||||
SYMBOL: compiled
|
||||
|
||||
: queue-compile? ( word -- ? )
|
||||
: compile? ( word -- ? )
|
||||
#! Don't attempt to compile certain words.
|
||||
{
|
||||
[ "forgotten" word-prop ]
|
||||
|
|
@ -24,7 +25,7 @@ SYMBOL: compiled
|
|||
} 1|| not ;
|
||||
|
||||
: queue-compile ( word -- )
|
||||
dup queue-compile? [ compile-queue get push-front ] [ drop ] if ;
|
||||
dup compile? [ compile-queue get push-front ] [ drop ] if ;
|
||||
|
||||
: recompile-callers? ( word -- ? )
|
||||
changed-effects get key? ;
|
||||
|
|
@ -41,6 +42,14 @@ SYMBOL: compiled
|
|||
H{ } clone generic-dependencies set
|
||||
clear-compiler-error ;
|
||||
|
||||
GENERIC: no-compile? ( word -- ? )
|
||||
|
||||
M: word no-compile? "no-compile" word-prop ;
|
||||
|
||||
M: method-body no-compile? "method-generic" word-prop no-compile? ;
|
||||
|
||||
M: predicate-engine-word no-compile? "owner-generic" word-prop no-compile? ;
|
||||
|
||||
: ignore-error? ( word error -- ? )
|
||||
#! Ignore some errors on inline combinators, macros, and special
|
||||
#! words such as 'call'.
|
||||
|
|
@ -48,8 +57,8 @@ SYMBOL: compiled
|
|||
{
|
||||
[ macro? ]
|
||||
[ inline? ]
|
||||
[ no-compile? ]
|
||||
[ "special" word-prop ]
|
||||
[ "no-compile" word-prop ]
|
||||
} 1||
|
||||
] [
|
||||
{
|
||||
|
|
@ -80,32 +89,45 @@ SYMBOL: compiled
|
|||
: not-compiled-def ( word error -- def )
|
||||
'[ _ _ not-compiled ] [ ] like ;
|
||||
|
||||
: ignore-error ( word error -- * )
|
||||
drop
|
||||
[ clear-compiler-error ]
|
||||
[ dup def>> deoptimize-with ]
|
||||
bi ;
|
||||
|
||||
: remember-error ( word error -- * )
|
||||
[ swap <compiler-error> compiler-error ]
|
||||
[ [ drop ] [ not-compiled-def ] 2bi deoptimize-with ]
|
||||
2bi ;
|
||||
|
||||
: deoptimize ( word error -- * )
|
||||
#! If the error is ignorable, compile the word with the
|
||||
#! non-optimizing compiler, using its definition. Otherwise,
|
||||
#! if the compiler error is not ignorable, use a dummy
|
||||
#! definition from 'not-compiled-def' which throws an error.
|
||||
2dup ignore-error? [
|
||||
drop
|
||||
[ dup def>> deoptimize-with ]
|
||||
[ clear-compiler-error ]
|
||||
bi
|
||||
] [
|
||||
[ swap <compiler-error> compiler-error ]
|
||||
[ [ drop ] [ not-compiled-def ] 2bi deoptimize-with ]
|
||||
2bi
|
||||
] if ;
|
||||
{
|
||||
{ [ dup inference-error? not ] [ rethrow ] }
|
||||
{ [ 2dup ignore-error? ] [ ignore-error ] }
|
||||
[ remember-error ]
|
||||
} cond ;
|
||||
|
||||
: optimize? ( word -- ? )
|
||||
{ [ predicate-engine-word? ] [ single-generic? ] } 1|| not ;
|
||||
|
||||
: contains-breakpoints? ( -- ? )
|
||||
dependencies get keys [ "break?" word-prop ] any? ;
|
||||
|
||||
: frontend ( word -- nodes )
|
||||
#! If the word contains breakpoints, don't optimize it, since
|
||||
#! the walker does not support this.
|
||||
dup contains-breakpoints? [ dup def>> deoptimize-with ] [
|
||||
[ build-tree ] [ deoptimize ] recover optimize-tree
|
||||
] if ;
|
||||
dup optimize? [
|
||||
[ [ build-tree ] [ deoptimize ] recover optimize-tree ] keep
|
||||
contains-breakpoints? [ nip dup def>> deoptimize-with ] [ drop ] if
|
||||
] [ dup def>> deoptimize-with ] if ;
|
||||
|
||||
: compile-dependency ( word -- )
|
||||
#! If a word calls an unoptimized word, try to compile the callee.
|
||||
dup optimized>> [ drop ] [ queue-compile ] if ;
|
||||
dup optimized? [ drop ] [ queue-compile ] if ;
|
||||
|
||||
! Only switch this off for debugging.
|
||||
SYMBOL: compile-dependencies?
|
||||
|
|
@ -161,15 +183,21 @@ M: optimizing-compiler recompile ( words -- alist )
|
|||
[
|
||||
<hashed-dlist> compile-queue set
|
||||
H{ } clone compiled set
|
||||
[ queue-compile ] each
|
||||
[
|
||||
[ queue-compile ]
|
||||
[ subwords [ compile-dependency ] each ] bi
|
||||
] each
|
||||
compile-queue get compile-loop
|
||||
compiled get >alist
|
||||
] with-scope ;
|
||||
|
||||
: enable-compiler ( -- )
|
||||
: with-optimizer ( quot -- )
|
||||
[ optimizing-compiler compiler-impl ] dip with-variable ; inline
|
||||
|
||||
: enable-optimizer ( -- )
|
||||
optimizing-compiler compiler-impl set-global ;
|
||||
|
||||
: disable-compiler ( -- )
|
||||
: disable-optimizer ( -- )
|
||||
f compiler-impl set-global ;
|
||||
|
||||
: recompile-all ( -- )
|
||||
|
|
|
|||
|
|
@ -1,6 +1,7 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! Copyright (C) 2008, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: math kernel layouts system strings ;
|
||||
USING: math kernel layouts system strings words quotations byte-arrays
|
||||
alien arrays literals sequences ;
|
||||
IN: compiler.constants
|
||||
|
||||
! These constants must match vm/memory.h
|
||||
|
|
@ -11,43 +12,44 @@ CONSTANT: deck-bits 18
|
|||
! These constants must match vm/layouts.h
|
||||
: header-offset ( -- n ) object tag-number neg ; inline
|
||||
: float-offset ( -- n ) 8 float tag-number - ; inline
|
||||
: string-offset ( -- n ) 4 bootstrap-cells object tag-number - ; inline
|
||||
: string-offset ( -- n ) 4 bootstrap-cells string tag-number - ; inline
|
||||
: string-aux-offset ( -- n ) 2 bootstrap-cells string tag-number - ; inline
|
||||
: profile-count-offset ( -- n ) 7 bootstrap-cells object tag-number - ; inline
|
||||
: byte-array-offset ( -- n ) 2 bootstrap-cells object tag-number - ; inline
|
||||
: alien-offset ( -- n ) 3 bootstrap-cells object tag-number - ; inline
|
||||
: underlying-alien-offset ( -- n ) bootstrap-cell object tag-number - ; inline
|
||||
: profile-count-offset ( -- n ) 8 bootstrap-cells \ word tag-number - ; inline
|
||||
: byte-array-offset ( -- n ) 2 bootstrap-cells byte-array tag-number - ; inline
|
||||
: alien-offset ( -- n ) 3 bootstrap-cells alien tag-number - ; inline
|
||||
: underlying-alien-offset ( -- n ) bootstrap-cell alien tag-number - ; inline
|
||||
: tuple-class-offset ( -- n ) bootstrap-cell tuple tag-number - ; inline
|
||||
: class-hash-offset ( -- n ) bootstrap-cell object tag-number - ; inline
|
||||
: word-xt-offset ( -- n ) 9 bootstrap-cells object tag-number - ; inline
|
||||
: quot-xt-offset ( -- n ) 5 bootstrap-cells object tag-number - ; inline
|
||||
: word-code-offset ( -- n ) 10 bootstrap-cells object tag-number - ; inline
|
||||
: array-start-offset ( -- n ) 2 bootstrap-cells object tag-number - ; inline
|
||||
: compiled-header-size ( -- n ) 5 bootstrap-cells ; inline
|
||||
: word-xt-offset ( -- n ) 10 bootstrap-cells \ word tag-number - ; inline
|
||||
: quot-xt-offset ( -- n ) 5 bootstrap-cells quotation tag-number - ; inline
|
||||
: word-code-offset ( -- n ) 11 bootstrap-cells \ word tag-number - ; inline
|
||||
: array-start-offset ( -- n ) 2 bootstrap-cells array tag-number - ; inline
|
||||
: compiled-header-size ( -- n ) 4 bootstrap-cells ; inline
|
||||
|
||||
! Relocation classes
|
||||
CONSTANT: rc-absolute-cell 0
|
||||
CONSTANT: rc-absolute 1
|
||||
CONSTANT: rc-relative 2
|
||||
CONSTANT: rc-absolute-cell 0
|
||||
CONSTANT: rc-absolute 1
|
||||
CONSTANT: rc-relative 2
|
||||
CONSTANT: rc-absolute-ppc-2/2 3
|
||||
CONSTANT: rc-relative-ppc-2 4
|
||||
CONSTANT: rc-relative-ppc-3 5
|
||||
CONSTANT: rc-relative-arm-3 6
|
||||
CONSTANT: rc-indirect-arm 7
|
||||
CONSTANT: rc-indirect-arm-pc 8
|
||||
CONSTANT: rc-absolute-ppc-2 4
|
||||
CONSTANT: rc-relative-ppc-2 5
|
||||
CONSTANT: rc-relative-ppc-3 6
|
||||
CONSTANT: rc-relative-arm-3 7
|
||||
CONSTANT: rc-indirect-arm 8
|
||||
CONSTANT: rc-indirect-arm-pc 9
|
||||
|
||||
! Relocation types
|
||||
CONSTANT: rt-primitive 0
|
||||
CONSTANT: rt-dlsym 1
|
||||
CONSTANT: rt-dispatch 2
|
||||
CONSTANT: rt-xt 3
|
||||
CONSTANT: rt-here 4
|
||||
CONSTANT: rt-this 5
|
||||
CONSTANT: rt-immediate 6
|
||||
CONSTANT: rt-stack-chain 7
|
||||
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
|
||||
|
||||
: rc-absolute? ( n -- ? )
|
||||
[ rc-absolute-ppc-2/2 = ]
|
||||
[ rc-absolute-cell = ]
|
||||
[ rc-absolute = ]
|
||||
tri or or ;
|
||||
${ rc-absolute-ppc-2/2 rc-absolute-cell rc-absolute } member? ;
|
||||
|
|
|
|||
|
|
@ -588,3 +588,16 @@ FUNCTION: complex-float ffi_test_47 ( complex-float x, complex-double y ) ;
|
|||
C{ 1.0 2.0 }
|
||||
C{ 1.5 1.0 } ffi_test_47
|
||||
] unit-test
|
||||
|
||||
! Reported by jedahu
|
||||
C-STRUCT: bool-field-test
|
||||
{ "char*" "name" }
|
||||
{ "bool" "on" }
|
||||
{ "short" "parents" } ;
|
||||
|
||||
FUNCTION: short ffi_test_48 ( bool-field-test x ) ;
|
||||
|
||||
[ 123 ] [
|
||||
"bool-field-test" <c-object> 123 over set-bool-field-test-parents
|
||||
ffi_test_48
|
||||
] unit-test
|
||||
|
|
@ -0,0 +1,14 @@
|
|||
IN: compiler.tests.call-effect
|
||||
USING: tools.test combinators generic.single sequences kernel ;
|
||||
|
||||
: execute-ic-test ( a b -- c ) execute( a -- c ) ;
|
||||
|
||||
! VM type check error
|
||||
[ 1 f execute-ic-test ] [ second 3 = ] must-fail-with
|
||||
|
||||
: call-test ( q -- ) call( -- ) ;
|
||||
|
||||
[ ] [ [ ] call-test ] unit-test
|
||||
[ ] [ f [ drop ] curry call-test ] unit-test
|
||||
[ ] [ [ ] [ ] compose call-test ] unit-test
|
||||
[ [ 1 2 3 ] call-test ] [ wrong-values? ] must-fail-with
|
||||
|
|
@ -26,7 +26,7 @@ IN: compiler.tests.codegen
|
|||
|
||||
[ 2 3 4 ] [ 3 [ 2 swap 4 ] compile-call ] unit-test
|
||||
|
||||
[ { 1 2 3 } { 1 4 3 } 3 3 ]
|
||||
[ { 1 2 3 } { 1 4 3 } 2 2 ]
|
||||
[ { 1 2 3 } { 1 4 3 } [ over tag over tag ] compile-call ]
|
||||
unit-test
|
||||
|
||||
|
|
@ -37,7 +37,7 @@ unit-test
|
|||
|
||||
: foo ( -- ) ;
|
||||
|
||||
[ 5 5 ]
|
||||
[ 3 3 ]
|
||||
[ 1.2 [ tag [ foo ] keep ] compile-call ]
|
||||
unit-test
|
||||
|
||||
|
|
@ -211,7 +211,7 @@ TUPLE: my-tuple ;
|
|||
{ tuple vector } 3 slot { word } declare
|
||||
dup 1 slot 0 fixnum-bitand { [ ] } dispatch ;
|
||||
|
||||
[ t ] [ \ dispatch-alignment-regression optimized>> ] unit-test
|
||||
[ t ] [ \ dispatch-alignment-regression optimized? ] unit-test
|
||||
|
||||
[ vector ] [ dispatch-alignment-regression ] unit-test
|
||||
|
||||
|
|
|
|||
|
|
@ -33,7 +33,7 @@ IN: compiler.tests.curry
|
|||
] unit-test
|
||||
|
||||
: foobar ( quot: ( -- ) -- )
|
||||
dup slip swap [ foobar ] [ drop ] if ; inline recursive
|
||||
[ call ] keep swap [ foobar ] [ drop ] if ; inline recursive
|
||||
|
||||
[ ] [ [ [ f ] foobar ] compile-call ] unit-test
|
||||
|
||||
|
|
|
|||
|
|
@ -9,7 +9,7 @@ math.private tools.test math.floats.private ;
|
|||
|
||||
[ 3.0 1 2 3 ] [ 1.0 2.0 [ float+ 1 2 3 ] compile-call ] unit-test
|
||||
|
||||
[ 5 ] [ 1.0 [ 2.0 float+ tag ] compile-call ] unit-test
|
||||
[ 3 ] [ 1.0 [ 2.0 float+ tag ] compile-call ] unit-test
|
||||
|
||||
[ 3.0 ] [ 1.0 [ 2.0 float+ ] compile-call ] unit-test
|
||||
[ 3.0 ] [ 1.0 [ 2.0 swap float+ ] compile-call ] unit-test
|
||||
|
|
|
|||
|
|
@ -0,0 +1,11 @@
|
|||
IN: compiler.tests.generic
|
||||
USING: tools.test math kernel compiler.units definitions ;
|
||||
|
||||
GENERIC: bad ( -- )
|
||||
M: integer bad ;
|
||||
M: object bad ;
|
||||
|
||||
[ 0 bad ] must-fail
|
||||
[ "" bad ] must-fail
|
||||
|
||||
[ ] [ [ \ bad forget ] with-compilation-unit ] unit-test
|
||||
|
|
@ -342,12 +342,12 @@ cell 8 = [
|
|||
] unit-test
|
||||
|
||||
[ 1 2 ] [
|
||||
1 2 [ <complex> ] compile-call
|
||||
1 2 [ complex boa ] compile-call
|
||||
dup real-part swap imaginary-part
|
||||
] unit-test
|
||||
|
||||
[ 1 2 ] [
|
||||
1 2 [ <ratio> ] compile-call dup numerator swap denominator
|
||||
1 2 [ ratio boa ] compile-call dup numerator swap denominator
|
||||
] unit-test
|
||||
|
||||
[ \ + ] [ \ + [ <wrapper> ] compile-call ] unit-test
|
||||
|
|
|
|||
|
|
@ -4,13 +4,13 @@ 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 ;
|
||||
compiler definitions ;
|
||||
IN: compiler.tests.optimizer
|
||||
|
||||
GENERIC: xyz ( obj -- obj )
|
||||
M: array xyz xyz ;
|
||||
|
||||
[ t ] [ \ xyz optimized>> ] unit-test
|
||||
[ t ] [ M\ array xyz optimized? ] unit-test
|
||||
|
||||
! Test predicate inlining
|
||||
: pred-test-1 ( a -- b c )
|
||||
|
|
@ -95,7 +95,7 @@ TUPLE: pred-test ;
|
|||
! regression
|
||||
GENERIC: void-generic ( obj -- * )
|
||||
: breakage ( -- * ) "hi" void-generic ;
|
||||
[ t ] [ \ breakage optimized>> ] unit-test
|
||||
[ t ] [ \ breakage optimized? ] unit-test
|
||||
[ breakage ] must-fail
|
||||
|
||||
! regression
|
||||
|
|
@ -120,7 +120,7 @@ GENERIC: void-generic ( obj -- * )
|
|||
! compiling <tuple> with a non-literal class failed
|
||||
: <tuple>-regression ( class -- tuple ) <tuple> ;
|
||||
|
||||
[ t ] [ \ <tuple>-regression optimized>> ] unit-test
|
||||
[ t ] [ \ <tuple>-regression optimized? ] unit-test
|
||||
|
||||
GENERIC: foozul ( a -- b )
|
||||
M: reversed foozul ;
|
||||
|
|
@ -229,7 +229,7 @@ USE: binary-search.private
|
|||
: node-successor-f-bug ( x -- * )
|
||||
[ 3 throw ] [ empty-compound ] compose [ 3 throw ] if ;
|
||||
|
||||
[ t ] [ \ node-successor-f-bug optimized>> ] unit-test
|
||||
[ t ] [ \ node-successor-f-bug optimized? ] unit-test
|
||||
|
||||
[ ] [ [ new ] build-tree optimize-tree drop ] unit-test
|
||||
|
||||
|
|
@ -243,7 +243,7 @@ USE: binary-search.private
|
|||
] if
|
||||
] if ;
|
||||
|
||||
[ t ] [ \ lift-throw-tail-regression optimized>> ] unit-test
|
||||
[ t ] [ \ lift-throw-tail-regression optimized? ] unit-test
|
||||
[ 3 "an integer" ] [ 3 lift-throw-tail-regression ] unit-test
|
||||
[ "hi" "a string" ] [ "hi" lift-throw-tail-regression ] unit-test
|
||||
|
||||
|
|
@ -274,7 +274,7 @@ HINTS: recursive-inline-hang array ;
|
|||
: recursive-inline-hang-1 ( -- a )
|
||||
{ } recursive-inline-hang ;
|
||||
|
||||
[ t ] [ \ recursive-inline-hang-1 optimized>> ] unit-test
|
||||
[ t ] [ \ recursive-inline-hang-1 optimized? ] unit-test
|
||||
|
||||
DEFER: recursive-inline-hang-3
|
||||
|
||||
|
|
@ -325,7 +325,7 @@ PREDICATE: list < improper-list
|
|||
dup "a" get { array-capacity } declare >=
|
||||
[ dup "b" get { array-capacity } declare >= [ 3 ] [ 4 ] if ] [ 5 ] if ;
|
||||
|
||||
[ t ] [ \ interval-inference-bug optimized>> ] unit-test
|
||||
[ t ] [ \ interval-inference-bug optimized? ] unit-test
|
||||
|
||||
[ ] [ 1 "a" set 2 "b" set ] unit-test
|
||||
[ 2 3 ] [ 2 interval-inference-bug ] unit-test
|
||||
|
|
@ -384,3 +384,15 @@ DEFER: loop-bbb
|
|||
1 >bignum 2 >bignum
|
||||
[ { bignum integer } declare [ shift ] keep 1+ ] compile-call
|
||||
] unit-test
|
||||
|
||||
: broken-declaration ( -- ) \ + declare ;
|
||||
|
||||
[ f ] [ \ broken-declaration optimized? ] unit-test
|
||||
|
||||
[ ] [ [ \ broken-declaration forget ] with-compilation-unit ] unit-test
|
||||
|
||||
! Modular arithmetic bug
|
||||
: modular-arithmetic-bug ( a -- b ) >integer 256 mod ;
|
||||
|
||||
[ 1 ] [ 257 modular-arithmetic-bug ] unit-test
|
||||
[ -10 ] [ -10 modular-arithmetic-bug ] unit-test
|
||||
|
|
@ -4,7 +4,7 @@
|
|||
! optimization, which would batch generic word updates at the
|
||||
! end of a compilation unit.
|
||||
|
||||
USING: kernel accessors peg.ebnf ;
|
||||
USING: kernel accessors peg.ebnf words ;
|
||||
IN: compiler.tests.peg-regression
|
||||
|
||||
TUPLE: pipeline-expr background ;
|
||||
|
|
@ -22,5 +22,5 @@ pipeline = "hello" => [[ ast>pipeline-expr ]]
|
|||
|
||||
USE: tools.test
|
||||
|
||||
[ t ] [ \ expr optimized>> ] unit-test
|
||||
[ t ] [ \ ast>pipeline-expr optimized>> ] unit-test
|
||||
[ t ] [ \ expr optimized? ] unit-test
|
||||
[ t ] [ \ ast>pipeline-expr optimized? ] unit-test
|
||||
|
|
|
|||
|
|
@ -0,0 +1,14 @@
|
|||
IN: compiler.tests.pic-problem-1
|
||||
USING: kernel sequences prettyprint memory tools.test ;
|
||||
|
||||
TUPLE: x ;
|
||||
|
||||
M: x length drop 0 ;
|
||||
|
||||
INSTANCE: x sequence
|
||||
|
||||
<< gc >>
|
||||
|
||||
CONSTANT: blah T{ x }
|
||||
|
||||
[ T{ x } ] [ blah ] unit-test
|
||||
|
|
@ -1,8 +1,8 @@
|
|||
USING: compiler.units definitions tools.test sequences ;
|
||||
IN: compiler.tests.redefine14
|
||||
|
||||
! TUPLE: bad ;
|
||||
!
|
||||
! M: bad length 1 2 3 ;
|
||||
!
|
||||
! [ ] [ [ { bad length } forget ] with-compilation-unit ] unit-test
|
||||
TUPLE: bad ;
|
||||
|
||||
M: bad length 1 2 3 ;
|
||||
|
||||
[ ] [ [ M\ bad length forget ] with-compilation-unit ] unit-test
|
||||
|
|
|
|||
|
|
@ -0,0 +1,49 @@
|
|||
IN: compiler.tests.redefine17
|
||||
USING: tools.test classes.mixin compiler.units arrays kernel.private
|
||||
strings sequences vocabs definitions kernel ;
|
||||
|
||||
<< "compiler.tests.redefine17" words forget-all >>
|
||||
|
||||
GENERIC: bong ( a -- b )
|
||||
|
||||
M: array bong ;
|
||||
|
||||
M: string bong length ;
|
||||
|
||||
MIXIN: mixin
|
||||
|
||||
INSTANCE: array mixin
|
||||
|
||||
: blah ( a -- b ) { mixin } declare bong ;
|
||||
|
||||
[ { } ] [ { } blah ] unit-test
|
||||
|
||||
[ ] [ [ \ array \ mixin remove-mixin-instance ] with-compilation-unit ] unit-test
|
||||
|
||||
[ ] [ [ \ string \ mixin add-mixin-instance ] with-compilation-unit ] unit-test
|
||||
|
||||
[ 0 ] [ "" blah ] unit-test
|
||||
|
||||
MIXIN: mixin1
|
||||
|
||||
INSTANCE: string mixin1
|
||||
|
||||
MIXIN: mixin2
|
||||
|
||||
GENERIC: billy ( a -- b )
|
||||
|
||||
M: mixin2 billy ;
|
||||
|
||||
M: array billy drop "BILLY" ;
|
||||
|
||||
INSTANCE: string mixin2
|
||||
|
||||
: bully ( a -- b ) { mixin1 } declare billy ;
|
||||
|
||||
[ "" ] [ "" bully ] unit-test
|
||||
|
||||
[ ] [ [ \ string \ mixin1 remove-mixin-instance ] with-compilation-unit ] unit-test
|
||||
|
||||
[ ] [ [ \ array \ mixin1 add-mixin-instance ] with-compilation-unit ] unit-test
|
||||
|
||||
[ "BILLY" ] [ { } bully ] unit-test
|
||||
|
|
@ -14,7 +14,7 @@ M: empty-mixin sheeple drop "wake up" ;
|
|||
: sheeple-test ( -- string ) { } sheeple ;
|
||||
|
||||
[ "sheeple" ] [ sheeple-test ] unit-test
|
||||
[ t ] [ \ sheeple-test optimized>> ] 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
|
||||
|
||||
|
|
@ -27,6 +27,6 @@ M: empty-mixin sheeple drop "wake up" ;
|
|||
[ ] [ [ array empty-mixin remove-mixin-instance ] with-compilation-unit ] unit-test
|
||||
|
||||
[ "sheeple" ] [ sheeple-test ] unit-test
|
||||
[ t ] [ \ sheeple-test optimized>> ] 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
|
||||
|
|
|
|||
|
|
@ -60,8 +60,8 @@ IN: compiler.tests.simple
|
|||
|
||||
! Make sure error reporting works
|
||||
|
||||
[ [ dup ] compile-call ] must-fail
|
||||
[ [ drop ] compile-call ] must-fail
|
||||
! [ [ dup ] compile-call ] must-fail
|
||||
! [ [ drop ] compile-call ] must-fail
|
||||
|
||||
! Regression
|
||||
|
||||
|
|
@ -235,6 +235,6 @@ M: f single-combination-test-2 single-combination-test-4 ;
|
|||
10 [
|
||||
[ "compiler.tests.foo" forget-vocab ] with-compilation-unit
|
||||
[ t ] [
|
||||
"USING: prettyprint words accessors ; IN: compiler.tests.foo : (recursive) ( -- ) (recursive) (recursive) ; inline recursive : recursive ( -- ) (recursive) ; \\ (recursive) optimized>>" eval( -- obj )
|
||||
"USING: prettyprint words accessors ; IN: compiler.tests.foo : (recursive) ( -- ) (recursive) (recursive) ; inline recursive : recursive ( -- ) (recursive) ; \\ (recursive) optimized?" eval( -- obj )
|
||||
] unit-test
|
||||
] times
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
USING: math.private kernel combinators accessors arrays
|
||||
generalizations tools.test ;
|
||||
generalizations tools.test words ;
|
||||
IN: compiler.tests.spilling
|
||||
|
||||
: float-spill-bug ( a -- b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b )
|
||||
|
|
@ -47,7 +47,7 @@ IN: compiler.tests.spilling
|
|||
[ 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 ]
|
||||
[ 1.0 float-spill-bug ] unit-test
|
||||
|
||||
[ t ] [ \ float-spill-bug optimized>> ] unit-test
|
||||
[ t ] [ \ float-spill-bug optimized? ] unit-test
|
||||
|
||||
: float-fixnum-spill-bug ( object -- object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object )
|
||||
{
|
||||
|
|
@ -132,7 +132,7 @@ IN: compiler.tests.spilling
|
|||
[ 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 ]
|
||||
[ 1.0 float-fixnum-spill-bug ] unit-test
|
||||
|
||||
[ t ] [ \ float-fixnum-spill-bug optimized>> ] unit-test
|
||||
[ t ] [ \ float-fixnum-spill-bug optimized? ] unit-test
|
||||
|
||||
: resolve-spill-bug ( a b -- c )
|
||||
[ 1 fixnum+fast ] bi@ dup 10 fixnum< [
|
||||
|
|
@ -159,7 +159,7 @@ IN: compiler.tests.spilling
|
|||
16 narray
|
||||
] if ;
|
||||
|
||||
[ t ] [ \ resolve-spill-bug optimized>> ] unit-test
|
||||
[ t ] [ \ resolve-spill-bug optimized? ] unit-test
|
||||
|
||||
[ 4 ] [ 1 1 resolve-spill-bug ] unit-test
|
||||
|
||||
|
|
|
|||
|
|
@ -54,15 +54,14 @@ PRIVATE>
|
|||
#! This slows down compiler.tree.propagation.inlining since then every
|
||||
#! inlined usage of a method has an inline-dependency on the mixin, and
|
||||
#! not the more specific type at the call site.
|
||||
specialize-method? off
|
||||
[
|
||||
#call in-d>> word/quot build-tree-with unclip-last in-d>> :> in-d
|
||||
{
|
||||
{ [ dup not ] [ ] }
|
||||
{ [ dup ends-with-terminate? ] [ #call out-d>> [ f swap #push ] map append ] }
|
||||
[ in-d #call out-d>> #copy suffix ]
|
||||
} cond
|
||||
] [ dup inference-error? [ drop f ] [ rethrow ] if ] recover ;
|
||||
f specialize-method? [
|
||||
[
|
||||
#call in-d>> word/quot build-tree-with unclip-last in-d>> :> in-d
|
||||
{
|
||||
{ [ dup not ] [ ] }
|
||||
{ [ dup ends-with-terminate? ] [ #call out-d>> [ f swap #push ] map append ] }
|
||||
[ in-d #call out-d>> #copy suffix ]
|
||||
} cond
|
||||
] [ dup inference-error? [ drop f ] [ rethrow ] if ] recover
|
||||
] with-variable ;
|
||||
|
||||
: contains-breakpoints? ( word -- ? )
|
||||
def>> [ word? ] filter [ "break?" word-prop ] any? ;
|
||||
|
|
|
|||
|
|
@ -153,7 +153,7 @@ SYMBOL: node-count
|
|||
[ 1+ ] dip
|
||||
dup #call? [
|
||||
word>> {
|
||||
{ [ dup "intrinsics" word-prop over "if-intrinsics" word-prop or ] [ intrinsics-called ] }
|
||||
{ [ dup "intrinsic" word-prop ] [ intrinsics-called ] }
|
||||
{ [ dup generic? ] [ generics-called ] }
|
||||
{ [ dup method-body? ] [ methods-called ] }
|
||||
[ words-called ]
|
||||
|
|
|
|||
|
|
@ -12,7 +12,6 @@ M: #push run-escape-analysis*
|
|||
|
||||
M: #call run-escape-analysis*
|
||||
{
|
||||
{ [ dup word>> \ <complex> eq? ] [ t ] }
|
||||
{ [ dup immutable-tuple-boa? ] [ t ] }
|
||||
[ f ]
|
||||
} cond nip ;
|
||||
|
|
|
|||
|
|
@ -17,7 +17,7 @@ GENERIC: count-unboxed-allocations* ( m node -- n )
|
|||
out-d>> first escaping-allocation? [ 1+ ] unless ;
|
||||
|
||||
M: #call count-unboxed-allocations*
|
||||
dup [ immutable-tuple-boa? ] [ word>> \ <complex> eq? ] bi or
|
||||
dup immutable-tuple-boa?
|
||||
[ (count-unboxed-allocations) ] [ drop ] if ;
|
||||
|
||||
M: #push count-unboxed-allocations*
|
||||
|
|
@ -291,7 +291,7 @@ C: <ro-box> ro-box
|
|||
|
||||
[ 0 ] [ [ bad-tuple-fib-3 i>> ] count-unboxed-allocations ] unit-test
|
||||
|
||||
[ 1 ] [ [ <complex> >rect ] count-unboxed-allocations ] unit-test
|
||||
[ 1 ] [ [ complex boa >rect ] count-unboxed-allocations ] unit-test
|
||||
|
||||
[ 0 ] [ [ 1 cons boa 2 cons boa ] count-unboxed-allocations ] unit-test
|
||||
|
||||
|
|
@ -302,7 +302,7 @@ C: <ro-box> ro-box
|
|||
[ 0 ] [ [ 1 cons boa "x" get slot ] count-unboxed-allocations ] unit-test
|
||||
|
||||
: impeach-node ( quot: ( node -- ) -- )
|
||||
dup slip impeach-node ; inline recursive
|
||||
[ call ] keep impeach-node ; inline recursive
|
||||
|
||||
: bleach-node ( quot: ( node -- ) -- )
|
||||
[ bleach-node ] curry [ ] compose impeach-node ; inline recursive
|
||||
|
|
|
|||
|
|
@ -47,9 +47,6 @@ M: #push escape-analysis*
|
|||
[ record-unknown-allocation ]
|
||||
if ;
|
||||
|
||||
: record-complex-allocation ( #call -- )
|
||||
[ in-d>> ] [ out-d>> first ] bi record-allocation ;
|
||||
|
||||
: slot-offset ( #call -- n/f )
|
||||
dup in-d>>
|
||||
[ first node-value-info class>> ]
|
||||
|
|
@ -71,7 +68,6 @@ M: #push escape-analysis*
|
|||
M: #call escape-analysis*
|
||||
dup word>> {
|
||||
{ \ <tuple-boa> [ record-tuple-allocation ] }
|
||||
{ \ <complex> [ record-complex-allocation ] }
|
||||
{ \ slot [ record-slot-call ] }
|
||||
[ drop record-unknown-allocation ]
|
||||
} case ;
|
||||
|
|
|
|||
|
|
@ -98,13 +98,18 @@ TUPLE: declared-fixnum { x fixnum } ;
|
|||
] { mod fixnum-mod } inlined?
|
||||
] unit-test
|
||||
|
||||
|
||||
[ f ] [
|
||||
[
|
||||
256 mod
|
||||
] { mod fixnum-mod } inlined?
|
||||
] unit-test
|
||||
|
||||
[ f ] [
|
||||
[
|
||||
>fixnum 256 mod
|
||||
] { mod fixnum-mod } inlined?
|
||||
] unit-test
|
||||
|
||||
[ f ] [
|
||||
[
|
||||
dup 0 >= [ 256 mod ] when
|
||||
|
|
@ -128,3 +133,6 @@ TUPLE: declared-fixnum { x fixnum } ;
|
|||
{ integer } declare [ 256 rem ] map
|
||||
] { mod fixnum-mod rem } inlined?
|
||||
] unit-test
|
||||
|
||||
[ [ >fixnum 255 fixnum-bitand ] ]
|
||||
[ [ >integer 256 rem ] test-modular-arithmetic ] unit-test
|
||||
|
|
@ -2,6 +2,7 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: math math.partial-dispatch namespaces sequences sets
|
||||
accessors assocs words kernel memoize fry combinators
|
||||
combinators.short-circuit
|
||||
compiler.tree
|
||||
compiler.tree.combinators
|
||||
compiler.tree.def-use
|
||||
|
|
@ -69,6 +70,12 @@ GENERIC: optimize-modular-arithmetic* ( node -- nodes )
|
|||
: optimize->fixnum ( #call -- nodes )
|
||||
dup redundant->fixnum? [ drop f ] when ;
|
||||
|
||||
: optimize->integer ( #call -- nodes )
|
||||
dup out-d>> first actually-used-by dup length 1 = [
|
||||
first node>> { [ #call? ] [ word>> \ >fixnum eq? ] } 1&&
|
||||
[ drop { } ] when
|
||||
] [ drop ] if ;
|
||||
|
||||
MEMO: fixnum-coercion ( flags -- nodes )
|
||||
[ [ ] [ >fixnum ] ? ] map '[ _ spread ] splice-quot ;
|
||||
|
||||
|
|
@ -87,6 +94,7 @@ MEMO: fixnum-coercion ( flags -- nodes )
|
|||
M: #call optimize-modular-arithmetic*
|
||||
dup word>> {
|
||||
{ [ dup \ >fixnum eq? ] [ drop optimize->fixnum ] }
|
||||
{ [ dup \ >integer eq? ] [ drop optimize->integer ] }
|
||||
{ [ dup "modular-arithmetic" word-prop ] [ drop optimize-modular-op ] }
|
||||
[ drop ]
|
||||
} cond ;
|
||||
|
|
|
|||
|
|
@ -59,29 +59,18 @@ CONSTANT: object-info T{ value-info f object full-interval }
|
|||
|
||||
: <value-info> ( -- info ) \ value-info new ;
|
||||
|
||||
: read-only-slots ( values class -- slots )
|
||||
all-slots
|
||||
[ read-only>> [ drop f ] unless ] 2map
|
||||
f prefix ;
|
||||
|
||||
DEFER: <literal-info>
|
||||
|
||||
: tuple-slot-infos ( tuple -- slots )
|
||||
[ tuple-slots ] [ class all-slots ] bi
|
||||
[ read-only>> [ <literal-info> ] [ drop f ] if ] 2map
|
||||
f prefix ;
|
||||
|
||||
: init-literal-info ( info -- info )
|
||||
dup literal>> class >>class
|
||||
dup literal>> dup real? [ [a,a] >>interval ] [
|
||||
[ [-inf,inf] >>interval ] dip
|
||||
{
|
||||
{ [ dup complex? ] [
|
||||
[ real-part <literal-info> ]
|
||||
[ imaginary-part <literal-info> ] bi
|
||||
2array >>slots
|
||||
] }
|
||||
{ [ dup tuple? ] [
|
||||
[ tuple-slots [ <literal-info> ] map ] [ class ] bi
|
||||
read-only-slots >>slots
|
||||
] }
|
||||
[ drop ]
|
||||
} cond
|
||||
dup tuple? [ tuple-slot-infos >>slots ] [ drop ] if
|
||||
] if ; inline
|
||||
|
||||
: init-value-info ( info -- info )
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2008, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors kernel arrays sequences math math.order
|
||||
math.partial-dispatch generic generic.standard generic.math
|
||||
math.partial-dispatch generic generic.standard generic.single generic.math
|
||||
classes.algebra classes.union sets quotations assocs combinators
|
||||
words namespaces continuations classes fry combinators.smart hints
|
||||
locals
|
||||
|
|
@ -157,11 +157,7 @@ DEFER: (flat-length)
|
|||
] sum-outputs ;
|
||||
|
||||
: should-inline? ( #call word -- ? )
|
||||
{
|
||||
{ [ dup contains-breakpoints? ] [ 2drop f ] }
|
||||
{ [ dup "inline" word-prop ] [ 2drop t ] }
|
||||
[ inlining-rank 5 >= ]
|
||||
} cond ;
|
||||
dup inline? [ 2drop t ] [ inlining-rank 5 >= ] if ;
|
||||
|
||||
SYMBOL: history
|
||||
|
||||
|
|
@ -188,9 +184,7 @@ SYMBOL: history
|
|||
{ curry compose } memq? ;
|
||||
|
||||
: never-inline-word? ( word -- ? )
|
||||
[ deferred? ]
|
||||
[ "default" word-prop ]
|
||||
[ { call execute } memq? ] tri or or ;
|
||||
[ deferred? ] [ "default" word-prop ] [ \ call eq? ] tri or or ;
|
||||
|
||||
: custom-inlining? ( word -- ? )
|
||||
"custom-inlining" word-prop ;
|
||||
|
|
|
|||
|
|
@ -148,10 +148,6 @@ most-negative-fixnum most-positive-fixnum [a,b]
|
|||
comparison-ops
|
||||
[ dup '[ _ define-comparison-constraints ] each-derived-op ] each
|
||||
|
||||
! generic-comparison-ops [
|
||||
! dup specific-comparison define-comparison-constraints
|
||||
! ] each
|
||||
|
||||
! Remove redundant comparisons
|
||||
: fold-comparison ( info1 info2 word -- info )
|
||||
[ [ interval>> ] bi@ ] dip interval-comparison {
|
||||
|
|
@ -217,6 +213,8 @@ generic-comparison-ops [
|
|||
{ >float float }
|
||||
{ fixnum>float float }
|
||||
{ bignum>float float }
|
||||
|
||||
{ >integer integer }
|
||||
} [
|
||||
'[
|
||||
_
|
||||
|
|
@ -228,19 +226,26 @@ generic-comparison-ops [
|
|||
] "outputs" set-word-prop
|
||||
] assoc-each
|
||||
|
||||
: rem-custom-inlining ( #call -- quot/f )
|
||||
second value-info literal>> dup integer?
|
||||
[ power-of-2? [ 1- bitand ] f ? ] [ drop f ] if ;
|
||||
|
||||
{
|
||||
mod-integer-integer
|
||||
mod-integer-fixnum
|
||||
mod-fixnum-integer
|
||||
fixnum-mod
|
||||
rem
|
||||
} [
|
||||
[
|
||||
in-d>> second value-info >literal<
|
||||
[ dup integer? [ power-of-2? [ 1- bitand ] f ? ] [ drop f ] if ] when
|
||||
in-d>> dup first value-info interval>> [0,inf] interval-subset?
|
||||
[ rem-custom-inlining ] [ drop f ] if
|
||||
] "custom-inlining" set-word-prop
|
||||
] each
|
||||
|
||||
\ rem [
|
||||
in-d>> rem-custom-inlining
|
||||
] "custom-inlining" set-word-prop
|
||||
|
||||
{
|
||||
bitand-integer-integer
|
||||
bitand-integer-fixnum
|
||||
|
|
|
|||
|
|
@ -9,7 +9,7 @@ compiler.tree.propagation.info compiler.tree.def-use
|
|||
compiler.tree.debugger compiler.tree.checker
|
||||
slots.private words hashtables classes assocs locals
|
||||
specialized-arrays.double system sorting math.libm
|
||||
math.intervals ;
|
||||
math.intervals quotations ;
|
||||
IN: compiler.tree.propagation.tests
|
||||
|
||||
[ V{ } ] [ [ ] final-classes ] unit-test
|
||||
|
|
@ -357,7 +357,7 @@ TUPLE: immutable-prop-test-tuple { x sequence read-only } ;
|
|||
] unit-test
|
||||
|
||||
[ V{ complex } ] [
|
||||
[ <complex> ] final-classes
|
||||
[ complex boa ] final-classes
|
||||
] unit-test
|
||||
|
||||
[ V{ complex } ] [
|
||||
|
|
@ -375,7 +375,7 @@ TUPLE: immutable-prop-test-tuple { x sequence read-only } ;
|
|||
[ V{ complex } ] [
|
||||
[
|
||||
{ float float object } declare
|
||||
[ "Oops" throw ] [ <complex> ] if
|
||||
[ "Oops" throw ] [ complex boa ] if
|
||||
] final-classes
|
||||
] unit-test
|
||||
|
||||
|
|
@ -590,7 +590,7 @@ MIXIN: empty-mixin
|
|||
|
||||
[ V{ float } ] [
|
||||
[
|
||||
[ { float float } declare <complex> ]
|
||||
[ { float float } declare complex boa ]
|
||||
[ 2drop C{ 0.0 0.0 } ]
|
||||
if real-part
|
||||
] final-classes
|
||||
|
|
@ -686,3 +686,11 @@ TUPLE: littledan-2 { from read-only } { to read-only } ;
|
|||
[ V{ 0 } ] [ [ { } length ] final-literals ] unit-test
|
||||
|
||||
[ V{ 1 } ] [ [ { } length 1+ f <array> length ] final-literals ] unit-test
|
||||
|
||||
! Mutable tuples with circularity should not cause problems
|
||||
TUPLE: circle me ;
|
||||
|
||||
[ ] [ circle new dup >>me 1quotation final-info drop ] unit-test
|
||||
|
||||
! Joe found an oversight
|
||||
[ V{ integer } ] [ [ >integer ] final-classes ] unit-test
|
||||
|
|
@ -109,7 +109,7 @@ M: #declare propagate-before
|
|||
|
||||
: output-value-infos ( #call word -- infos )
|
||||
{
|
||||
{ [ dup tuple-constructor? ] [ propagate-tuple-constructor ] }
|
||||
{ [ dup \ <tuple-boa> eq? ] [ drop propagate-<tuple-boa> ] }
|
||||
{ [ dup sequence-constructor? ] [ propagate-sequence-constructor ] }
|
||||
{ [ dup predicate? ] [ propagate-predicate ] }
|
||||
{ [ dup "outputs" word-prop ] [ call-outputs-quot ] }
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! Copyright (C) 2008, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: fry assocs arrays byte-arrays strings accessors sequences
|
||||
kernel slots classes.algebra classes.tuple classes.tuple.private
|
||||
|
|
@ -8,9 +8,6 @@ IN: compiler.tree.propagation.slots
|
|||
|
||||
! Propagation of immutable slots and array lengths
|
||||
|
||||
! Revisit this code when delegation is removed and when complex
|
||||
! numbers become tuples.
|
||||
|
||||
UNION: fixed-length-sequence array byte-array string ;
|
||||
|
||||
: sequence-constructor? ( word -- ? )
|
||||
|
|
@ -29,33 +26,26 @@ UNION: fixed-length-sequence array byte-array string ;
|
|||
[ constructor-output-class <class-info> ]
|
||||
bi* value-info-intersect 1array ;
|
||||
|
||||
: tuple-constructor? ( word -- ? )
|
||||
{ <tuple-boa> <complex> } memq? ;
|
||||
|
||||
: fold-<tuple-boa> ( values class -- info )
|
||||
[ [ literal>> ] map ] dip prefix >tuple
|
||||
<literal-info> ;
|
||||
|
||||
: read-only-slots ( values class -- slots )
|
||||
all-slots
|
||||
[ read-only>> [ value-info ] [ drop f ] if ] 2map
|
||||
f prefix ;
|
||||
|
||||
: (propagate-tuple-constructor) ( values class -- info )
|
||||
[ [ value-info ] map ] dip [ read-only-slots ] keep
|
||||
[ read-only-slots ] keep
|
||||
over rest-slice [ dup [ literal?>> ] when ] all? [
|
||||
[ rest-slice ] dip fold-<tuple-boa>
|
||||
] [
|
||||
<tuple-info>
|
||||
] if ;
|
||||
|
||||
: propagate-<tuple-boa> ( #call -- info )
|
||||
: propagate-<tuple-boa> ( #call -- infos )
|
||||
in-d>> unclip-last
|
||||
value-info literal>> first (propagate-tuple-constructor) ;
|
||||
|
||||
: propagate-<complex> ( #call -- info )
|
||||
in-d>> [ value-info ] map complex <tuple-info> ;
|
||||
|
||||
: propagate-tuple-constructor ( #call word -- infos )
|
||||
{
|
||||
{ \ <tuple-boa> [ propagate-<tuple-boa> ] }
|
||||
{ \ <complex> [ propagate-<complex> ] }
|
||||
} case 1array ;
|
||||
value-info literal>> first (propagate-tuple-constructor) 1array ;
|
||||
|
||||
: read-only-slot? ( n class -- ? )
|
||||
all-slots [ offset>> = ] with find nip
|
||||
|
|
|
|||
|
|
@ -32,7 +32,6 @@ TUPLE: empty-tuple ;
|
|||
[ dup [ drop f ] [ "A" throw ] if ]
|
||||
[ [ ] [ ] curry curry dup 2 slot swap 3 slot dup 2 slot swap 3 slot drop ]
|
||||
[ [ ] [ ] curry curry call ]
|
||||
[ <complex> <complex> dup 1 slot drop 2 slot drop ]
|
||||
[ 1 cons boa over [ "A" throw ] when car>> ]
|
||||
[ [ <=> ] sort ]
|
||||
[ [ <=> ] with search ]
|
||||
|
|
@ -40,7 +39,7 @@ TUPLE: empty-tuple ;
|
|||
|
||||
! A more complicated example
|
||||
: impeach-node ( quot: ( node -- ) -- )
|
||||
dup slip impeach-node ; inline recursive
|
||||
[ call ] keep impeach-node ; inline recursive
|
||||
|
||||
: bleach-node ( quot: ( node -- ) -- )
|
||||
[ bleach-node ] curry [ ] compose impeach-node ; inline recursive
|
||||
|
|
|
|||
|
|
@ -36,9 +36,6 @@ M: #push unbox-tuples* ( #push -- nodes )
|
|||
: unbox-<tuple-boa> ( #call -- nodes )
|
||||
dup unbox-output? [ in-d>> 1 tail* #drop ] when ;
|
||||
|
||||
: unbox-<complex> ( #call -- nodes )
|
||||
dup unbox-output? [ drop { } ] when ;
|
||||
|
||||
: (flatten-values) ( values accum -- )
|
||||
dup '[
|
||||
dup unboxed-allocation
|
||||
|
|
@ -70,7 +67,6 @@ M: #push unbox-tuples* ( #push -- nodes )
|
|||
M: #call unbox-tuples*
|
||||
dup word>> {
|
||||
{ \ <tuple-boa> [ unbox-<tuple-boa> ] }
|
||||
{ \ <complex> [ unbox-<complex> ] }
|
||||
{ \ slot [ unbox-slot-access ] }
|
||||
[ drop ]
|
||||
} case ;
|
||||
|
|
|
|||
|
|
@ -151,8 +151,8 @@ SYMBOL: event-stream-callbacks
|
|||
\ event-stream-counter counter ;
|
||||
|
||||
[
|
||||
event-stream-callbacks global
|
||||
[ [ drop expired? not ] assoc-filter H{ } assoc-like ] change-at
|
||||
event-stream-callbacks
|
||||
[ [ drop expired? not ] assoc-filter H{ } assoc-like ] change-global
|
||||
] "core-foundation" add-init-hook
|
||||
|
||||
: add-event-source-callback ( quot -- id )
|
||||
|
|
|
|||
|
|
@ -105,6 +105,15 @@ CONSTANT: kCGLRendererGenericFloatID HEX: 00020400
|
|||
|
||||
FUNCTION: CGLError CGLSetParameter ( CGLContextObj ctx, CGLContextParameter pname, GLint* params ) ;
|
||||
|
||||
FUNCTION: CGDirectDisplayID CGMainDisplayID ( ) ;
|
||||
|
||||
FUNCTION: CGError CGDisplayHideCursor ( CGDirectDisplayID display ) ;
|
||||
FUNCTION: CGError CGDisplayShowCursor ( CGDirectDisplayID display ) ;
|
||||
|
||||
FUNCTION: CGError CGAssociateMouseAndMouseCursorPosition ( boolean_t connected ) ;
|
||||
|
||||
FUNCTION: CGError CGWarpMouseCursorPosition ( CGPoint newCursorPosition ) ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: bitmap-flags ( -- flags )
|
||||
|
|
|
|||
|
|
@ -90,5 +90,8 @@ TYPEDEF: void* CGContextRef
|
|||
TYPEDEF: uint CGBitmapInfo
|
||||
|
||||
TYPEDEF: int CGLError
|
||||
TYPEDEF: int CGError
|
||||
TYPEDEF: uint CGDirectDisplayID
|
||||
TYPEDEF: int boolean_t
|
||||
TYPEDEF: void* CGLContextObj
|
||||
TYPEDEF: int CGLContextParameter
|
||||
TYPEDEF: int CGLContextParameter
|
||||
|
|
|
|||
|
|
@ -47,6 +47,7 @@ HOOK: %inc-r cpu ( n -- )
|
|||
|
||||
HOOK: stack-frame-size cpu ( stack-frame -- n )
|
||||
HOOK: %call cpu ( word -- )
|
||||
HOOK: %jump cpu ( word -- )
|
||||
HOOK: %jump-label cpu ( label -- )
|
||||
HOOK: %return cpu ( -- )
|
||||
|
||||
|
|
|
|||
|
|
@ -3,114 +3,114 @@ USING: cpu.ppc.assembler tools.test arrays kernel namespaces
|
|||
make vocabs sequences ;
|
||||
|
||||
: test-assembler ( expected quot -- )
|
||||
[ 1array ] [ [ { } make ] curry ] bi* unit-test ;
|
||||
[ 1array ] [ [ B{ } make ] curry ] bi* unit-test ;
|
||||
|
||||
{ HEX: 38220003 } [ 1 2 3 ADDI ] test-assembler
|
||||
{ HEX: 3c220003 } [ 1 2 3 ADDIS ] test-assembler
|
||||
{ HEX: 30220003 } [ 1 2 3 ADDIC ] test-assembler
|
||||
{ HEX: 34220003 } [ 1 2 3 ADDIC. ] test-assembler
|
||||
{ HEX: 38400001 } [ 1 2 LI ] test-assembler
|
||||
{ HEX: 3c400001 } [ 1 2 LIS ] test-assembler
|
||||
{ HEX: 3822fffd } [ 1 2 3 SUBI ] test-assembler
|
||||
{ HEX: 1c220003 } [ 1 2 3 MULI ] test-assembler
|
||||
{ HEX: 7c221a14 } [ 1 2 3 ADD ] test-assembler
|
||||
{ HEX: 7c221a15 } [ 1 2 3 ADD. ] test-assembler
|
||||
{ HEX: 7c221e14 } [ 1 2 3 ADDO ] test-assembler
|
||||
{ HEX: 7c221e15 } [ 1 2 3 ADDO. ] test-assembler
|
||||
{ HEX: 7c221814 } [ 1 2 3 ADDC ] test-assembler
|
||||
{ HEX: 7c221815 } [ 1 2 3 ADDC. ] test-assembler
|
||||
{ HEX: 7c221e14 } [ 1 2 3 ADDO ] test-assembler
|
||||
{ HEX: 7c221c15 } [ 1 2 3 ADDCO. ] test-assembler
|
||||
{ HEX: 7c221914 } [ 1 2 3 ADDE ] test-assembler
|
||||
{ HEX: 7c411838 } [ 1 2 3 AND ] test-assembler
|
||||
{ HEX: 7c411839 } [ 1 2 3 AND. ] test-assembler
|
||||
{ HEX: 7c221bd6 } [ 1 2 3 DIVW ] test-assembler
|
||||
{ HEX: 7c221b96 } [ 1 2 3 DIVWU ] test-assembler
|
||||
{ HEX: 7c411a38 } [ 1 2 3 EQV ] test-assembler
|
||||
{ HEX: 7c411bb8 } [ 1 2 3 NAND ] test-assembler
|
||||
{ HEX: 7c4118f8 } [ 1 2 3 NOR ] test-assembler
|
||||
{ HEX: 7c4110f8 } [ 1 2 NOT ] test-assembler
|
||||
{ HEX: 60410003 } [ 1 2 3 ORI ] test-assembler
|
||||
{ HEX: 64410003 } [ 1 2 3 ORIS ] test-assembler
|
||||
{ HEX: 7c411b78 } [ 1 2 3 OR ] test-assembler
|
||||
{ HEX: 7c411378 } [ 1 2 MR ] test-assembler
|
||||
{ HEX: 7c221896 } [ 1 2 3 MULHW ] test-assembler
|
||||
{ HEX: 1c220003 } [ 1 2 3 MULLI ] test-assembler
|
||||
{ HEX: 7c221816 } [ 1 2 3 MULHWU ] test-assembler
|
||||
{ HEX: 7c2219d6 } [ 1 2 3 MULLW ] test-assembler
|
||||
{ HEX: 7c411830 } [ 1 2 3 SLW ] test-assembler
|
||||
{ HEX: 7c411e30 } [ 1 2 3 SRAW ] test-assembler
|
||||
{ HEX: 7c411c30 } [ 1 2 3 SRW ] test-assembler
|
||||
{ HEX: 7c411e70 } [ 1 2 3 SRAWI ] test-assembler
|
||||
{ HEX: 7c221850 } [ 1 2 3 SUBF ] test-assembler
|
||||
{ HEX: 7c221810 } [ 1 2 3 SUBFC ] test-assembler
|
||||
{ HEX: 7c221910 } [ 1 2 3 SUBFE ] test-assembler
|
||||
{ HEX: 7c410774 } [ 1 2 EXTSB ] test-assembler
|
||||
{ HEX: 68410003 } [ 1 2 3 XORI ] test-assembler
|
||||
{ HEX: 7c411a78 } [ 1 2 3 XOR ] test-assembler
|
||||
{ HEX: 7c2200d0 } [ 1 2 NEG ] test-assembler
|
||||
{ HEX: 2c220003 } [ 1 2 3 CMPI ] test-assembler
|
||||
{ HEX: 28220003 } [ 1 2 3 CMPLI ] test-assembler
|
||||
{ HEX: 7c411800 } [ 1 2 3 CMP ] test-assembler
|
||||
{ HEX: 5422190a } [ 1 2 3 4 5 RLWINM ] test-assembler
|
||||
{ HEX: 54221838 } [ 1 2 3 SLWI ] test-assembler
|
||||
{ HEX: 5422e8fe } [ 1 2 3 SRWI ] test-assembler
|
||||
{ HEX: 88220003 } [ 1 2 3 LBZ ] test-assembler
|
||||
{ HEX: 8c220003 } [ 1 2 3 LBZU ] test-assembler
|
||||
{ HEX: a8220003 } [ 1 2 3 LHA ] test-assembler
|
||||
{ HEX: ac220003 } [ 1 2 3 LHAU ] test-assembler
|
||||
{ HEX: a0220003 } [ 1 2 3 LHZ ] test-assembler
|
||||
{ HEX: a4220003 } [ 1 2 3 LHZU ] test-assembler
|
||||
{ HEX: 80220003 } [ 1 2 3 LWZ ] test-assembler
|
||||
{ HEX: 84220003 } [ 1 2 3 LWZU ] test-assembler
|
||||
{ HEX: 7c4118ae } [ 1 2 3 LBZX ] test-assembler
|
||||
{ HEX: 7c4118ee } [ 1 2 3 LBZUX ] test-assembler
|
||||
{ HEX: 7c411aae } [ 1 2 3 LHAX ] test-assembler
|
||||
{ HEX: 7c411aee } [ 1 2 3 LHAUX ] test-assembler
|
||||
{ HEX: 7c411a2e } [ 1 2 3 LHZX ] test-assembler
|
||||
{ HEX: 7c411a6e } [ 1 2 3 LHZUX ] test-assembler
|
||||
{ HEX: 7c41182e } [ 1 2 3 LWZX ] test-assembler
|
||||
{ HEX: 7c41186e } [ 1 2 3 LWZUX ] test-assembler
|
||||
{ HEX: 48000001 } [ 1 B ] test-assembler
|
||||
{ HEX: 48000001 } [ 1 BL ] test-assembler
|
||||
{ HEX: 41800004 } [ 1 BLT ] test-assembler
|
||||
{ HEX: 41810004 } [ 1 BGT ] test-assembler
|
||||
{ HEX: 40810004 } [ 1 BLE ] test-assembler
|
||||
{ HEX: 40800004 } [ 1 BGE ] test-assembler
|
||||
{ HEX: 41800004 } [ 1 BLT ] test-assembler
|
||||
{ HEX: 40820004 } [ 1 BNE ] test-assembler
|
||||
{ HEX: 41820004 } [ 1 BEQ ] test-assembler
|
||||
{ HEX: 41830004 } [ 1 BO ] test-assembler
|
||||
{ HEX: 40830004 } [ 1 BNO ] test-assembler
|
||||
{ HEX: 4c200020 } [ 1 BCLR ] test-assembler
|
||||
{ HEX: 4e800020 } [ BLR ] test-assembler
|
||||
{ HEX: 4e800021 } [ BLRL ] test-assembler
|
||||
{ HEX: 4c200420 } [ 1 BCCTR ] test-assembler
|
||||
{ HEX: 4e800420 } [ BCTR ] test-assembler
|
||||
{ HEX: 7c6102a6 } [ 3 MFXER ] test-assembler
|
||||
{ HEX: 7c6802a6 } [ 3 MFLR ] test-assembler
|
||||
{ HEX: 7c6902a6 } [ 3 MFCTR ] test-assembler
|
||||
{ HEX: 7c6103a6 } [ 3 MTXER ] test-assembler
|
||||
{ HEX: 7c6803a6 } [ 3 MTLR ] test-assembler
|
||||
{ HEX: 7c6903a6 } [ 3 MTCTR ] test-assembler
|
||||
{ HEX: 7c6102a6 } [ 3 MFXER ] test-assembler
|
||||
{ HEX: 7c6802a6 } [ 3 MFLR ] test-assembler
|
||||
{ HEX: c0220003 } [ 1 2 3 LFS ] test-assembler
|
||||
{ HEX: c4220003 } [ 1 2 3 LFSU ] test-assembler
|
||||
{ HEX: c8220003 } [ 1 2 3 LFD ] test-assembler
|
||||
{ HEX: cc220003 } [ 1 2 3 LFDU ] test-assembler
|
||||
{ HEX: d0220003 } [ 1 2 3 STFS ] test-assembler
|
||||
{ HEX: d4220003 } [ 1 2 3 STFSU ] test-assembler
|
||||
{ HEX: d8220003 } [ 1 2 3 STFD ] test-assembler
|
||||
{ HEX: dc220003 } [ 1 2 3 STFDU ] test-assembler
|
||||
{ HEX: fc201048 } [ 1 2 FMR ] test-assembler
|
||||
{ HEX: fc20101e } [ 1 2 FCTIWZ ] test-assembler
|
||||
{ HEX: fc22182a } [ 1 2 3 FADD ] test-assembler
|
||||
{ HEX: fc22182b } [ 1 2 3 FADD. ] test-assembler
|
||||
{ HEX: fc221828 } [ 1 2 3 FSUB ] test-assembler
|
||||
{ HEX: fc2200f2 } [ 1 2 3 FMUL ] test-assembler
|
||||
{ HEX: fc221824 } [ 1 2 3 FDIV ] test-assembler
|
||||
{ HEX: fc20102c } [ 1 2 FSQRT ] test-assembler
|
||||
{ HEX: fc411800 } [ 1 2 3 FCMPU ] test-assembler
|
||||
{ HEX: fc411840 } [ 1 2 3 FCMPO ] test-assembler
|
||||
{ HEX: 3c601234 HEX: 60635678 } [ HEX: 12345678 3 LOAD ] test-assembler
|
||||
B{ HEX: 38 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 ADDI ] test-assembler
|
||||
B{ HEX: 3c HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 ADDIS ] test-assembler
|
||||
B{ HEX: 30 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 ADDIC ] test-assembler
|
||||
B{ HEX: 34 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 ADDIC. ] test-assembler
|
||||
B{ HEX: 38 HEX: 40 HEX: 00 HEX: 01 } [ 1 2 LI ] test-assembler
|
||||
B{ HEX: 3c HEX: 40 HEX: 00 HEX: 01 } [ 1 2 LIS ] test-assembler
|
||||
B{ HEX: 38 HEX: 22 HEX: ff HEX: fd } [ 1 2 3 SUBI ] test-assembler
|
||||
B{ HEX: 1c HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 MULI ] test-assembler
|
||||
B{ HEX: 7c HEX: 22 HEX: 1a HEX: 14 } [ 1 2 3 ADD ] test-assembler
|
||||
B{ HEX: 7c HEX: 22 HEX: 1a HEX: 15 } [ 1 2 3 ADD. ] test-assembler
|
||||
B{ HEX: 7c HEX: 22 HEX: 1e HEX: 14 } [ 1 2 3 ADDO ] test-assembler
|
||||
B{ HEX: 7c HEX: 22 HEX: 1e HEX: 15 } [ 1 2 3 ADDO. ] test-assembler
|
||||
B{ HEX: 7c HEX: 22 HEX: 18 HEX: 14 } [ 1 2 3 ADDC ] test-assembler
|
||||
B{ HEX: 7c HEX: 22 HEX: 18 HEX: 15 } [ 1 2 3 ADDC. ] test-assembler
|
||||
B{ HEX: 7c HEX: 22 HEX: 1e HEX: 14 } [ 1 2 3 ADDO ] test-assembler
|
||||
B{ HEX: 7c HEX: 22 HEX: 1c HEX: 15 } [ 1 2 3 ADDCO. ] test-assembler
|
||||
B{ HEX: 7c HEX: 22 HEX: 19 HEX: 14 } [ 1 2 3 ADDE ] test-assembler
|
||||
B{ HEX: 7c HEX: 41 HEX: 18 HEX: 38 } [ 1 2 3 AND ] test-assembler
|
||||
B{ HEX: 7c HEX: 41 HEX: 18 HEX: 39 } [ 1 2 3 AND. ] test-assembler
|
||||
B{ HEX: 7c HEX: 22 HEX: 1b HEX: d6 } [ 1 2 3 DIVW ] test-assembler
|
||||
B{ HEX: 7c HEX: 22 HEX: 1b HEX: 96 } [ 1 2 3 DIVWU ] test-assembler
|
||||
B{ HEX: 7c HEX: 41 HEX: 1a HEX: 38 } [ 1 2 3 EQV ] test-assembler
|
||||
B{ HEX: 7c HEX: 41 HEX: 1b HEX: b8 } [ 1 2 3 NAND ] test-assembler
|
||||
B{ HEX: 7c HEX: 41 HEX: 18 HEX: f8 } [ 1 2 3 NOR ] test-assembler
|
||||
B{ HEX: 7c HEX: 41 HEX: 10 HEX: f8 } [ 1 2 NOT ] test-assembler
|
||||
B{ HEX: 60 HEX: 41 HEX: 00 HEX: 03 } [ 1 2 3 ORI ] test-assembler
|
||||
B{ HEX: 64 HEX: 41 HEX: 00 HEX: 03 } [ 1 2 3 ORIS ] test-assembler
|
||||
B{ HEX: 7c HEX: 41 HEX: 1b HEX: 78 } [ 1 2 3 OR ] test-assembler
|
||||
B{ HEX: 7c HEX: 41 HEX: 13 HEX: 78 } [ 1 2 MR ] test-assembler
|
||||
B{ HEX: 7c HEX: 22 HEX: 18 HEX: 96 } [ 1 2 3 MULHW ] test-assembler
|
||||
B{ HEX: 1c HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 MULLI ] test-assembler
|
||||
B{ HEX: 7c HEX: 22 HEX: 18 HEX: 16 } [ 1 2 3 MULHWU ] test-assembler
|
||||
B{ HEX: 7c HEX: 22 HEX: 19 HEX: d6 } [ 1 2 3 MULLW ] test-assembler
|
||||
B{ HEX: 7c HEX: 41 HEX: 18 HEX: 30 } [ 1 2 3 SLW ] test-assembler
|
||||
B{ HEX: 7c HEX: 41 HEX: 1e HEX: 30 } [ 1 2 3 SRAW ] test-assembler
|
||||
B{ HEX: 7c HEX: 41 HEX: 1c HEX: 30 } [ 1 2 3 SRW ] test-assembler
|
||||
B{ HEX: 7c HEX: 41 HEX: 1e HEX: 70 } [ 1 2 3 SRAWI ] test-assembler
|
||||
B{ HEX: 7c HEX: 22 HEX: 18 HEX: 50 } [ 1 2 3 SUBF ] test-assembler
|
||||
B{ HEX: 7c HEX: 22 HEX: 18 HEX: 10 } [ 1 2 3 SUBFC ] test-assembler
|
||||
B{ HEX: 7c HEX: 22 HEX: 19 HEX: 10 } [ 1 2 3 SUBFE ] test-assembler
|
||||
B{ HEX: 7c HEX: 41 HEX: 07 HEX: 74 } [ 1 2 EXTSB ] test-assembler
|
||||
B{ HEX: 68 HEX: 41 HEX: 00 HEX: 03 } [ 1 2 3 XORI ] test-assembler
|
||||
B{ HEX: 7c HEX: 41 HEX: 1a HEX: 78 } [ 1 2 3 XOR ] test-assembler
|
||||
B{ HEX: 7c HEX: 22 HEX: 00 HEX: d0 } [ 1 2 NEG ] test-assembler
|
||||
B{ HEX: 2c HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 CMPI ] test-assembler
|
||||
B{ HEX: 28 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 CMPLI ] test-assembler
|
||||
B{ HEX: 7c HEX: 41 HEX: 18 HEX: 00 } [ 1 2 3 CMP ] test-assembler
|
||||
B{ HEX: 54 HEX: 22 HEX: 19 HEX: 0a } [ 1 2 3 4 5 RLWINM ] test-assembler
|
||||
B{ HEX: 54 HEX: 22 HEX: 18 HEX: 38 } [ 1 2 3 SLWI ] test-assembler
|
||||
B{ HEX: 54 HEX: 22 HEX: e8 HEX: fe } [ 1 2 3 SRWI ] test-assembler
|
||||
B{ HEX: 88 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 LBZ ] test-assembler
|
||||
B{ HEX: 8c HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 LBZU ] test-assembler
|
||||
B{ HEX: a8 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 LHA ] test-assembler
|
||||
B{ HEX: ac HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 LHAU ] test-assembler
|
||||
B{ HEX: a0 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 LHZ ] test-assembler
|
||||
B{ HEX: a4 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 LHZU ] test-assembler
|
||||
B{ HEX: 80 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 LWZ ] test-assembler
|
||||
B{ HEX: 84 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 LWZU ] test-assembler
|
||||
B{ HEX: 7c HEX: 41 HEX: 18 HEX: ae } [ 1 2 3 LBZX ] test-assembler
|
||||
B{ HEX: 7c HEX: 41 HEX: 18 HEX: ee } [ 1 2 3 LBZUX ] test-assembler
|
||||
B{ HEX: 7c HEX: 41 HEX: 1a HEX: ae } [ 1 2 3 LHAX ] test-assembler
|
||||
B{ HEX: 7c HEX: 41 HEX: 1a HEX: ee } [ 1 2 3 LHAUX ] test-assembler
|
||||
B{ HEX: 7c HEX: 41 HEX: 1a HEX: 2e } [ 1 2 3 LHZX ] test-assembler
|
||||
B{ HEX: 7c HEX: 41 HEX: 1a HEX: 6e } [ 1 2 3 LHZUX ] test-assembler
|
||||
B{ HEX: 7c HEX: 41 HEX: 18 HEX: 2e } [ 1 2 3 LWZX ] test-assembler
|
||||
B{ HEX: 7c HEX: 41 HEX: 18 HEX: 6e } [ 1 2 3 LWZUX ] test-assembler
|
||||
B{ HEX: 48 HEX: 00 HEX: 00 HEX: 01 } [ 1 B ] test-assembler
|
||||
B{ HEX: 48 HEX: 00 HEX: 00 HEX: 01 } [ 1 BL ] test-assembler
|
||||
B{ HEX: 41 HEX: 80 HEX: 00 HEX: 04 } [ 1 BLT ] test-assembler
|
||||
B{ HEX: 41 HEX: 81 HEX: 00 HEX: 04 } [ 1 BGT ] test-assembler
|
||||
B{ HEX: 40 HEX: 81 HEX: 00 HEX: 04 } [ 1 BLE ] test-assembler
|
||||
B{ HEX: 40 HEX: 80 HEX: 00 HEX: 04 } [ 1 BGE ] test-assembler
|
||||
B{ HEX: 41 HEX: 80 HEX: 00 HEX: 04 } [ 1 BLT ] test-assembler
|
||||
B{ HEX: 40 HEX: 82 HEX: 00 HEX: 04 } [ 1 BNE ] test-assembler
|
||||
B{ HEX: 41 HEX: 82 HEX: 00 HEX: 04 } [ 1 BEQ ] test-assembler
|
||||
B{ HEX: 41 HEX: 83 HEX: 00 HEX: 04 } [ 1 BO ] test-assembler
|
||||
B{ HEX: 40 HEX: 83 HEX: 00 HEX: 04 } [ 1 BNO ] test-assembler
|
||||
B{ HEX: 4c HEX: 20 HEX: 00 HEX: 20 } [ 1 BCLR ] test-assembler
|
||||
B{ HEX: 4e HEX: 80 HEX: 00 HEX: 20 } [ BLR ] test-assembler
|
||||
B{ HEX: 4e HEX: 80 HEX: 00 HEX: 21 } [ BLRL ] test-assembler
|
||||
B{ HEX: 4c HEX: 20 HEX: 04 HEX: 20 } [ 1 BCCTR ] test-assembler
|
||||
B{ HEX: 4e HEX: 80 HEX: 04 HEX: 20 } [ BCTR ] test-assembler
|
||||
B{ HEX: 7c HEX: 61 HEX: 02 HEX: a6 } [ 3 MFXER ] test-assembler
|
||||
B{ HEX: 7c HEX: 68 HEX: 02 HEX: a6 } [ 3 MFLR ] test-assembler
|
||||
B{ HEX: 7c HEX: 69 HEX: 02 HEX: a6 } [ 3 MFCTR ] test-assembler
|
||||
B{ HEX: 7c HEX: 61 HEX: 03 HEX: a6 } [ 3 MTXER ] test-assembler
|
||||
B{ HEX: 7c HEX: 68 HEX: 03 HEX: a6 } [ 3 MTLR ] test-assembler
|
||||
B{ HEX: 7c HEX: 69 HEX: 03 HEX: a6 } [ 3 MTCTR ] test-assembler
|
||||
B{ HEX: 7c HEX: 61 HEX: 02 HEX: a6 } [ 3 MFXER ] test-assembler
|
||||
B{ HEX: 7c HEX: 68 HEX: 02 HEX: a6 } [ 3 MFLR ] test-assembler
|
||||
B{ HEX: c0 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 LFS ] test-assembler
|
||||
B{ HEX: c4 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 LFSU ] test-assembler
|
||||
B{ HEX: c8 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 LFD ] test-assembler
|
||||
B{ HEX: cc HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 LFDU ] test-assembler
|
||||
B{ HEX: d0 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 STFS ] test-assembler
|
||||
B{ HEX: d4 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 STFSU ] test-assembler
|
||||
B{ HEX: d8 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 STFD ] test-assembler
|
||||
B{ HEX: dc HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 STFDU ] test-assembler
|
||||
B{ HEX: fc HEX: 20 HEX: 10 HEX: 48 } [ 1 2 FMR ] test-assembler
|
||||
B{ HEX: fc HEX: 20 HEX: 10 HEX: 1e } [ 1 2 FCTIWZ ] test-assembler
|
||||
B{ HEX: fc HEX: 22 HEX: 18 HEX: 2a } [ 1 2 3 FADD ] test-assembler
|
||||
B{ HEX: fc HEX: 22 HEX: 18 HEX: 2b } [ 1 2 3 FADD. ] test-assembler
|
||||
B{ HEX: fc HEX: 22 HEX: 18 HEX: 28 } [ 1 2 3 FSUB ] test-assembler
|
||||
B{ HEX: fc HEX: 22 HEX: 00 HEX: f2 } [ 1 2 3 FMUL ] test-assembler
|
||||
B{ HEX: fc HEX: 22 HEX: 18 HEX: 24 } [ 1 2 3 FDIV ] test-assembler
|
||||
B{ HEX: fc HEX: 20 HEX: 10 HEX: 2c } [ 1 2 FSQRT ] test-assembler
|
||||
B{ HEX: fc HEX: 41 HEX: 18 HEX: 00 } [ 1 2 3 FCMPU ] test-assembler
|
||||
B{ HEX: fc HEX: 41 HEX: 18 HEX: 40 } [ 1 2 3 FCMPO ] test-assembler
|
||||
B{ HEX: 3c HEX: 60 HEX: 12 HEX: 34 HEX: 60 HEX: 63 HEX: 56 HEX: 78 } [ HEX: 12345678 3 LOAD ] test-assembler
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2005, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: compiler.codegen.fixup kernel namespaces words
|
||||
io.binary math math.order cpu.ppc.assembler.backend ;
|
||||
USING: kernel namespaces words io.binary math math.order
|
||||
cpu.ppc.assembler.backend ;
|
||||
IN: cpu.ppc.assembler
|
||||
|
||||
! See the Motorola or IBM documentation for details. The opcode
|
||||
|
|
|
|||
|
|
@ -1,11 +1,10 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! Copyright (C) 2008, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: compiler.codegen.fixup cpu.architecture
|
||||
compiler.constants kernel namespaces make sequences words math
|
||||
math.bitwise io.binary parser lexer ;
|
||||
USING: kernel namespaces make sequences words math
|
||||
math.bitwise io.binary parser lexer fry ;
|
||||
IN: cpu.ppc.assembler.backend
|
||||
|
||||
: insn ( operand opcode -- ) { 26 0 } bitfield , ;
|
||||
: insn ( operand opcode -- ) { 26 0 } bitfield 4 >be % ;
|
||||
|
||||
: a-insn ( d a b c xo rc opcode -- )
|
||||
[ { 0 1 6 11 16 21 } bitfield ] dip insn ;
|
||||
|
|
@ -74,21 +73,16 @@ SYNTAX: XO1: (XO) (1) (( a s -- )) define-declared ;
|
|||
|
||||
GENERIC# (B) 2 ( dest aa lk -- )
|
||||
M: integer (B) 18 i-insn ;
|
||||
M: word (B) [ 0 ] 2dip (B) rc-relative-ppc-3 rel-word ;
|
||||
M: label (B) [ 0 ] 2dip (B) rc-relative-ppc-3 label-fixup ;
|
||||
|
||||
GENERIC: BC ( a b c -- )
|
||||
M: integer BC 0 0 16 b-insn ;
|
||||
M: word BC [ 0 BC ] dip rc-relative-ppc-2 rel-word ;
|
||||
M: label BC [ 0 BC ] dip rc-relative-ppc-2 label-fixup ;
|
||||
|
||||
: CREATE-B ( -- word ) scan "B" prepend create-in ;
|
||||
|
||||
SYNTAX: BC:
|
||||
CREATE-B scan-word scan-word
|
||||
[ rot BC ] 2curry (( c -- )) define-declared ;
|
||||
'[ [ _ _ ] dip BC ] (( c -- )) define-declared ;
|
||||
|
||||
SYNTAX: B:
|
||||
CREATE-B scan-word scan-word scan-word scan-word scan-word
|
||||
[ b-insn ] curry curry curry curry curry
|
||||
(( bo -- )) define-declared ;
|
||||
'[ _ _ _ _ _ b-insn ] (( bo -- )) define-declared ;
|
||||
|
|
|
|||
|
|
@ -2,17 +2,15 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: bootstrap.image.private kernel kernel.private namespaces
|
||||
system cpu.ppc.assembler compiler.codegen.fixup compiler.units
|
||||
compiler.constants math math.private layouts words words.private
|
||||
compiler.constants math math.private layouts words
|
||||
vocabs slots.private locals.backend ;
|
||||
IN: bootstrap.ppc
|
||||
|
||||
4 \ cell set
|
||||
big-endian on
|
||||
|
||||
4 jit-code-format set
|
||||
|
||||
CONSTANT: ds-reg 29
|
||||
CONSTANT: rs-reg 30
|
||||
CONSTANT: ds-reg 13
|
||||
CONSTANT: rs-reg 14
|
||||
|
||||
: factor-area-size ( -- n ) 4 bootstrap-cells ;
|
||||
|
||||
|
|
@ -23,73 +21,57 @@ CONSTANT: rs-reg 30
|
|||
: xt-save ( -- n ) stack-frame 2 bootstrap-cells - ;
|
||||
|
||||
[
|
||||
0 6 LOAD32
|
||||
11 6 profile-count-offset LWZ
|
||||
0 3 LOAD32 rc-absolute-ppc-2/2 rt-immediate jit-rel
|
||||
11 3 profile-count-offset LWZ
|
||||
11 11 1 tag-fixnum ADDI
|
||||
11 6 profile-count-offset STW
|
||||
11 6 word-code-offset LWZ
|
||||
11 3 profile-count-offset STW
|
||||
11 3 word-code-offset LWZ
|
||||
11 11 compiled-header-size ADDI
|
||||
11 MTCTR
|
||||
BCTR
|
||||
] rc-absolute-ppc-2/2 rt-immediate 1 jit-profiling jit-define
|
||||
] jit-profiling jit-define
|
||||
|
||||
[
|
||||
0 6 LOAD32
|
||||
0 3 LOAD32 rc-absolute-ppc-2/2 rt-this jit-rel
|
||||
0 MFLR
|
||||
1 1 stack-frame SUBI
|
||||
6 1 xt-save STW
|
||||
stack-frame 6 LI
|
||||
6 1 next-save STW
|
||||
3 1 xt-save STW
|
||||
stack-frame 3 LI
|
||||
3 1 next-save STW
|
||||
0 1 lr-save stack-frame + STW
|
||||
] rc-absolute-ppc-2/2 rt-this 1 jit-prolog jit-define
|
||||
] jit-prolog jit-define
|
||||
|
||||
[
|
||||
0 6 LOAD32
|
||||
6 ds-reg 4 STWU
|
||||
] rc-absolute-ppc-2/2 rt-immediate 1 jit-push-immediate jit-define
|
||||
0 3 LOAD32 rc-absolute-ppc-2/2 rt-immediate jit-rel
|
||||
3 ds-reg 4 STWU
|
||||
] jit-push-immediate jit-define
|
||||
|
||||
[
|
||||
0 6 LOAD32
|
||||
7 6 0 LWZ
|
||||
1 7 0 STW
|
||||
] rc-absolute-ppc-2/2 rt-stack-chain 1 jit-save-stack jit-define
|
||||
|
||||
[
|
||||
0 6 LOAD32
|
||||
6 MTCTR
|
||||
0 3 LOAD32 rc-absolute-ppc-2/2 rt-stack-chain jit-rel
|
||||
4 3 0 LWZ
|
||||
1 4 0 STW
|
||||
0 3 LOAD32 rc-absolute-ppc-2/2 rt-primitive jit-rel
|
||||
3 MTCTR
|
||||
BCTR
|
||||
] rc-absolute-ppc-2/2 rt-primitive 1 jit-primitive jit-define
|
||||
] jit-primitive jit-define
|
||||
|
||||
[ 0 BL ] rc-relative-ppc-3 rt-xt 0 jit-word-call jit-define
|
||||
[ 0 BL rc-relative-ppc-3 rt-xt-pic jit-rel ] jit-word-call jit-define
|
||||
|
||||
[ 0 B ] rc-relative-ppc-3 rt-xt 0 jit-word-jump jit-define
|
||||
[
|
||||
0 6 LOAD32 rc-absolute-ppc-2/2 rt-here jit-rel
|
||||
0 B rc-relative-ppc-3 rt-xt-pic-tail jit-rel
|
||||
] jit-word-jump jit-define
|
||||
|
||||
[ 0 B rc-relative-ppc-3 rt-xt jit-rel ] jit-word-special jit-define
|
||||
|
||||
[
|
||||
3 ds-reg 0 LWZ
|
||||
ds-reg dup 4 SUBI
|
||||
0 3 \ f tag-number CMPI
|
||||
2 BEQ
|
||||
0 B
|
||||
] rc-relative-ppc-3 rt-xt 4 jit-if-1 jit-define
|
||||
|
||||
[
|
||||
0 B
|
||||
] rc-relative-ppc-3 rt-xt 0 jit-if-2 jit-define
|
||||
|
||||
: jit-jump-quot ( -- )
|
||||
4 3 quot-xt-offset LWZ
|
||||
4 MTCTR
|
||||
BCTR ;
|
||||
|
||||
[
|
||||
0 3 LOAD32
|
||||
6 ds-reg 0 LWZ
|
||||
6 6 1 SRAWI
|
||||
3 3 6 ADD
|
||||
3 3 array-start-offset LWZ
|
||||
ds-reg dup 4 SUBI
|
||||
jit-jump-quot
|
||||
] rc-absolute-ppc-2/2 rt-immediate 1 jit-dispatch jit-define
|
||||
0 B rc-relative-ppc-3 rt-xt jit-rel
|
||||
0 B rc-relative-ppc-3 rt-xt jit-rel
|
||||
] jit-if jit-define
|
||||
|
||||
: jit->r ( -- )
|
||||
4 ds-reg 0 LWZ
|
||||
|
|
@ -139,46 +121,142 @@ CONSTANT: rs-reg 30
|
|||
|
||||
[
|
||||
jit->r
|
||||
0 BL
|
||||
0 BL rc-relative-ppc-3 rt-xt jit-rel
|
||||
jit-r>
|
||||
] rc-relative-ppc-3 rt-xt 3 jit-dip jit-define
|
||||
] jit-dip jit-define
|
||||
|
||||
[
|
||||
jit-2>r
|
||||
0 BL
|
||||
0 BL rc-relative-ppc-3 rt-xt jit-rel
|
||||
jit-2r>
|
||||
] rc-relative-ppc-3 rt-xt 6 jit-2dip jit-define
|
||||
] jit-2dip jit-define
|
||||
|
||||
[
|
||||
jit-3>r
|
||||
0 BL
|
||||
0 BL rc-relative-ppc-3 rt-xt jit-rel
|
||||
jit-3r>
|
||||
] rc-relative-ppc-3 rt-xt 8 jit-3dip jit-define
|
||||
] jit-3dip jit-define
|
||||
|
||||
: prepare-(execute) ( -- operand )
|
||||
3 ds-reg 0 LWZ
|
||||
ds-reg dup 4 SUBI
|
||||
4 3 word-xt-offset LWZ
|
||||
4 ;
|
||||
|
||||
[ prepare-(execute) MTCTR BCTR ] jit-execute-jump jit-define
|
||||
|
||||
[ prepare-(execute) MTLR BLRL ] jit-execute-call jit-define
|
||||
|
||||
[
|
||||
0 1 lr-save stack-frame + LWZ
|
||||
1 1 stack-frame ADDI
|
||||
0 MTLR
|
||||
] f f f jit-epilog jit-define
|
||||
] jit-epilog jit-define
|
||||
|
||||
[ BLR ] f f f jit-return jit-define
|
||||
[ BLR ] jit-return jit-define
|
||||
|
||||
! Sub-primitives
|
||||
! ! ! Polymorphic inline caches
|
||||
|
||||
! Don't touch r6 here; it's used to pass the tail call site
|
||||
! address for tail PICs
|
||||
|
||||
! Load a value from a stack position
|
||||
[
|
||||
4 ds-reg 0 LWZ rc-absolute-ppc-2 rt-untagged jit-rel
|
||||
] pic-load jit-define
|
||||
|
||||
! Tag
|
||||
: load-tag ( -- )
|
||||
4 4 tag-mask get ANDI
|
||||
4 4 tag-bits get SLWI ;
|
||||
|
||||
[ load-tag ] pic-tag jit-define
|
||||
|
||||
! Hi-tag
|
||||
[
|
||||
3 4 MR
|
||||
load-tag
|
||||
0 4 object tag-number tag-fixnum CMPI
|
||||
2 BNE
|
||||
4 3 object tag-number neg LWZ
|
||||
] pic-hi-tag jit-define
|
||||
|
||||
! Tuple
|
||||
[
|
||||
3 4 MR
|
||||
load-tag
|
||||
0 4 tuple tag-number tag-fixnum CMPI
|
||||
2 BNE
|
||||
4 3 tuple tag-number neg bootstrap-cell + LWZ
|
||||
] pic-tuple jit-define
|
||||
|
||||
! Hi-tag and tuple
|
||||
[
|
||||
3 4 MR
|
||||
load-tag
|
||||
! If bits 2 and 3 are set, the tag is either 6 (object) or 7 (tuple)
|
||||
0 4 BIN: 110 tag-fixnum CMPI
|
||||
5 BLT
|
||||
! Untag r3
|
||||
3 3 0 0 31 tag-bits get - RLWINM
|
||||
! Set r4 to 0 for objects, and bootstrap-cell for tuples
|
||||
4 4 1 tag-fixnum ANDI
|
||||
4 4 1 SRAWI
|
||||
! Load header cell or tuple layout cell
|
||||
4 4 3 LWZX
|
||||
] pic-hi-tag-tuple jit-define
|
||||
|
||||
[
|
||||
0 4 0 CMPI rc-absolute-ppc-2 rt-immediate jit-rel
|
||||
] pic-check-tag jit-define
|
||||
|
||||
[
|
||||
0 5 LOAD32 rc-absolute-ppc-2/2 rt-immediate jit-rel
|
||||
4 0 5 CMP
|
||||
] pic-check jit-define
|
||||
|
||||
[ 2 BNE 0 B rc-relative-ppc-3 rt-xt jit-rel ] pic-hit jit-define
|
||||
|
||||
! ! ! Megamorphic caches
|
||||
|
||||
[
|
||||
! cache = ...
|
||||
0 3 LOAD32 rc-absolute-ppc-2/2 rt-immediate jit-rel
|
||||
! key = class
|
||||
5 4 MR
|
||||
! key &= cache.length - 1
|
||||
5 5 mega-cache-size get 1- bootstrap-cell * ANDI
|
||||
! cache += array-start-offset
|
||||
3 3 array-start-offset ADDI
|
||||
! cache += key
|
||||
3 3 5 ADD
|
||||
! if(get(cache) == class)
|
||||
6 3 0 LWZ
|
||||
6 0 4 CMP
|
||||
10 BNE
|
||||
! megamorphic_cache_hits++
|
||||
0 4 LOAD32 rc-absolute-ppc-2/2 rt-megamorphic-cache-hits jit-rel
|
||||
5 4 0 LWZ
|
||||
5 5 1 ADDI
|
||||
5 4 0 STW
|
||||
! ... goto get(cache + bootstrap-cell)
|
||||
3 3 4 LWZ
|
||||
3 3 word-xt-offset LWZ
|
||||
3 MTCTR
|
||||
BCTR
|
||||
! fall-through on miss
|
||||
] mega-lookup jit-define
|
||||
|
||||
! ! ! Sub-primitives
|
||||
|
||||
! Quotations and words
|
||||
[
|
||||
3 ds-reg 0 LWZ
|
||||
ds-reg dup 4 SUBI
|
||||
jit-jump-quot
|
||||
] f f f \ (call) define-sub-primitive
|
||||
|
||||
[
|
||||
3 ds-reg 0 LWZ
|
||||
ds-reg dup 4 SUBI
|
||||
4 3 word-xt-offset LWZ
|
||||
4 3 quot-xt-offset LWZ
|
||||
4 MTCTR
|
||||
BCTR
|
||||
] f f f \ (execute) define-sub-primitive
|
||||
] \ (call) define-sub-primitive
|
||||
|
||||
! Objects
|
||||
[
|
||||
|
|
@ -186,7 +264,7 @@ CONSTANT: rs-reg 30
|
|||
3 3 tag-mask get ANDI
|
||||
3 3 tag-bits get SLWI
|
||||
3 ds-reg 0 STW
|
||||
] f f f \ tag define-sub-primitive
|
||||
] \ tag define-sub-primitive
|
||||
|
||||
[
|
||||
3 ds-reg 0 LWZ
|
||||
|
|
@ -195,25 +273,25 @@ CONSTANT: rs-reg 30
|
|||
4 4 0 0 31 tag-bits get - RLWINM
|
||||
4 3 3 LWZX
|
||||
3 ds-reg 0 STW
|
||||
] f f f \ slot define-sub-primitive
|
||||
] \ slot define-sub-primitive
|
||||
|
||||
! Shufflers
|
||||
[
|
||||
ds-reg dup 4 SUBI
|
||||
] f f f \ drop define-sub-primitive
|
||||
] \ drop define-sub-primitive
|
||||
|
||||
[
|
||||
ds-reg dup 8 SUBI
|
||||
] f f f \ 2drop define-sub-primitive
|
||||
] \ 2drop define-sub-primitive
|
||||
|
||||
[
|
||||
ds-reg dup 12 SUBI
|
||||
] f f f \ 3drop define-sub-primitive
|
||||
] \ 3drop define-sub-primitive
|
||||
|
||||
[
|
||||
3 ds-reg 0 LWZ
|
||||
3 ds-reg 4 STWU
|
||||
] f f f \ dup define-sub-primitive
|
||||
] \ dup define-sub-primitive
|
||||
|
||||
[
|
||||
3 ds-reg 0 LWZ
|
||||
|
|
@ -221,7 +299,7 @@ CONSTANT: rs-reg 30
|
|||
ds-reg dup 8 ADDI
|
||||
3 ds-reg 0 STW
|
||||
4 ds-reg -4 STW
|
||||
] f f f \ 2dup define-sub-primitive
|
||||
] \ 2dup define-sub-primitive
|
||||
|
||||
[
|
||||
3 ds-reg 0 LWZ
|
||||
|
|
@ -231,36 +309,36 @@ CONSTANT: rs-reg 30
|
|||
3 ds-reg 0 STW
|
||||
4 ds-reg -4 STW
|
||||
5 ds-reg -8 STW
|
||||
] f f f \ 3dup define-sub-primitive
|
||||
] \ 3dup define-sub-primitive
|
||||
|
||||
[
|
||||
3 ds-reg 0 LWZ
|
||||
ds-reg dup 4 SUBI
|
||||
3 ds-reg 0 STW
|
||||
] f f f \ nip define-sub-primitive
|
||||
] \ nip define-sub-primitive
|
||||
|
||||
[
|
||||
3 ds-reg 0 LWZ
|
||||
ds-reg dup 8 SUBI
|
||||
3 ds-reg 0 STW
|
||||
] f f f \ 2nip define-sub-primitive
|
||||
] \ 2nip define-sub-primitive
|
||||
|
||||
[
|
||||
3 ds-reg -4 LWZ
|
||||
3 ds-reg 4 STWU
|
||||
] f f f \ over define-sub-primitive
|
||||
] \ over define-sub-primitive
|
||||
|
||||
[
|
||||
3 ds-reg -8 LWZ
|
||||
3 ds-reg 4 STWU
|
||||
] f f f \ pick define-sub-primitive
|
||||
] \ pick define-sub-primitive
|
||||
|
||||
[
|
||||
3 ds-reg 0 LWZ
|
||||
4 ds-reg -4 LWZ
|
||||
4 ds-reg 0 STW
|
||||
3 ds-reg 4 STWU
|
||||
] f f f \ dupd define-sub-primitive
|
||||
] \ dupd define-sub-primitive
|
||||
|
||||
[
|
||||
3 ds-reg 0 LWZ
|
||||
|
|
@ -268,21 +346,21 @@ CONSTANT: rs-reg 30
|
|||
3 ds-reg 4 STWU
|
||||
4 ds-reg -4 STW
|
||||
3 ds-reg -8 STW
|
||||
] f f f \ tuck define-sub-primitive
|
||||
] \ tuck define-sub-primitive
|
||||
|
||||
[
|
||||
3 ds-reg 0 LWZ
|
||||
4 ds-reg -4 LWZ
|
||||
3 ds-reg -4 STW
|
||||
4 ds-reg 0 STW
|
||||
] f f f \ swap define-sub-primitive
|
||||
] \ swap define-sub-primitive
|
||||
|
||||
[
|
||||
3 ds-reg -4 LWZ
|
||||
4 ds-reg -8 LWZ
|
||||
3 ds-reg -8 STW
|
||||
4 ds-reg -4 STW
|
||||
] f f f \ swapd define-sub-primitive
|
||||
] \ swapd define-sub-primitive
|
||||
|
||||
[
|
||||
3 ds-reg 0 LWZ
|
||||
|
|
@ -291,7 +369,7 @@ CONSTANT: rs-reg 30
|
|||
4 ds-reg -8 STW
|
||||
3 ds-reg -4 STW
|
||||
5 ds-reg 0 STW
|
||||
] f f f \ rot define-sub-primitive
|
||||
] \ rot define-sub-primitive
|
||||
|
||||
[
|
||||
3 ds-reg 0 LWZ
|
||||
|
|
@ -300,13 +378,13 @@ CONSTANT: rs-reg 30
|
|||
3 ds-reg -8 STW
|
||||
5 ds-reg -4 STW
|
||||
4 ds-reg 0 STW
|
||||
] f f f \ -rot define-sub-primitive
|
||||
] \ -rot define-sub-primitive
|
||||
|
||||
[ jit->r ] f f f \ load-local define-sub-primitive
|
||||
[ jit->r ] \ load-local define-sub-primitive
|
||||
|
||||
! Comparisons
|
||||
: jit-compare ( insn -- )
|
||||
0 3 LOAD32
|
||||
0 3 LOAD32 rc-absolute-ppc-2/2 rt-immediate jit-rel
|
||||
4 ds-reg 0 LWZ
|
||||
5 ds-reg -4 LWZU
|
||||
5 0 4 CMP
|
||||
|
|
@ -315,8 +393,7 @@ CONSTANT: rs-reg 30
|
|||
3 ds-reg 0 STW ;
|
||||
|
||||
: define-jit-compare ( insn word -- )
|
||||
[ [ jit-compare ] curry rc-absolute-ppc-2/2 rt-immediate 1 ] dip
|
||||
define-sub-primitive ;
|
||||
[ [ jit-compare ] curry ] dip define-sub-primitive ;
|
||||
|
||||
\ BEQ \ eq? define-jit-compare
|
||||
\ BGE \ fixnum>= define-jit-compare
|
||||
|
|
@ -336,7 +413,7 @@ CONSTANT: rs-reg 30
|
|||
2 BNE
|
||||
1 tag-fixnum 4 LI
|
||||
4 ds-reg 0 STW
|
||||
] f f f \ both-fixnums? define-sub-primitive
|
||||
] \ both-fixnums? define-sub-primitive
|
||||
|
||||
: jit-math ( insn -- )
|
||||
3 ds-reg 0 LWZ
|
||||
|
|
@ -344,9 +421,9 @@ CONSTANT: rs-reg 30
|
|||
[ 5 3 4 ] dip execute( dst src1 src2 -- )
|
||||
5 ds-reg 0 STW ;
|
||||
|
||||
[ \ ADD jit-math ] f f f \ fixnum+fast define-sub-primitive
|
||||
[ \ ADD jit-math ] \ fixnum+fast define-sub-primitive
|
||||
|
||||
[ \ SUBF jit-math ] f f f \ fixnum-fast define-sub-primitive
|
||||
[ \ SUBF jit-math ] \ fixnum-fast define-sub-primitive
|
||||
|
||||
[
|
||||
3 ds-reg 0 LWZ
|
||||
|
|
@ -354,20 +431,20 @@ CONSTANT: rs-reg 30
|
|||
4 4 tag-bits get SRAWI
|
||||
5 3 4 MULLW
|
||||
5 ds-reg 0 STW
|
||||
] f f f \ fixnum*fast define-sub-primitive
|
||||
] \ fixnum*fast define-sub-primitive
|
||||
|
||||
[ \ AND jit-math ] f f f \ fixnum-bitand define-sub-primitive
|
||||
[ \ AND jit-math ] \ fixnum-bitand define-sub-primitive
|
||||
|
||||
[ \ OR jit-math ] f f f \ fixnum-bitor define-sub-primitive
|
||||
[ \ OR jit-math ] \ fixnum-bitor define-sub-primitive
|
||||
|
||||
[ \ XOR jit-math ] f f f \ fixnum-bitxor define-sub-primitive
|
||||
[ \ XOR jit-math ] \ fixnum-bitxor define-sub-primitive
|
||||
|
||||
[
|
||||
3 ds-reg 0 LWZ
|
||||
3 3 NOT
|
||||
3 3 tag-mask get XORI
|
||||
3 ds-reg 0 STW
|
||||
] f f f \ fixnum-bitnot define-sub-primitive
|
||||
] \ fixnum-bitnot define-sub-primitive
|
||||
|
||||
[
|
||||
3 ds-reg 0 LWZ
|
||||
|
|
@ -382,7 +459,7 @@ CONSTANT: rs-reg 30
|
|||
2 BGT
|
||||
5 7 MR
|
||||
5 ds-reg 0 STW
|
||||
] f f f \ fixnum-shift-fast define-sub-primitive
|
||||
] \ fixnum-shift-fast define-sub-primitive
|
||||
|
||||
[
|
||||
3 ds-reg 0 LWZ
|
||||
|
|
@ -392,7 +469,7 @@ CONSTANT: rs-reg 30
|
|||
6 5 3 MULLW
|
||||
7 6 4 SUBF
|
||||
7 ds-reg 0 STW
|
||||
] f f f \ fixnum-mod define-sub-primitive
|
||||
] \ fixnum-mod define-sub-primitive
|
||||
|
||||
[
|
||||
3 ds-reg 0 LWZ
|
||||
|
|
@ -401,7 +478,7 @@ CONSTANT: rs-reg 30
|
|||
5 4 3 DIVW
|
||||
5 5 tag-bits get SLWI
|
||||
5 ds-reg 0 STW
|
||||
] f f f \ fixnum/i-fast define-sub-primitive
|
||||
] \ fixnum/i-fast define-sub-primitive
|
||||
|
||||
[
|
||||
3 ds-reg 0 LWZ
|
||||
|
|
@ -412,20 +489,20 @@ CONSTANT: rs-reg 30
|
|||
5 5 tag-bits get SLWI
|
||||
5 ds-reg -4 STW
|
||||
7 ds-reg 0 STW
|
||||
] f f f \ fixnum/mod-fast define-sub-primitive
|
||||
] \ fixnum/mod-fast define-sub-primitive
|
||||
|
||||
[
|
||||
3 ds-reg 0 LWZ
|
||||
3 3 1 SRAWI
|
||||
rs-reg 3 3 LWZX
|
||||
3 ds-reg 0 STW
|
||||
] f f f \ get-local define-sub-primitive
|
||||
] \ get-local define-sub-primitive
|
||||
|
||||
[
|
||||
3 ds-reg 0 LWZ
|
||||
ds-reg ds-reg 4 SUBI
|
||||
3 3 1 SRAWI
|
||||
rs-reg 3 rs-reg SUBF
|
||||
] f f f \ drop-locals define-sub-primitive
|
||||
] \ drop-locals define-sub-primitive
|
||||
|
||||
[ "bootstrap.ppc" forget-vocab ] with-compilation-unit
|
||||
|
|
|
|||
|
|
@ -1,33 +1,39 @@
|
|||
! Copyright (C) 2005, 2008 Slava Pestov.
|
||||
! Copyright (C) 2005, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors assocs sequences kernel combinators make math
|
||||
math.order math.ranges system namespaces locals layouts words
|
||||
alien alien.c-types cpu.architecture cpu.ppc.assembler
|
||||
compiler.cfg.registers compiler.cfg.instructions
|
||||
compiler.constants compiler.codegen compiler.codegen.fixup
|
||||
compiler.cfg.intrinsics compiler.cfg.stack-frame ;
|
||||
alien alien.c-types literals cpu.architecture cpu.ppc.assembler
|
||||
cpu.ppc.assembler.backend literals compiler.cfg.registers
|
||||
compiler.cfg.instructions compiler.constants compiler.codegen
|
||||
compiler.codegen.fixup compiler.cfg.intrinsics
|
||||
compiler.cfg.stack-frame ;
|
||||
IN: cpu.ppc
|
||||
|
||||
! PowerPC register assignments:
|
||||
! r2-r27: integer vregs
|
||||
! r28: integer scratch
|
||||
! r29: data stack
|
||||
! r30: retain stack
|
||||
! r2-r12: integer vregs
|
||||
! r15-r29
|
||||
! r30: integer scratch
|
||||
! f0-f29: float vregs
|
||||
! f30, f31: float scratch
|
||||
! f30: float scratch
|
||||
|
||||
! Add some methods to the assembler that are useful to us
|
||||
M: label (B) [ 0 ] 2dip (B) rc-relative-ppc-3 label-fixup ;
|
||||
M: label BC [ 0 BC ] dip rc-relative-ppc-2 label-fixup ;
|
||||
|
||||
enable-float-intrinsics
|
||||
|
||||
<< \ ##integer>float t frame-required? set-word-prop
|
||||
\ ##float>integer t frame-required? set-word-prop >>
|
||||
<<
|
||||
\ ##integer>float t frame-required? set-word-prop
|
||||
\ ##float>integer t frame-required? set-word-prop
|
||||
>>
|
||||
|
||||
M: ppc machine-registers
|
||||
{
|
||||
{ int-regs T{ range f 2 26 1 } }
|
||||
{ double-float-regs T{ range f 0 29 1 } }
|
||||
{ int-regs $[ 2 12 [a,b] 15 29 [a,b] append ] }
|
||||
{ double-float-regs $[ 0 29 [a,b] ] }
|
||||
} ;
|
||||
|
||||
CONSTANT: scratch-reg 28
|
||||
CONSTANT: scratch-reg 30
|
||||
CONSTANT: fp-scratch-reg 30
|
||||
|
||||
M: ppc two-operand? f ;
|
||||
|
|
@ -40,8 +46,8 @@ M: ppc %load-reference ( reg obj -- )
|
|||
M: ppc %alien-global ( register symbol dll -- )
|
||||
[ 0 swap LOAD32 ] 2dip rc-absolute-ppc-2/2 rel-dlsym ;
|
||||
|
||||
CONSTANT: ds-reg 29
|
||||
CONSTANT: rs-reg 30
|
||||
CONSTANT: ds-reg 13
|
||||
CONSTANT: rs-reg 14
|
||||
|
||||
GENERIC: loc-reg ( loc -- reg )
|
||||
|
||||
|
|
@ -108,7 +114,12 @@ M: ppc stack-frame-size ( stack-frame -- i )
|
|||
factor-area-size +
|
||||
4 cells align ;
|
||||
|
||||
M: ppc %call ( label -- ) BL ;
|
||||
M: ppc %call ( word -- ) 0 BL rc-relative-ppc-3 rel-word-pic ;
|
||||
|
||||
M: ppc %jump ( word -- )
|
||||
0 6 LOAD32 8 rc-absolute-ppc-2/2 rel-here
|
||||
0 B rc-relative-ppc-3 rel-word-pic-tail ;
|
||||
|
||||
M: ppc %jump-label ( label -- ) B ;
|
||||
M: ppc %return ( -- ) BLR ;
|
||||
|
||||
|
|
@ -120,7 +131,7 @@ M:: ppc %dispatch ( src temp offset -- )
|
|||
BCTR ;
|
||||
|
||||
M: ppc %dispatch-label ( word -- )
|
||||
0 , rc-absolute-cell rel-word ;
|
||||
B{ 0 0 0 0 } % rc-absolute-cell rel-word ;
|
||||
|
||||
:: (%slot) ( obj slot tag temp -- reg offset )
|
||||
temp slot obj ADD
|
||||
|
|
@ -641,10 +652,10 @@ M: ppc %alien-callback ( quot -- )
|
|||
|
||||
M: ppc %prepare-alien-indirect ( -- )
|
||||
"unbox_alien" f %alien-invoke
|
||||
13 3 MR ;
|
||||
15 3 MR ;
|
||||
|
||||
M: ppc %alien-indirect ( -- )
|
||||
13 MTLR BLRL ;
|
||||
15 MTLR BLRL ;
|
||||
|
||||
M: ppc %callback-value ( ctype -- )
|
||||
! Save top of data stack
|
||||
|
|
@ -702,3 +713,4 @@ USE: vocabs.loader
|
|||
} cond
|
||||
|
||||
"complex-double" c-type t >>return-in-registers? drop
|
||||
"bool" c-type 4 >>size 4 >>align drop
|
||||
|
|
@ -42,11 +42,13 @@ M:: x86.32 %dispatch ( src temp offset -- )
|
|||
M: x86.32 param-reg-1 EAX ;
|
||||
M: x86.32 param-reg-2 EDX ;
|
||||
|
||||
M: x86.32 pic-tail-reg EBX ;
|
||||
|
||||
M: x86.32 reserved-area-size 0 ;
|
||||
|
||||
M: x86.32 %alien-invoke (CALL) rel-dlsym ;
|
||||
M: x86.32 %alien-invoke 0 CALL rc-relative rel-dlsym ;
|
||||
|
||||
M: x86.32 %alien-invoke-tail (JMP) rel-dlsym ;
|
||||
M: x86.32 %alien-invoke-tail 0 JMP rc-relative rel-dlsym ;
|
||||
|
||||
M: x86.32 return-struct-in-registers? ( c-type -- ? )
|
||||
c-type
|
||||
|
|
@ -309,7 +311,7 @@ FUNCTION: bool check_sse2 ( ) ;
|
|||
check_sse2 ;
|
||||
|
||||
"-no-sse2" (command-line) member? [
|
||||
optimizing-compiler compiler-impl [ { check_sse2 } compile ] with-variable
|
||||
[ { check_sse2 } compile ] with-optimizer
|
||||
|
||||
"Checking if your CPU supports SSE2..." print flush
|
||||
sse2? [
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
! Copyright (C) 2007 Slava Pestov.
|
||||
! Copyright (C) 2007, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: bootstrap.image.private kernel namespaces system
|
||||
cpu.x86.assembler layouts vocabs parser compiler.constants ;
|
||||
|
|
@ -22,13 +22,13 @@ IN: bootstrap.x86
|
|||
: rex-length ( -- n ) 0 ;
|
||||
|
||||
[
|
||||
temp0 0 [] MOV ! load stack_chain
|
||||
temp0 [] stack-reg MOV ! save stack pointer
|
||||
] rc-absolute-cell rt-stack-chain 2 jit-save-stack jit-define
|
||||
|
||||
[
|
||||
(JMP) drop
|
||||
] rc-relative rt-primitive 1 jit-primitive jit-define
|
||||
! load stack_chain
|
||||
temp0 0 [] MOV rc-absolute-cell rt-stack-chain jit-rel
|
||||
! save stack pointer
|
||||
temp0 [] stack-reg MOV
|
||||
! call the primitive
|
||||
0 JMP rc-relative rt-primitive jit-rel
|
||||
] jit-primitive jit-define
|
||||
|
||||
<< "vocab:cpu/x86/bootstrap.factor" parse-file parsed >>
|
||||
call
|
||||
|
|
|
|||
|
|
@ -39,6 +39,8 @@ M: x86.64 param-reg-1 int-regs param-regs first ;
|
|||
M: x86.64 param-reg-2 int-regs param-regs second ;
|
||||
: param-reg-3 ( -- reg ) int-regs param-regs third ; inline
|
||||
|
||||
M: x86.64 pic-tail-reg RBX ;
|
||||
|
||||
M: int-regs return-reg drop RAX ;
|
||||
M: float-regs return-reg drop XMM0 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
! Copyright (C) 2007 Slava Pestov.
|
||||
! Copyright (C) 2007, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: bootstrap.image.private kernel namespaces system
|
||||
cpu.x86.assembler layouts vocabs parser compiler.constants math ;
|
||||
|
|
@ -20,15 +20,16 @@ IN: bootstrap.x86
|
|||
: rex-length ( -- n ) 1 ;
|
||||
|
||||
[
|
||||
temp0 0 MOV ! load stack_chain
|
||||
! load stack_chain
|
||||
temp0 0 MOV rc-absolute-cell rt-stack-chain jit-rel
|
||||
temp0 temp0 [] MOV
|
||||
temp0 [] stack-reg MOV ! save stack pointer
|
||||
] rc-absolute-cell rt-stack-chain 1 rex-length + jit-save-stack jit-define
|
||||
|
||||
[
|
||||
temp1 0 MOV ! load XT
|
||||
temp1 JMP ! go
|
||||
] rc-absolute-cell rt-primitive 1 rex-length + jit-primitive jit-define
|
||||
! save stack pointer
|
||||
temp0 [] stack-reg MOV
|
||||
! load XT
|
||||
temp1 0 MOV rc-absolute-cell rt-primitive jit-rel
|
||||
! go
|
||||
temp1 JMP
|
||||
] jit-primitive jit-define
|
||||
|
||||
<< "vocab:cpu/x86/bootstrap.factor" parse-file parsed >>
|
||||
call
|
||||
|
|
|
|||
|
|
@ -62,3 +62,5 @@ IN: cpu.x86.assembler.tests
|
|||
[ { HEX: 48 HEX: d3 HEX: e1 } ] [ [ RCX CL SHL ] { } make ] unit-test
|
||||
[ { HEX: 48 HEX: d3 HEX: e8 } ] [ [ RAX CL SHR ] { } make ] unit-test
|
||||
[ { HEX: 48 HEX: d3 HEX: e9 } ] [ [ RCX CL SHR ] { } make ] unit-test
|
||||
|
||||
[ { HEX: f7 HEX: c1 HEX: d2 HEX: 04 HEX: 00 HEX: 00 } ] [ [ ECX 1234 TEST ] { } make ] unit-test
|
||||
|
|
|
|||
|
|
@ -1,12 +1,11 @@
|
|||
! Copyright (C) 2005, 2008 Slava Pestov.
|
||||
! Copyright (C) 2005, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays cpu.architecture compiler.constants
|
||||
compiler.codegen.fixup io.binary kernel combinators
|
||||
kernel.private math namespaces make sequences words system
|
||||
layouts math.order accessors cpu.x86.assembler.syntax ;
|
||||
USING: arrays io.binary kernel combinators
|
||||
kernel.private math namespaces make sequences words system layouts
|
||||
math.order accessors cpu.x86.assembler.syntax ;
|
||||
IN: cpu.x86.assembler
|
||||
|
||||
! A postfix assembler for x86 and AMD64.
|
||||
! A postfix assembler for x86-32 and x86-64.
|
||||
|
||||
! In 32-bit mode, { 1234 } is absolute indirect addressing.
|
||||
! In 64-bit mode, { 1234 } is RIP-relative.
|
||||
|
|
@ -296,35 +295,23 @@ M: operand (MOV-I)
|
|||
{ BIN: 000 t HEX: c6 }
|
||||
pick byte? [ immediate-1 ] [ immediate-4 ] if ;
|
||||
|
||||
PREDICATE: callable < word register? not ;
|
||||
|
||||
GENERIC: MOV ( dst src -- )
|
||||
M: immediate MOV swap (MOV-I) ;
|
||||
M: callable MOV [ 0 ] 2dip (MOV-I) rc-absolute-cell rel-word ;
|
||||
M: operand MOV HEX: 88 2-operand ;
|
||||
|
||||
: LEA ( dst src -- ) swap HEX: 8d 2-operand ;
|
||||
|
||||
! Control flow
|
||||
GENERIC: JMP ( op -- )
|
||||
: (JMP) ( -- rel-class ) HEX: e9 , 0 4, rc-relative ;
|
||||
M: f JMP (JMP) 2drop ;
|
||||
M: callable JMP (JMP) rel-word ;
|
||||
M: label JMP (JMP) label-fixup ;
|
||||
M: integer JMP HEX: e9 , 4, ;
|
||||
M: operand JMP { BIN: 100 t HEX: ff } 1-operand ;
|
||||
|
||||
GENERIC: CALL ( op -- )
|
||||
: (CALL) ( -- rel-class ) HEX: e8 , 0 4, rc-relative ;
|
||||
M: f CALL (CALL) 2drop ;
|
||||
M: callable CALL (CALL) rel-word ;
|
||||
M: label CALL (CALL) label-fixup ;
|
||||
M: integer CALL HEX: e8 , 4, ;
|
||||
M: operand CALL { BIN: 010 t HEX: ff } 1-operand ;
|
||||
|
||||
GENERIC# JUMPcc 1 ( addr opcode -- )
|
||||
: (JUMPcc) ( n -- rel-class ) extended-opcode, 0 4, rc-relative ;
|
||||
M: f JUMPcc nip (JUMPcc) drop ;
|
||||
M: callable JUMPcc (JUMPcc) rel-word ;
|
||||
M: label JUMPcc (JUMPcc) label-fixup ;
|
||||
M: integer JUMPcc extended-opcode, 4, ;
|
||||
|
||||
: JO ( dst -- ) HEX: 80 JUMPcc ;
|
||||
: JNO ( dst -- ) HEX: 81 JUMPcc ;
|
||||
|
|
@ -382,6 +369,10 @@ GENERIC: CMP ( dst src -- )
|
|||
M: immediate CMP swap { BIN: 111 t HEX: 80 } immediate-1/4 ;
|
||||
M: operand CMP OCT: 070 2-operand ;
|
||||
|
||||
GENERIC: TEST ( dst src -- )
|
||||
M: immediate TEST swap { BIN: 0 t HEX: f7 } immediate-4 ;
|
||||
M: operand TEST OCT: 204 2-operand ;
|
||||
|
||||
: XCHG ( dst src -- ) OCT: 207 2-operand ;
|
||||
|
||||
: BSR ( dst src -- ) swap { HEX: 0f HEX: bd } (2-operand) ;
|
||||
|
|
|
|||
|
|
@ -1,18 +1,16 @@
|
|||
! Copyright (C) 2007, 2008 Slava Pestov.
|
||||
! Copyright (C) 2007, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: bootstrap.image.private kernel kernel.private namespaces
|
||||
system cpu.x86.assembler layouts compiler.units math
|
||||
math.private compiler.constants vocabs slots.private words
|
||||
words.private locals.backend ;
|
||||
locals.backend make sequences combinators arrays ;
|
||||
IN: bootstrap.x86
|
||||
|
||||
big-endian off
|
||||
|
||||
1 jit-code-format set
|
||||
|
||||
[
|
||||
! Load word
|
||||
temp0 0 MOV
|
||||
temp0 0 MOV rc-absolute-cell rt-immediate jit-rel
|
||||
! Bump profiling counter
|
||||
temp0 profile-count-offset [+] 1 tag-fixnum ADD
|
||||
! Load word->code
|
||||
|
|
@ -21,35 +19,40 @@ big-endian off
|
|||
temp0 compiled-header-size ADD
|
||||
! Jump to XT
|
||||
temp0 JMP
|
||||
] rc-absolute-cell rt-immediate 1 rex-length + jit-profiling jit-define
|
||||
] jit-profiling jit-define
|
||||
|
||||
[
|
||||
! load XT
|
||||
temp0 0 MOV
|
||||
temp0 0 MOV rc-absolute-cell rt-this jit-rel
|
||||
! save stack frame size
|
||||
stack-frame-size PUSH
|
||||
! push XT
|
||||
temp0 PUSH
|
||||
! alignment
|
||||
stack-reg stack-frame-size 3 bootstrap-cells - SUB
|
||||
] rc-absolute-cell rt-this 1 rex-length + jit-prolog jit-define
|
||||
] jit-prolog jit-define
|
||||
|
||||
[
|
||||
! load literal
|
||||
temp0 0 MOV
|
||||
temp0 0 MOV rc-absolute-cell rt-immediate jit-rel
|
||||
! increment datastack pointer
|
||||
ds-reg bootstrap-cell ADD
|
||||
! store literal on datastack
|
||||
ds-reg [] temp0 MOV
|
||||
] rc-absolute-cell rt-immediate 1 rex-length + jit-push-immediate jit-define
|
||||
] jit-push-immediate jit-define
|
||||
|
||||
[
|
||||
f JMP
|
||||
] rc-relative rt-xt 1 jit-word-jump jit-define
|
||||
temp3 0 MOV rc-absolute-cell rt-here jit-rel
|
||||
0 JMP rc-relative rt-xt-pic-tail jit-rel
|
||||
] jit-word-jump jit-define
|
||||
|
||||
[
|
||||
f CALL
|
||||
] rc-relative rt-xt 1 jit-word-call jit-define
|
||||
0 CALL rc-relative rt-xt-pic jit-rel
|
||||
] jit-word-call jit-define
|
||||
|
||||
[
|
||||
0 JMP rc-relative rt-xt jit-rel
|
||||
] jit-word-special jit-define
|
||||
|
||||
[
|
||||
! load boolean
|
||||
|
|
@ -59,31 +62,10 @@ big-endian off
|
|||
! compare boolean with f
|
||||
temp0 \ f tag-number CMP
|
||||
! jump to true branch if not equal
|
||||
f JNE
|
||||
] rc-relative rt-xt 10 rex-length 3 * + jit-if-1 jit-define
|
||||
|
||||
[
|
||||
0 JNE rc-relative rt-xt jit-rel
|
||||
! jump to false branch if equal
|
||||
f JMP
|
||||
] rc-relative rt-xt 1 jit-if-2 jit-define
|
||||
|
||||
[
|
||||
! load dispatch table
|
||||
temp1 0 MOV
|
||||
! load index
|
||||
temp0 ds-reg [] MOV
|
||||
! turn it into an array offset
|
||||
fixnum>slot@
|
||||
! pop index
|
||||
ds-reg bootstrap-cell SUB
|
||||
! compute quotation location
|
||||
temp0 temp1 ADD
|
||||
! load quotation
|
||||
arg temp0 array-start-offset [+] MOV
|
||||
! execute branch. the quot must be in arg, since it might
|
||||
! not be compiled yet
|
||||
arg quot-xt-offset [+] JMP
|
||||
] rc-absolute-cell rt-immediate 1 rex-length + jit-dispatch jit-define
|
||||
0 JMP rc-relative rt-xt jit-rel
|
||||
] jit-if jit-define
|
||||
|
||||
: jit->r ( -- )
|
||||
rs-reg bootstrap-cell ADD
|
||||
|
|
@ -135,30 +117,133 @@ big-endian off
|
|||
|
||||
[
|
||||
jit->r
|
||||
f CALL
|
||||
0 CALL rc-relative rt-xt jit-rel
|
||||
jit-r>
|
||||
] rc-relative rt-xt 11 rex-length 4 * + jit-dip jit-define
|
||||
] jit-dip jit-define
|
||||
|
||||
[
|
||||
jit-2>r
|
||||
f CALL
|
||||
0 CALL rc-relative rt-xt jit-rel
|
||||
jit-2r>
|
||||
] rc-relative rt-xt 17 rex-length 6 * + jit-2dip jit-define
|
||||
] jit-2dip jit-define
|
||||
|
||||
[
|
||||
jit-3>r
|
||||
f CALL
|
||||
0 CALL rc-relative rt-xt jit-rel
|
||||
jit-3r>
|
||||
] rc-relative rt-xt 23 rex-length 8 * + jit-3dip jit-define
|
||||
] jit-3dip jit-define
|
||||
|
||||
: prepare-(execute) ( -- operand )
|
||||
! load from stack
|
||||
temp0 ds-reg [] MOV
|
||||
! pop stack
|
||||
ds-reg bootstrap-cell SUB
|
||||
! execute word
|
||||
temp0 word-xt-offset [+] ;
|
||||
|
||||
[ prepare-(execute) JMP ] jit-execute-jump jit-define
|
||||
|
||||
[ prepare-(execute) CALL ] jit-execute-call jit-define
|
||||
|
||||
[
|
||||
! unwind stack frame
|
||||
stack-reg stack-frame-size bootstrap-cell - ADD
|
||||
] f f f jit-epilog jit-define
|
||||
] jit-epilog jit-define
|
||||
|
||||
[ 0 RET ] f f f jit-return jit-define
|
||||
[ 0 RET ] jit-return jit-define
|
||||
|
||||
! Sub-primitives
|
||||
! ! ! Polymorphic inline caches
|
||||
|
||||
! The PIC and megamorphic code stubs are not permitted to touch temp3.
|
||||
|
||||
! Load a value from a stack position
|
||||
[
|
||||
temp1 ds-reg HEX: ffffffff [+] MOV rc-absolute rt-untagged jit-rel
|
||||
] pic-load jit-define
|
||||
|
||||
! Tag
|
||||
: load-tag ( -- )
|
||||
temp1 tag-mask get AND
|
||||
temp1 tag-bits get SHL ;
|
||||
|
||||
[ load-tag ] pic-tag jit-define
|
||||
|
||||
! The 'make' trick lets us compute the jump distance for the
|
||||
! conditional branches there
|
||||
|
||||
! Hi-tag
|
||||
[
|
||||
temp0 temp1 MOV
|
||||
load-tag
|
||||
temp1 object tag-number tag-fixnum CMP
|
||||
[ temp1 temp0 object tag-number neg [+] MOV ] { } make
|
||||
[ length JNE ] [ % ] bi
|
||||
] pic-hi-tag jit-define
|
||||
|
||||
! Tuple
|
||||
[
|
||||
temp0 temp1 MOV
|
||||
load-tag
|
||||
temp1 tuple tag-number tag-fixnum CMP
|
||||
[ temp1 temp0 tuple tag-number neg bootstrap-cell + [+] MOV ] { } make
|
||||
[ length JNE ] [ % ] bi
|
||||
] pic-tuple jit-define
|
||||
|
||||
! Hi-tag and tuple
|
||||
[
|
||||
temp0 temp1 MOV
|
||||
load-tag
|
||||
! If bits 2 and 3 are set, the tag is either 6 (object) or 7 (tuple)
|
||||
temp1 BIN: 110 tag-fixnum CMP
|
||||
[
|
||||
! Untag temp0
|
||||
temp0 tag-mask get bitnot AND
|
||||
! Set temp1 to 0 for objects, and bootstrap-cell for tuples
|
||||
temp1 1 tag-fixnum AND
|
||||
bootstrap-cell 4 = [ temp1 1 SHR ] when
|
||||
! Load header cell or tuple layout cell
|
||||
temp1 temp0 temp1 [+] MOV
|
||||
] [ ] make [ length JL ] [ % ] bi
|
||||
] pic-hi-tag-tuple jit-define
|
||||
|
||||
[
|
||||
temp1 HEX: ffffffff CMP rc-absolute rt-immediate jit-rel
|
||||
] pic-check-tag jit-define
|
||||
|
||||
[
|
||||
temp2 HEX: ffffffff MOV rc-absolute-cell rt-immediate jit-rel
|
||||
temp1 temp2 CMP
|
||||
] pic-check jit-define
|
||||
|
||||
[ 0 JE rc-relative rt-xt jit-rel ] pic-hit jit-define
|
||||
|
||||
! ! ! Megamorphic caches
|
||||
|
||||
[
|
||||
! cache = ...
|
||||
temp0 0 MOV rc-absolute-cell rt-immediate jit-rel
|
||||
! key = class
|
||||
temp2 temp1 MOV
|
||||
bootstrap-cell 8 = [ temp2 1 SHL ] when
|
||||
! key &= cache.length - 1
|
||||
temp2 mega-cache-size get 1- bootstrap-cell * AND
|
||||
! cache += array-start-offset
|
||||
temp0 array-start-offset ADD
|
||||
! cache += key
|
||||
temp0 temp2 ADD
|
||||
! if(get(cache) == class)
|
||||
temp0 [] temp1 CMP
|
||||
bootstrap-cell 4 = 14 22 ? JNE ! Yuck!
|
||||
! megamorphic_cache_hits++
|
||||
temp1 0 MOV rc-absolute-cell rt-megamorphic-cache-hits jit-rel
|
||||
temp1 [] 1 ADD
|
||||
! goto get(cache + bootstrap-cell)
|
||||
temp0 temp0 bootstrap-cell [+] MOV
|
||||
temp0 word-xt-offset [+] JMP
|
||||
! fall-through on miss
|
||||
] mega-lookup jit-define
|
||||
|
||||
! ! ! Sub-primitives
|
||||
|
||||
! Quotations and words
|
||||
[
|
||||
|
|
@ -168,16 +253,7 @@ big-endian off
|
|||
ds-reg bootstrap-cell SUB
|
||||
! call quotation
|
||||
arg quot-xt-offset [+] JMP
|
||||
] f f f \ (call) define-sub-primitive
|
||||
|
||||
[
|
||||
! load from stack
|
||||
temp0 ds-reg [] MOV
|
||||
! pop stack
|
||||
ds-reg bootstrap-cell SUB
|
||||
! execute word
|
||||
temp0 word-xt-offset [+] JMP
|
||||
] f f f \ (execute) define-sub-primitive
|
||||
] \ (call) define-sub-primitive
|
||||
|
||||
! Objects
|
||||
[
|
||||
|
|
@ -189,7 +265,7 @@ big-endian off
|
|||
temp0 tag-bits get SHL
|
||||
! push to stack
|
||||
ds-reg [] temp0 MOV
|
||||
] f f f \ tag define-sub-primitive
|
||||
] \ tag define-sub-primitive
|
||||
|
||||
[
|
||||
! load slot number
|
||||
|
|
@ -207,26 +283,26 @@ big-endian off
|
|||
temp0 temp1 temp0 [+] MOV
|
||||
! push to stack
|
||||
ds-reg [] temp0 MOV
|
||||
] f f f \ slot define-sub-primitive
|
||||
] \ slot define-sub-primitive
|
||||
|
||||
! Shufflers
|
||||
[
|
||||
ds-reg bootstrap-cell SUB
|
||||
] f f f \ drop define-sub-primitive
|
||||
] \ drop define-sub-primitive
|
||||
|
||||
[
|
||||
ds-reg 2 bootstrap-cells SUB
|
||||
] f f f \ 2drop define-sub-primitive
|
||||
] \ 2drop define-sub-primitive
|
||||
|
||||
[
|
||||
ds-reg 3 bootstrap-cells SUB
|
||||
] f f f \ 3drop define-sub-primitive
|
||||
] \ 3drop define-sub-primitive
|
||||
|
||||
[
|
||||
temp0 ds-reg [] MOV
|
||||
ds-reg bootstrap-cell ADD
|
||||
ds-reg [] temp0 MOV
|
||||
] f f f \ dup define-sub-primitive
|
||||
] \ dup define-sub-primitive
|
||||
|
||||
[
|
||||
temp0 ds-reg [] MOV
|
||||
|
|
@ -234,7 +310,7 @@ big-endian off
|
|||
ds-reg 2 bootstrap-cells ADD
|
||||
ds-reg [] temp0 MOV
|
||||
ds-reg bootstrap-cell neg [+] temp1 MOV
|
||||
] f f f \ 2dup define-sub-primitive
|
||||
] \ 2dup define-sub-primitive
|
||||
|
||||
[
|
||||
temp0 ds-reg [] MOV
|
||||
|
|
@ -244,31 +320,31 @@ big-endian off
|
|||
ds-reg [] temp0 MOV
|
||||
ds-reg -1 bootstrap-cells [+] temp1 MOV
|
||||
ds-reg -2 bootstrap-cells [+] temp3 MOV
|
||||
] f f f \ 3dup define-sub-primitive
|
||||
] \ 3dup define-sub-primitive
|
||||
|
||||
[
|
||||
temp0 ds-reg [] MOV
|
||||
ds-reg bootstrap-cell SUB
|
||||
ds-reg [] temp0 MOV
|
||||
] f f f \ nip define-sub-primitive
|
||||
] \ nip define-sub-primitive
|
||||
|
||||
[
|
||||
temp0 ds-reg [] MOV
|
||||
ds-reg 2 bootstrap-cells SUB
|
||||
ds-reg [] temp0 MOV
|
||||
] f f f \ 2nip define-sub-primitive
|
||||
] \ 2nip define-sub-primitive
|
||||
|
||||
[
|
||||
temp0 ds-reg -1 bootstrap-cells [+] MOV
|
||||
ds-reg bootstrap-cell ADD
|
||||
ds-reg [] temp0 MOV
|
||||
] f f f \ over define-sub-primitive
|
||||
] \ over define-sub-primitive
|
||||
|
||||
[
|
||||
temp0 ds-reg -2 bootstrap-cells [+] MOV
|
||||
ds-reg bootstrap-cell ADD
|
||||
ds-reg [] temp0 MOV
|
||||
] f f f \ pick define-sub-primitive
|
||||
] \ pick define-sub-primitive
|
||||
|
||||
[
|
||||
temp0 ds-reg [] MOV
|
||||
|
|
@ -276,7 +352,7 @@ big-endian off
|
|||
ds-reg [] temp1 MOV
|
||||
ds-reg bootstrap-cell ADD
|
||||
ds-reg [] temp0 MOV
|
||||
] f f f \ dupd define-sub-primitive
|
||||
] \ dupd define-sub-primitive
|
||||
|
||||
[
|
||||
temp0 ds-reg [] MOV
|
||||
|
|
@ -285,21 +361,21 @@ big-endian off
|
|||
ds-reg [] temp0 MOV
|
||||
ds-reg -1 bootstrap-cells [+] temp1 MOV
|
||||
ds-reg -2 bootstrap-cells [+] temp0 MOV
|
||||
] f f f \ tuck define-sub-primitive
|
||||
] \ tuck define-sub-primitive
|
||||
|
||||
[
|
||||
temp0 ds-reg [] MOV
|
||||
temp1 ds-reg bootstrap-cell neg [+] MOV
|
||||
ds-reg bootstrap-cell neg [+] temp0 MOV
|
||||
ds-reg [] temp1 MOV
|
||||
] f f f \ swap define-sub-primitive
|
||||
] \ swap define-sub-primitive
|
||||
|
||||
[
|
||||
temp0 ds-reg -1 bootstrap-cells [+] MOV
|
||||
temp1 ds-reg -2 bootstrap-cells [+] MOV
|
||||
ds-reg -2 bootstrap-cells [+] temp0 MOV
|
||||
ds-reg -1 bootstrap-cells [+] temp1 MOV
|
||||
] f f f \ swapd define-sub-primitive
|
||||
] \ swapd define-sub-primitive
|
||||
|
||||
[
|
||||
temp0 ds-reg [] MOV
|
||||
|
|
@ -308,7 +384,7 @@ big-endian off
|
|||
ds-reg -2 bootstrap-cells [+] temp1 MOV
|
||||
ds-reg -1 bootstrap-cells [+] temp0 MOV
|
||||
ds-reg [] temp3 MOV
|
||||
] f f f \ rot define-sub-primitive
|
||||
] \ rot define-sub-primitive
|
||||
|
||||
[
|
||||
temp0 ds-reg [] MOV
|
||||
|
|
@ -317,14 +393,14 @@ big-endian off
|
|||
ds-reg -2 bootstrap-cells [+] temp0 MOV
|
||||
ds-reg -1 bootstrap-cells [+] temp3 MOV
|
||||
ds-reg [] temp1 MOV
|
||||
] f f f \ -rot define-sub-primitive
|
||||
] \ -rot define-sub-primitive
|
||||
|
||||
[ jit->r ] f f f \ load-local define-sub-primitive
|
||||
[ jit->r ] \ load-local define-sub-primitive
|
||||
|
||||
! Comparisons
|
||||
: jit-compare ( insn -- )
|
||||
! load t
|
||||
temp3 0 MOV
|
||||
temp3 0 MOV rc-absolute-cell rt-immediate jit-rel
|
||||
! load f
|
||||
temp1 \ f tag-number MOV
|
||||
! load first value
|
||||
|
|
@ -339,8 +415,7 @@ big-endian off
|
|||
ds-reg [] temp1 MOV ;
|
||||
|
||||
: define-jit-compare ( insn word -- )
|
||||
[ [ jit-compare ] curry rc-absolute-cell rt-immediate 1 rex-length + ] dip
|
||||
define-sub-primitive ;
|
||||
[ [ jit-compare ] curry ] dip define-sub-primitive ;
|
||||
|
||||
\ CMOVE \ eq? define-jit-compare
|
||||
\ CMOVGE \ fixnum>= define-jit-compare
|
||||
|
|
@ -357,9 +432,9 @@ big-endian off
|
|||
! compute result
|
||||
[ ds-reg [] temp0 ] dip execute( dst src -- ) ;
|
||||
|
||||
[ \ ADD jit-math ] f f f \ fixnum+fast define-sub-primitive
|
||||
[ \ ADD jit-math ] \ fixnum+fast define-sub-primitive
|
||||
|
||||
[ \ SUB jit-math ] f f f \ fixnum-fast define-sub-primitive
|
||||
[ \ SUB jit-math ] \ fixnum-fast define-sub-primitive
|
||||
|
||||
[
|
||||
! load second input
|
||||
|
|
@ -374,20 +449,20 @@ big-endian off
|
|||
temp0 temp1 IMUL2
|
||||
! push result
|
||||
ds-reg [] temp1 MOV
|
||||
] f f f \ fixnum*fast define-sub-primitive
|
||||
] \ fixnum*fast define-sub-primitive
|
||||
|
||||
[ \ AND jit-math ] f f f \ fixnum-bitand define-sub-primitive
|
||||
[ \ AND jit-math ] \ fixnum-bitand define-sub-primitive
|
||||
|
||||
[ \ OR jit-math ] f f f \ fixnum-bitor define-sub-primitive
|
||||
[ \ OR jit-math ] \ fixnum-bitor define-sub-primitive
|
||||
|
||||
[ \ XOR jit-math ] f f f \ fixnum-bitxor define-sub-primitive
|
||||
[ \ XOR jit-math ] \ fixnum-bitxor define-sub-primitive
|
||||
|
||||
[
|
||||
! complement
|
||||
ds-reg [] NOT
|
||||
! clear tag bits
|
||||
ds-reg [] tag-mask get XOR
|
||||
] f f f \ fixnum-bitnot define-sub-primitive
|
||||
] \ fixnum-bitnot define-sub-primitive
|
||||
|
||||
[
|
||||
! load shift count
|
||||
|
|
@ -411,7 +486,7 @@ big-endian off
|
|||
temp1 temp3 CMOVGE
|
||||
! push to stack
|
||||
ds-reg [] temp1 MOV
|
||||
] f f f \ fixnum-shift-fast define-sub-primitive
|
||||
] \ fixnum-shift-fast define-sub-primitive
|
||||
|
||||
: jit-fixnum-/mod ( -- )
|
||||
! load second parameter
|
||||
|
|
@ -431,7 +506,7 @@ big-endian off
|
|||
ds-reg bootstrap-cell SUB
|
||||
! push to stack
|
||||
ds-reg [] mod-arg MOV
|
||||
] f f f \ fixnum-mod define-sub-primitive
|
||||
] \ fixnum-mod define-sub-primitive
|
||||
|
||||
[
|
||||
jit-fixnum-/mod
|
||||
|
|
@ -441,7 +516,7 @@ big-endian off
|
|||
div-arg tag-bits get SHL
|
||||
! push to stack
|
||||
ds-reg [] div-arg MOV
|
||||
] f f f \ fixnum/i-fast define-sub-primitive
|
||||
] \ fixnum/i-fast define-sub-primitive
|
||||
|
||||
[
|
||||
jit-fixnum-/mod
|
||||
|
|
@ -450,7 +525,7 @@ big-endian off
|
|||
! push to stack
|
||||
ds-reg [] mod-arg MOV
|
||||
ds-reg bootstrap-cell neg [+] div-arg MOV
|
||||
] f f f \ fixnum/mod-fast define-sub-primitive
|
||||
] \ fixnum/mod-fast define-sub-primitive
|
||||
|
||||
[
|
||||
temp0 ds-reg [] MOV
|
||||
|
|
@ -461,7 +536,7 @@ big-endian off
|
|||
temp1 1 tag-fixnum MOV
|
||||
temp0 temp1 CMOVE
|
||||
ds-reg [] temp0 MOV
|
||||
] f f f \ both-fixnums? define-sub-primitive
|
||||
] \ both-fixnums? define-sub-primitive
|
||||
|
||||
[
|
||||
! load local number
|
||||
|
|
@ -472,7 +547,7 @@ big-endian off
|
|||
temp0 rs-reg temp0 [+] MOV
|
||||
! push to stack
|
||||
ds-reg [] temp0 MOV
|
||||
] f f f \ get-local define-sub-primitive
|
||||
] \ get-local define-sub-primitive
|
||||
|
||||
[
|
||||
! load local count
|
||||
|
|
@ -483,6 +558,6 @@ big-endian off
|
|||
fixnum>slot@
|
||||
! decrement retain stack pointer
|
||||
rs-reg temp0 SUB
|
||||
] f f f \ drop-locals define-sub-primitive
|
||||
] \ drop-locals define-sub-primitive
|
||||
|
||||
[ "bootstrap.x86" forget-vocab ] with-compilation-unit
|
||||
|
|
|
|||
|
|
@ -11,6 +11,10 @@ IN: cpu.x86
|
|||
|
||||
<< enable-fixnum-log2 >>
|
||||
|
||||
! Add some methods to the assembler to be more useful to the backend
|
||||
M: label JMP 0 JMP rc-relative label-fixup ;
|
||||
M: label JUMPcc [ 0 ] dip JUMPcc rc-relative label-fixup ;
|
||||
|
||||
M: x86 two-operand? t ;
|
||||
|
||||
HOOK: temp-reg-1 cpu ( -- reg )
|
||||
|
|
@ -19,6 +23,8 @@ HOOK: temp-reg-2 cpu ( -- reg )
|
|||
HOOK: param-reg-1 cpu ( -- reg )
|
||||
HOOK: param-reg-2 cpu ( -- reg )
|
||||
|
||||
HOOK: pic-tail-reg cpu ( -- reg )
|
||||
|
||||
M: x86 %load-immediate MOV ;
|
||||
|
||||
M: x86 %load-reference swap 0 MOV rc-absolute-cell rel-immediate ;
|
||||
|
|
@ -53,8 +59,18 @@ M: x86 stack-frame-size ( stack-frame -- i )
|
|||
reserved-area-size +
|
||||
align-stack ;
|
||||
|
||||
M: x86 %call ( label -- ) CALL ;
|
||||
M: x86 %jump-label ( label -- ) JMP ;
|
||||
M: x86 %call ( word -- ) 0 CALL rc-relative rel-word-pic ;
|
||||
|
||||
: xt-tail-pic-offset ( -- n )
|
||||
#! See the comment in vm/cpu-x86.hpp
|
||||
cell 4 + 1 + ; inline
|
||||
|
||||
M: x86 %jump ( word -- )
|
||||
pic-tail-reg 0 MOV xt-tail-pic-offset rc-absolute-cell rel-here
|
||||
0 JMP rc-relative rel-word-pic-tail ;
|
||||
|
||||
M: x86 %jump-label ( label -- ) 0 JMP rc-relative label-fixup ;
|
||||
|
||||
M: x86 %return ( -- ) 0 RET ;
|
||||
|
||||
: code-alignment ( align -- n )
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
USING: alien arrays generic generic.math help.markup help.syntax
|
||||
kernel math memory strings sbufs vectors io io.files classes
|
||||
help generic.standard continuations io.files.private listener
|
||||
help generic.single continuations io.files.private listener
|
||||
alien.libraries ;
|
||||
IN: debugger
|
||||
|
||||
|
|
|
|||
|
|
@ -1,14 +1,13 @@
|
|||
! Copyright (C) 2004, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: slots arrays definitions generic hashtables summary io
|
||||
kernel math namespaces make prettyprint prettyprint.config
|
||||
sequences assocs sequences.private strings io.styles
|
||||
io.pathnames vectors words system splitting math.parser
|
||||
classes.mixin classes.tuple continuations continuations.private
|
||||
combinators generic.math classes.builtin classes compiler.units
|
||||
generic.standard vocabs init kernel.private io.encodings
|
||||
accessors math.order destructors source-files parser
|
||||
classes.tuple.parser effects.parser lexer
|
||||
USING: slots arrays definitions generic hashtables summary io kernel
|
||||
math namespaces make prettyprint prettyprint.config sequences assocs
|
||||
sequences.private strings io.styles io.pathnames vectors words system
|
||||
splitting math.parser classes.mixin classes.tuple continuations
|
||||
continuations.private combinators generic.math classes.builtin classes
|
||||
compiler.units generic.standard generic.single vocabs init
|
||||
kernel.private io.encodings accessors math.order destructors
|
||||
source-files parser classes.tuple.parser effects.parser lexer
|
||||
generic.parser strings.parser vocabs.loader vocabs.parser see
|
||||
source-files.errors ;
|
||||
IN: debugger
|
||||
|
|
@ -17,6 +16,7 @@ GENERIC: error. ( error -- )
|
|||
GENERIC: error-help ( error -- topic )
|
||||
|
||||
M: object error. . ;
|
||||
|
||||
M: object error-help drop f ;
|
||||
|
||||
M: tuple error-help class ;
|
||||
|
|
@ -77,7 +77,7 @@ M: string error. print ;
|
|||
"Object did not survive image save/load: " write third . ;
|
||||
|
||||
: io-error. ( error -- )
|
||||
"I/O error: " write third print ;
|
||||
"I/O error #" write third . ;
|
||||
|
||||
: type-check-error. ( obj -- )
|
||||
"Type check error" print
|
||||
|
|
@ -98,9 +98,7 @@ HOOK: signal-error. os ( obj -- )
|
|||
"Cannot convert to C string: " write third . ;
|
||||
|
||||
: ffi-error. ( obj -- )
|
||||
"FFI: " write
|
||||
dup third [ write ": " write ] when*
|
||||
fourth print ;
|
||||
"FFI error" print drop ;
|
||||
|
||||
: heap-scan-error. ( obj -- )
|
||||
"Cannot do next-object outside begin/end-scan" print drop ;
|
||||
|
|
|
|||
|
|
@ -24,7 +24,7 @@ HELP: CONSULT:
|
|||
|
||||
HELP: SLOT-PROTOCOL:
|
||||
{ $syntax "SLOT-PROTOCOL: protocol-name slots... ;" }
|
||||
{ $description "Defines a protocol consisting of reader and writer words for the listen slot names." } ;
|
||||
{ $description "Defines a protocol consisting of reader and writer words for the listed slot names." } ;
|
||||
|
||||
{ define-protocol POSTPONE: PROTOCOL: } related-words
|
||||
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
USING: delegate kernel arrays tools.test words math definitions
|
||||
compiler.units parser generic prettyprint io.streams.string
|
||||
accessors eval multiline generic.standard delegate.protocols
|
||||
accessors eval multiline generic.single delegate.protocols
|
||||
delegate.private assocs see ;
|
||||
IN: delegate.tests
|
||||
|
||||
|
|
|
|||
|
|
@ -15,6 +15,7 @@ $nl
|
|||
"Iterating over elements:"
|
||||
{ $subsection dlist-each }
|
||||
{ $subsection dlist-find }
|
||||
{ $subsection dlist-filter }
|
||||
{ $subsection dlist-any? }
|
||||
"Deleting a node matching a predicate:"
|
||||
{ $subsection delete-node-if* }
|
||||
|
|
@ -40,6 +41,11 @@ HELP: dlist-find
|
|||
"This operation is O(n)."
|
||||
} ;
|
||||
|
||||
HELP: dlist-filter
|
||||
{ $values { "dlist" { $link dlist } } { "quot" quotation } { "dlist" { $link dlist } } }
|
||||
{ $description "Applies the quotation to each element of the " { $link dlist } " in turn, removing the corresponding nodes if the quotation returns " { $link f } "." }
|
||||
{ $side-effects { "dlist" } } ;
|
||||
|
||||
HELP: dlist-any?
|
||||
{ $values { "dlist" { $link dlist } } { "quot" quotation } { "?" "a boolean" } }
|
||||
{ $description "Just like " { $link dlist-find } " except it doesn't return the object." }
|
||||
|
|
|
|||
|
|
@ -79,3 +79,8 @@ IN: dlists.tests
|
|||
[ V{ f 3 1 f } ] [ <dlist> 1 over push-front 3 over push-front f over push-front f over push-back dlist>seq ] unit-test
|
||||
|
||||
[ V{ } ] [ <dlist> dlist>seq ] unit-test
|
||||
|
||||
[ V{ 0 2 4 } ] [ <dlist> { 0 1 2 3 4 } over push-all-back [ even? ] dlist-filter dlist>seq ] unit-test
|
||||
[ V{ 2 4 } ] [ <dlist> { 1 2 3 4 } over push-all-back [ even? ] dlist-filter dlist>seq ] unit-test
|
||||
[ V{ 2 4 } ] [ <dlist> { 1 2 3 4 5 } over push-all-back [ even? ] dlist-filter dlist>seq ] unit-test
|
||||
[ V{ 0 2 4 } ] [ <dlist> { 0 1 2 3 4 5 } over push-all-back [ even? ] dlist-filter dlist>seq ] unit-test
|
||||
|
|
|
|||
|
|
@ -95,7 +95,7 @@ M: dlist pop-front* ( dlist -- )
|
|||
[
|
||||
[
|
||||
[ empty-dlist ] unless*
|
||||
[ f ] change-next drop
|
||||
next>>
|
||||
f over set-prev-when
|
||||
] change-front drop
|
||||
] keep
|
||||
|
|
@ -108,7 +108,7 @@ M: dlist pop-back* ( dlist -- )
|
|||
[
|
||||
[
|
||||
[ empty-dlist ] unless*
|
||||
[ f ] change-prev drop
|
||||
prev>>
|
||||
f over set-next-when
|
||||
] change-back drop
|
||||
] keep
|
||||
|
|
@ -157,6 +157,9 @@ M: dlist clear-deque ( dlist -- )
|
|||
|
||||
: 1dlist ( obj -- dlist ) <dlist> [ push-front ] keep ;
|
||||
|
||||
: dlist-filter ( dlist quot -- dlist )
|
||||
over [ '[ dup obj>> @ [ drop ] [ _ delete-node ] if ] dlist-each-node ] keep ; inline
|
||||
|
||||
M: dlist clone
|
||||
<dlist> [ '[ _ push-back ] dlist-each ] keep ;
|
||||
|
||||
|
|
|
|||
|
|
@ -79,6 +79,13 @@ M: one-word-elt next-elt
|
|||
drop
|
||||
[ f next-word ] modify-col ;
|
||||
|
||||
SINGLETON: word-start-elt
|
||||
|
||||
M: word-start-elt prev-elt
|
||||
drop one-word-elt prev-elt ;
|
||||
|
||||
M: word-start-elt next-elt 2drop ;
|
||||
|
||||
SINGLETON: word-elt
|
||||
|
||||
M: word-elt prev-elt
|
||||
|
|
|
|||
|
|
@ -1,10 +1,10 @@
|
|||
! Copyright (C) 2005, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: parser lexer kernel namespaces sequences definitions io.files
|
||||
io.backend io.pathnames io summary continuations tools.crossref
|
||||
tools.vocabs prettyprint source-files source-files.errors assocs
|
||||
vocabs vocabs.loader splitting accessors debugger prettyprint
|
||||
help.topics ;
|
||||
USING: parser lexer kernel namespaces sequences definitions
|
||||
io.files io.backend io.pathnames io summary continuations
|
||||
tools.crossref vocabs.hierarchy prettyprint source-files
|
||||
source-files.errors assocs vocabs vocabs.loader splitting
|
||||
accessors debugger prettyprint help.topics ;
|
||||
IN: editors
|
||||
|
||||
TUPLE: no-edit-hook ;
|
||||
|
|
|
|||
|
|
@ -4,7 +4,7 @@
|
|||
USING: accessors arrays ascii assocs calendar combinators fry kernel
|
||||
generalizations io io.encodings.ascii io.files io.streams.string
|
||||
macros math math.functions math.parser peg.ebnf quotations
|
||||
sequences splitting strings unicode.case vectors ;
|
||||
sequences splitting strings unicode.case vectors combinators.smart ;
|
||||
|
||||
IN: formatting
|
||||
|
||||
|
|
@ -113,7 +113,6 @@ MACRO: printf ( format-string -- )
|
|||
: sprintf ( format-string -- result )
|
||||
[ printf ] with-string-writer ; inline
|
||||
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: pad-00 ( n -- string ) number>string 2 CHAR: 0 pad-head ; inline
|
||||
|
|
@ -129,12 +128,15 @@ MACRO: printf ( format-string -- )
|
|||
[ pad-00 ] map "/" join ; inline
|
||||
|
||||
: >datetime ( timestamp -- string )
|
||||
{ [ day-of-week day-abbreviation3 ]
|
||||
[ month>> month-abbreviation ]
|
||||
[ day>> pad-00 ]
|
||||
[ >time ]
|
||||
[ year>> number>string ]
|
||||
} cleave 5 narray " " join ; inline
|
||||
[
|
||||
{
|
||||
[ day-of-week day-abbreviation3 ]
|
||||
[ month>> month-abbreviation ]
|
||||
[ day>> pad-00 ]
|
||||
[ >time ]
|
||||
[ year>> number>string ]
|
||||
} cleave
|
||||
] output>array " " join ; inline
|
||||
|
||||
: (week-of-year) ( timestamp day -- n )
|
||||
[ dup clone 1 >>month 1 >>day day-of-week dup ] dip > [ 7 swap - ] when
|
||||
|
|
@ -187,5 +189,3 @@ PRIVATE>
|
|||
MACRO: strftime ( format-string -- )
|
||||
parse-strftime [ length ] keep [ ] join
|
||||
'[ _ <vector> @ reverse concat nip ] ;
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -57,7 +57,6 @@ $nl
|
|||
"Here are some built-in combinators rewritten in terms of fried quotations:"
|
||||
{ $table
|
||||
{ { $link literalize } { $snippet ": literalize '[ _ ] ;" } }
|
||||
{ { $link slip } { $snippet ": slip '[ @ _ ] call ;" } }
|
||||
{ { $link curry } { $snippet ": curry '[ _ @ ] ;" } }
|
||||
{ { $link compose } { $snippet ": compose '[ @ @ ] ;" } }
|
||||
{ { $link bi@ } { $snippet ": bi@ tuck '[ _ @ _ @ ] call ;" } }
|
||||
|
|
|
|||
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in New Issue